Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv8238/utils-kt
Modified Files: debug.lisp defpackage.lisp detritus.lisp flow-control.lisp utils-kt.lpr Log Message: CVS sucks
--- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/07/25 10:51:48 1.9 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/08/21 04:29:31 1.10 @@ -20,7 +20,7 @@
(in-package :utils-kt)
-(defparameter *trcdepth* 0) + (defvar *count* nil) (defvar *counting* nil) (defvar *dbg*) @@ -29,114 +29,10 @@ (defun utils-kt-reset () (setf *count* nil *stop* nil - *dbg* nil - *trcdepth* 0) + *dbg* nil) (print "----------UTILSRESET----------------------------------"))
-;----------- trc ------------------------------------------- - -(defun trcdepth-reset () - (setf *trcdepth* 0)) - -(defmacro trc (tgt-form &rest os - &aux (wrapper (if (macro-function 'without-c-dependency) - 'without-c-dependency 'progn))) - (if (eql tgt-form 'nil) - '(progn) - (if (stringp tgt-form) - `(,wrapper - (call-trc t ,tgt-form ,@os)) - (let ((tgt (gensym))) - `(,wrapper - (bif (,tgt ,tgt-form) - (if (trcp ,tgt) - (progn - (assert (stringp ,(car os))) - (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) - (progn - ;; (break "trcfailed") - (count-it :trcfailed))) - (count-it :tgtnileval))))))) - -(defun call-trc (stream s &rest os) - (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*) - *trcdepth*) - (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*) - (format stream "~&")) - - (format stream "~a" s) - (let (pkwp) - (dolist (o os) - (format stream (if pkwp " ~s" " | ~s") o) - (setf pkwp (keywordp o)))) - (force-output stream) - (values)) - -(defun call-trc-to-string (fmt$ &rest fmt-args) - (let ((o$ (make-array '(0) :element-type 'base-char - :fill-pointer 0 :adjustable t))) - (with-output-to-string (os-stream o$) - (apply 'call-trc os-stream fmt$ fmt-args)) - o$)) - -#+findtrcevalnils -(defmethod trcp :around (other) - (unless (call-next-method other)(break))) - -(defmethod trcp (other) - (eq other t)) - -(defmethod trcp (($ string)) - t) - -(defun trcdepth-incf () - (incf *trcdepth*)) - -(defun trcdepth-decf () - (format t "decrementing trc depth ~d" *trcdepth*) - (decf *trcdepth*)) - -(export! wtrc) - -(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body ) - `(let ((*trcdepth* (if *trcdepth* - (1+ *trcdepth*) - 0))) - ,(when banner `(when (>= *trcdepth* ,min) - (if (< *trcdepth* ,max) - (trc ,@banner) - (progn - (break "excess trace notttt!!! ~d" *trcdepth*) ;; ,@banner) - nil)))) - (when (< *trcdepth* ,max) - ,@body))) - -(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body ) - (declare (ignore min max banner)) - `(progn ,@body)) - -;------ eko -------------------------------------- -
-(defmacro eko ((&rest trcargs) &rest body) - (let ((result (gensym))) - `(let ((,result ,@body)) - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)) - ,result))) - -(defmacro eko-if ((test &rest trcargs) &rest body) - (let ((result (gensym))) - `(let ((,result ,@body)) - (when ,test - (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))) - ,result))) - -(defmacro ek (label &rest body) - (let ((result (gensym))) - `(let ((,result (,@body))) - (when ,label - (trc ,label ,result)) - ,result)))
;------------- counting ---------------------------
--- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/05/20 06:32:20 1.4 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/08/21 04:29:31 1.5 @@ -40,3 +40,27 @@ #-(or lispworks mcl) #:true #+(and mcl (not openmcl-partial-mop)) #:class-slots )) + +(in-package :utils-kt) + +(defmacro eval-now! (&body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@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 2006/07/08 03:28:07 1.8 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/08/21 04:29:31 1.9 @@ -26,14 +26,6 @@ `(let ((*dbg* t)) ,@body))
-(defmacro eval-now! (&body body) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@body)) - -(defmacro export! (&rest symbols) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (export ',symbols))) - ;;;(defmethod class-slot-named ((classname symbol) slotname) ;;; (class-slot-named (find-class classname) slotname)) ;;; @@ -54,6 +46,11 @@ (defun xor (c1 c2) (if c1 (not c2) c2))
+(export! push-end) + +(defmacro push-end (item place ) + `(setf ,place (nconc ,place (list ,item)))) + ;;; --- FIFO Queue -----------------------------
(defun make-fifo-queue (&rest init-data) @@ -116,19 +113,6 @@ (loop until (fifo-empty q) do (print (fifo-pop q)))))
-(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))))
#+allegro (defun line-count (path &optional show-files (depth 0)) @@ -165,3 +149,29 @@ :device "c" :directory `(:absolute "0dev" "Algebra")) t)
+(export! tree-includes tree-traverse tree-intersect) + +(defun tree-includes (sought tree &key (test 'eql)) + (typecase tree + (null) + (atom (eko (nil "tree-inc? testing" sought tree) + (funcall test sought tree))) + (cons (loop for subtree in tree + when (tree-includes sought subtree :test test) + do (return-from tree-includes t))))) + +(defun tree-traverse (tree fn) + (typecase tree + (null) + (atom (funcall fn tree)) + (cons (loop for subtree in tree + do (tree-traverse subtree fn)))) + (values)) + +(defun tree-intersect (t1 t2 &key (test 'eql)) + (tree-traverse t1 + (lambda (t1-node) + (eko (nil "treeinter?" t1-node t2) + (when (tree-includes t1-node t2 :test test) + (return-from tree-intersect t1-node)))))) + --- /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/07/03 00:08:29 1.4 +++ /project/cells/cvsroot/cells/utils-kt/flow-control.lisp 2006/08/21 04:29:31 1.5 @@ -31,6 +31,8 @@ (defun min-if (v1 v2) (if v1 (if v2 (min v1 v2) v1) v2))
+(export! list-flatten!) + (defun list-flatten! (&rest list) (if (consp list) (let (head work visited) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/07/25 10:51:48 1.15 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/08/21 04:29:31 1.16 @@ -1,4 +1,4 @@ -;; -*- lisp-version: "8.0 [Windows] (Jul 24, 2006 15:27)"; cg: "1.81"; -*- +;; -*- lisp-version: "8.0 [Windows] (Aug 10, 2006 12:19)"; cg: "1.81"; -*-
(in-package :cg-user)