[cells-cvs] CVS cells/utils-kt
ktilton
ktilton at common-lisp.net
Fri Nov 30 16:51:26 UTC 2007
Update of /project/cells/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv2729/utils-kt
Modified Files:
datetime.lisp debug.lisp defpackage.lisp detritus.lisp
flow-control.lisp strings.lisp utils-kt.lpr
Added Files:
core.lisp
Log Message:
--- /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2006/07/06 22:10:03 1.3
+++ /project/cells/cvsroot/cells/utils-kt/datetime.lisp 2007/11/30 16:51:20 1.4
@@ -197,5 +197,8 @@
(defun hyphenated-time-string ()
(substitute #\- #\: (ymdhmsh)))
+
+#+test
+(hyphenated-time-string)
--- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/01/29 06:44:04 1.14
+++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/11/30 16:51:20 1.15
@@ -27,6 +27,7 @@
(defvar *stop* nil)
(defun utils-kt-reset ()
+ (clock-off :ukt-reset)
(setf *count* nil
*stop* nil
*dbg* nil)
@@ -121,3 +122,21 @@
,form-measured)
, at postlude))
+(export! clock clock-0 clock-off)
+
+(defvar *clock*)
+
+(defun clock-off (key)
+ (when (boundp '*clock*)
+ (print (list :clock-off key))
+ (makunbound '*clock*)))
+
+(defun clock-0 (key &aux (now (get-internal-real-time)))
+ (setf *clock* (cons now now))
+ (print (list :clock-initialized-by key)))
+
+(defun clock (&rest keys &aux (now (get-internal-real-time)))
+ (when (boundp '*clock*)
+ (print (list* :clock (- now (cdr *clock*)) :tot (- now (car *clock*)) :at keys))
+ (setf (cdr *clock*) now)))
+
--- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/09/05 18:40:48 1.6
+++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/11/30 16:51:20 1.7
@@ -17,6 +17,9 @@
(in-package :cl-user)
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (delete :its-alive! *features*)))
+
(defpackage :utils-kt
(:nicknames #:ukt)
(:use #:common-lisp
@@ -41,26 +44,3 @@
#+(and mcl (not openmcl-partial-mop)) #:class-slots
))
-(in-package :utils-kt)
-
-(defmacro eval-now! (&body body)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- , at body))
-
-(defmacro export! (&rest symbols)
- `(eval-when (:compile-toplevel :load-toplevel :execute)
- (export ',symbols)))
-
-(defmacro define-constant (name value &optional docstring)
- "Define a constant properly. If NAME is unbound, DEFCONSTANT
-it to VALUE. If it is already bound, and it is EQUAL to VALUE,
-reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again,
-resulting in implementation-specific behavior."
- `(defconstant ,name
- (if (not (boundp ',name))
- ,value
- (let ((value ,value))
- (if (equal value (symbol-value ',name))
- (symbol-value ',name)
- value)))
- ,@(when docstring (list docstring))))
--- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/01/29 06:44:04 1.13
+++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/11/30 16:51:20 1.14
@@ -49,10 +49,7 @@
(defun xor (c1 c2)
(if c1 (not c2) c2))
-(export! push-end collect collect-if)
-
-(defmacro push-end (item place )
- `(setf ,place (nconc ,place (list ,item))))
+(export! collect collect-if)
(defun collect (x list &key (key 'identity) (test 'eql))
(loop for i in list
@@ -60,10 +57,22 @@
collect i))
(defun collect-if (test list)
- (loop for i in list
- when (funcall test i)
- collect i))
+ (remove-if-not test list))
+
+(defun test-setup ()
+ #-its-alive!
+ (ide.base::find-new-prompt-command
+ (cg.base::find-window :listener-frame)))
+
+#+test
+(test-setup)
+
+(defun test-prep ()
+ (test-setup))
+(defun test-init ()
+ (test-setup))
+(export! test-setup test-prep test-init)
;;; --- FIFO Queue -----------------------------
@@ -142,7 +151,8 @@
do (bwhen (fname (pathname-name file))
(format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines))
summing lines)))
- (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines)
+ (unless (zerop directory-lines)
+ (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines))
directory-lines))
((find (pathname-type path) '("cl" "lisp" "c" "h" "java")
@@ -162,7 +172,14 @@
#+(or)
(line-count (make-pathname
:device "c"
- :directory `(:absolute "0dev" "Algebra")) t)
+ :directory `(:absolute "0dev")))
+
+#+(or)
+(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml")
+ summing (line-count (make-pathname
+ :device "c"
+ :directory `(:absolute "1-devtools" ,d1))))
+
(export! tree-includes tree-traverse tree-intersect)
--- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/01/29 06:44:04 1.10
+++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2007/11/30 16:51:20 1.11
@@ -59,6 +59,10 @@
(defun tree-flatten (tree)
(list-flatten! (copy-tree tree)))
+(export! push-end)
+(defmacro push-end (item place )
+ `(setf ,place (nconc ,place (list ,item))))
+
(defun pair-off (list &optional (test 'eql))
(loop with pairs and copy = (copy-list list)
while (cdr copy)
@@ -184,8 +188,9 @@
(export! without-repeating)
-
(let ((generators (make-hash-table :test 'equalp)))
+ (defun reset-without-repeating ()
+ (setf generators (make-hash-table :test 'equalp)))
(defun without-repeating (key all &optional (decent-interval (floor (length all) 2)))
(funcall (or (gethash key generators)
(setf (gethash key generators)
--- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/09/05 18:40:50 1.6
+++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2007/11/30 16:51:20 1.7
@@ -90,6 +90,9 @@
(defun left$ (s n)
(subseq s 0 (max (min n (length s)) 0)))
+(export! cc$)
+(defun cc$ (code) (string (code-char code)))
+
(defun mid$ (s offset length)
(let* ((slen (length s))
(start (min slen (max offset 0)))
--- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/01/29 06:44:04 1.22
+++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2007/11/30 16:51:20 1.23
@@ -1,16 +1,10 @@
-;; -*- lisp-version: "8.0 [Windows] (Jan 22, 2007 8:01)"; cg: "1.81"; -*-
+;; -*- lisp-version: "8.1 [Windows] (Sep 29, 2007 20:23)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
-(defpackage :COMMON-LISP
- (:export #:list
- #:make-instance
- #:t
- #:nil
- #:quote))
-
(define-project :name :utils-kt
:modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "core.lisp")
(make-instance 'module :name "debug.lisp")
(make-instance 'module :name "flow-control.lisp")
(make-instance 'module :name "detritus.lisp")
@@ -28,12 +22,13 @@
:runtime-modules nil
:splash-file-module (make-instance 'build-module :name "")
:icon-file-module (make-instance 'build-module :name "")
- :include-flags '(:local-name-info)
- :build-flags '(:allow-debug :purify)
+ :include-flags (list :local-name-info)
+ :build-flags (list :allow-debug :purify)
:autoload-warning t
:full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
:default-command-line-arguments "+cx +t \"Initializing\""
- :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
:old-space-size 256000
:new-space-size 6144
:runtime-build-option :standard
--- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:26 NONE
+++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:26 1.1
#|
Utils-kt core
Copyright (C) 1995, 2006 by Kenneth Tilton
This library is free software; you can redistribute it and/or
modify it under the terms of the Lisp Lesser GNU Public License
(http://opensource.franz.com/preamble.html), known as the LLGPL.
This library is distributed WITHOUT ANY WARRANTY; without even
the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the Lisp Lesser GNU Public License for more details.
|#
(in-package :utils-kt)
(defmacro eval-now! (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
, at body))
(defmacro export! (&rest symbols)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(export ',symbols)))
(defmacro define-constant (name value &optional docstring)
"Define a constant properly. If NAME is unbound, DEFCONSTANT
it to VALUE. If it is already bound, and it is EQUAL to VALUE,
reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again,
resulting in implementation-specific behavior."
`(defconstant ,name
(if (not (boundp ',name))
,value
(let ((value ,value))
(if (equal value (symbol-value ',name))
(symbol-value ',name)
value)))
,@(when docstring (list docstring))))
(export! exe-path exe-dll font-path)
(defun exe-path ()
#+its-alive!
(excl:current-directory)
#-its-alive!
(excl:path-pathname (ide.base::project-file ide.base:*current-project*)))
(defun font-path ()
(merge-pathnames
(make-pathname
:directory #+its-alive! (list :relative "font")
#-its-alive! (append (butlast (pathname-directory (exe-path)))
(list "TY Extender" "font")))
(exe-path)))
#+test
(list (exe-path)(font-path))
(defmacro exe-dll (&optional filename)
(assert filename)
(concatenate 'string filename ".dll"))
#+chya
(defun exe-dll (&optional filename)
(merge-pathnames
(make-pathname :name filename :type "DLL"
:directory (append (butlast (pathname-directory (exe-path)))
(list "dll")))
(exe-path)))
#+test
(probe-file (exe-dll "openal32"))
More information about the Cells-cvs
mailing list