Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv23261/utils-kt

Modified Files: debug.lisp defpackage.lisp detritus.lisp strings.lisp utils-kt.lpr Log Message: Cells 3 support

--- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2005/09/26 15:36:05 1.5 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2006/03/16 05:26:47 1.6 @@ -55,7 +55,7 @@ (assert (stringp ,(car os))) (call-trc t ,@os)) ;;,(car os) ,tgt ,@(cdr os))) (progn - (break "trcfailed") + ;; (break "trcfailed") (count-it :trcfailed))) (count-it :tgtnileval)))))))

--- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2005/05/06 21:05:56 1.1 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2006/03/16 05:26:47 1.2 @@ -38,9 +38,11 @@ #:intern$ #:define-constant #:*count* #:*stop* #:*dbg* #:*trcdepth* - #:make-fifo-queue #:fifo-add #:fifo-empty #:fifo-pop #:mapfifo + #:make-fifo-queue #:fifo-queue #:fifo-add #:fifo-delete + #:fifo-empty #:fifo-pop #:fifo-clear + #:fifo-map #:fifo-peek #:fifo-data #:with-fifo-map #:fifo-length

- #-mcl #:true + #-(or lispworks mcl) #:true #+clisp #:slot-definition-name #+(and mcl (not openmcl-partial-mop)) #:class-slots -)) + )) --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2005/09/26 15:36:05 1.2 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2006/03/16 05:26:47 1.3 @@ -42,7 +42,7 @@ (copy-list (class-instance-slots c))))

-#-(or mcl) +#-(or lispworks mcl) (progn (defun true (it) (declare (ignore it)) t) (defun false (it) (declare (ignore it)))) @@ -50,7 +50,22 @@ (defun xor (c1 c2) (if c1 (not c2) c2))

-(defun make-fifo-queue () (cons nil nil)) +;;; --- FIFO Queue ----------------------------- + +(defun make-fifo-queue (&rest init-data) + (let ((q (cons nil nil))) + (prog1 q + (loop for id in init-data + do (fifo-add q id))))) + +(deftype fifo-queue () 'cons) + +(defun fifo-data (q) (car q)) +(defun fifo-clear (q) (rplaca q nil)) +(defun fifo-empty (q) (not (fifo-data q))) +(defun fifo-length (q) (length (fifo-data q))) +(defun fifo-peek (q) (car (fifo-data q))) + (defun fifo-add (q new) (if (car q) (let ((last (cdr q)) @@ -60,23 +75,37 @@ (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-delete (q dead) + (let ((c (member dead (fifo-data q)))) + (assert c) + (rplaca q (delete dead (fifo-data q))) + (when (eq c (cdr q)) + (rplacd q (last (fifo-data q)))))) + (defun fifo-pop (q) - (prog1 - (caar q) - (rplaca q (cdar q)))) + (unless (fifo-empty q) + (prog1 + (fifo-peek q) + (rplaca q (cdar q)))))

-(defun mapfifo (fn q) +(defun fifo-map (q fn) (loop until (fifo-empty q) do (funcall fn (fifo-pop q))))

+(defmacro with-fifo-map ((pop-var q) &body body) + (let ((qc (gensym))) + `(loop with ,qc = ,q + while (not (fifo-empty ,qc)) + do (let ((,pop-var (fifo-pop ,qc))) + ,@body)))) + #+(or) (let ((*print-circle* t)) (let ((q (make-fifo-queue))) (loop for n below 3 do (fifo-add q n)) - (fifo-queue q) + (fifo-delete q 1) (loop until (fifo-empty q) do (print (fifo-pop q)))))

@@ -93,3 +122,39 @@ (symbol-value ',name) value))) ,@(when docstring (list docstring)))) + +#+allegro +(defun line-count (path &optional show-files (depth 0)) + (cond + ((excl:file-directory-p path) + (when show-files + (format t "~&~v,8t~a counts:" depth (pathname-directory path))) + (let ((directory-lines + (loop for file in (directory path :directories-are-files nil) + for lines = (line-count file show-files (1+ depth)) + when (and show-files (plusp lines)) + do (bwhen (fname (pathname-name file)) + (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines)) + summing lines))) + (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines) + directory-lines)) + + ((find (pathname-type path) '("cl" "lisp" "c" "h" "java") + :test 'string-equal) + (source-line-count path)) + (t 0))) + +(defun source-line-count (path) + (with-open-file (s path) + (loop with lines = 0 + for c = (read-char s nil nil) + while c + when (find c '(#\newline #\return)) + do (incf lines) + finally (return lines)))) + +#+(or) +(line-count (make-pathname + :device "c" + :directory `(:absolute "0dev" "Algebra")) t) + --- /project/cells/cvsroot/cells/utils-kt/strings.lisp 2005/09/26 15:36:05 1.2 +++ /project/cells/cvsroot/cells/utils-kt/strings.lisp 2006/03/16 05:26:47 1.3 @@ -159,7 +159,7 @@ (down$ s))

(defun down$ (s) - (typecase s + (etypecase s (null "") (string (string-downcase s)) (number (format nil "~a" s)) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2005/09/26 15:05:43 1.4 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.lpr 2006/03/16 05:26:47 1.5 @@ -1,9 +1,9 @@ -;; -*- lisp-version: "7.0 [Windows] (Sep 4, 2005 16:25)"; cg: "1.54.2.17"; -*- +;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*-

(in-package :cg-user)

(defpackage :COMMON-LISP - (:export #:list + (:export #:list #:make-instance #:t #:nil @@ -12,9 +12,10 @@ (define-project :name :utils-kt :modules (list (make-instance 'module :name "defpackage.lisp") (make-instance 'module :name "debug.lisp") - (make-instance 'module :name "detritus.lisp") (make-instance 'module :name "flow-control.lisp") - (make-instance 'module :name "strings.lisp")) + (make-instance 'module :name "detritus.lisp") + (make-instance 'module :name "strings.lisp") + (make-instance 'module :name "datetime.lisp")) :projects nil :libraries nil :distributed-files nil