[cells-cvs] CVS cells/utils-kt
ktilton
ktilton at common-lisp.net
Mon Aug 21 04:29:34 UTC 2006
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 , at os))
- (let ((tgt (gensym)))
- `(,wrapper
- (bif (,tgt ,tgt-form)
- (if (trcp ,tgt)
- (progn
- (assert (stringp ,(car os)))
- (call-trc t , at 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 , at banner)
- (progn
- (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
- nil))))
- (when (< *trcdepth* ,max)
- , at body)))
-
-(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body )
- (declare (ignore min max banner))
- `(progn , at body))
-
-;------ eko --------------------------------------
-
-(defmacro eko ((&rest trcargs) &rest body)
- (let ((result (gensym)))
- `(let ((,result , at body))
- (trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
- ,result)))
-
-(defmacro eko-if ((test &rest trcargs) &rest body)
- (let ((result (gensym)))
- `(let ((,result , at body))
- (when ,test
- (trc ,(car trcargs) :=> ,result ,@(cdr trcargs)))
- ,result)))
-
-(defmacro ek (label &rest body)
- (let ((result (gensym)))
- `(let ((,result (, at 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)
+ , 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 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))
, at body))
-(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)))
-
;;;(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)
More information about the Cells-cvs
mailing list