;;;; 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)))
+++ /dev/null
-;;;; -*- 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))))
;;;; 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))))
+
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
--- /dev/null
+;;;; -*- 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))
+
+++ /dev/null
-;;;; -*- 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))
--- /dev/null
+;;;; -*- 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)))
+
;;;; 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
;;;;
(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)
(oos 'load-op 'kmrcl-tests)
(oos 'test-op 'kmrcl-tests))
+#+kmr-mop
+(setq cl:*features* (delete :kmr-mop cl:*features*))
--- /dev/null
+;;;; -*- 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))))))))
;;;; 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
;;;;
(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))
;;;; 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
+ ))
;;;; 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))
(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 #\& "&")
- #\< "<"))
+ (string-replace-chars-strings
+ string '((#\& . "&") (#\> . ">") (#\< . "<"))))
(defun string-replace-char-string (string repl-char repl-str)
"Replace all occurances of repl-char with repl-str"
--- /dev/null
+;;;; -*- 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))))))
;;;; 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&cd")
+(deftest str.10 (escape-xml-string "ab&cd<") "ab&cd<")
+(deftest str.11 (escape-xml-string "ab&c><") "ab&c><")
+
+#+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*))