Update of /project/cells/cvsroot/cells-gtk3/pod-utils
In directory clnet:/tmp/cvs-serv5005/pod-utils
Added Files:
kt-trace.lisp pod-utils.asd utils.lisp
Log Message:
cells-gtk3 initial.
--- /project/cells/cvsroot/cells-gtk3/pod-utils/kt-trace.lisp 2008/04/13 10:59:26 NONE
+++ /project/cells/cvsroot/cells-gtk3/pod-utils/kt-trace.lisp 2008/04/13 10:59:26 1.1
;;; Copyright (c) 2004 Kenny 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.
;;;-----------------------------------------------------------------------
;;;
;;; Kenny Tilton trace stuff.
;;;
(in-package :pod-utils)
(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 -------------------------------------------
(defmacro count-it (&rest keys)
`(when *counting*
(call-count-it ,@keys)))
(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))))
(values))
(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*))))
;(export '(trc)) ; trc is now in cells--- /project/cells/cvsroot/cells-gtk3/pod-utils/pod-utils.asd 2008/04/13 10:59:26 NONE
+++ /project/cells/cvsroot/cells-gtk3/pod-utils/pod-utils.asd 2008/04/13 10:59:26 1.1
(asdf:defsystem :pod-utils
:name "pod-utils"
:components
((:file "utils")
(:file "kt-trace")))
--- /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 NONE
+++ /project/cells/cvsroot/cells-gtk3/pod-utils/utils.lisp 2008/04/13 10:59:26 1.1
;;; Copyright (c) 2004 Peter Denno
;;;
;;; 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.
;;;-----------------------------------------------------------------------
;;;
;;; Peter Denno
;;; Date: 12/2/95 - on going.
;;;
;;; Generally applicable utilities. Some from Norvig's "Paradigms of
;;; Artificial Programming," Some from Kiczales et. al. "The Art of the
;;; Metaobject Protocol," some from Graham's "On Lisp," some from Sam Steingold.
;;;
(in-package :cl-user)
(defpackage pod-utils
(:nicknames pod)
(:use cl)
(:export combinations flatten kintern sintern mapappend pairs memo debug-memo memoize
clear-memoize defun-memoize VARS mac mac2 load-ht when-bind if-bind when-bind*
substring remove-extra-spaces break-line-at read-string-to-list split
name2initials c-name2lisp lisp-name2c single-p mklist longer group prune find2 before
duplicate split-if mvb mvs dbind decode-time-interval strcat tree-search depth-first-search
prepend breadth-first-search update with-stack-size pprint-without-strings chop setx
reuse-cons intersect-predicates
defmemo system-clear-memoized-fns system-add-memoized-fn system-list-memoized-fns
system-forget-memoized-fns with-gensyms fail))
; ph: removed last1 new-reslist reslist-pop reslist-push reslist-fillptr now
(in-package :pod-utils)
;;; Purpose: Return the combinations possible when selecting one item
;;; from each of the argument sets.
;;; Example: (combinations '(a) '(b c) '(d e))
;;; => ((A B D) (A B E) (A C D) (A C E))
;;; Arg: sets - lists
;;; Value: a list of lists. If the argument is nil, it returns nil.
(defun combinations (&rest sets)
(cond ((null sets) nil)
(t
(flet ((combinations-aux (aset bset)
(cond ((not aset) bset)
((not bset) aset)
(t (loop for a in aset
append (loop for b in bset
collect (list a b)))))))
(loop for set in (reduce #'combinations-aux sets)
collect (flatten set))))))
(defun flatten (input &optional accumulator)
"Return a flat list of the atoms in the input.
Ex: (flatten '((a (b (c) d))) => (a b c d))"
(cond ((null input) accumulator)
((atom input) (cons input accumulator))
(t (flatten (first input)
(flatten (rest input) accumulator)))))
(declaim (inline kintern))
(defun kintern (string &rest args)
"Apply FORMAT to STRING and ARGS, upcase the resulting string and
intern it into the KEYWORD package."
(intern (string-upcase (apply #'format nil (string string) args))
(find-package "KEYWORD")))
(declaim (inline sintern))
(defun sintern (string &rest args)
"Apply FORMAT to STRING and ARGS, upcase the resulting string and
intern it into the current (*PACKAGE*) package."
(intern (string-upcase (apply #'format nil (string string) args))))
(defun mapappend (fun &rest args)
(loop until (some #'null args)
append (apply fun (loop for largs on args
collect (pop (first largs))))))
(defun mapnconc (fun &rest args)
(loop until (some #'null args)
nconc (apply fun (loop for largs on args
collect (pop (first largs))))))
;;; Purpose: Return a list of pairs of elements from the argument list:
;;; Ex: (pairs '(a b c d)) => ((a b) (a c) (a d) (b c) (b d) (c d))
;;;
;;; Args: inlist - a list
(defun pairs (inlist)
(loop for sublist on inlist
while (cdr sublist)
append
(loop for elem in (cdr sublist)
collect `(,(first sublist) ,elem))))
;;; Purpose: Called by memoize, below. This returns
;;; the memoized function. Norvig, Page 270.
;;; When you want to use this on &rest args use :test #'equal :key #'identity
;;; Args: fn - the function object.
;;; name - the function symbol.
;;; key - On what argument the result is indexed.
;;; test - Either eql or equal, the :test of the hash table.
(defun memo (fn name key test)
"Return a memo-function of fn."
(let ((table (make-hash-table :test test)))
(setf (get name 'memo) table)
#'(lambda (&rest args)
(let ((k (funcall key args)))
(multiple-value-bind (val found-p)
(gethash k table)
(if found-p
val
(setf (gethash k table) (apply fn args))))))))
(defun debug-memo (fn name key test)
"Like memo but prints *hit* on every hit."
(let ((table (make-hash-table :test test)))
(setf (get name 'memo) table)
#'(lambda (&rest args)
(let ((k (funcall key args)))
(multiple-value-bind (val found-p)
(gethash k table)
(if found-p
(progn (princ " *HIT*") val)
(progn
(princ " *miss*")
(setf (gethash k table) (apply fn args)))))))))
;;; Purpose: memoize the argument function.
;;; Arguments as those in memo.
(defun memoize (fn-name &key (key #'first) (test #'eql) (debug nil))
"Replace fn-name's global definition with a memoized version."
#-Allegro-V4.3 (format t "~%;;; Memoizing (~a) ~a ****" test fn-name)
#+Allegro-V4.3 (format t "~%;;; Memoizing ~a ****" fn-name)
(if debug
(setf (symbol-function fn-name)
(debug-memo (symbol-function fn-name) fn-name key test))
(setf (symbol-function fn-name)
(memo (symbol-function fn-name) fn-name key test))))
;;; Clear the hash table from the function.
(defun clear-memoize (fn-name)
"Clear the hash table from a memo function."
(let ((table (get fn-name 'memo)))
(when table (clrhash table))))
;;; Purpose: define a function and memoize it.
;;; Limitations: only useful for default arguments, i.e.,
;;; key on first and test eql. In all other
;;; cases call (memoize <fn> :key <key> :test <test>).
(defmacro defun-memoize (fn args &body body)
`(memoize (defun ,fn ,args ,body)))
;;; Stuff to use when you have a serious number of memoized functions,
;;; and you have a notion of "starting over."
(defmacro defmemo (fname &body body)
`(progn (defun ,fname ,@body)
(eval-when (:load-toplevel)
(memoize ',fname)
(system-add-memoized-fn ',fname))))
(let ((+memoized-fns+ nil))
(defun system-clear-memoized-fns ()
(mapcar #'(lambda (x)
(warn "Clearing memoized ~A" x)
(clear-memoize x))
+memoized-fns+))
(defun system-add-memoized-fn (fname)
(pushnew fname +memoized-fns+))
(defun system-list-memoized-fns ()
+memoized-fns+)
(defun system-forget-memoized-fns ()
(setf +memoized-fns+ nil))
)
;;; Purpose: Diagnostic (From Howard Stearns) that does
;;; (vars a b c) => (FORMAT *TRACE-OUTPUT* "~&a = ~S b = ~S c = ~S ~%" A B C)
(defmacro VARS (&rest variables)
`(format *trace-output*
,(loop with result = "~&"
for var in variables
do
(setf result
(if (and (consp var)
(eq (first var) 'quote))
(concatenate 'string result " ~S ")
(concatenate 'string result (string-downcase var) " = ~S ")))
finally (return (concatenate 'string result "~%")))
,@variables))
;;; The most essential macro building tool.
(defmacro mac (macro)
`(pprint (macroexpand-1 ',macro)))
;;; Similar, but used on 'subtype' macros.
(defmacro mac2 (macro)
`(pprint (macroexpand-1 (macroexpand-1 ',macro))))
;;; Dirk H.P. Gerrits' "Lisp Code Walker" slides, ALU Meeting, Amsterdam, 2003.
;;; With additional corrections (beyond that in his notes).
(defvar *mea-hooks* (make-hash-table :test #'eq))
(defun macroexpand-all (form &optional env)
"Macroexpand FORM recursively until none of its subforms can be further expanded."
(multiple-value-bind (expansion macrop)
(macroexpand-1 form env)
(declare (ignore macrop))
(let* ((key (and (consp form) (car form)))
(hook (gethash key *mea-hooks*)))
(cond (hook (funcall hook form env))
((and (consp form) (symbolp (car form)) (macro-function (car form)))
(macroexpand-all expansion env))
((consp form) (cons (car form)
(mapcar #'(lambda (arg)
(macroexpand-all arg env))
(cdr form))))
(t expansion)))))
(defun load-ht (ht key-value-pairs)
"Load the argument hash table with the argument values
provided in a flat list of <key> <value>. "
(loop while key-value-pairs
do
(setf (gethash (pop key-value-pairs) ht)
(pop key-value-pairs)))
ht)
(defmacro when-bind ((var expr) &body body)
"Paul Graham ON LISP pg 145. when+let"
`(let ((,var ,expr))
(when ,var
,@body)))
(defmacro if-bind ((var expr) then else)
`(let ((,var ,expr))
(if ,var
,then
,else)))
(defmacro when-bind* (binds &body body)
"Paul Graham ON LISP pg 145. when+let*"
(if (null binds)
`(progn ,@body)
`(let (,(car binds))
(if ,(caar binds)
(when-bind* ,(cdr binds) ,@body)))))
(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)
,@body))
(declaim (inline substring))
(defun substring (str1 str2)
"Returns the place in str1 where str2 begins or nil if str2 is not in str1"
(search str2 str1 :test #'string=))
(defun remove-extra-spaces (string)
"Leave only one space between non-space characters of argument string."
(let* ((len (length string))
(new-string (make-array len :element-type 'character :fill-pointer 0)))
(vector-push (char string 0) new-string)
(loop for i from 1 to (1- len)
unless (and (char= #\Space (char string i))
(char= #\Space (char string (1- i))))
do (vector-push (char string i) new-string))
new-string))
(defun break-line-at (string break-bag position)
"Return the argument STRING with linefeeds inserted at some position past POSITION
where a character in the break-bag is encountered."
(let* ((len (length string))
(new-string (make-array (* 2 len) :element-type 'character :fill-pointer 0)))
(loop for ix from 0 to (1- (length string))
with count = 0
do (vector-push (char string ix) new-string)
(incf count)
when (and (> count position)
(find (char string ix) break-bag))
do (vector-push #\Linefeed new-string)
(setf count 0)
finally (return new-string))))
(defun read-string-to-list (string)
(loop with val = nil and start = 0
do (multiple-value-setq (val start)
(read-from-string string nil :eof :start start))
until (eql val :eof)
collect val))
[405 lines skipped]
