[cells-cvs] CVS cells/utils-kt
ktilton
ktilton at common-lisp.net
Sun Oct 12 01:21:10 UTC 2008
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 , at msg)
+ (count-clear nil , at msg)
(progn , at body)
(show-count t , at msg)))
(progn , at 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 , at 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 , at 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))
+ , at body))
+
(defmacro maptimes ((nvar count) &body body)
`(loop for ,nvar below ,count
collecting (progn , at 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= , at 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)
More information about the Cells-cvs
mailing list