r4666: *** empty log message ***
authorKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 28 Apr 2003 23:51:59 +0000 (23:51 +0000)
committerKevin M. Rosenberg <kevin@rosenberg.net>
Mon, 28 Apr 2003 23:51:59 +0000 (23:51 +0000)
14 files changed:
attrib-class.lisp
cl-symbols.lisp [deleted file]
datetime.lisp
debian/changelog
functions.lisp [new file with mode: 0644]
genutils.lisp [deleted file]
io.lisp [new file with mode: 0644]
kmrcl.asd
macros.lisp [new file with mode: 0644]
math.lisp
package.lisp
strings.lisp
symbols.lisp [new file with mode: 0644]
tests.lisp

index 0b837ad..1c15e34 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: attrib-class.lisp,v 1.5 2003/04/28 21:12:27 kevin Exp $
+;;;; $Id: attrib-class.lisp,v 1.6 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 
 (in-package :kmrcl)
 
-(defclass attributes-dsd (standard-direct-slot-definition)
-  ((attributes :initarg :attributes :initform nil 
-              :accessor attributes)))
+(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition)
+  ((attributes :initarg :attributes :initform nil
+              :accessor dsd-attributes)))
 
-(defclass attributes-esd (standard-effective-slot-definition)
+(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
   ((attributes :initarg :attributes :initform nil 
-              :accessor slot-definition-attributes)))
+              :accessor esd-attributes)))
 
 
-(defclass attributes-class (standard-class)
+(defclass attributes-class (kmr-mop:standard-class)
   ()
-  )
+  (:documentation "metaclass that implements attributes on slots. Based
+on example from AMOP"))
+
 
 #+(or cmu scl sbcl)
-(defmethod validate-superclass ((class attributes-class)
-                               (superclass standard-class))
+(defmethod kmr-mop:validate-superclass ((class attributes-class)
+                                       (superclass kmr-mop:standard-class))
   t)
 
-(defmethod direct-slot-definition-class ((cl attributes-class) 
-                                             &rest iargs &key attributes)
-  (declare (ignorable attributes))
-;;  (format t "attributes:~s iargs:~s~%" attributes iargs)
-  (find-class 'attributes-dsd))
+(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) 
+                                                &rest iargs &key attributes)
+  (declare (ignore attributes))
+  ;;  (format t "attributes:~s iargs:~s~%" attributes iargs)
+  (kmr-mop:find-class 'attributes-dsd))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (when (>= (length (generic-function-lambda-list
-                    (ensure-generic-function
-                     'compute-effective-slot-definition)))
-           3)
-    (push :ho-named-cesd-fun cl:*features*)))
-
-(defmethod compute-effective-slot-definition :around
-    ((cl attributes-class) #+ho-named-cesd-fun name dsds)
-  #+ho-named-cesd-fun (declare (ignore name))
+(defmethod kmr-mop:compute-effective-slot-definition :around
+    ((cl attributes-class) #+kmr-named-cesd name dsds)
+  #+kmr-named-cesd (declare (ignore name))
   (apply
    #'make-instance 'attributes-esd 
-   :attributes (remove-duplicates (mapappend #'attributes dsds))
-   (compute-effective-slot-definition-initargs cl dsds))
+   :attributes (remove-duplicates (mapappend #'dsd-attributes dsds))
+   (kmr-mop:compute-effective-slot-definition-initargs cl dsds))
   )
 
-
 #+ignore
-(defmethod compute-effective-slot-definition :around
-    ((cl attributes-class) #+ho-named-cesd-fun name dsds)
-  #+ho-named-cesd-fun (declare (ignore name))
+(defmethod kmr-mop:compute-effective-slot-definition :around
+    ((cl attributes-class) #+kmr-named-cesd name dsds)
+  #+kmr-named-cesd (declare (ignore name))
   (let ((normal-slot (call-next-method)))
-    (setf (slot-definition-attributes normal-slot)
+    (setf (esd-attributes normal-slot)
       (remove-duplicates
-       (mapappend #'slot-definition-attributes dsds)))
+       (mapappend #'esd-attributes dsds)))
     normal-slot))
 
 
-(defmethod compute-slots ((class attributes-class))
+(defmethod kmr-mop:compute-slots ((class attributes-class))
   (let* ((normal-slots (call-next-method))
         (alist
          (mapcar
           #'(lambda (slot)
               (let ((attr-list (mapcar #'(lambda (attr) (cons attr nil))
-                                       (slot-definition-attributes slot))))
+                                       (esd-attributes slot))))
                 (when attr-list
-                  (cons (mop::slot-definition-name slot) attr-list))))
+                  (cons (kmr-mop:slot-definition-name slot) attr-list))))
           normal-slots)))
     (setq alist (delete nil alist))
-    (cons (mop::make-instance 'mop::standard-effective-slot-definition
+    (cons (make-instance 'kmr-mop:standard-effective-slot-definition
            :name 'all-attributes
            :initform `',alist
            :initfunction #'(lambda () alist))
               slot-name instance attribute))
       attr-bucket)))
 
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (export '(attributes-class slot-attributes)))
 
diff --git a/cl-symbols.lisp b/cl-symbols.lisp
deleted file mode 100644 (file)
index ab709f6..0000000
+++ /dev/null
@@ -1,72 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          cl-symbols.lisp
-;;;; Purpose:       Returns all defined Common Lisp symbols
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Apr 2000
-;;;;
-;;;; $Id: cl-symbols.lisp,v 1.5 2002/12/15 17:10:50 kevin Exp $
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; KMRCL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(in-package :kmrcl)
-
-(defun cl-symbols ()
-  (append (cl-variables) (cl-functions)))
-
-(defun cl-variables ()
-  (let ((vars '()))
-    (do-symbols (s 'common-lisp)
-      (multiple-value-bind (sym status)
-         (find-symbol (symbol-name s) 'common-lisp)
-       (when (and (or (eq status :external)
-                      (eq status :internal))
-                  (boundp sym))
-         (push sym vars))))
-    (nreverse vars)))
-
-(defun cl-functions ()
-  (let ((funcs '()))
-    (do-symbols (s 'common-lisp)
-      (multiple-value-bind (sym status)
-       (find-symbol (symbol-name s) 'common-lisp)
-       (when (and (or (eq status :external)
-                      (eq status :internal))
-                  (fboundp sym))
-         (push sym funcs))))
-    (nreverse funcs)))
-
-;;; Symbol functions
-
-(defun concat-symbol-pkg (pkg &rest args)
-  (declare (dynamic-extent args))
-  (flet ((stringify (arg)
-           (etypecase arg
-             (string
-              (string-upcase arg))
-             (symbol
-              (symbol-name arg)))))
-    (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
-      (intern #-case-sensitive (string-upcase str)
-             #+case-sensitive str
-             (if pkg pkg *package*)))))
-
-
-(defun concat-symbol (&rest args)
-  (apply #'concat-symbol-pkg nil args))
-
-(defun ensure-keyword (name)
-  "Returns keyword for a name"
-  (etypecase name
-    (keyword name)
-    (string (intern #-case-sensitive (string-upcase name)
-                   #+case-sensitive name
-                   :keyword))
-    (symbol (intern (symbol-name name) :keyword))))
index 9d20449..b8d3267 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: datetime.lisp,v 1.1 2003/04/28 21:12:27 kevin Exp $
+;;;; $Id: datetime.lisp,v 1.2 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
                (1- mon)
                year
                hr min sec))))
+
+(defun print-seconds (secs)
+  (print-float-units secs "sec"))
+
+(defun print-float-units (val unit)
+  (cond
+    ((< val 1d-6)
+     (format t "~,2,9F nano~A" val unit))
+    ((< val 1d-3)
+     (format t "~,2,6F micro~A" val unit))
+    ((< val 1)
+     (format t "~,2,3F milli~A" val unit))
+    ((> val 1d9)
+     (format t "~,2,-9F giga~A" val unit))
+    ((> val 1d6)
+     (format t "~,2,-6F mega~A" val unit))
+    ((> val 1d3)
+     (format t "~,2,-3F kilo~A" val unit))
+    (t
+     (format t "~,2F ~A" val unit))))
+
index e8165ab..075394f 100644 (file)
@@ -1,6 +1,7 @@
 cl-kmrcl (1.31-1) unstable; urgency=low
 
   * New upstream
+  * Add kmr-mop package
   * Add tests suite, add cl-rt to depends
   * Use compat file rather than DH_COMPAT variable
 
diff --git a/functions.lisp b/functions.lisp
new file mode 100644 (file)
index 0000000..ffc8ac6
--- /dev/null
@@ -0,0 +1,54 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          functions.lisp
+;;;; Purpose:       Function routines for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: functions.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(defun memo-proc (fn)
+  "Memoize results of call to fn, returns a closure with hash-table"
+  (let ((cache (make-hash-table :test #'equal)))
+    #'(lambda (&rest args)
+        (multiple-value-bind (val foundp) (gethash args cache)
+          (if foundp
+              val
+              (setf (gethash args cache) 
+                    (apply fn args)))))))
+
+(defun memoize (fn-name)
+  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
+
+(defmacro defun-memo (fn args &body body)
+  "Define a memoized function"
+  `(memoize (defun ,fn ,args . ,body)))
+
+(defmacro _f (op place &rest args)
+  (multiple-value-bind (vars forms var set access) 
+                       (get-setf-expansion place)
+    `(let* (,@(mapcar #'list vars forms)
+            (,(car var) (,op ,access ,@args)))
+       ,set)))
+
+(defun compose (&rest fns)
+  (if fns
+      (let ((fn1 (car (last fns)))
+            (fns (butlast fns)))
+        #'(lambda (&rest args)
+            (reduce #'funcall fns 
+                    :from-end t
+                    :initial-value (apply fn1 args))))
+      #'identity))
+
diff --git a/genutils.lisp b/genutils.lisp
deleted file mode 100644 (file)
index cbd78f1..0000000
+++ /dev/null
@@ -1,529 +0,0 @@
-;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          gentils.lisp
-;;;; Purpose:       Main general utility functions for KMRCL package
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Apr 2000
-;;;;
-;;;; $Id: genutils.lisp,v 1.16 2003/04/28 21:12:27 kevin Exp $
-;;;;
-;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; KMRCL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-
-(in-package :kmrcl)
-
-(defmacro let-when ((var test-form) &body body)
-  `(let ((,var ,test-form))
-      (when ,var ,@body)))
-  
-(defmacro let-if ((var test-form) if-true &optional if-false)
-  `(let ((,var ,test-form))
-      (if ,var ,if-true ,if-false)))
-
-;; Anaphoric macros
-
-(defmacro aif (test then &optional else)
-  `(let ((it ,test))
-     (if it ,then ,else)))
-
-(defmacro awhen (test-form &body body)
-  `(aif ,test-form
-        (progn ,@body)))
-
-(defmacro awhile (expr &body body)
-  `(do ((it ,expr ,expr))
-       ((not it))
-     ,@body))
-
-(defmacro aand (&rest args)
-  (cond ((null args) t)
-        ((null (cdr args)) (car args))
-        (t `(aif ,(car args) (aand ,@(cdr args))))))
-
-(defmacro acond (&rest clauses)
-  (if (null clauses)
-      nil
-      (let ((cl1 (car clauses))
-            (sym (gensym)))
-        `(let ((,sym ,(car cl1)))
-           (if ,sym
-               (let ((it ,sym)) ,@(cdr cl1))
-               (acond ,@(cdr clauses)))))))
-
-(defmacro alambda (parms &body body)
-  `(labels ((self ,parms ,@body))
-     #'self))
-
-
-(defmacro aif2 (test &optional then else)
-  (let ((win (gensym)))
-    `(multiple-value-bind (it ,win) ,test
-       (if (or it ,win) ,then ,else))))
-
-(defmacro awhen2 (test &body body)
-  `(aif2 ,test
-         (progn ,@body)))
-
-(defmacro awhile2 (test &body body)
-  (let ((flag (gensym)))
-    `(let ((,flag t))
-       (while ,flag
-         (aif2 ,test
-               (progn ,@body)
-               (setq ,flag nil))))))
-
-(defmacro acond2 (&rest clauses)
-  (if (null clauses)
-      nil
-      (let ((cl1 (car clauses))
-            (val (gensym))
-            (win (gensym)))
-        `(multiple-value-bind (,val ,win) ,(car cl1)
-           (if (or ,val ,win)
-               (let ((it ,val)) ,@(cdr cl1))
-               (acond2 ,@(cdr clauses)))))))
-
-
-;; Debugging 
-
-(defmacro mac (expr)
-"Expand a macro"
-  `(pprint (macroexpand-1 ',expr)))
-
-(defmacro print-form-and-results (form)
-  `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
-
-(defun show (&optional (what :variables) (package *package*))
-  (ecase what
-    (:variables (show-variables package))
-    (:functions (show-functions package))))
-
-(defun show-variables (package)
-  (do-symbols (s package)
-    (multiple-value-bind (sym status)
-       (find-symbol (symbol-name s) package)
-      (when (and (or (eq status :external)
-                    (eq status :internal))
-                (boundp sym))
-       (format t "~&Symbol ~S~T -> ~S~%"
-               sym
-               (symbol-value sym))))))
-
-(defun show-functions (package)
-  (do-symbols (s package)
-    (multiple-value-bind (sym status)
-       (find-symbol (symbol-name s) package)
-      (when (and (or (eq status :external)
-                    (eq status :internal))
-                (fboundp sym))
-       (format t "~&Function ~S~T -> ~S~%"
-               sym
-               (symbol-function sym))))))
-
-#+allegro
-(ff:def-foreign-call (memory-status-dump "memory_status_dump")
-    ()
-  :strings-convert t)
-
-
-;; Ensure functions
-
-(defmacro ensure-integer (obj)
-  "Ensure object is an integer. If it is a string, then parse it"
-  `(if (stringp ,obj)
-      (parse-integer ,obj)
-    ,obj))
-
-;; Lists
-
-(defun mklist (obj)
-  "Make into list if atom"
-  (if (listp obj) obj (list obj)))
-
-(defun filter (fn lst)
-  "Filter a list by function, eliminate elements where fn returns nil"
-  (let ((acc nil))
-    (dolist (x lst)
-      (let ((val (funcall fn x)))
-        (if val (push val acc))))
-    (nreverse acc)))
-
-(defun appendnew (l1 l2)
-  "Append two lists, filtering out elem from second list that are already in first list"
-  (dolist (elem l2)
-    (unless (find elem l1)
-      (setq l1 (append l1 (list elem)))))
-  l1)
-
-;; Functions
-
-(defun memo-proc (fn)
-  "Memoize results of call to fn, returns a closure with hash-table"
-  (let ((cache (make-hash-table :test #'equal)))
-    #'(lambda (&rest args)
-        (multiple-value-bind (val foundp) (gethash args cache)
-          (if foundp
-              val
-              (setf (gethash args cache) 
-                    (apply fn args)))))))
-
-(defun memoize (fn-name)
-  (setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
-
-(defmacro defun-memo (fn args &body body)
-  "Define a memoized function"
-  `(memoize (defun ,fn ,args . ,body)))
-
-(defmacro _f (op place &rest args)
-  (multiple-value-bind (vars forms var set access) 
-                       (get-setf-expansion place)
-    `(let* (,@(mapcar #'list vars forms)
-            (,(car var) (,op ,access ,@args)))
-       ,set)))
-
-(defun compose (&rest fns)
-  (if fns
-      (let ((fn1 (car (last fns)))
-            (fns (butlast fns)))
-        #'(lambda (&rest args)
-            (reduce #'funcall fns 
-                    :from-end t
-                    :initial-value (apply fn1 args))))
-      #'identity))
-
-;;; Loop macros
-
-(defmacro until (test &body body)
-  `(do ()
-       (,test)
-     ,@body))
-
-(defmacro while (test &body body)
-  `(do ()
-       ((not ,test))
-     ,@body))
-
-(defmacro for ((var start stop) &body body)
-  (let ((gstop (gensym)))
-    `(do ((,var ,start (1+ ,var))
-          (,gstop ,stop))
-         ((> ,var ,gstop))
-       ,@body)))
-
-(defmacro with-each-stream-line ((var stream) &body body)
-  (let ((eof (gensym))
-       (eof-value (gensym))
-       (strm (gensym)))
-    `(let ((,strm ,stream)
-          (,eof ',eof-value))
-      (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
-         ((eql ,var ,eof))
-       ,@body))))
-
-(defmacro with-each-file-line ((var file) &body body)
-  (let ((stream (gensym)))
-    `(with-open-file (,stream ,file :direction :input)
-      (with-each-stream-line (,var ,stream)
-       ,@body))))
-
-               
-;;; Keyword functions
-
-(defun remove-keyword (key arglist)
-  (loop for sublist = arglist then rest until (null sublist)
-       for (elt arg . rest) = sublist
-       unless (eq key elt) append (list elt arg)))
-
-(defun remove-keywords (key-names args)
-  (loop for ( name val ) on args by #'cddr
-       unless (member (symbol-name name) key-names 
-                      :key #'symbol-name :test 'equal)
-       append (list name val)))
-
-(defmacro in (obj &rest choices)
-  (let ((insym (gensym)))
-    `(let ((,insym ,obj))
-       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
-                     choices)))))
-
-(defmacro mean (&rest args)
-  `(/ (+ ,@args) ,(length args)))
-
-(defmacro with-gensyms (syms &body body)
-  `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
-         syms)
-     ,@body))
-
-
-;;; Mapping
-
-(defun mapappend (fn list)
-  (apply #'append (mapcar fn list)))
-
-
-(defun mapcar-append-string-nontailrec (func v)
-  "Concatenate results of mapcar lambda calls"  
-  (aif (car v)
-       (concatenate 'string (funcall func it)
-                   (mapcar-append-string-nontailrec func (cdr v)))
-       ""))
-
-
-(defun mapcar-append-string (func v &optional (accum ""))
-  "Concatenate results of mapcar lambda calls"  
-  (aif (car v)
-       (mapcar-append-string 
-       func 
-       (cdr v) 
-       (concatenate 'string accum (funcall func it)))
-       accum))
-
-(defun mapcar2-append-string-nontailrec (func la lb)
-  "Concatenate results of mapcar lambda call's over two lists"  
-  (let ((a (car la))
-       (b (car lb)))
-    (if (and a b)
-      (concatenate 'string (funcall func a b)
-                  (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
-      "")))
-  
-(defun mapcar2-append-string (func la lb &optional (accum ""))
-  "Concatenate results of mapcar lambda call's over two lists"  
-  (let ((a (car la))
-       (b (car lb)))
-    (if (and a b)
-       (mapcar2-append-string 
-        func 
-        (cdr la) 
-        (cdr lb)
-        (concatenate 'string accum (funcall func a b)))
-      accum)))
-  
-
-;;; Output
-
-(defun indent-spaces (n &optional (stream *standard-output*))
-  "Indent n*2 spaces to output stream"
-  (when (numberp n)
-    (let ((fmt (format nil "~~~DT" (+ n n))))
-      (format stream fmt))))
-
-(defun print-list (l &optional (output *standard-output*))
-  "Print a list to a stream"
-  (if (consp l)
-    (progn
-      (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
-      t)
-    nil))
-
-(defun print-rows (rows &optional (ostrm *standard-output*))
-  "Print a list of list rows to a stream"  
-  (dolist (r rows)
-    (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
-    (terpri ostrm)))
-
-
-;;; IO
-
-
-(defstruct buf
-  vec (start -1) (used -1) (new -1) (end -1))
-
-(defun bref (buf n)
-  (svref (buf-vec buf)
-         (mod n (length (buf-vec buf)))))
-
-(defun (setf bref) (val buf n)
-  (setf (svref (buf-vec buf)
-               (mod n (length (buf-vec buf))))
-        val))
-
-(defun new-buf (len)
-  (make-buf :vec (make-array len)))
-
-(defun buf-insert (x b)
-  (setf (bref b (incf (buf-end b))) x))
-
-(defun buf-pop (b)
-  (prog1 
-    (bref b (incf (buf-start b)))
-    (setf (buf-used b) (buf-start b)
-          (buf-new  b) (buf-end   b))))
-
-(defun buf-next (b)
-  (when (< (buf-used b) (buf-new b))
-    (bref b (incf (buf-used b)))))
-
-(defun buf-reset (b)
-  (setf (buf-used b) (buf-start b)
-        (buf-new  b) (buf-end   b)))
-
-(defun buf-clear (b)
-  (setf (buf-start b) -1 (buf-used  b) -1
-        (buf-new   b) -1 (buf-end   b) -1))
-
-(defun buf-flush (b str)
-  (do ((i (1+ (buf-used b)) (1+ i)))
-      ((> i (buf-end b)))
-    (princ (bref b i) str)))
-
-
-(defun file-subst (old new file1 file2)
-  (with-open-file (in file1 :direction :input)
-    (with-open-file (out file2 :direction :output
-                        :if-exists :supersede)
-      (stream-subst old new in out))))
-
-(defun stream-subst (old new in out)
-  (declare (string old new))
-  (let* ((pos 0)
-         (len (length old))
-         (buf (new-buf len))
-         (from-buf nil))
-    (declare (fixnum pos len))
-    (do ((c (read-char in nil :eof)
-            (or (setf from-buf (buf-next buf))
-                (read-char in nil :eof))))
-        ((eql c :eof))
-      (declare (character c))
-      (cond ((char= c (char old pos))
-             (incf pos)
-             (cond ((= pos len)            ; 3
-                    (princ new out)
-                    (setf pos 0)
-                    (buf-clear buf))
-                   ((not from-buf)         ; 2
-                    (buf-insert c buf))))
-            ((zerop pos)                   ; 1
-             (princ c out)
-             (when from-buf
-               (buf-pop buf)
-               (buf-reset buf)))
-            (t                             ; 4
-             (unless from-buf
-               (buf-insert c buf))
-             (princ (buf-pop buf) out)
-             (buf-reset buf)
-             (setf pos 0))))
-    (buf-flush buf out)))
-
-
-;;; Tree Functions
-
-(defun remove-tree-if (pred tree)
-  "Strip from tree of atoms that satistify predicate"
-  (if (atom tree)
-      (unless (funcall pred tree)
-       tree)
-    (let ((car-strip (remove-tree-if pred (car tree)))
-         (cdr-strip (remove-tree-if pred (cdr tree))))
-      (cond
-       ((and car-strip (atom (cadr tree)) (null cdr-strip))
-       (list car-strip))
-       ((and car-strip cdr-strip)
-       (cons car-strip cdr-strip))
-       (car-strip
-       car-strip)
-       (cdr-strip
-       cdr-strip)))))
-
-(defun find-tree (sym tree)
-  "Finds an atom as a car in tree and returns cdr tree at that positions"
-  (if (or (null tree) (atom tree))
-      nil
-    (if (eql sym (car tree))
-       (cdr tree)
-      (aif (find-tree sym (car tree))
-         it
-       (aif (find-tree sym (cdr tree))
-           it
-         nil)))))
-
-;;; Files
-
-(defun print-file-contents (file &optional (strm *standard-output*))
-  "Opens a reads a file. Returns the contents as a single string"
-  (when (probe-file file)
-    (with-open-file (in file :direction :input)
-      (let ((eof (gensym)))                
-       (do ((line (read-line in nil eof) 
-                  (read-line in nil eof)))
-           ((eq line eof))
-         (format strm "~A~%" line))))))
-
-(defun read-file-to-string (file)
-  "Opens a reads a file. Returns the contents as a single string"
-  (with-output-to-string (out)
-    (with-open-file (in file :direction :input)
-      (let ((eof (gensym)))                
-       (do ((line (read-line in nil eof) 
-                  (read-line in nil eof)))
-           ((eq line eof))
-         (format out "~A~%" line))))))
-
-(defun read-file-to-strings (file)
-  "Opens a reads a file. Returns the contents as a list of strings"
-  (let ((lines '()))
-    (with-open-file (in file :direction :input)
-      (let ((eof (gensym)))                
-       (do ((line (read-line in nil eof) 
-                  (read-line in nil eof)))
-           ((eq line eof))
-         (push line lines)))
-      (nreverse lines))))
-
-
-
-;; Benchmarking
-
-(defun print-float-units (val unit)
-  (cond
-    ((< val 1d-6)
-     (format t "~,2,9F nano~A" val unit))
-    ((< val 1d-3)
-     (format t "~,2,6F micro~A" val unit))
-    ((< val 1)
-     (format t "~,2,3F milli~A" val unit))
-    ((> val 1d9)
-     (format t "~,2,-9F giga~A" val unit))
-    ((> val 1d6)
-     (format t "~,2,-6F mega~A" val unit))
-    ((> val 1d3)
-     (format t "~,2,-3F kilo~A" val unit))
-    (t
-     (format t "~,2F ~A" val unit))))
-
-(defun print-seconds (secs)
-  (print-float-units secs "sec"))
-
-(defmacro time-iterations (n &body body)
-  (let ((i (gensym))
-       (count (gensym)))
-    `(progn
-       (let ((,count ,n))
-        (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
-        (let ((t1 (get-internal-real-time)))
-          (dotimes (,i ,count)
-            ,@body)
-          (let* ((t2 (get-internal-real-time))
-                 (secs (coerce (/ (- t2 t1)
-                                  internal-time-units-per-second)
-                               'double-float)))
-            (format t "~&Total time: ")
-            (print-seconds secs)
-            (format t ", time per iteration: ")
-            (print-seconds (coerce (/ secs ,n) 'double-float))))))))
-
-
-(defun nsubseq (sequence start &optional (end (length sequence)))
-  (make-array (- end start)
-             :element-type (array-element-type sequence)
-             :displaced-to sequence
-             :displaced-index-offset start))
diff --git a/io.lisp b/io.lisp
new file mode 100644 (file)
index 0000000..753cc44
--- /dev/null
+++ b/io.lisp
@@ -0,0 +1,156 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          io.lisp
+;;;; Purpose:       Input/Output functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: io.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(defun print-file-contents (file &optional (strm *standard-output*))
+  "Opens a reads a file. Returns the contents as a single string"
+  (when (probe-file file)
+    (with-open-file (in file :direction :input)
+      (let ((eof (gensym)))                
+       (do ((line (read-line in nil eof) 
+                  (read-line in nil eof)))
+           ((eq line eof))
+         (format strm "~A~%" line))))))
+
+(defun read-file-to-string (file)
+  "Opens a reads a file. Returns the contents as a single string"
+  (with-output-to-string (out)
+    (with-open-file (in file :direction :input)
+      (let ((eof (gensym)))                
+       (do ((line (read-line in nil eof) 
+                  (read-line in nil eof)))
+           ((eq line eof))
+         (format out "~A~%" line))))))
+
+(defun read-file-to-strings (file)
+  "Opens a reads a file. Returns the contents as a list of strings"
+  (let ((lines '()))
+    (with-open-file (in file :direction :input)
+      (let ((eof (gensym)))                
+       (do ((line (read-line in nil eof) 
+                  (read-line in nil eof)))
+           ((eq line eof))
+         (push line lines)))
+      (nreverse lines))))
+
+(defun file-subst (old new file1 file2)
+  (with-open-file (in file1 :direction :input)
+    (with-open-file (out file2 :direction :output
+                        :if-exists :supersede)
+      (stream-subst old new in out))))
+
+
+(defun indent-spaces (n &optional (stream *standard-output*))
+  "Indent n*2 spaces to output stream"
+  (when (numberp n)
+    (let ((fmt (format nil "~~~DT" (+ n n))))
+      (format stream fmt))))
+
+(defun print-list (l &optional (output *standard-output*))
+  "Print a list to a stream"
+  (if (consp l)
+    (progn
+      (mapcar (lambda (x) (princ x output) (princ #\newline output)) l)
+      t)
+    nil))
+
+(defun print-rows (rows &optional (ostrm *standard-output*))
+  "Print a list of list rows to a stream"  
+  (dolist (r rows)
+    (mapcar (lambda (a) (princ a ostrm) (princ #\space ostrm)) r)
+    (terpri ostrm)))
+
+
+;; Buffered stream substitute
+
+(defstruct buf
+  vec (start -1) (used -1) (new -1) (end -1))
+
+(defun bref (buf n)
+  (svref (buf-vec buf)
+         (mod n (length (buf-vec buf)))))
+
+(defun (setf bref) (val buf n)
+  (setf (svref (buf-vec buf)
+               (mod n (length (buf-vec buf))))
+        val))
+
+(defun new-buf (len)
+  (make-buf :vec (make-array len)))
+
+(defun buf-insert (x b)
+  (setf (bref b (incf (buf-end b))) x))
+
+(defun buf-pop (b)
+  (prog1 
+    (bref b (incf (buf-start b)))
+    (setf (buf-used b) (buf-start b)
+          (buf-new  b) (buf-end   b))))
+
+(defun buf-next (b)
+  (when (< (buf-used b) (buf-new b))
+    (bref b (incf (buf-used b)))))
+
+(defun buf-reset (b)
+  (setf (buf-used b) (buf-start b)
+        (buf-new  b) (buf-end   b)))
+
+(defun buf-clear (b)
+  (setf (buf-start b) -1 (buf-used  b) -1
+        (buf-new   b) -1 (buf-end   b) -1))
+
+(defun buf-flush (b str)
+  (do ((i (1+ (buf-used b)) (1+ i)))
+      ((> i (buf-end b)))
+    (princ (bref b i) str)))
+
+
+(defun stream-subst (old new in out)
+  (declare (string old new))
+  (let* ((pos 0)
+         (len (length old))
+         (buf (new-buf len))
+         (from-buf nil))
+    (declare (fixnum pos len))
+    (do ((c (read-char in nil :eof)
+            (or (setf from-buf (buf-next buf))
+                (read-char in nil :eof))))
+        ((eql c :eof))
+      (declare (character c))
+      (cond ((char= c (char old pos))
+             (incf pos)
+             (cond ((= pos len)            ; 3
+                    (princ new out)
+                    (setf pos 0)
+                    (buf-clear buf))
+                   ((not from-buf)         ; 2
+                    (buf-insert c buf))))
+            ((zerop pos)                   ; 1
+             (princ c out)
+             (when from-buf
+               (buf-pop buf)
+               (buf-reset buf)))
+            (t                             ; 4
+             (unless from-buf
+               (buf-insert c buf))
+             (princ (buf-pop buf) out)
+             (buf-reset buf)
+             (setf pos 0))))
+    (buf-flush buf out)))
+
index 6b7ca40..eb47c3f 100644 (file)
--- a/kmrcl.asd
+++ b/kmrcl.asd
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: kmrcl.asd,v 1.24 2003/04/28 21:12:27 kevin Exp $
+;;;; $Id: kmrcl.asd,v 1.25 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -19,7 +19,7 @@
 (defpackage #:kmrcl-system (:use #:asdf #:cl))
 (in-package #:kmrcl-system)
 
-#+(or allegro cmucl lispworks sbcl scl) (push :kmr-mop cl:*features*)
+#+(or allegro cmucl lispworks sbcl scl) (pushnew :kmr-mop cl:*features*)
 
 (defsystem kmrcl
     :name "kmrcl"
 
     :components 
     ((:file "package")
-     (:file "console" :depends-on ("package"))
-     (:file "genutils" :depends-on ("package"))
-     (:file "strings" :depends-on ("package"))
-     (:file "equal" :depends-on ("package"))
-     (:file "buff-input" :depends-on ("genutils"))
-     (:file "telnet-server" :depends-on ("genutils"))
-     (:file "random" :depends-on ("package"))
-     (:file "cl-symbols" :depends-on ("package"))
-     (:file "datetime" :depends-on ("package"))
-     (:file "math" :depends-on ("package"))
-     #+kmr-mop (:file "mop" :depends-on ("package"))
-     #+kmr-mop (:file "attrib-class" :depends-on ("package"))
-     (:file "web-utils" :depends-on ("package"))
-     (:file "xml-utils" :depends-on ("package")))
+     (:file "macros" :depends-on ("package"))
+     (:file "functions" :depends-on ("macros"))
+     (:file "lists" :depends-on ("macros"))
+     (:file "seqs" :depends-on ("macros"))
+     (:file "io" :depends-on ("macros"))
+     (:file "console" :depends-on ("macros"))
+     (:file "strings" :depends-on ("genutils"))
+     (:file "equal" :depends-on ("macros"))
+     (:file "buff-input" :depends-on ("macros"))
+     (:file "telnet-server" :depends-on ("macros"))
+     (:file "random" :depends-on ("macros"))
+     (:file "symbols" :depends-on ("macros"))
+     (:file "datetime" :depends-on ("macros"))
+     (:file "math" :depends-on ("macros"))
+     #+kmr-mop (:file "mop" :depends-on ("macros"))
+     #+kmr-mop (:file "attrib-class" :depends-on ("genutils" "mop"))
+     (:file "web-utils" :depends-on ("macros"))
+     (:file "xml-utils" :depends-on ("macros")))
     )
 
 #+(or allegro lispworks sbcl cmu scl)
@@ -51,3 +55,5 @@
   (oos 'load-op 'kmrcl-tests)
   (oos 'test-op 'kmrcl-tests))
 
+#+kmr-mop
+(setq cl:*features* (delete :kmr-mop cl:*features*))
diff --git a/macros.lisp b/macros.lisp
new file mode 100644 (file)
index 0000000..74ea24b
--- /dev/null
@@ -0,0 +1,167 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          gentils.lisp
+;;;; Purpose:       Main general utility functions for KMRCL package
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: macros.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(defmacro let-when ((var test-form) &body body)
+  `(let ((,var ,test-form))
+      (when ,var ,@body)))
+  
+(defmacro let-if ((var test-form) if-true &optional if-false)
+  `(let ((,var ,test-form))
+      (if ,var ,if-true ,if-false)))
+
+;; Anaphoric macros
+
+(defmacro aif (test then &optional else)
+  `(let ((it ,test))
+     (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+  `(aif ,test-form
+        (progn ,@body)))
+
+(defmacro awhile (expr &body body)
+  `(do ((it ,expr ,expr))
+       ((not it))
+     ,@body))
+
+(defmacro aand (&rest args)
+  (cond ((null args) t)
+        ((null (cdr args)) (car args))
+        (t `(aif ,(car args) (aand ,@(cdr args))))))
+
+(defmacro acond (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses))
+            (sym (gensym)))
+        `(let ((,sym ,(car cl1)))
+           (if ,sym
+               (let ((it ,sym)) ,@(cdr cl1))
+               (acond ,@(cdr clauses)))))))
+
+(defmacro alambda (parms &body body)
+  `(labels ((self ,parms ,@body))
+     #'self))
+
+
+(defmacro aif2 (test &optional then else)
+  (let ((win (gensym)))
+    `(multiple-value-bind (it ,win) ,test
+       (if (or it ,win) ,then ,else))))
+
+(defmacro awhen2 (test &body body)
+  `(aif2 ,test
+         (progn ,@body)))
+
+(defmacro awhile2 (test &body body)
+  (let ((flag (gensym)))
+    `(let ((,flag t))
+       (while ,flag
+         (aif2 ,test
+               (progn ,@body)
+               (setq ,flag nil))))))
+
+(defmacro acond2 (&rest clauses)
+  (if (null clauses)
+      nil
+      (let ((cl1 (car clauses))
+            (val (gensym))
+            (win (gensym)))
+        `(multiple-value-bind (,val ,win) ,(car cl1)
+           (if (or ,val ,win)
+               (let ((it ,val)) ,@(cdr cl1))
+               (acond2 ,@(cdr clauses)))))))
+
+(defmacro mac (expr)
+"Expand a macro"
+  `(pprint (macroexpand-1 ',expr)))
+
+(defmacro print-form-and-results (form)
+  `(format t "~&~A --> ~S~%" (write-to-string ',form) ,form))
+
+
+;;; Loop macros
+
+(defmacro until (test &body body)
+  `(do ()
+       (,test)
+     ,@body))
+
+(defmacro while (test &body body)
+  `(do ()
+       ((not ,test))
+     ,@body))
+
+(defmacro for ((var start stop) &body body)
+  (let ((gstop (gensym)))
+    `(do ((,var ,start (1+ ,var))
+          (,gstop ,stop))
+         ((> ,var ,gstop))
+       ,@body)))
+
+(defmacro with-each-stream-line ((var stream) &body body)
+  (let ((eof (gensym))
+       (eof-value (gensym))
+       (strm (gensym)))
+    `(let ((,strm ,stream)
+          (,eof ',eof-value))
+      (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
+         ((eql ,var ,eof))
+       ,@body))))
+
+(defmacro with-each-file-line ((var file) &body body)
+  (let ((stream (gensym)))
+    `(with-open-file (,stream ,file :direction :input)
+      (with-each-stream-line (,var ,stream)
+       ,@body))))
+
+
+(defmacro in (obj &rest choices)
+  (let ((insym (gensym)))
+    `(let ((,insym ,obj))
+       (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c))
+                     choices)))))
+
+(defmacro mean (&rest args)
+  `(/ (+ ,@args) ,(length args)))
+
+(defmacro with-gensyms (syms &body body)
+  `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
+         syms)
+     ,@body))
+
+
+(defmacro time-iterations (n &body body)
+  (let ((i (gensym))
+       (count (gensym)))
+    `(progn
+       (let ((,count ,n))
+        (format t "~&Test with ~d iterations: ~W" ,count (quote ,body))
+        (let ((t1 (get-internal-real-time)))
+          (dotimes (,i ,count)
+            ,@body)
+          (let* ((t2 (get-internal-real-time))
+                 (secs (coerce (/ (- t2 t1)
+                                  internal-time-units-per-second)
+                               'double-float)))
+            (format t "~&Total time: ")
+            (print-seconds secs)
+            (format t ", time per iteration: ")
+            (print-seconds (coerce (/ secs ,n) 'double-float))))))))
index 9a6862b..6e585ba 100644 (file)
--- a/math.lisp
+++ b/math.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Nov 2002
 ;;;;
-;;;; $Id: math.lisp,v 1.2 2003/04/28 16:07:42 kevin Exp $
+;;;; $Id: math.lisp,v 1.3 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
@@ -28,3 +28,9 @@
     (funcall (deriv #'sin 1d-8) x))
 
 ;;; (sin^ pi)
+
+(defmacro ensure-integer (obj)
+  "Ensure object is an integer. If it is a string, then parse it"
+  `(if (stringp ,obj)
+      (parse-integer ,obj)
+     ,obj))
index f518b81..7b7238b 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.20 2003/02/07 14:21:55 kevin Exp $
+;;;; $Id: package.lisp,v 1.21 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 (defpackage #:kmrcl
   (:nicknames :kl)
   (:use :common-lisp)
-  (:export #:let-if
-          #:let-when
-          #:aif
-         #:awhen
-         #:awhile
-         #:aand
-         #:acond
-         #:alambda
-         #:it
-         #:mac
-         #:show
-         #:show-variables
-         #:show-functions
-         #:ensure-integer
-         #:mklist
-         #:filter
-         #:appendnew
-         #:memo-proc
-         #:memoize
-         #:defun-memo
-         #:_f
-         #:compose
-         #:until
-         #:while
-         #:for
-         #:mapappend
-         #:mapcar-append-string
-         #:mapcar2-append-string
-         #:delimited-string-to-list
-         #:list-to-delimited-string
-         #:indent-spaces
-         #:print-list
-         #:print-rows
-         #:file-subst
-         #:stream-subst
-         #:remove-tree-if
-         #:find-tree
-         #:with-each-file-line
-         #:with-each-stream-line
-         #:print-file-contents
-         #:read-file-to-string
-         #:read-file-to-strings
-         #:add-sql-quotes
-         #:escape-backslashes
-         #:remove-keyword
-         #:remove-keywords
-         #:in
-         #:mean
-         #:with-gensyms
-         #:time-iterations
-         #:print-float-units
-         #:print-seconds
-         #:nsubseq
-         
-         ;; strings.lisp
-         #:string-append
-         #:count-string-words
-         #:substitute-string-for-char
-         #:string-trim-last-character
-         #:string-hash
-         #:string-not-null?
-         #:whitespace?
-         #:not-whitespace?
-         #:string-ws?
-         #:string-invert
-         #:escape-xml-string
-         #:string-replace-char-string
-         #:make-usb8-array
-         #:usb8-array-to-string
-         #:string-to-usb8-array
-         
-         ;; symbols.lisp
-         #:ensure-keyword
-         #:concat-symbol
-         #:concat-symbol-pkg
-
-         ;; From attrib-class.lisp
-         #:attributes-class
-         #:slot-attribute
-
-         #:generalized-equal
-         
-         ;; From buffered input
-         
-         #:make-fields-buffer
-         #:read-buffered-fields
-
-         #:pretty-date
-         #:date-string
-
-         ;; From random.lisp
-         #:seed-random-generator
-         #:random-choice
-
-         ;; From telnet-server.lisp
-         #:start-telnet-server   
-
-         ;; From web-utils
-         #:*base-url*
-         #:base-url!
-         #:make-url
-         #:*standard-html-header*
-         #:*standard-xhtml-header*
-         #:*standard-xml-header*
-         #:user-agent-ie-p
-
-         ;; From xml-utils
-         #:wrap-with-xml
-         #:xml-tag-contents
-         #:positions-xml-tag-contents
-         #:xml-cdata
-         
-         ;; From console
-         *console-msgs*
-         cmsg
-         cmsg-c
-         cmsg-add
-         cmsg-remove
-         fixme
-         ))
+  (:export
+   #:ensure-integer
+   #:mklist
+   #:filter
+   #:appendnew
+   #:memo-proc
+   #:memoize
+   #:defun-memo
+   #:_f
+   #:compose
+   #:until
+   #:while
+   #:for
+   #:mapappend
+   #:mapcar-append-string
+   #:mapcar2-append-string
+   #:delimited-string-to-list
+   #:list-to-delimited-string
+   #:indent-spaces
+   #:print-list
+   #:print-rows
+   #:file-subst
+   #:stream-subst
+   #:remove-tree-if
+   #:find-tree
+   #:with-each-file-line
+   #:with-each-stream-line
+   #:remove-keyword
+   #:remove-keywords
+   #:nsubseq
+   
+   ;; macros.lisp
+   #:time-iterations
+   #:in
+   #:mean
+   #:with-gensyms
+   #:let-if
+   #:let-when
+   #:aif
+   #:awhen
+   #:awhile
+   #:aand
+   #:acond
+   #:alambda
+   #:it
+   #:mac
+   
+   ;; files.lisp
+   #:print-file-contents
+   #:read-file-to-string
+   #:read-file-to-strings
+   
+   ;; strings.lisp
+   #:string-append
+   #:count-string-words
+   #:substitute-string-for-char
+   #:string-trim-last-character
+   #:string-hash
+   #:string-not-null?
+   #:whitespace?
+   #:not-whitespace?
+   #:string-ws?
+   #:string-invert
+   #:escape-xml-string
+   #:string-replace-char-string
+   #:make-usb8-array
+   #:usb8-array-to-string
+   #:string-to-usb8-array
+   #:string-replace-chars-strings
+   #:add-sql-quotes
+   #:escape-backslashes
+   
+   ;; symbols.lisp
+   #:ensure-keyword
+   #:concat-symbol
+   #:concat-symbol-pkg
+   #:show
+   #:show-variables
+   #:show-functions
+   
+   ;; From attrib-class.lisp
+   #:attributes-class
+   #:slot-attribute
+   
+   #:generalized-equal
+   
+   ;; From buffered input
+   
+   #:make-fields-buffer
+   #:read-buffered-fields
+   
+   ;; From datetime.lisp
+   #:pretty-date
+   #:date-string
+   #:print-float-units
+   #:print-seconds
+   
+   ;; From random.lisp
+   #:seed-random-generator
+   #:random-choice
+   
+   ;; From telnet-server.lisp
+   #:start-telnet-server         
+   
+   ;; From web-utils
+   #:*base-url*
+   #:base-url!
+   #:make-url
+   #:*standard-html-header*
+   #:*standard-xhtml-header*
+   #:*standard-xml-header*
+   #:user-agent-ie-p
+   
+   ;; From xml-utils
+   #:wrap-with-xml
+   #:xml-tag-contents
+   #:positions-xml-tag-contents
+   #:xml-cdata
+   
+   ;; From console
+   *console-msgs*
+   cmsg
+   cmsg-c
+   cmsg-add
+   cmsg-remove
+   fixme
+   ))
 
 
 
index d8c0e43..45c2d7a 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: strings.lisp,v 1.9 2003/04/28 21:12:27 kevin Exp $
+;;;; $Id: strings.lisp,v 1.10 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 
 (defun substitute-string-for-char (procstr match-char subst-str) 
   "Substitutes a string for a single matching character of a string"
-  (let ((pos (position match-char procstr)))
-    (if pos
-       (concatenate 'string
-         (subseq procstr 0 pos) subst-str
-         (substitute-string-for-char (subseq procstr (1+ pos)) match-char subst-str))
-      procstr)))
+  (replace-chars-strings procstr (list (cons match-char subst-str))))
 
 (defun string-substitute (string substring replacement-string)
   "String substitute by Larry Hunter. Obtained from Google"
          replacement-string))
       (setq last-end (+ next-start substring-length)))))
 
-
 (defun string-trim-last-character (s)
-"Return the string less the last character"
-  (subseq s 0 (1- (length s))))
+  "Return the string less the last character"
+  (aif (plusp (length s))
+       (subseq s 0 (1- it))
+       s))
 
 (defun string-hash (str &optional (bitmask 65535))
   (let ((hash 0))
   (when (stringp str)
     (null (find-if #'not-whitespace? str))))
 
-(defun string-replace-chars-strings (str repl-alist)
-  "Replace all instances of a chars with a string. repl-alist is an assoc
-list of characters and replacement strings."
+(defun replaced-string-length (str repl-alist)
   (declare (string str))
   (let* ((orig-len (length str))
         (new-len orig-len))
@@ -157,32 +151,39 @@ list of characters and replacement strings."
             (match (assoc c repl-alist :test #'char=)))
        (declare (character c))
        (when match
-         (incf new-len (length (cdr match))))))
-    (let ((new-string (make-string new-len))
-         (i 0))
-      (declare (string new-string)
-              (fixnum i))
-      (dotimes (i orig-len)
-       (declare (fixnum i))
-       (let* ((c (char str i))
-              (match (assoc c repl-alist :test #'char=)))
-         (declare (character c))
-         (if match
-             (let* ((subst (cdr match))
-                    (len (length match)))
-               (dotimes (j len)
-                 (setf (char new-string i) (char subst j))
-                 (incf i))
-               (decf i))
-           (progn
-             (setf (char new-string i) c)))))
-      new-string)))
+         (incf new-len (1- (length (cdr match)))))))
+    new-len))
+
+(defun string-replace-chars-strings (str repl-alist)
+  "Replace all instances of a chars with a string. repl-alist is an assoc
+list of characters and replacement strings."
+  (declare (simple-string str))
+  (do* ((orig-len (length str))
+       (new-string (make-string (replaced-string-length str repl-alist)))
+       (spos 0 (1+ spos))
+       (dpos 0))
+      ((>= spos orig-len)
+       new-string)
+    (declare (fixnum spos dpos) (simple-string new-string))
+    (let* ((c (char str spos))
+          (match (assoc c repl-alist :test #'char=)))
+      (declare (character c))
+      (if match
+         (let* ((subst (cdr match))
+                (len (length subst)))
+           (declare (fixnum len))
+           (dotimes (j len)
+             (declare (fixnum j))
+             (setf (char new-string dpos) (char subst j))
+             (incf dpos)))
+       (progn
+         (setf (char new-string dpos) c)
+         (incf dpos))))))
 
 (defun escape-xml-string (string)
   "Escape invalid XML characters"
-  (string-replace-char-string
-   (string-replace-char-string string #\& "&amp;")
-   #\< "&lt;"))
+  (string-replace-chars-strings 
+   string '((#\& . "&amp;") (#\> . "&gt;") (#\< . "&lt;"))))
 
 (defun string-replace-char-string (string repl-char repl-str)
   "Replace all occurances of repl-char with repl-str"
diff --git a/symbols.lisp b/symbols.lisp
new file mode 100644 (file)
index 0000000..f2af14b
--- /dev/null
@@ -0,0 +1,99 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cl-symbols.lisp
+;;;; Purpose:       Returns all defined Common Lisp symbols
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Apr 2000
+;;;;
+;;;; $Id: symbols.lisp,v 1.1 2003/04/28 23:51:59 kevin Exp $
+;;;;
+;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; KMRCL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(in-package :kmrcl)
+
+(defun cl-symbols ()
+  (append (cl-variables) (cl-functions)))
+
+(defun cl-variables ()
+  (let ((vars '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+         (find-symbol (symbol-name s) 'common-lisp)
+       (when (and (or (eq status :external)
+                      (eq status :internal))
+                  (boundp sym))
+         (push sym vars))))
+    (nreverse vars)))
+
+(defun cl-functions ()
+  (let ((funcs '()))
+    (do-symbols (s 'common-lisp)
+      (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) 'common-lisp)
+       (when (and (or (eq status :external)
+                      (eq status :internal))
+                  (fboundp sym))
+         (push sym funcs))))
+    (nreverse funcs)))
+
+;;; Symbol functions
+
+(defun concat-symbol-pkg (pkg &rest args)
+  (declare (dynamic-extent args))
+  (flet ((stringify (arg)
+           (etypecase arg
+             (string
+              (string-upcase arg))
+             (symbol
+              (symbol-name arg)))))
+    (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
+      (intern #-case-sensitive (string-upcase str)
+             #+case-sensitive str
+             (if pkg pkg *package*)))))
+
+
+(defun concat-symbol (&rest args)
+  (apply #'concat-symbol-pkg nil args))
+
+(defun ensure-keyword (name)
+  "Returns keyword for a name"
+  (etypecase name
+    (keyword name)
+    (string (intern #-case-sensitive (string-upcase name)
+                   #+case-sensitive name
+                   :keyword))
+    (symbol (intern (symbol-name name) :keyword))))
+
+(defun show (&optional (what :variables) (package *package*))
+  (ecase what
+    (:variables (show-variables package))
+    (:functions (show-functions package))))
+
+(defun show-variables (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                    (eq status :internal))
+                (boundp sym))
+       (format t "~&Symbol ~S~T -> ~S~%"
+               sym
+               (symbol-value sym))))))
+
+(defun show-functions (package)
+  (do-symbols (s package)
+    (multiple-value-bind (sym status)
+       (find-symbol (symbol-name s) package)
+      (when (and (or (eq status :external)
+                    (eq status :internal))
+                (fboundp sym))
+       (format t "~&Function ~S~T -> ~S~%"
+               sym
+               (symbol-function sym))))))
index eebaf13..467a02d 100644 (file)
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2003
 ;;;;
-;;;; $Id: tests.lisp,v 1.1 2003/04/28 21:12:27 kevin Exp $
+;;;; $Id: tests.lisp,v 1.2 2003/04/28 23:51:59 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
   (:use #:kmrcl #:cl #:rtest))
 (in-package #:kmrcl-tests)
 
+(rem-all-tests)
+
+
+(when (find-package '#:kmr-mop)
+  (pushnew :kmrtest-mop cl:*features*))
+
 (deftest p1 t t)
 
-#+kmrcl-mop
+(deftest str.0 (string-replace-chars-strings "" nil) "")
+(deftest str.1 (string-replace-chars-strings "abcd" nil) "abcd")
+(deftest str.2 (string-replace-chars-strings "abcd" nil) "abcd")
+(deftest str.3 (string-replace-chars-strings "abcd" '((#\j . "ef"))) "abcd")
+(deftest str.4 (string-replace-chars-strings "abcd" '((#\a . "ef"))) "efbcd")
+(deftest str.5
+    (string-replace-chars-strings "abcd" '((#\a . "ef") (#\j . "ghi")))
+  "efbcd")
+(deftest str.6
+    (string-replace-chars-strings "abcd" '((#\a . "ef") (#\d . "ghi")))
+  "efbcghi")
+
+(deftest str.7 (escape-xml-string "") "")
+(deftest str.8 (escape-xml-string "abcd") "abcd")
+(deftest str.9 (escape-xml-string "ab&cd") "ab&amp;cd")
+(deftest str.10 (escape-xml-string "ab&cd<") "ab&amp;cd&lt;")
+(deftest str.11 (escape-xml-string "ab&c><") "ab&amp;c&gt;&lt;")
+
+#+kmrtest-mop
 (progn
   (defclass credit-rating ()
     ((level :attributes (date-set time-set))
      (id :attributes (person-setting)))
-    (:metaclass kmrcl:attributes-class))
-  (defparameter cr (make-instance 'credit-rating))
+    (:metaclass attributes-class))
+  (defparameter cr nil)
+  
+  (defclass monitored-credit-rating (credit-rating)
+    ((level :attributes (last-checked interval date-set))
+     (cc :initarg :cc)
+     (id :attributes (verified)))
+    (:metaclass attributes-class))
+  (defparameter mcr (make-instance 'monitored-credit-rating))
+
+  (deftest attrib.mop.1
+      (progn
+       (setq cr (make-instance 'credit-rating))
+       (slot-attribute cr 'level 'date-set))
+      nil)
+
+  (deftest attrib.mop.2
+      (progn
+       (setq cr (make-instance 'credit-rating))
+       (setf (slot-attribute cr 'level 'date-set) "12/15/1990")
+       (slot-attribute cr 'level 'date-set))
+    "12/15/1990")
+
+  (deftest attrib.mop.3
+      (progn
+       (setq mcr (make-instance 'monitored-credit-rating))
+       (setf (slot-attribute mcr 'level 'date-set) "01/05/2002")
+       (slot-attribute mcr 'level 'date-set))
+    "01/05/2002")
   
-  (format t "~&date-set: ~a" (slot-attribute cr 'level 'date-set))
-  (setf (slot-attribute cr 'level 'date-set) "12/15/1990")
-(format t "~&date-set: ~a" (slot-attribute cr 'level 'date-set))
-
-(defclass monitored-credit-rating (credit-rating)
-  ((level :attributes (last-checked interval date-set))
-   (cc :initarg :cc)
-   (id :attributes (verified))
-   )
-  (:metaclass attributes-class))
-(defparameter mcr (make-instance 'monitored-credit-rating))
-
-(setf (slot-attribute mcr 'level 'date-set) "01/05/2002")
-(format t "~&date-set for mcr: ~a" (slot-attribute mcr 'level 'date-set))
-)   ;; kmrcl-mop
+  )   ;; kmrcl-mop
 
+#+kmrtest-mop
+(setq cl:*features* (delete :kmrtest-mop cl:*features*))