[cells-gtk-cvs] CVS cells/utils-kt
pdenno
pdenno at common-lisp.net
Wed Jun 7 16:28:58 UTC 2006
Update of /project/cells-gtk/cvsroot/cells/utils-kt
In directory clnet:/tmp/cvs-serv32368/utils-kt
Added Files:
debug.lisp defpackage.lisp detritus.lisp flow-control.lisp
quad.lisp strings.lisp utils-kt.asd
Log Message:
new files
--- /project/cells-gtk/cvsroot/cells/utils-kt/debug.lisp 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/debug.lisp 2006/06/07 16:28:58 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;; Copyright (c) 1995,2004 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :utils-kt)
(defparameter *trcdepth* 0)
(defvar *count* nil)
(defvar *counting* nil)
(defvar *dbg*)
(defvar *stop* nil)
(defun utils-kt-reset ()
(setf *count* nil
*stop* nil
*dbg* nil
*trcdepth* 0))
;----------- 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))))
(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*))
(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 ---------------------------
(defmacro with-counts ((onp &rest msg) &body body)
`(if ,onp
(let ((*counting* (cons t *counting*)))
(prog2
(count-clear , at msg)
(progn , at body)
(show-count t , at msg)))
(progn , at body)))
(defun count-of (key)
(cdr (assoc key *count* :key 'car)))
(defun count-clear (&rest msg)
(declare (ignorable msg))
(format t "~&count-clear > ~a" msg)
(setf *count* nil))
(defmacro count-it (&rest keys)
`(when *counting*
(call-count-it , at keys)))
(defun call-count-it (&rest keys)
(declare (ignorable keys))
;;; (when (eql :TGTNILEVAL (car keys))(break))
(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)
(let ((res (sort (copy-list *count*) (lambda (v1 v2)
(let ((v1$ (symbol-name (caar v1)))
(v2$ (symbol-name (caar v2))))
(if (string= v1$ v2$)
(< (cdr v1) (cdr v2))
(string< v1$ v2$))))))
)
(loop for entry in res
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")))
;-------------------- timex ---------------------------------
(eval-when (compile eval load)
(export '(timex)))
(defmacro timex ((onp &rest trcargs) &body body)
`(if ,onp
(prog1
(time (progn , at body))
(trc "timing was of" , at trcargs))
(progn , at body)))
#+save
(defun dbg-time-report (cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes)
(trc "cpu-gc-user" cpu-gc-user)
(trc "cpu-gc-sys" cpu-gc-sys)
(trc "cpu-tot-user" cpu-tot-user)
(trc "cpu-tot-sys" cpu-tot-sys)
(trc "<non-gc user cpu>" (- cpu-tot-user cpu-gc-user))
(trc "<non-gc sys cpu>" (- cpu-tot-sys cpu-gc-sys))
(trc "conses" conses)
(trc "other-bytes" other-bytes)
(trc "static-bytes" static-bytes)
(excl::time-report cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes))
;---------------- Metrics -------------------
(defmacro with-metrics ((countp timep &rest trcargs) form-measured &body postlude)
`(with-counts (,countp , at trcargs)
(timex (,timep , at trcargs)
,form-measured)
, at postlude))
--- /project/cells-gtk/cvsroot/cells/utils-kt/defpackage.lisp 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/defpackage.lisp 2006/06/07 16:28:58 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;; Copyright (c) 1995,2004 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :cl-user)
(defpackage :utils-kt
(:nicknames #:ukt)
(:use #:common-lisp
#-(or cormanlisp cmu sbcl) #:clos
#+sbcl #:sb-mop
#+mcl #:ccl)
(:export #:utils-kt-reset
#:eko #:count-it #:count-of #:trc #:trcp
#:wdbg #:maptimes #:bwhen #:bif #:xor
#:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics
#:shortc
#:intern$
#:define-constant #:*count* #:*stop*
#:*dbg* #:*trcdepth*
#:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo #:with-gensyms
#:ensure-gethash
#-(or lispworks mcl) #:true
#+clisp #:slot-definition-name
))
--- /project/cells-gtk/cvsroot/cells/utils-kt/detritus.lisp 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/detritus.lisp 2006/06/07 16:28:58 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :utils-kt)
(defmacro wdbg (&body body)
`(let ((*dbg* t))
, at body))
#+mcl
(defun class-slots (c)
(nconc (copy-list (class-class-slots c))
(copy-list (class-instance-slots c))))
#-(or lispworks mcl)
(defun true (it) (declare (ignore it)) t)
(defun false (it) (declare (ignore it)))
(defun xor (c1 c2)
(if c1 (not c2) c2))
(defun make-fifo-queue () (cons nil nil))
(defun fifo-add (q new)
(if (car q)
(let ((last (cdr q))
(newlast (list new)))
(rplacd last newlast)
(rplacd q newlast))
(let ((newlist (list new)))
(rplaca q newlist)
(rplacd q newlist))))
(defun fifo-queue (q) (car q))
(defun fifo-empty (q) (not (car q)))
(defun fifo-pop (q)
(prog1
(caar q)
(rplaca q (cdar q))))
(defun mapfifo (fn q)
(loop until (fifo-empty q)
do (funcall fn (fifo-pop q))))
#+test
(let ((*print-circle* t))
(let ((q (make-fifo-queue)))
(loop for n below 3
do (fifo-add q n))
(fifo-queue q)
(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))))
(defmacro with-gensyms (syms &body body)
"Paul Graham ON LISP pg 145. Used in macros to avoid variable capture."
`(let ,(mapcar #'(lambda (s)
`(,s (gensym)))
syms)
, at body))
(defmacro ensure-gethash (object ht default)
"Sam Steingold: Just like GETHASH with the default argument,
but DEFAULT is only evaluated when OBJECT is not found and
in that case the value of DEFAULT is placed into (GETHASH OBJECT HT)."
(with-gensyms (obj tab)
`(let ((,obj ,object) (,tab ,ht))
(or (gethash ,obj ,tab)
(setf (gethash ,obj ,tab) ,default)))))
--- /project/cells-gtk/cvsroot/cells/utils-kt/flow-control.lisp 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/flow-control.lisp 2006/06/07 16:28:58 1.1
;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
;;;
;;;
;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a copy
;;; of this software and associated documentation files (the "Software"), to deal
;;; in the Software without restriction, including without limitation the rights
;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
;;; copies of the Software, and to permit persons to whom the Software is furnished
;;; to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
;;; IN THE SOFTWARE.
(in-package :utils-kt)
(defun last1 (thing)
(car (last thing)))
(defun max-if (&rest values)
(loop for x in values when x maximize x))
(defun min-max-of (v1 v2)
(values (min-if v1 v2) (max-if v1 v2)))
[100 lines skipped]
--- /project/cells-gtk/cvsroot/cells/utils-kt/quad.lisp 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/quad.lisp 2006/06/07 16:28:58 1.1
[226 lines skipped]
--- /project/cells-gtk/cvsroot/cells/utils-kt/strings.lisp 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/strings.lisp 2006/06/07 16:28:58 1.1
[434 lines skipped]
--- /project/cells-gtk/cvsroot/cells/utils-kt/utils-kt.asd 2006/06/07 16:28:58 NONE
+++ /project/cells-gtk/cvsroot/cells/utils-kt/utils-kt.asd 2006/06/07 16:28:58 1.1
[461 lines skipped]
More information about the Cells-gtk-cvs
mailing list