Update of /project/cells/cvsroot/cells/utils-kt In directory cl-net:/tmp/cvs-serv22971/utils-kt
Modified Files: core.lisp debug.lisp defpackage.lisp detritus.lisp flow-control.lisp strings.lisp utils-kt.lpr Log Message: Just trying to get a patch in for record-caller
--- /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/06/16 12:38:04 1.10 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2008/10/12 01:21:10 1.11 @@ -17,6 +17,8 @@
(in-package :utils-kt)
+ + (defmacro with-gensyms ((&rest symbols) &body body) `(let ,(loop for sym in symbols collecting `(,sym (gensym ,(string sym)))) @@ -47,7 +49,7 @@ ,@(when docstring (list docstring)))))
(defun test-setup (&optional drib) - #+(and allegro ide) + #+(and allegro ide (or (not its-alive!) debugging-alive!)) (ide.base::find-new-prompt-command (cg.base::find-window :listener-frame)) (when drib @@ -58,8 +60,9 @@ (export! test-setup test-prep test-init) (export! project-path) (defun project-path () - #+(and allegro ide) - (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) + #+(and allegro ide (not its-alive!)) + (excl:path-pathname (ide.base::project-file ide.base:*current-project*)) + )
#+test (test-setup) --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/06/16 12:38:04 1.20 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2008/10/12 01:21:10 1.21 @@ -40,7 +40,7 @@ `(if ,onp (let ((*counting* (cons t *counting*))) (prog2 - (count-clear ,@msg) + (count-clear nil ,@msg) (progn ,@body) (show-count t ,@msg))) (progn ,@body))) @@ -48,28 +48,38 @@ (defun count-of (key) (cdr (assoc key *count* :key 'car)))
-(defun count-clear (&rest msg) +(defun count-clear (announce &rest msg) (declare (ignorable msg)) - (format t "~&count-clear > ~a" msg) + (when announce (format t "~&count-clear > ~a" msg)) (setf *count* nil))
(defmacro count-it (&rest keys) (declare (ignorable keys)) + #+nahhh `(progn) - #+(or) `(when (car *counting*) + `(when (car *counting*) + (call-count-it ,@keys))) + +(export! count-it!) +(defmacro count-it! (&rest keys) + (declare (ignorable keys)) + #+(and its-alive! (not debugging-alive!)) + `(progn) + #-(and its-alive! (not debugging-alive!)) + `(when (car *counting*) (call-count-it ,@keys)))
(defun call-count-it (&rest keys) (declare (ignorable keys)) #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL)) - (break "clean up time ~a" keys)) + (break "clean up time ~a" keys)) (let ((entry (assoc keys *count* :test #'equal))) (if entry (setf (cdr entry) (1+ (cdr entry))) (push (cons keys 1) *count*))))
-(defun show-count (clearp &rest msg) - (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg) +(defun show-count (clearp &rest msg &aux announced) + (let ((res (sort (copy-list *count*) (lambda (v1 v2) (let ((v1$ (symbol-name (caar v1))) (v2$ (symbol-name (caar v2)))) @@ -81,10 +91,11 @@ for occs = (cdr entry) when (plusp occs) sum occs into running - and do (format t "~&~4d ... ~2d ... ~s" running occs (car entry)))) - (when clearp (count-clear "show-count"))) - - + and do (unless announced + (setf announced t) + (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg)) + (format t "~&~4d ... ~2d ... ~(~{~a ~}~)" running occs (car entry)))) + (when clearp (count-clear announced "show-count" )))
;-------------------- timex ---------------------------------
--- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2008/04/22 11:03:45 1.10 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2008/10/12 01:21:10 1.11 @@ -15,14 +15,27 @@
|#
+ (in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *features* (delete :its-alive! *features*))) + (setf *features* (remove :its-alive! *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (pushnew :gimme-a-break *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *features* (remove :debugging-alive! *features*))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + ;;; #+(and its-alive! (not debugging-alive!)) + ;;; (proclaim '(optimize (speed 3) (safety 1) (space 1) (debug 0))) + ;;; #-(and its-alive! (not debugging-alive!)) + (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
(defpackage :utils-kt (:nicknames #:ukt) - (:use #:common-lisp + (:use #:common-lisp #:excl #+(or allegro lispworks clisp) #:clos #+cmu #:mop #+sbcl #:sb-mop --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/06/16 12:38:04 1.21 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2008/10/12 01:21:10 1.22 @@ -20,7 +20,7 @@ (in-package :utils-kt)
(eval-when (:compile-toplevel :load-toplevel :execute) - (export '(eval-now! export! assocd rassoca))) + (export '(eval-now! export! assocd rassoca class-proto brk)))
(defmacro wdbg (&body body) `(let ((*dbg* t)) @@ -29,11 +29,37 @@ (defun assocd (x y) (cdr (assoc x y))) (defun rassoca (x y) (car (assoc x y)))
-;;;(defmethod class-slot-named ((classname symbol) slotname) -;;; (class-slot-named (find-class classname) slotname)) -;;; -;;;(defmethod class-slot-named (class slotname) -;;; (find slotname (class-slots class) :key #'slot-definition-name)) +(defun class-proto (c) + (let ((cc (find-class c))) + (when cc + (finalize-inheritance cc)) + (mop::class-prototype cc))) + + +(defun brk (&rest args) + #+its-alive! (apply 'error args) + #-its-alive! (progn + ;;(setf *ctk-dbg* t) + (apply 'break args))) + +(defun find-after (x l) + (bIf (xm (member x l)) + (cadr xm) + (brk "find-after ~a not member of ~a" x l))) + +(defun find-before (x l) + (loop with prior = nil + for i in l + if (eql i x) + return prior + else do (setf prior i) + finally (brk "find-before ~a not member of ~a" x l))) + +(defun list-insert-after (list after new ) + (let* ((new-list (copy-list list)) + (m (member after new-list))) + (rplacd m (cons new (cdr m))) + new-list))
#+(and mcl (not openmcl-partial-mop)) (defun class-slots (c) @@ -49,7 +75,7 @@ (defun xor (c1 c2) (if c1 (not c2) c2))
-(export! collect collect-if) +(export! collect collect-if find-after find-before list-insert-after)
(defun collect (x list &key (key 'identity) (test 'eql)) (loop for i in list @@ -121,6 +147,8 @@ (loop until (fifo-empty q) do (print (fifo-pop q)))))
+#+test +(line-count "/openair" t 10 t)
#+allegro (defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0)) @@ -167,14 +195,14 @@ #+(or) (line-count (make-pathname :device "c" - :directory `(:absolute "ALGCOUNT" )) + :directory `(:absolute "0algcount" )) nil 5 t)
#+(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)))) + :directory `(:absolute "0Algebra" "1-devtools" ,d1))))
(export! tree-includes tree-traverse tree-intersect) --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/06/16 12:38:04 1.14 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2008/10/12 01:21:10 1.15 @@ -131,11 +131,15 @@ ,yup ,nope)))
+(defmacro b1 ((bindvar boundform) &body body) + `(let ((,bindvar ,boundform)) + ,@body)) + (defmacro maptimes ((nvar count) &body body) `(loop for ,nvar below ,count collecting (progn ,@body)))
-(export! maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when) +(export! b1 maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when)
(defun maphash* (f h) (loop for k being the hash-keys of h @@ -213,6 +217,7 @@ (head (let ((v (shuffle all))) (nconc v v)))) (lambda () + ;(print (list "without-repeating-generator sees len all =" len :decent-interval decent-interval)) (if (< len 2) (car all) (prog2 @@ -233,11 +238,17 @@
(export! without-repeating shuffle)
-(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) +(defparameter *without-repeating-generators* nil) + +(defun reset-without-repeating () + (if *without-repeating-generators* + (clrhash *without-repeating-generators*) + (setf *without-repeating-generators* (make-hash-table :test 'equalp)))) + +(defun without-repeating (key all &optional (decent-interval (floor (length all) 2))) + (funcall (or (gethash key *without-repeating-generators*) + (progn + ;(print (list "without-repeating makes new gen" key :all-len (length all) :int decent-interval)) + (setf (gethash key *without-repeating-generators*) (without-repeating-generator decent-interval all))))))
--- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2007/11/30 16:51:20 1.7 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2008/10/12 01:21:10 1.8 @@ -24,8 +24,8 @@ left$ mid$ seg$ right$ insert$ remove$ trim$ trunc$ abbrev$ empty$ find$ num$ normalize$ down$ lower$ up$ upper$ equal$ - min$ numeric$ alpha$ assoc$ member$ match-left$ - +return$+ +lf$+))) + min$ numeric$ alpha$ assoc$ member$ starts$ + +return$+ +lf$+ case-string-equal)))
(defmacro case$ (string-form &rest cases) (let ((v$ (gensym)) @@ -40,6 +40,19 @@ cases) (t ,@(or (cdr default) `(nil)))))))
+(defmacro case-string-equal (string-form &rest cases) + (let ((v$ (gensym)) + (default (or (find 'otherwise cases :key #'car) + (find 'otherwise cases :key #'car)))) + (when default + (setf cases (delete default cases))) + `(let ((,v$ ,string-form)) + (cond + ,@(mapcar (lambda (case-forms) + `((string-equal ,v$ ,(string (car case-forms))) ,@(rest case-forms))) + cases) + (t ,@(or (cdr default) `(nil))))))) + ;--------
(defmethod shortc (other) @@ -200,8 +213,9 @@ (defmacro member$ (item list &rest kws) `(member ,item ,list :test #'string= ,@kws))
-(defun match-left$ (a b) - (string-equal a (subseq b 0 (length a)))) +(defun starts$ (a b) + (bwhen (s (search b a)) + (zerop s)))
(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed))) (defparameter *lf$* (string #\linefeed)) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/03/15 15:18:34 1.24 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2008/10/12 01:21:10 1.25 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.1 [Windows] (Feb 1, 2008 18:35)"; cg: "1.103.2.10"; -*- +;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
(in-package :cg-user)
@@ -32,6 +32,7 @@ :old-space-size 256000 :new-space-size 6144 :runtime-build-option :standard + :build-number 0 :on-initialization 'default-init-function :on-restart 'do-default-restart)