[cells-cvs] CVS cells/utils-kt
ktilton
ktilton at common-lisp.net
Thu Mar 16 05:26:47 UTC 2006
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 , at 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)))
+ , at 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
More information about the Cells-cvs
mailing list