(defclass attributes-dsd (kmr-mop:standard-direct-slot-definition)
((attributes :initarg :attributes :initform nil
- :accessor dsd-attributes)))
+ :accessor dsd-attributes)))
(defclass attributes-esd (kmr-mop:standard-effective-slot-definition)
- ((attributes :initarg :attributes :initform nil
- :accessor esd-attributes)))
+ ((attributes :initarg :attributes :initform nil
+ :accessor esd-attributes)))
;; encapsulating macro for Lispworks
(kmr-mop:process-slot-option attributes-class :attributes)
#+(or cmu scl sbcl openmcl)
(defmethod kmr-mop:validate-superclass ((class attributes-class)
- (superclass kmr-mop:standard-class))
+ (superclass kmr-mop:standard-class))
t)
(defmethod kmr-mop:direct-slot-definition-class ((cl attributes-class) #+kmr-normal-dsdc &rest initargs)
(defmethod kmr-mop:compute-slots ((class attributes-class))
(let* ((normal-slots (call-next-method))
- (alist (mapcar
- #'(lambda (slot)
- (cons (kmr-mop:slot-definition-name slot)
- (mapcar #'(lambda (attr) (list attr))
- (esd-attributes slot))))
- normal-slots)))
+ (alist (mapcar
+ #'(lambda (slot)
+ (cons (kmr-mop:slot-definition-name slot)
+ (mapcar #'(lambda (attr) (list attr))
+ (esd-attributes slot))))
+ normal-slots)))
(cons (make-instance
- 'attributes-esd
- :name 'all-attributes
- :initform `',alist
- :initfunction #'(lambda () alist)
- :allocation :instance
- :documentation "Attribute bucket"
- :type t
- )
- normal-slots)))
-
+ 'attributes-esd
+ :name 'all-attributes
+ :initform `',alist
+ :initfunction #'(lambda () alist)
+ :allocation :instance
+ :documentation "Attribute bucket"
+ :type t
+ )
+ normal-slots)))
+
(defun slot-attribute (instance slot-name attribute)
(cdr (slot-attribute-bucket instance slot-name attribute)))
(defun slot-attribute-bucket (instance slot-name attribute)
(let* ((all-buckets (slot-value instance 'all-attributes))
- (slot-bucket (assoc slot-name all-buckets)))
+ (slot-bucket (assoc slot-name all-buckets)))
(unless slot-bucket
(error "The slot named ~S of ~S has no attributes."
- slot-name instance))
+ slot-name instance))
(let ((attr-bucket (assoc attribute (cdr slot-bucket))))
(unless attr-bucket
- (error "The slot named ~S of ~S has no attributes named ~S."
- slot-name instance attribute))
+ (error "The slot named ~S of ~S has no attributes named ~S."
+ slot-name instance attribute))
attr-bucket)))
(defconstant +newline+ #\Newline)
(declaim (type character +eof-char+ +field-delim+ +newline+)
- (type fixnum +max-field+ +max-fields-per-line+))
+ (type fixnum +max-field+ +max-fields-per-line+))
;; Buffered fields parsing function
;; Uses fill-pointer for size
-(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
- (max-field-len +max-field+))
+(defun make-fields-buffer (&optional (max-fields +max-fields-per-line+)
+ (max-field-len +max-field+))
(let ((bufs (make-array max-fields :element-type 'vector :fill-pointer 0 :adjustable nil)))
(dotimes (i +max-fields-per-line+)
(setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer 0 :adjustable nil)))
bufs))
(defun read-buffered-fields (fields strm &optional (field-delim +field-delim+)
- (eof 'eof))
+ (eof 'eof))
"Read a line from a stream into a field buffers"
(declare (type base-char field-delim)
- (type vector fields))
+ (type vector fields))
(setf (fill-pointer fields) 0)
(do ((ifield 0 (1+ ifield))
(linedone nil)
(is-eof nil))
(linedone (if is-eof eof fields))
(declare (type fixnum ifield)
- (type boolean linedone is-eof))
+ (type boolean linedone is-eof))
(let ((field (aref fields ifield)))
(declare (type base-string field))
(do ((ipos 0)
- (fielddone nil)
- (rc (read-char strm nil +eof-char+)
- (read-char strm nil +eof-char+)))
- (fielddone (unread-char rc strm))
- (declare (type fixnum ipos)
- (type base-char rc)
- (type boolean fielddone))
- (cond
- ((char= rc field-delim)
- (setf (fill-pointer field) ipos)
- (setq fielddone t))
- ((char= rc +newline+)
- (setf (fill-pointer field) ipos)
- (setf (fill-pointer fields) ifield)
- (setq fielddone t)
- (setq linedone t))
- ((char= rc +eof-char+)
- (setf (fill-pointer field) ipos)
- (setf (fill-pointer fields) ifield)
- (setq fielddone t)
- (setq linedone t)
- (setq is-eof t))
- (t
- (setf (char field ipos) rc)
- (incf ipos)))))))
+ (fielddone nil)
+ (rc (read-char strm nil +eof-char+)
+ (read-char strm nil +eof-char+)))
+ (fielddone (unread-char rc strm))
+ (declare (type fixnum ipos)
+ (type base-char rc)
+ (type boolean fielddone))
+ (cond
+ ((char= rc field-delim)
+ (setf (fill-pointer field) ipos)
+ (setq fielddone t))
+ ((char= rc +newline+)
+ (setf (fill-pointer field) ipos)
+ (setf (fill-pointer fields) ifield)
+ (setq fielddone t)
+ (setq linedone t))
+ ((char= rc +eof-char+)
+ (setf (fill-pointer field) ipos)
+ (setf (fill-pointer fields) ifield)
+ (setq fielddone t)
+ (setq linedone t)
+ (setq is-eof t))
+ (t
+ (setf (char field ipos) rc)
+ (incf ipos)))))))
;; Buffered fields parsing
;; Does not use fill-pointer
;; Returns 2 values -- string array and length array
-(defstruct field-buffers
+(defstruct field-buffers
(nfields 0 :type fixnum)
(buffers)
(field-lengths))
-(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
- (max-field-len +max-field+))
+(defun make-fields-buffer2 (&optional (max-fields +max-fields-per-line+)
+ (max-field-len +max-field+))
(let ((bufs (make-array max-fields :element-type 'vector :fill-pointer nil :adjustable nil))
- (bufstruct (make-field-buffers)))
+ (bufstruct (make-field-buffers)))
(dotimes (i +max-fields-per-line+)
(setf (aref bufs i) (make-array max-field-len :element-type 'character :fill-pointer nil :adjustable nil)))
(setf (field-buffers-buffers bufstruct) bufs)
- (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
- :element-type 'fixnum :fill-pointer nil :adjustable nil))
+ (setf (field-buffers-field-lengths bufstruct) (make-array +max-fields-per-line+
+ :element-type 'fixnum :fill-pointer nil :adjustable nil))
(setf (field-buffers-nfields bufstruct) 0)
bufstruct))
(defun read-buffered-fields2 (fields strm &optional (field-delim +field-delim+)
- (eof 'eof))
+ (eof 'eof))
"Read a line from a stream into a field buffers"
(declare (character field-delim))
(setf (field-buffers-nfields fields) 0)
(is-eof nil))
(linedone (if is-eof eof fields))
(declare (fixnum ifield)
- (t linedone is-eof))
+ (t linedone is-eof))
(let ((field (aref (field-buffers-buffers fields) ifield)))
(declare (simple-string field))
(do ((ipos 0)
- (fielddone nil)
- (rc (read-char strm nil +eof-char+)
- (read-char strm nil +eof-char+)))
- (fielddone (unread-char rc strm))
- (declare (fixnum ipos)
- (character rc)
- (t fielddone))
- (cond
- ((char= rc field-delim)
- (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
- (setq fielddone t))
- ((char= rc +newline+)
- (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
- (setf (field-buffers-nfields fields) ifield)
- (setq fielddone t)
- (setq linedone t))
- ((char= rc +eof-char+)
- (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
- (setf (field-buffers-nfields fields) ifield)
- (setq fielddone t)
- (setq linedone t)
- (setq is-eof t))
- (t
- (setf (char field ipos) rc)
- (incf ipos)))))))
+ (fielddone nil)
+ (rc (read-char strm nil +eof-char+)
+ (read-char strm nil +eof-char+)))
+ (fielddone (unread-char rc strm))
+ (declare (fixnum ipos)
+ (character rc)
+ (t fielddone))
+ (cond
+ ((char= rc field-delim)
+ (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+ (setq fielddone t))
+ ((char= rc +newline+)
+ (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+ (setf (field-buffers-nfields fields) ifield)
+ (setq fielddone t)
+ (setq linedone t))
+ ((char= rc +eof-char+)
+ (setf (aref (field-buffers-field-lengths fields) ifield) ipos)
+ (setf (field-buffers-nfields fields) ifield)
+ (setq fielddone t)
+ (setq linedone t)
+ (setq is-eof t))
+ (t
+ (setf (char field ipos) rc)
+ (incf ipos)))))))
(defun bfield (fields i)
(if (>= i (field-buffers-nfields fields))
(defconstant +max-line+ 20000)
(let ((linebuffer (make-array +max-line+
- :element-type 'character
- :fill-pointer 0)))
+ :element-type 'character
+ :fill-pointer 0)))
(defun read-buffered-line (strm eof)
"Read a line from astream into a vector buffer"
(declare (optimize (speed 3) (space 0) (safety 0)))
(let ((pos 0)
- (done nil))
+ (done nil))
(declare (fixnum pos) (type boolean done))
(setf (fill-pointer linebuffer) 0)
(do ((c (read-char strm nil +eof-char+)
- (read-char strm nil +eof-char+)))
- (done (progn
- (unless (eql c +eof-char+) (unread-char c strm))
- (if (eql c +eof-char+) eof linebuffer)))
- (declare (character c))
- (cond
+ (read-char strm nil +eof-char+)))
+ (done (progn
+ (unless (eql c +eof-char+) (unread-char c strm))
+ (if (eql c +eof-char+) eof linebuffer)))
+ (declare (character c))
+ (cond
((>= pos +max-line+)
(warn "Line overflow")
(setf done t))
#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (sb-ext:without-package-locks
- (sb-pcl::structure-class-p
- (find-class (intern "FILE-STREAM" "SB-IMPL"))))
+ (sb-pcl::structure-class-p
+ (find-class (intern "FILE-STREAM" "SB-IMPL"))))
(push :old-sb-file-stream cl:*features*)))
#+(or cmu sbcl)
(progn
(defstruct (byte-array-output-stream
(:include #+cmu system:lisp-stream
- #+(and sbcl old-sb-file-stream) sb-impl::file-stream
- #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
+ #+(and sbcl old-sb-file-stream) sb-impl::file-stream
+ #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
(bout #'byte-array-bout)
(misc #'byte-array-out-misc))
(:print-function %print-byte-array-output-stream)
(defun byte-array-bout (stream byte)
(let ((current (byte-array-output-stream-index stream))
- (workspace (byte-array-output-stream-buffer stream)))
+ (workspace (byte-array-output-stream-buffer stream)))
(if (= current (length workspace))
- (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8))))
- (replace new-workspace workspace)
- (setf (aref new-workspace current) byte)
- (setf (byte-array-output-stream-buffer stream) new-workspace))
- (setf (aref workspace current) byte))
+ (let ((new-workspace (make-array (* current 2) :element-type '(unsigned-byte 8))))
+ (replace new-workspace workspace)
+ (setf (aref new-workspace current) byte)
+ (setf (byte-array-output-stream-buffer stream) new-workspace))
+ (setf (aref workspace current) byte))
(setf (byte-array-output-stream-index stream) (1+ current))))
(defun byte-array-out-misc (stream operation &optional arg1 arg2)
(case operation
(:file-position
(if (null arg1)
- (byte-array-output-stream-index stream)))
+ (byte-array-output-stream-index stream)))
(:element-type '(unsigned-byte 8))))
(defun get-output-stream-data (stream)
Make-Byte-Array-Output-Stream since the last call to this function and
clears buffer."
(declare (type byte-array-output-stream stream))
- (prog1
- (dump-output-stream-data stream)
+ (prog1
+ (dump-output-stream-data stream)
(setf (byte-array-output-stream-index stream) 0)))
(defun dump-output-stream-data (stream)
Make-Byte-Array-Output-Stream since the last call to this function."
(declare (type byte-array-output-stream stream))
(let* ((length (byte-array-output-stream-index stream))
- (result (make-array length :element-type '(unsigned-byte 8))))
+ (result (make-array length :element-type '(unsigned-byte 8))))
(replace result (byte-array-output-stream-buffer stream))
result))
(eval-when (:compile-toplevel :load-toplevel :execute)
(sb-ext:without-package-locks
(defvar *system-copy-fn* (if (fboundp (intern "COPY-SYSTEM-AREA" "SB-KERNEL"))
- (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
- (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
+ (intern "COPY-SYSTEM-AREA" "SB-KERNEL")
+ (intern "COPY-SYSTEM-UB8-AREA" "SB-KERNEL")))
(defconstant +system-copy-multiplier+ (if (fboundp (intern "COPY-FROM-SYSTEM-AREA" "SB-KERNEL"))
- sb-vm:n-byte-bits
- 1))))
-
+ sb-vm:n-byte-bits
+ 1))))
+
#+(or cmu sbcl)
(progn
(defstruct (byte-array-input-stream
- (:include #+cmu system:lisp-stream
- ;;#+sbcl sb-impl::file-stream
- #+(and sbcl old-sb-file-stream) sb-impl::file-stream
- #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
- (in #'byte-array-inch)
- (bin #'byte-array-binch)
- (n-bin #'byte-array-stream-read-n-bytes)
- (misc #'byte-array-in-misc))
- (:print-function %print-byte-array-input-stream)
- ;(:constructor nil)
- (:constructor internal-make-byte-array-input-stream
- (byte-array current end)))
+ (:include #+cmu system:lisp-stream
+ ;;#+sbcl sb-impl::file-stream
+ #+(and sbcl old-sb-file-stream) sb-impl::file-stream
+ #+(and sbcl (not old-sb-file-stream)) sb-sys:fd-stream
+ (in #'byte-array-inch)
+ (bin #'byte-array-binch)
+ (n-bin #'byte-array-stream-read-n-bytes)
+ (misc #'byte-array-in-misc))
+ (:print-function %print-byte-array-input-stream)
+ ;(:constructor nil)
+ (:constructor internal-make-byte-array-input-stream
+ (byte-array current end)))
(byte-array nil :type vector)
(current nil)
(end nil))
-
+
(defun %print-byte-array-input-stream (s stream d)
(declare (ignore s d))
(write-string "#<Byte-Array-Input Stream>" stream))
(defun byte-array-inch (stream eof-errorp eof-value)
(let ((byte-array (byte-array-input-stream-byte-array stream))
- (index (byte-array-input-stream-current stream)))
+ (index (byte-array-input-stream-current stream)))
(cond ((= index (byte-array-input-stream-end stream))
- #+cmu
- (eof-or-lose stream eof-errorp eof-value)
- #+sbcl
- (sb-impl::eof-or-lose stream eof-errorp eof-value)
- )
- (t
- (setf (byte-array-input-stream-current stream) (1+ index))
- (aref byte-array index)))))
+ #+cmu
+ (eof-or-lose stream eof-errorp eof-value)
+ #+sbcl
+ (sb-impl::eof-or-lose stream eof-errorp eof-value)
+ )
+ (t
+ (setf (byte-array-input-stream-current stream) (1+ index))
+ (aref byte-array index)))))
(defun byte-array-binch (stream eof-errorp eof-value)
(let ((byte-array (byte-array-input-stream-byte-array stream))
- (index (byte-array-input-stream-current stream)))
+ (index (byte-array-input-stream-current stream)))
(cond ((= index (byte-array-input-stream-end stream))
- #+cmu
- (eof-or-lose stream eof-errorp eof-value)
- #+sbcl
- (sb-impl::eof-or-lose stream eof-errorp eof-value)
- )
- (t
- (setf (byte-array-input-stream-current stream) (1+ index))
- (aref byte-array index)))))
+ #+cmu
+ (eof-or-lose stream eof-errorp eof-value)
+ #+sbcl
+ (sb-impl::eof-or-lose stream eof-errorp eof-value)
+ )
+ (t
+ (setf (byte-array-input-stream-current stream) (1+ index))
+ (aref byte-array index)))))
(defun byte-array-stream-read-n-bytes (stream buffer start requested eof-errorp)
(declare (type byte-array-input-stream stream))
(let* ((byte-array (byte-array-input-stream-byte-array stream))
- (index (byte-array-input-stream-current stream))
- (available (- (byte-array-input-stream-end stream) index))
- (copy (min available requested)))
+ (index (byte-array-input-stream-current stream))
+ (available (- (byte-array-input-stream-end stream) index))
+ (copy (min available requested)))
(when (plusp copy)
(setf (byte-array-input-stream-current stream)
- (+ index copy))
+ (+ index copy))
#+cmu
(system:without-gcing
(system::system-area-copy (system:vector-sap byte-array)
- (* index vm:byte-bits)
- (if (typep buffer 'system::system-area-pointer)
- buffer
- (system:vector-sap buffer))
- (* start vm:byte-bits)
- (* copy vm:byte-bits)))
+ (* index vm:byte-bits)
+ (if (typep buffer 'system::system-area-pointer)
+ buffer
+ (system:vector-sap buffer))
+ (* start vm:byte-bits)
+ (* copy vm:byte-bits)))
#+sbcl
(sb-sys:without-gcing
(funcall *system-copy-fn* (sb-sys:vector-sap byte-array)
- (* index +system-copy-multiplier+)
- (if (typep buffer 'sb-sys::system-area-pointer)
- buffer
- (sb-sys:vector-sap buffer))
- (* start +system-copy-multiplier+)
- (* copy +system-copy-multiplier+))))
+ (* index +system-copy-multiplier+)
+ (if (typep buffer 'sb-sys::system-area-pointer)
+ buffer
+ (sb-sys:vector-sap buffer))
+ (* start +system-copy-multiplier+)
+ (* copy +system-copy-multiplier+))))
(if (and (> requested copy) eof-errorp)
- (error 'end-of-file :stream stream)
- copy)))
+ (error 'end-of-file :stream stream)
+ copy)))
(defun byte-array-in-misc (stream operation &optional arg1 arg2)
(declare (ignore arg2))
(case operation
(:file-position
(if arg1
- (setf (byte-array-input-stream-current stream) arg1)
- (byte-array-input-stream-current stream)))
+ (setf (byte-array-input-stream-current stream) arg1)
+ (byte-array-input-stream-current stream)))
(:file-length (length (byte-array-input-stream-byte-array stream)))
(:unread (decf (byte-array-input-stream-current stream)))
(:listen (or (/= (the fixnum (byte-array-input-stream-current stream))
- (the fixnum (byte-array-input-stream-end stream)))
- :eof))
+ (the fixnum (byte-array-input-stream-end stream)))
+ :eof))
(:element-type 'base-char)))
-
+
(defun make-byte-array-input-stream (buffer &optional (start 0) (end (length buffer)))
"Returns an input stream which will supply the bytes of BUFFER between
Start and End in order."
"Returns an array of all data sent to a stream made by
Make-Byte-Array-Output-Stream since the last call to this function
and clears buffer."
- (prog1
- (dump-output-stream-data stream)
+ (prog1
+ (dump-output-stream-data stream)
(file-position stream 0)))
-
+
(defun dump-output-stream-data (stream)
"Returns an array of all data sent to a stream made by
Make-Byte-Array-Output-Stream since the last call to this function."
(force-output stream)
(let* ((length (file-position stream))
- (result (make-array length :element-type '(unsigned-byte 8))))
+ (result (make-array length :element-type '(unsigned-byte 8))))
(replace result (slot-value stream 'excl::buffer))
result))
-
+
(defmethod excl:device-extend ((stream extendable-buffer-output-stream)
- need action)
+ need action)
(declare (ignore action))
(let* ((len (file-position stream))
- (new-len (max (+ len need) (* 2 len)))
- (old-buf (slot-value stream 'excl::buffer))
- (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
+ (new-len (max (+ len need) (* 2 len)))
+ (old-buf (slot-value stream 'excl::buffer))
+ (new-buf (make-array new-len :element-type '(unsigned-byte 8))))
(declare (fixnum len)
- (optimize (speed 3) (safety 0)))
+ (optimize (speed 3) (safety 0)))
(dotimes (i len)
- (setf (aref new-buf i) (aref old-buf i)))
+ (setf (aref new-buf i) (aref old-buf i)))
(setf (slot-value stream 'excl::buffer) new-buf)
(setf (slot-value stream 'excl::buffer-ptr) new-len)
)
t)
-
+
)
#+allegro
(progn
(defun make-byte-array-input-stream (buffer &optional (start 0)
- (end (length buffer)))
+ (end (length buffer)))
(excl:make-buffer-input-stream buffer start end :octets))
) ;; progn
;; point in the plane. The disks on the right show this for various
;; values.
-(defun hsv->rgb (h s v)
+(defun hsv->rgb (h s v)
(declare (optimize (speed 3) (safety 0)))
(when (zerop s)
(return-from hsv->rgb (values v v v)))
(incf h 360))
(while (>= h 360)
(decf h 360))
-
+
(let ((h-pos (/ h 60)))
(multiple-value-bind (h-int h-frac) (truncate h-pos)
(declare (fixnum h-int))
(q (* v (- 1 (* s h-frac))))
(t_ (* v (- 1 (* s (- 1 h-frac)))))
r g b)
-
+
(cond
((zerop h-int)
(setf r v
- g t_
+ g t_
b p))
((= 1 h-int)
(setf r q
(values r g b)))))
-(defun hsv255->rgb255 (h s v)
+(defun hsv255->rgb255 (h s v)
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
(when (zerop s)
(incf h 360))
(while (>= h 360)
(decf h 360))
-
+
(let ((h-pos (/ h 60)))
(multiple-value-bind (h-int h-frac) (truncate h-pos)
(declare (fixnum h-int))
(q (round (* 255 fv (- 1 (* fs h-frac)))))
(t_ (round (* 255 fv (- 1 (* fs (- 1 h-frac))))))
r g b)
-
+
(cond
((zerop h-int)
(setf r v
- g t_
+ g t_
b p))
((= 1 h-int)
(setf r q
(defun rgb->hsv (r g b)
(declare (optimize (speed 3) (safety 0)))
-
+
(let* ((min (min r g b))
(max (max r g b))
(delta (- max min))
(setq h (the fixnum (* 60 h)))
(when (minusp h)
(incf h 360)))
-
+
(values h s v)))
(defun rgb255->hsv255 (r g b)
(h nil))
(declare (fixnum min max delta v s)
(type (or null fixnum) h))
-
+
(when (plusp max)
(setq s (truncate (the fixnum (* 255 delta)) max)))
(+ 240 (truncate (the fixnum (* 60 (the fixnum (- r g)))) delta))))))
(when (minusp h)
(incf h 360)))
-
+
(values h s v)))
(defun hsv-equal (h1 s1 v1 h2 s2 v2 &key (limit .001))
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
(flet ((~= (a b)
- (cond
+ (cond
((and (null a) (null b))
t)
((or (null a) (null b))
(optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)))
(flet ((~= (a b)
(declare (type (or null fixnum) a b))
- (cond
+ (cond
((and (null a) (null b))
t)
((or (null a) (null b))
(when (~= h1 h2) (~= s1 s2) (~= v1 v2)
t)))))
-(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
+(defun hsv-similar (h1 s1 v1 h2 s2 v2 &key
(hue-range 15) (value-range .2) (saturation-range 0.2)
(gray-limit 0.3) (black-limit 0.3))
"Returns T if two HSV values are similar."
t))))
-(defun hsv255-similar (h1 s1 v1 h2 s2 v2
+(defun hsv255-similar (h1 s1 v1 h2 s2 v2
&key (hue-range 15) (value-range 50) (saturation-range 50)
(gray-limit 75) (black-limit 75))
"Returns T if two HSV values are similar."
t))))
-
+
(defun hue-difference (h1 h2)
"Return difference between two hues around 360 degree circle"
(cond
(- (- 360 diff)))
(t
diff))))))
-
-
+
+
(defun hue-difference-fixnum (h1 h2)
"Return difference between two hues around 360 degree circle"
(cond
(- (- 360 diff)))
(t
diff)))))))
-
+
(decode-universal-time
(encode-universal-time s m hour day month year))
(values (elt '("Monday" "Tuesday" "Wednesday" "Thursday"
- "Friday" "Saturday" "Sunday")
- wkday)
- (elt '("January" "February" "March" "April" "May" "June"
- "July" "August" "September" "October" "November"
- "December")
- (1- mn))
- (format nil "~A" dy)
+ "Friday" "Saturday" "Sunday")
+ wkday)
+ (elt '("January" "February" "March" "April" "May" "June"
+ "July" "August" "September" "October" "November"
+ "December")
+ (1- mn))
+ (format nil "~A" dy)
(format nil "~A" yr)
- (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
+ (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
(defun pretty-date-ut (&optional (tm (get-universal-time)))
(multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm)
(defun date-string (ut)
(if (typep ut 'integer)
(multiple-value-bind (sec min hr day mon year dow daylight-p zone)
- (decode-universal-time ut)
- (declare (ignore daylight-p zone))
- (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
- dow
- day
- (1- mon)
- year
- hr min sec))))
+ (decode-universal-time ut)
+ (declare (ignore daylight-p zone))
+ (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
+ dow
+ day
+ (1- mon)
+ year
+ hr min sec))))
(defun print-seconds (secs)
(print-float-units secs "sec"))
(let ((%name (gensym)))
`(let ((,%name ,name))
(with-open-file (stream ,%name :direction :output
- :if-exists :supersede)
- (docbook-stream stream ,tree))
+ :if-exists :supersede)
+ (docbook-stream stream ,tree))
(values))))
-#+allegro
+#+allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'pxml)
(require 'uri))
(declare (ignore token public))
(cond
((and (net.uri:uri-scheme var)
- (string= "http" (net.uri:uri-scheme var)))
+ (string= "http" (net.uri:uri-scheme var)))
nil)
(t
(let ((path (net.uri:uri-path var)))
(if (probe-file path)
- (ignore-errors (open path))
- (make-string-input-stream
- (let ((*print-circle* nil))
- (format nil "<!ENTITY ~A '~A'>" path path))))))))
-
+ (ignore-errors (open path))
+ (make-string-input-stream
+ (let ((*print-circle* nil))
+ (format nil "<!ENTITY ~A '~A'>" path path))))))))
+
#+allegro
(defun xml-file->sexp-file (file &key (preprocess nil))
(let* ((path (etypecase file
- (string (parse-namestring file))
- (pathname file)))
- (new-path (make-pathname :defaults path
- :type "sexp"))
- raw-sexp)
-
+ (string (parse-namestring file))
+ (pathname file)))
+ (new-path (make-pathname :defaults path
+ :type "sexp"))
+ raw-sexp)
+
(if preprocess
- (multiple-value-bind (xml error status)
- (kmrcl:command-output (format nil
- "sh -c \"export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A\""
- "catalog-debian.xml"
- (namestring (make-pathname :defaults (if (pathname-directory path)
- path
- *default-pathname-defaults*)
- :name nil :type nil))
- (namestring path)))
- (unless (and (zerop status) (or (null error) (zerop (length error))))
- (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A"
- path status error))
- (setq raw-sexp (net.xml.parser:parse-xml
- (apply #'concatenate 'string xml)
- :content-only nil)))
+ (multiple-value-bind (xml error status)
+ (kmrcl:command-output (format nil
+ "sh -c \"export XML_CATALOG_FILES='~A'; cd ~A; xsltproc --xinclude pprint.xsl ~A\""
+ "catalog-debian.xml"
+ (namestring (make-pathname :defaults (if (pathname-directory path)
+ path
+ *default-pathname-defaults*)
+ :name nil :type nil))
+ (namestring path)))
+ (unless (and (zerop status) (or (null error) (zerop (length error))))
+ (error "Unable to preprocess XML file ~A, status ~D.~%Error: ~A"
+ path status error))
+ (setq raw-sexp (net.xml.parser:parse-xml
+ (apply #'concatenate 'string xml)
+ :content-only nil)))
(with-open-file (input path :direction :input)
- (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback))))
+ (setq raw-sexp (net.xml.parser:parse-xml input :external-callback #'entity-callback))))
(with-open-file (output new-path :direction :output
- :if-exists :supersede)
+ :if-exists :supersede)
(let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string
- raw-sexp
- #'atom-processor)))
- (write filtered :stream output :pretty t))))
+ raw-sexp
+ #'atom-processor)))
+ (write filtered :stream output :pretty t))))
(values))
(defun generalized-equal (obj1 obj2)
(if (not (equal (type-of obj1) (type-of obj2)))
(progn
- (terpri)
- (describe obj1)
- (describe obj2)
- nil)
+ (terpri)
+ (describe obj1)
+ (describe obj2)
+ nil)
(typecase obj1
(double-float
(let ((diff (abs (/ (- obj1 obj2) obj1))))
- (if (> diff (* 10 double-float-epsilon))
- nil
- t)))
+ (if (> diff (* 10 double-float-epsilon))
+ nil
+ t)))
(complex
(and (generalized-equal (realpart obj1) (realpart obj2))
- (generalized-equal (imagpart obj1) (imagpart obj2))))
+ (generalized-equal (imagpart obj1) (imagpart obj2))))
(structure-object
(generalized-equal-fielded-object obj1 obj2))
(standard-object
(return-from test nil))
(dotimes (i (array-total-size obj1))
(unless (generalized-equal (aref obj1 i) (aref obj2 i))
- (return-from test nil)))
+ (return-from test nil)))
(return-from test t)))
(defun generalized-equal-hash-table (obj1 obj2)
(return-from test nil))
(maphash
#'(lambda (k v)
- (multiple-value-bind (value found) (gethash k obj2)
- (unless (and found (generalized-equal v value))
- (return-from test nil))))
+ (multiple-value-bind (value found) (gethash k obj2)
+ (unless (and found (generalized-equal v value))
+ (return-from test nil))))
obj1)
(return-from test t)))
(return-from test nil))
(dolist (field (class-slot-names (class-name (class-of obj1))))
(unless (generalized-equal (slot-value obj1 field) (slot-value obj2 field))
- (return-from test nil)))
+ (return-from test nil)))
(return-from test t)))
(defun class-slot-names (c-name)
"Given a CLASS-NAME, returns a list of the slots in the class."
#+(or allegro cmu lispworks sbcl scl)
(mapcar #'kmr-mop:slot-definition-name
- (kmr-mop:class-slots (kmr-mop:find-class c-name)))
+ (kmr-mop:class-slots (kmr-mop:find-class c-name)))
#+(and mcl (not openmcl))
(let* ((class (find-class c-name nil)))
(when (typep class 'standard-class)
"Given a STRUCTURE-NAME, returns a list of the slots in the structure."
#+allegro (class-slot-names s-name)
#+lispworks (structure:structure-class-slot-names
- (find-class s-name))
+ (find-class s-name))
#+(or sbcl cmu) (mapcar #'kmr-mop:slot-definition-name
- (kmr-mop:class-slots (kmr-mop:find-class s-name)))
+ (kmr-mop:class-slots (kmr-mop:find-class s-name)))
#+scl (mapcar #'kernel:dsd-name
- (kernel:dd-slots
- (kernel:layout-info
- (kernel:class-layout (find-class s-name)))))
+ (kernel:dd-slots
+ (kernel:layout-info
+ (kernel:class-layout (find-class s-name)))))
#+(and mcl (not openmcl))
(let* ((sd (gethash s-name ccl::%defstructs%))
- (slots (if sd (ccl::sd-slots sd))))
- (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
+ (slots (if sd (ccl::sd-slots sd))))
+ (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots))))
#-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
(declare (ignore s-name))
#-(or allegro lispworks cmu sbcl scl (and mcl (not openmcl)))
(multiple-value-bind (lambda closurep name) (function-lambda-expression obj)
(declare (ignore closurep))
(if lambda
- (format nil "#'~s" lambda)
+ (format nil "#'~s" lambda)
(if name
- (format nil "#'~s" name)
- (progn
- (print obj)
- (break))))))
+ (format nil "#'~s" name)
+ (progn
+ (print obj)
+ (break))))))
(multiple-value-bind (val foundp) (gethash args cache)
(if foundp
val
- (setf (gethash args cache) (apply fn args)))))))
+ (setf (gethash args cache) (apply fn args)))))))
(defun memoize (fn-name)
(setf (fdefinition fn-name) (memo-proc (fdefinition fn-name))))
`(memoize (defun ,fn ,args . ,body)))
(defmacro _f (op place &rest args)
- (multiple-value-bind (vars forms var set access)
+ (multiple-value-bind (vars forms var set access)
(get-setf-expansion place)
`(let* (,@(mapcar #'list vars forms)
(,(car var) (,op ,access ,@args)))
(let ((fn1 (car (last fns)))
(fns (butlast fns)))
#'(lambda (&rest args)
- (reduce #'funcall fns
+ (reduce #'funcall fns
:from-end t
:initial-value (apply fn1 args))))
#'identity))
(defmacro if* (&rest args)
(do ((xx (reverse args) (cdr xx))
- (state :init)
- (elseseen nil)
- (totalcol nil)
- (lookat nil nil)
- (col nil))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
((null xx)
- (cond ((eq state :compl)
- `(cond ,@totalcol))
- (t (error "if*: illegal form ~s" args))))
+ (cond ((eq state :compl)
+ `(cond ,@totalcol))
+ (t (error "if*: illegal form ~s" args))))
(cond ((and (symbolp (car xx))
- (member (symbol-name (car xx))
- if*-keyword-list
- :test #'string-equal))
- (setq lookat (symbol-name (car xx)))))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
(cond ((eq state :init)
- (cond (lookat (cond ((string-equal lookat "thenret")
- (setq col nil
- state :then))
- (t (error
- "if*: bad keyword ~a" lookat))))
- (t (setq state :col
- col nil)
- (push (car xx) col))))
- ((eq state :col)
- (cond (lookat
- (cond ((string-equal lookat "else")
- (cond (elseseen
- (error
- "if*: multiples elses")))
- (setq elseseen t)
- (setq state :init)
- (push `(t ,@col) totalcol))
- ((string-equal lookat "then")
- (setq state :then))
- (t (error "if*: bad keyword ~s"
- lookat))))
- (t (push (car xx) col))))
- ((eq state :then)
- (cond (lookat
- (error
- "if*: keyword ~s at the wrong place " (car xx)))
- (t (setq state :compl)
- (push `(,(car xx) ,@col) totalcol))))
- ((eq state :compl)
- (cond ((not (string-equal lookat "elseif"))
- (error "if*: missing elseif clause ")))
- (setq state :init)))))
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t ,@col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) ,@col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
(defun canonicalize-directory-name (filename)
(flet ((un-unspecific (value)
- (if (eq value :unspecific) nil value)))
+ (if (eq value :unspecific) nil value)))
(let* ((path (pathname filename))
- (name (un-unspecific (pathname-name path)))
- (type (un-unspecific (pathname-type path)))
- (new-dir
- (cond ((and name type) (list (concatenate 'string name "." type)))
- (name (list name))
- (type (list type))
- (t nil))))
+ (name (un-unspecific (pathname-name path)))
+ (type (un-unspecific (pathname-type path)))
+ (new-dir
+ (cond ((and name type) (list (concatenate 'string name "." type)))
+ (name (list name))
+ (type (list type))
+ (t nil))))
(if new-dir
- (make-pathname
- :directory (append (un-unspecific (pathname-directory path))
- new-dir)
- :name nil :type nil :version nil :defaults path)
- path))))
+ (make-pathname
+ :directory (append (un-unspecific (pathname-directory path))
+ new-dir)
+ :name nil :type nil :version nil :defaults path)
+ path))))
(defun probe-directory (filename &key (error-if-does-not-exist nil))
(let* ((path (canonicalize-directory-name filename))
- (probe
- #+allegro (excl:probe-directory path)
- #+clisp (values
- (ignore-errors
- (#+lisp=cl ext:probe-directory
- #-lisp=cl lisp:probe-directory
- path)))
- #+(or cmu scl) (when (eq :directory
- (unix:unix-file-kind (namestring path)))
- path)
- #+lispworks (when (lw:file-directory-p path)
- path)
- #+sbcl (when (eq :directory
- (sb-unix:unix-file-kind (namestring path)))
- path)
- #-(or allegro clisp cmu lispworks sbcl scl)
- (probe-file path)))
+ (probe
+ #+allegro (excl:probe-directory path)
+ #+clisp (values
+ (ignore-errors
+ (#+lisp=cl ext:probe-directory
+ #-lisp=cl lisp:probe-directory
+ path)))
+ #+(or cmu scl) (when (eq :directory
+ (unix:unix-file-kind (namestring path)))
+ path)
+ #+lispworks (when (lw:file-directory-p path)
+ path)
+ #+sbcl (when (eq :directory
+ (sb-unix:unix-file-kind (namestring path)))
+ path)
+ #-(or allegro clisp cmu lispworks sbcl scl)
+ (probe-file path)))
(if probe
- probe
- (when error-if-does-not-exist
- (error "Directory ~A does not exist." filename)))))
+ probe
+ (when error-if-does-not-exist
+ (error "Directory ~A does not exist." filename)))))
(defun cwd (&optional dir)
"Change directory and set default pathname"
(cond
((not (null dir))
(when (and (typep dir 'logical-pathname)
- (translate-logical-pathname dir))
+ (translate-logical-pathname dir))
(setq dir (translate-logical-pathname dir)))
(when (stringp dir)
(setq dir (parse-namestring dir)))
(setq cl:*default-pathname-defaults* dir))
(t
(let ((dir
- #+allegro (excl:current-directory)
- #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
- #+(or cmu scl) (ext:default-directory)
- #+sbcl (sb-unix:posix-getcwd/)
- #+cormanlisp (ccl:get-current-directory)
- #+lispworks (hcl:get-working-directory)
- #+mcl (ccl:mac-default-directory)
- #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
+ #+allegro (excl:current-directory)
+ #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
+ #+(or cmu scl) (ext:default-directory)
+ #+sbcl (sb-unix:posix-getcwd/)
+ #+cormanlisp (ccl:get-current-directory)
+ #+lispworks (hcl:get-working-directory)
+ #+mcl (ccl:mac-default-directory)
+ #-(or allegro clisp cmu scl cormanlisp mcl sbcl lispworks) (truename ".")))
(when (stringp dir)
- (setq dir (parse-namestring dir)))
+ (setq dir (parse-namestring dir)))
dir))))
)
(defun copy-file (from to &key link overwrite preserve-symbolic-links
- (preserve-time t) remove-destination force verbose)
+ (preserve-time t) remove-destination force verbose)
#+allegro (sys:copy-file from to :link link :overwrite overwrite
- :preserve-symbolic-links preserve-symbolic-links
- :preserve-time preserve-time
- :remove-destination remove-destination
- :force force :verbose verbose)
+ :preserve-symbolic-links preserve-symbolic-links
+ :preserve-time preserve-time
+ :remove-destination remove-destination
+ :force force :verbose verbose)
#-allegro
(declare (ignore verbose preserve-symbolic-links overwrite))
(cond
(run-shell-command "ln -f ~A ~A" (namestring from) (namestring to)))
(link
(multiple-value-bind (stdout stderr status)
- (command-output "ln -f ~A ~A" (namestring from) (namestring to))
+ (command-output "ln -f ~A ~A" (namestring from) (namestring to))
(declare (ignore stdout stderr))
;; try symbolic if command failed
(unless (zerop status)
- (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
+ (run-shell-command "ln -sf ~A ~A" (namestring from) (namestring to)))))
(t
(when (and (or force remove-destination) (probe-file to))
(delete-file to))
(let* ((options (if preserve-time
- "-p"
- ""))
- (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
+ "-p"
+ ""))
+ (cmd (format nil "cp ~A ~A ~A" options (namestring from) (namestring to))))
(run-shell-command cmd)))))
(when (probe-file file)
(let ((eof (cons 'eof nil)))
(with-open-file (in file :direction :input)
- (do ((line (read-line in nil eof)
+ (do ((line (read-line in nil eof)
(read-line in nil eof)))
((eq line eof))
(write-string line strm)
(defun read-stream-to-string (in)
(with-output-to-string (out)
- (let ((eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
- (format out "~A~%" line)))))
-
+ (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-string (file)
"Opens a reads a file. Returns the contents as a single string"
(with-open-file (in file :direction :input)
"Opens a reads a file. Returns the contents as single unsigned-byte array"
(with-open-file (in file :direction :input :element-type '(unsigned-byte 8))
(let* ((file-len (file-length in))
- (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
- (pos (read-sequence usb8 in)))
+ (usb8 (make-array file-len :element-type '(unsigned-byte 8)))
+ (pos (read-sequence usb8 in)))
(unless (= file-len pos)
- (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
+ (error "Length read (~D) doesn't match file length (~D)~%" pos file-len))
usb8)))
-
+
(defun read-stream-to-strings (in)
(let ((lines '())
- (eof (gensym)))
- (do ((line (read-line in nil eof)
- (read-line in nil eof)))
- ((eq line eof))
+ (eof (gensym)))
+ (do ((line (read-line in nil eof)
+ (read-line in nil eof)))
+ ((eq line eof))
(push line lines))
(nreverse lines)))
-
+
(defun read-file-to-strings (file)
"Opens a reads a file. Returns the contents as a list of strings"
(with-open-file (in file :direction :input)
(defun file-subst (old new file1 file2)
(with-open-file (in file1 :direction :input)
(with-open-file (out file2 :direction :output
- :if-exists :supersede)
+ :if-exists :supersede)
(stream-subst old new in out))))
(defun print-n-chars (char n stream)
(defun indent-html-spaces (n &optional (stream *standard-output*))
"Indent n*2 html spaces to output stream"
(print-n-strings " " (+ n n) stream))
-
+
(defun print-list (l &optional (output *standard-output*))
"Print a list to a stream"
(format output "~{~A~%~}" l))
(defun print-rows (rows &optional (ostrm *standard-output*))
- "Print a list of list rows to a stream"
+ "Print a list of list rows to a stream"
(dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
(setf (bref b (incf (buf-end b))) x))
(defun buf-pop (b)
- (prog1
+ (prog1
(bref b (incf (buf-start b)))
(setf (buf-used b) (buf-start b)
(buf-new b) (buf-end b))))
(defun null-output-stream ()
(when (probe-file #p"/dev/null")
- (open #p"/dev/null" :direction :output :if-exists :overwrite))
+ (open #p"/dev/null" :direction :output :if-exists :overwrite))
)
(defun directory-tree (filename)
"Returns a tree of pathnames for sub-directories of a directory"
(let* ((root (canonicalize-directory-name filename))
- (subdirs (loop for path in (directory
- (make-pathname :name :wild
- :type :wild
- :defaults root))
- when (probe-directory path)
- collect (canonicalize-directory-name path))))
+ (subdirs (loop for path in (directory
+ (make-pathname :name :wild
+ :type :wild
+ :defaults root))
+ when (probe-directory path)
+ collect (canonicalize-directory-name path))))
(when (find nil subdirs)
(error "~A" subdirs))
(when (null root)
(error "~A" root))
(if subdirs
- (cons root (mapcar #'directory-tree subdirs))
- (if (probe-directory root)
- (list root)
- (error "root not directory ~A" root)))))
+ (cons root (mapcar #'directory-tree subdirs))
+ (if (probe-directory root)
+ (list root)
+ (error "root not directory ~A" root)))))
(defmacro with-utime-decoding ((utime &optional zone) &body body)
(declare (ignorable second minute hour day-of-month month year day-of-week daylight-p zone))
,@body))
-(defvar +datetime-number-strings+
+(defvar +datetime-number-strings+
(make-array 61 :adjustable nil :element-type 'string :fill-pointer nil
- :initial-contents
- '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
- "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
- "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
- "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
- "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
- "60")))
+ :initial-contents
+ '("00" "01" "02" "03" "04" "05" "06" "07" "08" "09" "10" "11"
+ "12" "13" "14" "15" "16" "17" "18" "19" "20" "21" "22" "23"
+ "24" "25" "26" "27" "28" "29" "30" "31" "32" "33" "34" "35"
+ "36" "37" "38" "39" "40" "41" "42" "43" "44" "45" "46" "47"
+ "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58" "59"
+ "60")))
(defun is-dst (utime)
(with-utime-decoding (utime)
(defmacro with-utime-decoding-utc-offset ((utime utc-offset) &body body)
(with-gensyms (zone)
`(let* ((,zone (cond
- ((eq :utc ,utc-offset)
- 0)
- ((null utc-offset)
- nil)
- (t
- (if (is-dst ,utime)
- (1- (- ,utc-offset))
- (- ,utc-offset))))))
+ ((eq :utc ,utc-offset)
+ 0)
+ ((null utc-offset)
+ nil)
+ (t
+ (if (is-dst ,utime)
+ (1- (- ,utc-offset))
+ (- ,utc-offset))))))
(if ,zone
- (with-utime-decoding (,utime ,zone)
- ,@body)
- (with-utime-decoding (,utime)
- ,@body)))))
+ (with-utime-decoding (,utime ,zone)
+ ,@body)
+ (with-utime-decoding (,utime)
+ ,@body)))))
(defun write-utime-hms (utime &key utc-offset stream)
(defun copy-binary-stream (in out &key (chunk-size 16384))
(do* ((buf (make-array chunk-size :element-type '(unsigned-byte 8)))
- (pos (read-sequence buf in) (read-sequence buf in)))
+ (pos (read-sequence buf in) (read-sequence buf in)))
((zerop pos))
(write-sequence buf out :end pos)))
"List of active listeners")
(defclass listener ()
- ((port :initarg :port :accessor port)
+ ((port :initarg :port :accessor port)
(function :initarg :function :accessor listener-function
- :initform nil)
+ :initform nil)
(function-args :initarg :function-args :accessor function-args
- :initform nil)
+ :initform nil)
(process :initarg :process :accessor process :initform nil)
(socket :initarg :socket :accessor socket :initform nil)
(workers :initform nil :accessor workers
- :documentation "list of worker threads")
+ :documentation "list of worker threads")
(name :initform "" :accessor name :initarg :name)
(base-name :initform "listener" :accessor base-name :initarg :base-name)
(wait :initform nil :accessor wait :initarg :wait)
(timeout :initform nil :accessor timeout :initarg :timeout)
(number-fixed-workers :initform nil :accessor number-fixed-workers
- :initarg :number-fixed-workers)
+ :initarg :number-fixed-workers)
(catch-errors :initform nil :accessor catch-errors :initarg :catch-errors)
(remote-host-checker :initform nil :accessor remote-host-checker
- :initarg :remote-host-checker)
+ :initarg :remote-host-checker)
(format :initform :text :accessor listener-format :initarg :format)))
(defclass fixed-worker ()
(defmethod print-object ((obj fixed-worker) s)
(print-unreadable-object (obj s :type t :identity nil)
(format s "port ~A" (port (listener obj)))))
-
+
;; High-level API
(defun init/listener (listener state)
(defun listener-startup (listener)
(handler-case
(progn
- (setf (name listener) (next-server-name (base-name listener)))
- (make-socket-server listener))
+ (setf (name listener) (next-server-name (base-name listener)))
+ (make-socket-server listener))
(error (e)
- (format t "~&Error while trying to start listener on port ~A~& ~A"
- (port listener) e)
+ (format t "~&Error while trying to start listener on port ~A~& ~A"
+ (port listener) e)
(decf *listener-count*)
nil)
(:no-error (res)
(defun listener-shutdown (listener)
(dolist (worker (workers listener))
(when (and (typep worker 'worker)
- (connection worker))
+ (connection worker))
(errorset (close-active-socket
- (connection worker)) nil)
+ (connection worker)) nil)
(setf (connection worker) nil))
(when (process worker)
(errorset (destroy-process (process worker)) nil)
;; Low-level functions
(defun next-server-name (base-name)
- (format nil "~D-~A-socket-server" (incf *listener-count*) base-name))
+ (format nil "~D-~A-socket-server" (incf *listener-count*) base-name))
(defun next-worker-name (base-name)
(format nil "~D-~A-worker" (incf *worker-count*) base-name))
(progn
(setf (process listener)
(comm:start-up-server :process-name (name listener)
- :service (port listener)
- :function
- #'(lambda (handle)
- (lw-worker handle listener)))))
+ :service (port listener)
+ :function
+ #'(lambda (handle)
+ (lw-worker handle listener)))))
#-lispworks
(progn
(setf (socket listener) (create-inet-listener
- (port listener)
- :format (listener-format listener)))
+ (port listener)
+ :format (listener-format listener)))
(if (number-fixed-workers listener)
- (start-fixed-number-of-workers listener)
- (setf (process listener) (make-process
- (name listener)
- #'(lambda ()
- (start-socket-server listener))))))
+ (start-fixed-number-of-workers listener)
+ (setf (process listener) (make-process
+ (name listener)
+ #'(lambda ()
+ (start-socket-server listener))))))
listener)
(defmethod initialize-instance :after
((self worker) &key listener connection name &allow-other-keys)
(flet ((do-work ()
- (apply (listener-function listener)
- connection
- (function-args listener))))
+ (apply (listener-function listener)
+ connection
+ (function-args listener))))
(unless connection
(error "connection not provided to modlisp-worker"))
(setf (slot-value self 'listener) listener)
(setf (slot-value self 'name) name)
(setf (slot-value self 'connection) connection)
(setf (slot-value self 'thread-fun)
- #'(lambda ()
- (unwind-protect
- (if (catch-errors listener)
- (handler-case
- (if (timeout listener)
- (with-timeout ((timeout listener))
- (do-work))
- (do-work))
- (error (e)
- (cmsg "Error ~A [~A]" e name)))
- (if (timeout listener)
- (with-timeout ((timeout listener))
- (do-work))
- (do-work)))
- (progn
- (errorset (finish-output connection) nil)
- (errorset (close-active-socket connection) nil)
- (cmsg-c :threads "~A ended" name)
- (setf (workers listener)
- (remove self (workers listener)))))))))
+ #'(lambda ()
+ (unwind-protect
+ (if (catch-errors listener)
+ (handler-case
+ (if (timeout listener)
+ (with-timeout ((timeout listener))
+ (do-work))
+ (do-work))
+ (error (e)
+ (cmsg "Error ~A [~A]" e name)))
+ (if (timeout listener)
+ (with-timeout ((timeout listener))
+ (do-work))
+ (do-work)))
+ (progn
+ (errorset (finish-output connection) nil)
+ (errorset (close-active-socket connection) nil)
+ (cmsg-c :threads "~A ended" name)
+ (setf (workers listener)
+ (remove self (workers listener)))))))))
(defun accept-and-check-tcp-connection (listener)
(multiple-value-bind (conn socket) (accept-tcp-connection (socket listener))
(when (and (remote-host-checker listener)
- (not (funcall (remote-host-checker listener)
- (remote-host socket))))
+ (not (funcall (remote-host-checker listener)
+ (remote-host socket))))
(cmsg-c :thread "Deny connection from ~A" (remote-host conn))
(errorset (close-active-socket conn) nil)
(setq conn nil))
(defun start-socket-server (listener)
(unwind-protect
- (loop
+ (loop
(let ((connection (accept-and-check-tcp-connection listener)))
- (when connection
- (if (wait listener)
- (unwind-protect
- (apply (listener-function listener)
- connection
- (function-args listener))
- (progn
- (errorset (finish-output connection) nil)
- (errorset (close-active-socket connection) nil)))
- (let ((worker (make-instance 'worker :listener listener
- :connection connection
- :name (next-worker-name
- (base-name listener)))))
- (setf (process worker)
- (make-process (name worker) (thread-fun worker)))
- (push worker (workers listener)))))))
+ (when connection
+ (if (wait listener)
+ (unwind-protect
+ (apply (listener-function listener)
+ connection
+ (function-args listener))
+ (progn
+ (errorset (finish-output connection) nil)
+ (errorset (close-active-socket connection) nil)))
+ (let ((worker (make-instance 'worker :listener listener
+ :connection connection
+ :name (next-worker-name
+ (base-name listener)))))
+ (setf (process worker)
+ (make-process (name worker) (thread-fun worker)))
+ (push worker (workers listener)))))))
(errorset (close-passive-socket (socket listener)) nil)))
#+lispworks
(defun lw-worker (handle listener)
(let ((connection (make-instance 'comm:socket-stream
- :socket handle
- :direction :io
- :element-type 'base-char)))
+ :socket handle
+ :direction :io
+ :element-type 'base-char)))
(if (wait listener)
- (progn
- (apply (listener-function listener)
- connection
- (function-args listener))
- (finish-output connection))
- (let ((worker (make-instance 'worker :listener listener
- :connection connection
- :name (next-worker-name
- (base-name listener)))))
- (setf (process worker)
- (make-process (name worker) (thread-fun worker)))
- (push worker (workers listener))))))
+ (progn
+ (apply (listener-function listener)
+ connection
+ (function-args listener))
+ (finish-output connection))
+ (let ((worker (make-instance 'worker :listener listener
+ :connection connection
+ :name (next-worker-name
+ (base-name listener)))))
+ (setf (process worker)
+ (make-process (name worker) (thread-fun worker)))
+ (push worker (workers listener))))))
;; Fixed pool of workers
(let ((name (next-worker-name (base-name listener))))
(push
(make-instance 'fixed-worker
- :name name
- :listener listener
- :process
- (make-process
- name #'(lambda () (fixed-worker name listener))))
+ :name name
+ :listener listener
+ :process
+ (make-process
+ name #'(lambda () (fixed-worker name listener))))
(workers listener)))))
(defun fixed-worker (name listener)
- (loop
+ (loop
(let ((connection (accept-and-check-tcp-connection listener)))
(when connection
(flet ((do-work ()
- (apply (listener-function listener)
- connection
- (function-args listener))))
- (unwind-protect
- (handler-case
- (if (catch-errors listener)
- (handler-case
- (if (timeout listener)
- (with-timeout ((timeout listener))
- (do-work))
- (do-work))
- (error (e)
- (cmsg "Error ~A [~A]" e name)))
- (if (timeout listener)
- (with-timeout ((timeout listener))
- (do-work))
- (do-work)))
- (error (e)
- (format t "Error: ~A" e)))
- (errorset (finish-output connection) nil)
- (errorset (close connection) nil)))))))
-
+ (apply (listener-function listener)
+ connection
+ (function-args listener))))
+ (unwind-protect
+ (handler-case
+ (if (catch-errors listener)
+ (handler-case
+ (if (timeout listener)
+ (with-timeout ((timeout listener))
+ (do-work))
+ (do-work))
+ (error (e)
+ (cmsg "Error ~A [~A]" e name)))
+ (if (timeout listener)
+ (with-timeout ((timeout listener))
+ (do-work))
+ (do-work)))
+ (error (e)
+ (format t "Error: ~A" e)))
+ (errorset (finish-output connection) nil)
+ (errorset (close connection) nil)))))))
+
"Strip from tree of atoms that satistify predicate"
(if (atom tree)
(unless (funcall pred tree)
- (if atom-processor
- (funcall atom-processor tree)
- tree))
+ (if atom-processor
+ (funcall atom-processor tree)
+ tree))
(let ((car-strip (remove-from-tree-if pred (car tree) atom-processor))
- (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))
+ (cdr-strip (remove-from-tree-if pred (cdr tree) atom-processor)))
(cond
((and car-strip (atom (cadr tree)) (null cdr-strip))
- (list car-strip))
+ (list car-strip))
((and car-strip cdr-strip)
- (cons car-strip cdr-strip))
+ (cons car-strip cdr-strip))
(car-strip
- car-strip)
+ car-strip)
(cdr-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)
+ (cdr tree)
(aif (find-tree sym (car tree))
- it
- (aif (find-tree sym (cdr tree))
- it
- nil)))))
+ it
+ (aif (find-tree sym (cdr tree))
+ it
+ nil)))))
(defun flatten (lis)
(cond ((atom lis) lis)
- ((listp (car lis))
- (append (flatten (car lis)) (flatten (cdr lis))))
- (t (append (list (car lis)) (flatten (cdr lis))))))
+ ((listp (car lis))
+ (append (flatten (car lis)) (flatten (cdr lis))))
+ (t (append (list (car lis)) (flatten (cdr lis))))))
;;; 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)))
+ 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)))
+ unless (member (symbol-name name) key-names
+ :key #'symbol-name :test 'equal)
+ append (list name val)))
(defun mapappend (func seq)
(apply #'append (mapcar func seq)))
(defun mapcar-append-string-nontailrec (func v)
- "Concatenate results of mapcar lambda calls"
+ "Concatenate results of mapcar lambda calls"
(aif (car v)
(concatenate 'string (funcall func it)
- (mapcar-append-string-nontailrec func (cdr v)))
+ (mapcar-append-string-nontailrec func (cdr v)))
""))
(defun mapcar-append-string (func v &optional (accum ""))
- "Concatenate results of mapcar lambda calls"
+ "Concatenate results of mapcar lambda calls"
(aif (car v)
- (mapcar-append-string
- func
- (cdr v)
- (concatenate 'string accum (funcall func it)))
+ (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"
+ "Concatenate results of mapcar lambda call's over two lists"
(let ((a (car la))
- (b (car lb)))
+ (b (car lb)))
(if (and a b)
(concatenate 'string (funcall func a b)
- (mapcar2-append-string-nontailrec func (cdr la) (cdr lb)))
+ (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"
+ "Concatenate results of mapcar lambda call's over two lists"
(let ((a (car la))
- (b (car lb)))
+ (b (car lb)))
(if (and a b)
- (mapcar2-append-string func (cdr la) (cdr lb)
- (concatenate 'string accum (funcall func a b)))
+ (mapcar2-append-string func (cdr la) (cdr lb)
+ (concatenate 'string accum (funcall func a b)))
accum)))
(defun append-sublists (list)
(defmacro update-alist (akey value alist &key (test '#'eql) (key '#'identity))
"Macro to support below (setf get-alist)"
(let ((elem (gensym "ELEM-"))
- (val (gensym "VAL-")))
+ (val (gensym "VAL-")))
`(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))
- (,val ,value))
+ (,val ,value))
(cond
- (,elem
- (setf (cdr ,elem) ,val))
- (,alist
- (setf (cdr (last ,alist)) (list (cons ,akey ,val))))
- (t
- (setf ,alist (list (cons ,akey ,val)))))
+ (,elem
+ (setf (cdr ,elem) ,val))
+ (,alist
+ (setf (cdr (last ,alist)) (list (cons ,akey ,val))))
+ (t
+ (setf ,alist (list (cons ,akey ,val)))))
,alist)))
(defun get-alist (key alist &key (test #'eql))
(let ((pos (gensym)))
`(let ((,pos (member ,pkey ,plist :test ,test)))
(if ,pos
- (progn
- (setf (cadr ,pos) ,value)
- ,plist)
- (setf ,plist (append ,plist (list ,pkey ,value)))))))
+ (progn
+ (setf (cadr ,pos) ,value)
+ ,plist)
+ (setf ,plist (append ,plist (list ,pkey ,value)))))))
(defun unique-slot-values (list slot &key (test 'eql))
(let ((uniq '()))
(dolist (item list (nreverse uniq))
(let ((value (slot-value item slot)))
- (unless (find value uniq :test test)
- (push value uniq))))))
+ (unless (find value uniq :test test)
+ (push value uniq))))))
(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)))
(defmacro with-each-stream-line ((var stream) &body body)
(let ((eof (gensym))
- (eof-value (gensym))
- (strm (gensym)))
+ (eof-value (gensym))
+ (strm (gensym)))
`(let ((,strm ,stream)
- (,eof ',eof-value))
+ (,eof ',eof-value))
(do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
- ((eql ,var ,eof))
- ,@body))))
+ ((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))))
+ ,@body))))
(defmacro in (obj &rest choices)
(defmacro with-gensyms (syms &body body)
`(let ,(mapcar #'(lambda (s) `(,s (gensym)))
- syms)
+ syms)
,@body))
(let ((t1 (gensym)))
`(let ((,t1 (get-internal-real-time)))
(values
- (progn ,@body)
- (coerce (/ (- (get-internal-real-time) ,t1)
- internal-time-units-per-second)
- 'double-float)))))
-
+ (progn ,@body)
+ (coerce (/ (- (get-internal-real-time) ,t1)
+ internal-time-units-per-second)
+ 'double-float)))))
+
(defmacro time-iterations (n &body body)
(let ((i (gensym))
- (count (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))))))))
+ (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))))))))
(defmacro mv-bind (vars form &body body)
- `(multiple-value-bind ,vars ,form
+ `(multiple-value-bind ,vars ,form
,@body))
;; From USENET
-(defmacro deflex (var val &optional (doc nil docp))
+(defmacro deflex (var val &optional (doc nil docp))
"Defines a top level (global) lexical VAR with initial value VAL,
which is assigned unconditionally as with DEFPARAMETER. If a DOC
string is provided, it is attached to both the name |VAR| and the
kind 'VARIABLE. The new VAR will have lexical scope and thus may
be shadowed by LET bindings without affecting its global value."
(let* ((s0 (load-time-value (symbol-name '#:*storage-for-deflex-var-)))
- (s1 (symbol-name var))
- (p1 (symbol-package var))
- (s2 (load-time-value (symbol-name '#:*)))
- (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
+ (s1 (symbol-name var))
+ (p1 (symbol-package var))
+ (s2 (load-time-value (symbol-name '#:*)))
+ (backing-var (intern (concatenate 'string s0 s1 s2) p1)))
`(progn
(defparameter ,backing-var ,val ,@(when docp `(,doc)))
,@(when docp
- `((setf (documentation ',var 'variable) ,doc)))
+ `((setf (documentation ',var 'variable) ,doc)))
(define-symbol-macro ,var ,backing-var))))
(defmacro def-cached-vector (name element-type)
(let ((get-name (concat-symbol "get-" name "-vector"))
- (release-name (concat-symbol "release-" name "-vector"))
- (table-name (concat-symbol "*cached-" name "-table*"))
- (lock-name (concat-symbol "*cached-" name "-lock*")))
+ (release-name (concat-symbol "release-" name "-vector"))
+ (table-name (concat-symbol "*cached-" name "-table*"))
+ (lock-name (concat-symbol "*cached-" name "-lock*")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar ,table-name (make-hash-table :test 'equal))
(defvar ,lock-name (kmrcl::make-lock ,name))
-
- (defun ,get-name (size)
- (kmrcl::with-lock-held (,lock-name)
- (let ((buffers (gethash (cons size ,element-type) ,table-name)))
- (if buffers
- (let ((buffer (pop buffers)))
- (setf (gethash (cons size ,element-type) ,table-name) buffers)
- buffer)
- (make-array size :element-type ,element-type)))))
-
- (defun ,release-name (buffer)
- (kmrcl::with-lock-held (,lock-name)
- (let ((buffers (gethash (cons (array-total-size buffer)
- ,element-type)
- ,table-name)))
- (setf (gethash (cons (array-total-size buffer)
- ,element-type) ,table-name)
- (cons buffer buffers))))))))
+
+ (defun ,get-name (size)
+ (kmrcl::with-lock-held (,lock-name)
+ (let ((buffers (gethash (cons size ,element-type) ,table-name)))
+ (if buffers
+ (let ((buffer (pop buffers)))
+ (setf (gethash (cons size ,element-type) ,table-name) buffers)
+ buffer)
+ (make-array size :element-type ,element-type)))))
+
+ (defun ,release-name (buffer)
+ (kmrcl::with-lock-held (,lock-name)
+ (let ((buffers (gethash (cons (array-total-size buffer)
+ ,element-type)
+ ,table-name)))
+ (setf (gethash (cons (array-total-size buffer)
+ ,element-type) ,table-name)
+ (cons buffer buffers))))))))
(defmacro def-cached-instance (name)
(let* ((new-name (concat-symbol "new-" name "-instance"))
- (release-name (concat-symbol "release-" name "-instance"))
- (cache-name (concat-symbol "*cached-" name "-instance-table*"))
- (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
+ (release-name (concat-symbol "release-" name "-instance"))
+ (cache-name (concat-symbol "*cached-" name "-instance-table*"))
+ (lock-name (concat-symbol "*cached-" name "-instance-lock*")))
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar ,cache-name nil)
(defvar ,lock-name (kmrcl::make-lock ',name))
-
- (defun ,new-name ()
- (kmrcl::with-lock-held (,lock-name)
- (if ,cache-name
- (pop ,cache-name)
- (make-instance ',name))))
-
- (defun ,release-name (instance)
- (kmrcl::with-lock-held (,lock-name)
- (push instance ,cache-name))))))
+
+ (defun ,new-name ()
+ (kmrcl::with-lock-held (,lock-name)
+ (if ,cache-name
+ (pop ,cache-name)
+ (make-instance ',name))))
+
+ (defun ,release-name (instance)
+ (kmrcl::with-lock-held (,lock-name)
+ (push instance ,cache-name))))))
(defmacro with-ignore-errors (&rest forms)
`(progn
,@(mapcar
- (lambda (x) (list 'ignore-errors x))
- forms)))
+ (lambda (x) (list 'ignore-errors x))
+ forms)))
(defmacro ppmx (form)
"Pretty prints the macro expansion of FORM."
`(let* ((exp1 (macroexpand-1 ',form))
- (exp (macroexpand exp1))
- (*print-circle* nil))
+ (exp (macroexpand exp1))
+ (*print-circle* nil))
(cond ((equal exp exp1)
- (format t "~&Macro expansion:")
- (pprint exp))
- (t (format t "~&First step of expansion:")
- (pprint exp1)
- (format t "~%~%Final expansion:")
- (pprint exp)))
+ (format t "~&Macro expansion:")
+ (pprint exp))
+ (t (format t "~&First step of expansion:")
+ (pprint exp1)
+ (format t "~%~%Final expansion:")
+ (pprint exp)))
(format t "~%~%")
(values)))
(defmacro defconstant* (sym value &optional doc)
"Ensure VALUE is evaluated only once."
`(defconstant ,sym (if (boundp ',sym)
- (symbol-value ',sym)
- ,value)
+ (symbol-value ',sym)
+ ,value)
,@(when doc (list doc))))
(defmacro defvar-unbound (sym &optional (doc ""))
(defun deriv (f dx)
#'(lambda (x)
(/ (- (funcall f (+ x dx)) (funcall f x))
- dx)))
+ dx)))
(defun sin^ (x)
(funcall (deriv #'sin 1d-8) x))
(when (zerop (length v))
(return-from histogram (values nil nil nil)) )
(let ((n (length v))
- (bins (make-array n-bins :element-type 'integer :initial-element 0))
- found-min found-max)
+ (bins (make-array n-bins :element-type 'integer :initial-element 0))
+ found-min found-max)
(declare (fixnum n))
(unless (and min max)
(setq found-min (aref v 0)
- found-max (aref v 0))
+ found-max (aref v 0))
(loop for i fixnum from 1 to (1- n)
- do
- (let ((x (aref v i)))
- (cond
- ((> x found-max)
- (setq found-max x))
- ((< x found-min)
- (setq found-min x)))))
+ do
+ (let ((x (aref v i)))
+ (cond
+ ((> x found-max)
+ (setq found-max x))
+ ((< x found-min)
+ (setq found-min x)))))
(unless min
- (setq min found-min))
+ (setq min found-min))
(unless max
- (setq max found-max)))
+ (setq max found-max)))
(let ((width (/ (- max min) n-bins)))
(setq width (+ width (* double-float-epsilon width)))
(dotimes (i n)
- (let ((bin (nth-value 0 (truncate (- (aref v i) min) width))))
- (declare (fixnum bin))
- (when (and (not (minusp bin))
- (< bin n-bins))
- (incf (aref bins bin))))))
+ (let ((bin (nth-value 0 (truncate (- (aref v i) min) width))))
+ (declare (fixnum bin))
+ (when (and (not (minusp bin))
+ (< bin n-bins))
+ (incf (aref bins bin))))))
(values bins min max)))
-
+
(defun fixnum-width ()
(nth-value 0 (truncate (+ (/ (log (1+ most-positive-fixnum)) (log 2)) .5))))
(multiple-value-bind (significand exponent)
(decode-float float)
(multiple-value-bind (1.0-significand 1.0-exponent)
- (decode-float (float 1.0 float))
+ (decode-float (float 1.0 float))
(if (and (eq operation '-)
- (= significand 1.0-significand))
- (scale-float (typecase float
- (short-float short-float-negative-epsilon)
- (single-float single-float-negative-epsilon)
- (double-float double-float-negative-epsilon)
- (long-float long-float-negative-epsilon))
- (- exponent 1.0-exponent))
- (scale-float (typecase float
- (short-float short-float-epsilon)
- (single-float single-float-epsilon)
- (double-float double-float-epsilon)
- (long-float long-float-epsilon))
- (- exponent 1.0-exponent))))))
+ (= significand 1.0-significand))
+ (scale-float (typecase float
+ (short-float short-float-negative-epsilon)
+ (single-float single-float-negative-epsilon)
+ (double-float double-float-negative-epsilon)
+ (long-float long-float-negative-epsilon))
+ (- exponent 1.0-exponent))
+ (scale-float (typecase float
+ (short-float short-float-epsilon)
+ (single-float single-float-epsilon)
+ (double-float double-float-epsilon)
+ (long-float long-float-epsilon))
+ (- exponent 1.0-exponent))))))
(defun sinc (x)
(if (zerop x)
#+cmu
(eval-when (:compile-toplevel :load-toplevel :execute)
(if (eq (symbol-package 'pcl:find-class)
- (find-package 'common-lisp))
+ (find-package 'common-lisp))
(pushnew :kmr-cmucl-mop cl:*features*)
(pushnew :kmr-cmucl-pcl cl:*features*)))
(defmacro process-class-option (metaclass slot-name &optional required)
#+lispworks
`(defmethod clos:process-a-class-option ((class ,metaclass)
- (name (eql ,slot-name))
- value)
+ (name (eql ,slot-name))
+ value)
(when (and ,required (null value))
(error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name))
(list name `',value))
(defmacro process-slot-option (metaclass slot-name)
#+lispworks
`(defmethod clos:process-a-slot-option ((class ,metaclass)
- (option (eql ,slot-name))
- value
- already-processed-options
- slot)
+ (option (eql ,slot-name))
+ value
+ already-processed-options
+ slot)
(list* option `',value already-processed-options))
#-lispworks
(declare (ignore metaclass slot-name))
openmcl-mop:class-prototype openmcl-mop:generic-function-method-class openmcl-mop:intern-eql-specializer
openmcl-mop:make-method-lambda openmcl-mop:generic-function-lambda-list
openmcl-mop::compute-slots) ))
-
+
(eval-when (:compile-toplevel :load-toplevel :execute)
(export '(class-of class-name class-slots find-class
- standard-class
- slot-definition-name finalize-inheritance
- standard-direct-slot-definition
- standard-effective-slot-definition validate-superclass
- compute-effective-slot-definition-initargs
- direct-slot-definition-class effective-slot-definition-class
- compute-effective-slot-definition
- slot-value-using-class
- class-prototype generic-function-method-class intern-eql-specializer
- make-method-lambda generic-function-lambda-list
- compute-slots
- class-direct-slots
- ;; KMR-MOP encapsulating macros
- process-slot-option
- process-class-option))
-
+ standard-class
+ slot-definition-name finalize-inheritance
+ standard-direct-slot-definition
+ standard-effective-slot-definition validate-superclass
+ compute-effective-slot-definition-initargs
+ direct-slot-definition-class effective-slot-definition-class
+ compute-effective-slot-definition
+ slot-value-using-class
+ class-prototype generic-function-method-class intern-eql-specializer
+ make-method-lambda generic-function-lambda-list
+ compute-slots
+ class-direct-slots
+ ;; KMR-MOP encapsulating macros
+ process-slot-option
+ process-class-option))
+
#+sbcl
(if (find-package 'sb-mop)
(setq cl:*features* (delete :kmr-sbcl-mop cl:*features*))
(setq cl:*features* (delete :kmr-sbcl-pcl cl:*features*)))
-
+
#+cmu
(if (find-package 'mop)
(setq cl:*features* (delete :kmr-cmucl-mop cl:*features*))
(setq cl:*features* (delete :kmr-cmucl-pcl cl:*features*)))
-
+
(when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'compute-effective-slot-definition)))
- 3)
+ (ensure-generic-function
+ 'compute-effective-slot-definition)))
+ 3)
(pushnew :kmr-normal-cesd cl:*features*))
-
+
(when (>= (length (generic-function-lambda-list
- (ensure-generic-function
- 'direct-slot-definition-class)))
- 3)
+ (ensure-generic-function
+ 'direct-slot-definition-class)))
+ 3)
(pushnew :kmr-normal-dsdc cl:*features*))
) ;; eval-when
(let ((command (apply #'format nil control-string args)))
#+sbcl
(let* ((process (sb-ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output :stream :error :stream))
- (output (read-stream-to-string (sb-impl::process-output process)))
- (error (read-stream-to-string (sb-impl::process-error process))))
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output :stream :error :stream))
+ (output (read-stream-to-string (sb-impl::process-output process)))
+ (error (read-stream-to-string (sb-impl::process-error process))))
(close (sb-impl::process-output process))
(close (sb-impl::process-error process))
(values
#+(or cmu scl)
(let* ((process (ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output :stream :error :stream))
- (output (read-stream-to-string (ext::process-output process)))
- (error (read-stream-to-string (ext::process-error process))))
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output :stream :error :stream))
+ (output (read-stream-to-string (ext::process-output process)))
+ (error (read-stream-to-string (ext::process-error process))))
(close (ext::process-output process))
(close (ext::process-error process))
#+allegro
(multiple-value-bind (output error status)
- (excl.osi:command-output command :whole t)
+ (excl.osi:command-output command :whole t)
(values output error status))
#+lispworks
;; BUG: Lispworks combines output and error streams
(let ((output (make-string-output-stream)))
(unwind-protect
- (let ((status
- (system:call-system-showing-output
- command
- :prefix ""
- :show-cmd nil
- :output-stream output)))
- (values (get-output-stream-string output) nil status))
- (close output)))
+ (let ((status
+ (system:call-system-showing-output
+ command
+ :prefix ""
+ :show-cmd nil
+ :output-stream output)))
+ (values (get-output-stream-string output) nil status))
+ (close output)))
#+clisp
;; BUG: CLisp doesn't allow output to user-specified stream
#+openmcl
(let* ((process (ccl:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output :stream :error :stream
- :wait t))
- (output (read-stream-to-string (ccl::external-process-output-stream process)))
- (error (read-stream-to-string (ccl::external-process-error-stream process))))
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output :stream :error :stream
+ :wait t))
+ (output (read-stream-to-string (ccl::external-process-output-stream process)))
+ (error (read-stream-to-string (ccl::external-process-error-stream process))))
(close (ccl::external-process-output-stream process))
(close (ccl::external-process-error-stream process))
(values output
- error
- (nth-value 1 (ccl::external-process-status process))))
+ error
+ (nth-value 1 (ccl::external-process-status process))))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
(error "COMMAND-OUTPUT not implemented for this Lisp")
#+allegro
(excl:run-shell-command command :input nil :output nil
- :wait t)
+ :wait t)
#+lispworks
(system:call-system-showing-output
:prefix ""
:output-stream nil)
- #+clisp ;XXX not exactly *verbose-out*, I know
+ #+clisp ;XXX not exactly *verbose-out*, I know
(ext:run-shell-command command :output :terminal :wait t)
#+openmcl
(nth-value 1
- (ccl:external-process-status
- (ccl:run-program "/bin/sh" (list "-c" command)
- :input nil :output nil
- :wait t)))
+ (ccl:external-process-status
+ (ccl:run-program "/bin/sh" (list "-c" command)
+ :input nil :output nil
+ :wait t)))
#-(or openmcl clisp lispworks allegro scl cmu sbcl)
(error "RUN-SHELL-PROGRAM not implemented for this Lisp")
(defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
#+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
- :quiet quiet :force force)
+ :quiet quiet :force force)
#-(or allegro) (declare (ignore force))
#-(or allegro) (cond
- ((probe-directory dir)
- (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
- (unless quiet
- (format *trace-output* ";; ~A" cmd))
- (command-output cmd)))
- ((eq if-does-not-exist :error)
- (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
+ ((probe-directory dir)
+ (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
+ (unless quiet
+ (format *trace-output* ";; ~A" cmd))
+ (command-output cmd)))
+ ((eq if-does-not-exist :error)
+ (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
(defun file-size (file)
(when (probe-file file)
#+allegro (let ((stat (excl.osi:stat (namestring file))))
- (excl.osi:stat-size stat))
+ (excl.osi:stat-size stat))
#-allegro
(with-open-file (in file :direction :input)
(file-length in))))
#+openmcl (ccl::getpid)
#+(and clisp unix) (system::process-id)
#+(and clisp win32) (cond ((find-package :win32)
- (funcall (find-symbol "GetCurrentProcessId"
- :win32)))
- (t
- (system::getenv "PID")))
+ (funcall (find-symbol "GetCurrentProcessId"
+ :win32)))
+ (t
+ (system::getenv "PID")))
)
#-(or allegro cmu sb-thread openmcl)
`(progn ,@body)
)
-
+
(defun process-sleep (n)
#+allegro (mp:process-sleep n)
#-allegro (sleep n))
(defun seed-random-generator ()
"Evaluate a random number of items"
- (let ((randfile (make-pathname
- :directory '(:absolute "dev")
- :name "urandom")))
+ (let ((randfile (make-pathname
+ :directory '(:absolute "dev")
+ :name "urandom")))
(setf *random-state* (make-random-state t))
(if (probe-file randfile)
- (with-open-file
- (rfs randfile :element-type 'unsigned-byte)
- (let*
- ;; ((seed (char-code (read-char rfs))))
- ((seed (read-byte rfs)))
- ;;(format t "Randomizing!~%")
- (loop
- for item from 1 to seed
- do (loop
- for it from 0 to (+ (read-byte rfs) 5)
- do (random 65536))))))))
+ (with-open-file
+ (rfs randfile :element-type 'unsigned-byte)
+ (let*
+ ;; ((seed (char-code (read-char rfs))))
+ ((seed (read-byte rfs)))
+ ;;(format t "Randomizing!~%")
+ (loop
+ for item from 1 to seed
+ do (loop
+ for it from 0 to (+ (read-byte rfs) 5)
+ do (random 65536))))))))
(defmacro random-choice (&rest exprs)
(defclass repl ()
((listener :initarg :listener :accessor listener
- :initform nil)))
+ :initform nil)))
(defun make-repl (&key (port +default-repl-server-port+)
- announce user-checker remote-host-checker)
- (make-instance 'listener
+ announce user-checker remote-host-checker)
+ (make-instance 'listener
:port port
- :base-name "repl"
+ :base-name "repl"
:function 'repl-worker
:function-args (list user-checker announce)
:format :text
(finish-output conn)
(setq password (read-socket-line conn))
(unless (funcall user-checker login password)
- (format conn "Invalid login~%")
- (finish-output conn)
- (return-from repl-worker))))
+ (format conn "Invalid login~%")
+ (finish-output conn)
+ (return-from repl-worker))))
#+allegro
(tpl::start-interactive-top-level
conn
(defun read-socket-line (stream)
(string-right-trim-one-char #\return
- (read-line stream nil nil)))
+ (read-line stream nil nil)))
(defun print-prompt (stream)
(format stream "~&~A> " (package-name *package*))
(defun repl-on-stream (stream)
(let ((*standard-input* stream)
- (*standard-output* stream)
- (*terminal-io* stream)
- (*debug-io* stream))
+ (*standard-output* stream)
+ (*terminal-io* stream)
+ (*debug-io* stream))
#|
#+sbcl
(if (and (find-package 'sb-aclrepl)
- (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
- (sb-aclrepl::repl-fun)
- (%repl))
+ (fboundp (intern "REPL-FUN" "SB-ACLREPL")))
+ (sb-aclrepl::repl-fun)
+ (%repl))
#-sbcl
|#
(%repl)))
(print-prompt *standard-output*)
(let ((form (read *standard-input*)))
(format *standard-output* "~&~S~%" (eval form)))))
-
+
-(in-package #:cl-user)
+(in-package #:cl-user)
(defpackage #:run-tests (:use #:cl))
(in-package #:run-tests)
"Return a subsequence by pointing to location in original sequence"
(unless end (setq end (length sequence)))
(make-array (- end start)
- :element-type (array-element-type sequence)
- :displaced-to sequence
- :displaced-index-offset start))
+ :element-type (array-element-type sequence)
+ :displaced-to sequence
+ :displaced-index-offset start))
"Create, bind and listen to an inet socket on *:PORT.
setsockopt SO_REUSEADDR if :reuse is not nil"
(let ((socket (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream
- :protocol :tcp)))
+ :type :stream
+ :protocol :tcp)))
(if reuse
(setf (sb-bsd-sockets:sockopt-reuse-address socket) t))
(sb-bsd-sockets:socket-bind
#+cmu (ext:create-inet-listener port)
#+allegro
(socket:make-socket :connect :passive :local-port port :format format
- :address-family
- (if (stringp port)
- :file
- (if (or (null port) (integerp port))
- :internet
- (error "illegal value for port: ~s" port)))
- :reuse-address reuse-address)
+ :address-family
+ (if (stringp port)
+ :file
+ (if (or (null port) (integerp port))
+ :internet
+ (error "illegal value for port: ~s" port)))
+ :reuse-address reuse-address)
#+sbcl (declare (ignore format))
#+sbcl (listen-to-inet-port :port port :reuse reuse-address)
#+clisp (declare (ignore format reuse-address))
(declare (ignore format))
#+openmcl
(ccl:make-socket :connect :passive :local-port port
- :reuse-address reuse-address)
+ :reuse-address reuse-address)
#-(or allegro clisp cmu sbcl openmcl)
(warn "create-inet-listener not supported on this implementation")
)
(defun make-fd-stream (socket &key input output element-type)
#+cmu
(sys:make-fd-stream socket :input input :output output
- :element-type element-type)
+ :element-type element-type)
#+sbcl
(sb-bsd-sockets:socket-make-stream socket :input input :output output
- :element-type element-type)
+ :element-type element-type)
#-(or cmu sbcl) (declare (ignore input output element-type))
#-(or cmu sbcl) socket
)
(values (sys:make-fd-stream sock :input t :output t) sock)))
#+sbcl
(when (sb-sys:wait-until-fd-usable
- (sb-bsd-sockets:socket-file-descriptor listener) :input)
+ (sb-bsd-sockets:socket-file-descriptor listener) :input)
(let ((sock (sb-bsd-sockets:socket-accept listener)))
(values
(sb-bsd-sockets:socket-make-stream
- sock :element-type :default :input t :output t)
+ sock :element-type :default :input t :output t)
sock)))
#+openmcl
(let ((sock (ccl:accept-connection listener :wait t)))
#+clisp (ext:socket-server-close socket)
#+cmu (unix:unix-close socket)
#+sbcl (sb-unix:unix-close
- (sb-bsd-sockets:socket-file-descriptor socket))
+ (sb-bsd-sockets:socket-file-descriptor socket))
#+openmcl (close socket)
#-(or allegro clisp cmu sbcl openmcl)
(warn "close-passive-socket not supported on this implementation")
"Convert from 32-bit integer to dotted string."
(declare (type (unsigned-byte 32) ipaddr))
(let ((a (logand #xff (ash ipaddr -24)))
- (b (logand #xff (ash ipaddr -16)))
- (c (logand #xff (ash ipaddr -8)))
- (d (logand #xff ipaddr)))
+ (b (logand #xff (ash ipaddr -16)))
+ (c (logand #xff (ash ipaddr -8)))
+ (d (logand #xff ipaddr)))
(if values
- (values a b c d)
+ (values a b c d)
(format nil "~d.~d.~d.~d" a b c d))))
(defun dotted-to-ipaddr (dotted &key (errorp t))
(declare (string dotted))
(if errorp
(let ((ll (delimited-string-to-list dotted #\.)))
- (+ (ash (parse-integer (first ll)) 24)
- (ash (parse-integer (second ll)) 16)
- (ash (parse-integer (third ll)) 8)
- (parse-integer (fourth ll))))
+ (+ (ash (parse-integer (first ll)) 24)
+ (ash (parse-integer (second ll)) 16)
+ (ash (parse-integer (third ll)) 8)
+ (parse-integer (fourth ll))))
(ignore-errors
(let ((ll (delimited-string-to-list dotted #\.)))
- (+ (ash (parse-integer (first ll)) 24)
- (ash (parse-integer (second ll)) 16)
- (ash (parse-integer (third ll)) 8)
- (parse-integer (fourth ll)))))))
+ (+ (ash (parse-integer (first ll)) 24)
+ (ash (parse-integer (second ll)) 16)
+ (ash (parse-integer (third ll)) 8)
+ (parse-integer (fourth ll)))))))
#+sbcl
(defun ipaddr-to-hostname (ipaddr &key ignore-cache)
"Returns (VALUES STREAM SOCKET)"
#+allegro
(let ((sock (socket:make-socket :remote-host server
- :remote-port port)))
+ :remote-port port)))
(values sock sock))
#+lispworks
(let ((sock (comm:open-tcp-stream server port)))
(values sock sock))
#+sbcl
(let ((sock (make-instance 'sb-bsd-sockets:inet-socket
- :type :stream
- :protocol :tcp)))
+ :type :stream
+ :protocol :tcp)))
(sb-bsd-sockets:socket-connect sock (lookup-hostname server) port)
(values
(sb-bsd-sockets:socket-make-stream
(format nil "~{~D~^.~}" (coerce array 'list))
#+ignore
(format nil "~D.~D.~D.~D"
- (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
+ (aref 0 array) (aref 1 array) (aref 2 array) (array 3 array)))
(defun remote-host (socket)
#+allegro (socket:ipaddr-to-dotted (socket:remote-host socket))
#+lispworks (nth-value 0 (comm:get-socket-peer-address socket))
#+sbcl (ipaddr-array-to-dotted
- (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
+ (nth-value 0 (sb-bsd-sockets:socket-peername socket)))
#+cmu (nth-value 0 (ext:get-peer-host-and-port socket))
#+clisp (let* ((peer (ext:socket-stream-peer socket t))
(stop (position #\Space peer)))
(defun count-string-words (str)
(declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(let ((n-words 0)
- (in-word nil))
+ (in-word nil))
(declare (fixnum n-words))
(do* ((len (length str))
- (i 0 (1+ i)))
- ((= i len) n-words)
+ (i 0 (1+ i)))
+ ((= i len) n-words)
(declare (fixnum i))
(if (alphanumericp (schar str i))
- (unless in-word
- (incf n-words)
- (setq in-word t))
- (setq in-word nil)))))
+ (unless in-word
+ (incf n-words)
+ (setq in-word t))
+ (setq in-word nil)))))
;; From Larry Hunter with modifications
(defun position-char (char string start max)
(declare (optimize (speed 3) (safety 0) (space 0))
- (fixnum start max) (simple-string string))
+ (fixnum start max) (simple-string string))
(do* ((i start (1+ i)))
((= i max) nil)
(declare (fixnum i))
(defun position-not-char (char string start max)
(declare (optimize (speed 3) (safety 0) (space 0))
- (fixnum start max) (simple-string string))
+ (fixnum start max) (simple-string string))
(do* ((i start (1+ i)))
((= i max) nil)
(declare (fixnum i))
(when (char/= char (schar string i)) (return i))))
(defun delimited-string-to-list (string &optional (separator #\space)
- skip-terminal)
+ skip-terminal)
"split a string with delimiter"
(declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0))
- (type string string)
- (type character separator))
+ (type string string)
+ (type character separator))
(do* ((len (length string))
- (output '())
- (pos 0)
- (end (position-char separator string pos len)
- (position-char separator string pos len)))
+ (output '())
+ (pos 0)
+ (end (position-char separator string pos len)
+ (position-char separator string pos len)))
((null end)
- (if (< pos len)
- (push (subseq string pos) output)
- (when (or (not skip-terminal) (zerop len))
- (push "" output)))
- (nreverse output))
+ (if (< pos len)
+ (push (subseq string pos) output)
+ (when (or (not skip-terminal) (zerop len))
+ (push "" output)))
+ (nreverse output))
(declare (type fixnum pos len)
- (type (or null fixnum) end))
+ (type (or null fixnum) end))
(push (subseq string pos end) output)
(setq pos (1+ end))))
(let ((up nil) (down nil))
(block skip
(loop for char of-type character across str do
- (cond ((upper-case-p char)
- (if down (return-from skip str) (setf up t)))
- ((lower-case-p char)
- (if up (return-from skip str) (setf down t)))))
+ (cond ((upper-case-p char)
+ (if down (return-from skip str) (setf up t)))
+ ((lower-case-p char)
+ (if up (return-from skip str) (setf down t)))))
(if up (string-downcase str) (string-upcase str)))))
(defun add-sql-quotes (s)
(defun string-substitute (string substring replacement-string)
"String substitute by Larry Hunter. Obtained from Google"
(let ((substring-length (length substring))
- (last-end 0)
- (new-string ""))
+ (last-end 0)
+ (new-string ""))
(do ((next-start
- (search substring string)
- (search substring string :start2 last-end)))
- ((null next-start)
- (concatenate 'string new-string (subseq string last-end)))
+ (search substring string)
+ (search substring string :start2 last-end)))
+ ((null next-start)
+ (concatenate 'string new-string (subseq string last-end)))
(setq new-string
- (concatenate 'string
- new-string
- (subseq string last-end next-start)
- replacement-string))
+ (concatenate 'string
+ new-string
+ (subseq string last-end next-start)
+ replacement-string))
(setq last-end (+ next-start substring-length)))))
(defun string-trim-last-character (s)
"Return the string less the last character"
(let ((len (length s)))
(if (plusp len)
- (subseq s 0 (1- len))
- s)))
+ (subseq s 0 (1- len))
+ s)))
(defun nstring-trim-last-character (s)
"Return the string less the last character"
(let ((len (length s)))
(if (plusp len)
- (nsubseq s 0 (1- len))
- s)))
+ (nsubseq s 0 (1- len))
+ s)))
(defun string-hash (str &optional (bitmask 65535))
(let ((hash 0))
(declare (fixnum hash)
- (simple-string str))
+ (simple-string str))
(dotimes (i (length str))
(declare (fixnum i))
(setq hash (+ hash (char-code (char str i)))))
(zerop (length str)))
(defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed
- #+allegro #\%space
- #+lispworks #\No-Break-Space))
+ #+allegro #\%space
+ #+lispworks #\No-Break-Space))
(defun is-char-whitespace (c)
(declare (character c) (optimize (speed 3) (safety 0)))
(defun replaced-string-length (str repl-alist)
(declare (simple-string str)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((i 0 (1+ i))
- (orig-len (length str))
- (new-len orig-len))
- ((= i orig-len) new-len)
+ (orig-len (length str))
+ (new-len orig-len))
+ ((= i orig-len) new-len)
(declare (fixnum i orig-len new-len))
(let* ((c (char str i))
- (match (assoc c repl-alist :test #'char=)))
- (declare (character c))
- (when match
- (incf new-len (1- (length
- (the simple-string (cdr match)))))))))
+ (match (assoc c repl-alist :test #'char=)))
+ (declare (character c))
+ (when match
+ (incf new-len (1- (length
+ (the simple-string (cdr match)))))))))
(defun substitute-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)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((orig-len (length str))
- (new-string (make-string (replaced-string-length str repl-alist)))
- (spos 0 (1+ spos))
- (dpos 0))
+ (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=)))
+ (match (assoc c repl-alist :test #'char=)))
(declare (character c))
(if match
- (let* ((subst (cdr match))
- (len (length subst)))
- (declare (fixnum len)
- (simple-string subst))
- (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))))))
+ (let* ((subst (cdr match))
+ (len (length subst)))
+ (declare (fixnum len)
+ (simple-string subst))
+ (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"
(defun usb8-array-to-string (vec &key (start 0) end)
(declare (type (simple-array (unsigned-byte 8) (*)) vec)
- (fixnum start))
+ (fixnum start))
(unless end
(setq end (length vec)))
(let* ((len (- end start))
- (str (make-string len)))
+ (str (make-string len)))
(declare (fixnum len)
- (simple-string str)
- (optimize (speed 3) (safety 0)))
+ (simple-string str)
+ (optimize (speed 3) (safety 0)))
(do ((i 0 (1+ i)))
- ((= i len) str)
+ ((= i len) str)
(declare (fixnum i))
(setf (schar str i) (code-char (aref vec (the fixnum (+ i start))))))))
(defun string-to-usb8-array (str)
(declare (simple-string str))
(let* ((len (length str))
- (vec (make-usb8-array len)))
+ (vec (make-usb8-array len)))
(declare (fixnum len)
- (type (simple-array (unsigned-byte 8) (*)) vec)
- (optimize (speed 3)))
+ (type (simple-array (unsigned-byte 8) (*)) vec)
+ (optimize (speed 3)))
(do ((i 0 (1+ i)))
- ((= i len) vec)
+ ((= i len) vec)
(declare (fixnum i))
(setf (aref vec i) (char-code (schar str i))))))
(defun concat-separated-strings (separator &rest lists)
(format nil (concatenate 'string "~{~A~^" (string separator) "~}")
- (append-sublists lists)))
+ (append-sublists lists)))
(defun only-null-list-elements-p (lst)
(or (null lst) (every #'null lst)))
(defun print-separated-strings (strm separator &rest lists)
(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
- (compilation-speed 0)))
+ (compilation-speed 0)))
(do* ((rest-lists lists (cdr rest-lists))
- (list (car rest-lists) (car rest-lists))
- (last-list (only-null-list-elements-p (cdr rest-lists))
- (only-null-list-elements-p (cdr rest-lists))))
+ (list (car rest-lists) (car rest-lists))
+ (last-list (only-null-list-elements-p (cdr rest-lists))
+ (only-null-list-elements-p (cdr rest-lists))))
((null rest-lists) strm)
(do* ((lst list (cdr lst))
- (elem (car lst) (car lst))
- (last-elem (null (cdr lst)) (null (cdr lst))))
- ((null lst))
+ (elem (car lst) (car lst))
+ (last-elem (null (cdr lst)) (null (cdr lst))))
+ ((null lst))
(write-string elem strm)
(unless (and last-elem last-list)
- (write-string separator strm)))))
+ (write-string separator strm)))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro def-prefixed-number-string (fn-name type &optional doc)
(setf (schar result 0) pchar))
(when minus? (setf (schar result (if pchar 1 0)) #\-))
result)
- (declare (,type val)
+ (declare (,type val)
(fixnum mod zero-code pos)
(boolean minus?)
(simple-string result))
"Outputs a string of LEN digit with an optional initial character PCHAR.
Leading zeros are present."
(declare (optimize (speed 3) (safety 0) (space 0))
- (type fixnum len)
- (type integer num))
+ (type fixnum len)
+ (type integer num))
(do* ((zero-code (char-code #\0))
- (result (make-string len :initial-element #\0))
- (minus? (minusp num))
- (val (if minus? (- 0 num) num)
- (nth-value 0 (floor val 10)))
- (pos (1- len) (1- pos))
- (mod (mod val 10) (mod val 10)))
+ (result (make-string len :initial-element #\0))
+ (minus? (minusp num))
+ (val (if minus? (- 0 num) num)
+ (nth-value 0 (floor val 10)))
+ (pos (1- len) (1- pos))
+ (mod (mod val 10) (mod val 10)))
((or (zerop val) (minusp pos))
(when minus? (setf (schar result 0) #\-))
result)
(defun fast-string-search (substr str substr-length startpos endpos)
"Optimized search for a substring in a simple-string"
(declare (simple-string substr str)
- (fixnum substr-length startpos endpos)
- (optimize (speed 3) (space 0) (safety 0)))
+ (fixnum substr-length startpos endpos)
+ (optimize (speed 3) (space 0) (safety 0)))
(do* ((pos startpos (1+ pos))
- (lastpos (- endpos substr-length)))
+ (lastpos (- endpos substr-length)))
((> pos lastpos) nil)
(declare (fixnum pos lastpos))
(do ((i 0 (1+ i)))
- ((= i substr-length)
- (return-from fast-string-search pos))
+ ((= i substr-length)
+ (return-from fast-string-search pos))
(declare (fixnum i))
(unless (char= (schar str (+ i pos)) (schar substr i))
- (return nil)))))
+ (return nil)))))
(defun string-delimited-string-to-list (str substr)
"splits a string delimited by substr into a list of strings"
(declare (simple-string str substr)
- (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
- (debug 0)))
+ (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)
+ (debug 0)))
(do* ((substr-len (length substr))
- (strlen (length str))
- (output '())
- (pos 0)
- (end (fast-string-search substr str substr-len pos strlen)
- (fast-string-search substr str substr-len pos strlen)))
+ (strlen (length str))
+ (output '())
+ (pos 0)
+ (end (fast-string-search substr str substr-len pos strlen)
+ (fast-string-search substr str substr-len pos strlen)))
((null end)
- (when (< pos strlen)
- (push (subseq str pos) output))
- (nreverse output))
+ (when (< pos strlen)
+ (push (subseq str pos) output))
+ (nreverse output))
(declare (fixnum strlen substr-len pos)
- (type (or fixnum null) end))
+ (type (or fixnum null) end))
(push (subseq str pos end) output)
(setq pos (+ end substr-len))))
(defun string-to-list-skip-delimiter (str &optional (delim #\space))
"Return a list of strings, delimited by spaces, skipping spaces."
(declare (simple-string str)
- (optimize (speed 0) (space 0) (safety 0)))
+ (optimize (speed 0) (space 0) (safety 0)))
(do* ((results '())
- (end (length str))
- (i (position-not-char delim str 0 end)
- (position-not-char delim str j end))
- (j (when i (position-char delim str i end))
- (when i (position-char delim str i end))))
+ (end (length str))
+ (i (position-not-char delim str 0 end)
+ (position-not-char delim str j end))
+ (j (when i (position-char delim str i end))
+ (when i (position-char delim str i end))))
((or (null i) (null j))
- (when (and i (< i end))
- (push (subseq str i end) results))
- (nreverse results))
+ (when (and i (< i end))
+ (push (subseq str i end) results))
+ (nreverse results))
(declare (fixnum end)
- (type (or fixnum null) i j))
+ (type (or fixnum null) i j))
(push (subseq str i j) results)))
(defun string-starts-with (start str)
(defun count-string-char (s c)
"Return a count of the number of times a character appears in a string"
(declare (simple-string s)
- (character c)
- (optimize (speed 3) (safety 0)))
+ (character c)
+ (optimize (speed 3) (safety 0)))
(do ((len (length s))
(i 0 (1+ i))
(count 0))
"Return a count of the number of times a predicate is true
for characters in a string"
(declare (simple-string s)
- (type (or function symbol) pred)
- (optimize (speed 3) (safety 0) (space 0)))
+ (type (or function symbol) pred)
+ (optimize (speed 3) (safety 0) (space 0)))
(do ((len (length s))
(i 0 (1+ i))
(count 0))
(defconstant* +char-code-upper-a+ (char-code #\A))
(defconstant* +char-code-0+ (char-code #\0))
(declaim (type fixnum +char-code-0+ +char-code-upper-a+
- +char-code-0))
+ +char-code-0))
(defun charhex (ch)
"convert hex character to decimal"
(let ((code (char-code (char-upcase ch))))
(declare (fixnum ch))
(if (>= code +char-code-upper-a+)
- (+ 10 (- code +char-code-upper-a+))
- (- code +char-code-0+))))
+ (+ 10 (- code +char-code-upper-a+))
+ (- code +char-code-0+))))
(defun binary-sequence-to-hex-string (seq)
(let ((list (etypecase seq
(defun encode-uri-string (query)
"Escape non-alphanumeric characters for URI fields"
(declare (simple-string query)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((count (count-string-char-if #'non-alphanumericp query))
- (len (length query))
- (new-len (+ len (* 2 count)))
- (str (make-string new-len))
- (spos 0 (1+ spos))
- (dpos 0 (1+ dpos)))
+ (len (length query))
+ (new-len (+ len (* 2 count)))
+ (str (make-string new-len))
+ (spos 0 (1+ spos))
+ (dpos 0 (1+ dpos)))
((= spos len) str)
(declare (fixnum count len new-len spos dpos)
- (simple-string str))
+ (simple-string str))
(let ((ch (schar query spos)))
(if (non-alphanumericp ch)
- (let ((c (char-code ch)))
- (setf (schar str dpos) #\%)
- (incf dpos)
- (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
- (incf dpos)
- (setf (schar str dpos) (hexchar (logand c 15))))
- (setf (schar str dpos) ch)))))
+ (let ((c (char-code ch)))
+ (setf (schar str dpos) #\%)
+ (incf dpos)
+ (setf (schar str dpos) (hexchar (logand (ash c -4) 15)))
+ (incf dpos)
+ (setf (schar str dpos) (hexchar (logand c 15))))
+ (setf (schar str dpos) ch)))))
(defun decode-uri-string (query)
"Unescape non-alphanumeric characters for URI fields"
(declare (simple-string query)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((count (count-string-char query #\%))
- (len (length query))
- (new-len (- len (* 2 count)))
- (str (make-string new-len))
- (spos 0 (1+ spos))
- (dpos 0 (1+ dpos)))
+ (len (length query))
+ (new-len (- len (* 2 count)))
+ (str (make-string new-len))
+ (spos 0 (1+ spos))
+ (dpos 0 (1+ dpos)))
((= spos len) str)
(declare (fixnum count len new-len spos dpos)
- (simple-string str))
+ (simple-string str))
(let ((ch (schar query spos)))
(if (char= #\% ch)
- (let ((c1 (charhex (schar query (1+ spos))))
- (c2 (charhex (schar query (+ spos 2)))))
- (declare (fixnum c1 c2))
- (setf (schar str dpos)
- (code-char (logior c2 (ash c1 4))))
- (incf spos 2))
- (setf (schar str dpos) ch)))))
+ (let ((c1 (charhex (schar query (1+ spos))))
+ (c2 (charhex (schar query (+ spos 2)))))
+ (declare (fixnum c1 c2))
+ (setf (schar str dpos)
+ (code-char (logior c2 (ash c1 4))))
+ (incf spos 2))
+ (setf (schar str dpos) ch)))))
(defun uri-query-to-alist (query)
(:lower-alphanumeric
(let ((n (random 36)))
(if (>= n 26)
- (code-char (+ +char-code-0+ (- n 26)))
- (code-char (+ +char-code-lower-a+ n)))))
+ (code-char (+ +char-code-0+ (- n 26)))
+ (code-char (+ +char-code-lower-a+ n)))))
(:upper-alpha
(code-char (+ +char-code-upper-a+ (random 26))))
(:unambiguous
(:upper-lower-alpha
(let ((n (random 52)))
(if (>= n 26)
- (code-char (+ +char-code-upper-a+ (- n 26)))
- (code-char (+ +char-code-lower-a+ n)))))))
+ (code-char (+ +char-code-upper-a+ (- n 26)))
+ (code-char (+ +char-code-lower-a+ n)))))))
(defun random-string (&key (length 10) (set :lower-alpha))
(defun string-right-trim-one-char (char str)
(declare (simple-string str))
(let* ((len (length str))
- (last (1- len)))
+ (last (1- len)))
(declare (fixnum len last))
(if (char= char (schar str last))
- (subseq str 0 last)
+ (subseq str 0 last)
str)))
(let ((len (length str)))
(dolist (ending endings str)
(when (and (>= len (length ending))
- (string-equal ending
- (subseq str (- len
- (length ending)))))
- (return-from string-strip-ending
- (subseq str 0 (- len (length ending))))))))
+ (string-equal ending
+ (subseq str (- len
+ (length ending)))))
+ (return-from string-strip-ending
+ (subseq str 0 (- len (length ending))))))))
(defun string-maybe-shorten (str maxlen)
"...")
((eq position :middle)
(multiple-value-bind (mid remain) (truncate maxlen 2)
- (let ((end1 (- mid 1))
- (start2 (- len (- mid 2) remain)))
- (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
+ (let ((end1 (- mid 1))
+ (start2 (- len (- mid 2) remain)))
+ (concatenate 'string (subseq str 0 end1) "..." (subseq str start2)))))
((or (eq position :end) t)
(concatenate 'string (subseq str 0 (- maxlen 3)) "...")))))
(defun split-alphanumeric-string (string)
"Separates a string at any non-alphanumeric chararacter"
(declare (simple-string string)
- (optimize (speed 3) (safety 0)))
+ (optimize (speed 3) (safety 0)))
(flet ((is-sep (char)
- (declare (character char))
- (and (non-alphanumericp char)
- (not (char= #\_ char)))))
+ (declare (character char))
+ (and (non-alphanumericp char)
+ (not (char= #\_ char)))))
(let ((tokens nil))
(do* ((token-start
(position-if-not #'is-sep string)
(defun trim-non-alphanumeric (word)
"Strip non-alphanumeric characters from beginning and end of a word."
(declare (simple-string word)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(let* ((start 0)
- (len (length word))
- (end len))
+ (len (length word))
+ (end len))
(declare (fixnum start end len))
(do ((done nil))
- ((or done (= start end)))
+ ((or done (= start end)))
(if (alphanumericp (schar word start))
- (setq done t)
- (incf start)))
+ (setq done t)
+ (incf start)))
(when (> end start)
(do ((done nil))
- ((or done (= start end)))
- (if (alphanumericp (schar word (1- end)))
- (setq done t)
- (decf end))))
+ ((or done (= start end)))
+ (if (alphanumericp (schar word (1- end)))
+ (setq done t)
+ (decf end))))
(if (or (plusp start) (/= len end))
- (subseq word start end)
+ (subseq word start end)
word)))
(defun collapse-whitespace (s)
"Convert multiple whitespace characters to a single space character."
(declare (simple-string s)
- (optimize (speed 3) (safety 0)))
+ (optimize (speed 3) (safety 0)))
(with-output-to-string (stream)
(do ((pos 0 (1+ pos))
- (in-white nil)
- (len (length s)))
- ((= pos len))
+ (in-white nil)
+ (len (length s)))
+ ((= pos len))
(declare (fixnum pos len))
(let ((c (schar s pos)))
- (declare (character c))
- (cond
- ((kl:is-char-whitespace c)
- (unless in-white
- (write-char #\space stream))
- (setq in-white t))
- (t
- (setq in-white nil)
- (write-char c stream)))))))
+ (declare (character c))
+ (cond
+ ((kl:is-char-whitespace c)
+ (unless in-white
+ (write-char #\space stream))
+ (setq in-white t))
+ (t
+ (setq in-white nil)
+ (write-char c stream)))))))
(defun string->list (string)
(let ((eof (list nil)))
"Score a match between two strings with s1 being reference string.
S1 can be a string or a list or strings/conses"
(let* ((word-list-1 (if (stringp s1)
- (split-alphanumeric-string s1)
- s1))
- (word-list-2 (split-alphanumeric-string s2))
- (n1 (length word-list-1))
- (n2 (length word-list-2))
- (unmatched n1)
- (score 0))
+ (split-alphanumeric-string s1)
+ s1))
+ (word-list-2 (split-alphanumeric-string s2))
+ (n1 (length word-list-1))
+ (n2 (length word-list-2))
+ (unmatched n1)
+ (score 0))
(declare (fixnum n1 n2 score unmatched))
(decf score (* 4 (abs (- n1 n2))))
(dotimes (iword n1)
(declare (fixnum iword))
(let ((w1 (nth iword word-list-1))
- pos)
- (cond
- ((consp w1)
- (let ((first t))
- (dotimes (i-alt (length w1))
- (setq pos
- (position (nth i-alt w1) word-list-2
- :test #'string-equal))
- (when pos
- (incf score (- 30
- (if first 0 5)
- (abs (- iword pos))))
- (decf unmatched)
- (return))
- (setq first nil))))
- ((stringp w1)
- (kmrcl:awhen (position w1 word-list-2
- :test #'string-equal)
- (incf score (- 30 (abs (- kmrcl::it iword))))
- (decf unmatched))))))
+ pos)
+ (cond
+ ((consp w1)
+ (let ((first t))
+ (dotimes (i-alt (length w1))
+ (setq pos
+ (position (nth i-alt w1) word-list-2
+ :test #'string-equal))
+ (when pos
+ (incf score (- 30
+ (if first 0 5)
+ (abs (- iword pos))))
+ (decf unmatched)
+ (return))
+ (setq first nil))))
+ ((stringp w1)
+ (kmrcl:awhen (position w1 word-list-2
+ :test #'string-equal)
+ (incf score (- 30 (abs (- kmrcl::it iword))))
+ (decf unmatched))))))
(decf score (* 4 unmatched))
score))
(defun multiword-match (s1 s2)
"Matches two multiword strings, ignores case, word position, punctuation"
(let* ((word-list-1 (split-alphanumeric-string s1))
- (word-list-2 (split-alphanumeric-string s2))
- (n1 (length word-list-1))
- (n2 (length word-list-2)))
+ (word-list-2 (split-alphanumeric-string s2))
+ (n1 (length word-list-1))
+ (n2 (length word-list-2)))
(when (= n1 n2)
;; remove each word from word-list-2 as walk word-list-1
(dolist (w word-list-1)
- (let ((p (position w word-list-2 :test #'string-equal)))
- (unless p
- (return-from multiword-match nil))
- (setf (nth p word-list-2) "")))
+ (let ((p (position w word-list-2 :test #'string-equal)))
+ (unless p
+ (return-from multiword-match nil))
+ (setf (nth p word-list-2) "")))
t)))
-
-
-
+
+
+
(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))))
+ (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))))
+ (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
(when (char= #\a (schar (symbol-name '#:a) 0))
(pushnew :kmrcl-lowercase-reader *features*))
(when (not (string= (symbol-name '#:a)
- (symbol-name '#:A)))
+ (symbol-name '#:A)))
(pushnew :kmrcl-case-sensitive *features*)))
(defun string-default-case (str)
(symbol-name arg)))))
(let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
(nth-value 0 (intern (string-default-case str)
- (if pkg pkg *package*))))))
+ (if pkg pkg *package*))))))
(defun concat-symbol (&rest args)
(defun ensure-keyword-upcase (desig)
(nth-value 0 (intern (string-upcase
- (symbol-name (ensure-keyword desig))) :keyword)))
+ (symbol-name (ensure-keyword desig))) :keyword)))
(defun ensure-keyword-default-case (desig)
(nth-value 0 (intern (string-default-case
- (symbol-name (ensure-keyword desig))) :keyword)))
+ (symbol-name (ensure-keyword desig))) :keyword)))
(defun show (&optional (what :variables) (package *package*))
(ecase what
(defun show-variables (package)
(do-symbols (s package)
(multiple-value-bind (sym status)
- (find-symbol (symbol-name s) package)
+ (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))))))
+ (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)
+ (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))))))
+ (eq status :internal))
+ (fboundp sym))
+ (format t "~&Function ~S~T -> ~S~%"
+ sym
+ (symbol-function sym))))))
(defun find-test-generic-functions (instance)
"Return a list of symbols for generic functions specialized on the
class of an instance and whose name begins with the string 'test-'"
(let ((res)
- (package (symbol-package (class-name (class-of instance)))))
+ (package (symbol-package (class-name (class-of instance)))))
(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)
- (eq (symbol-package sym) package)
- (> (length (symbol-name sym)) 5)
- (string-equal "test-" (subseq (symbol-name sym) 0 5))
- (typep (symbol-function sym) 'generic-function)
- (plusp
- (length
- (compute-applicable-methods
- (ensure-generic-function sym)
- (list instance)))))
- (push sym res))))
+ (find-symbol (symbol-name s) package)
+ (when (and (or (eq status :external)
+ (eq status :internal))
+ (fboundp sym)
+ (eq (symbol-package sym) package)
+ (> (length (symbol-name sym)) 5)
+ (string-equal "test-" (subseq (symbol-name sym) 0 5))
+ (typep (symbol-function sym) 'generic-function)
+ (plusp
+ (length
+ (compute-applicable-methods
+ (ensure-generic-function sym)
+ (list instance)))))
+ (push sym res))))
(nreverse res)))
(defun run-tests-for-instance (instance)
(defpackage #:kmrcl-tests
(:use #:kmrcl #:cl #:rtest))
(in-package #:kmrcl-tests)
-
+
(rem-all-tests)
(deftest :str.17 (nstring-trim-last-character "ab") "a")
(deftest :str.18 (delimited-string-to-list "ab|cd|ef" #\|)
- ("ab" "cd" "ef"))
+ ("ab" "cd" "ef"))
(deftest :str.19 (delimited-string-to-list "ab|cd|ef" #\| t)
- ("ab" "cd" "ef"))
+ ("ab" "cd" "ef"))
(deftest :str.20 (delimited-string-to-list "") (""))
(deftest :str.21 (delimited-string-to-list "" #\space t) (""))
(deftest :str.22 (delimited-string-to-list "ab") ("ab"))
(deftest :apsl.4 (append-sublists '((a))) (a))
(deftest :apsl.5 (append-sublists '((a) (b) (c d (e f g)))) (a b c d (e f g)))
-(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil))
+(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil))
"")
(deftest :pss.1
(deftest :css.5 (concat-separated-strings "|" '("ab" "cd") nil '("ef")) "ab|cd|ef")
(deftest :f.1 (map-and-remove-nils #'(lambda (x) (when (oddp x) (* x x)))
- '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81))
+ '(0 1 2 3 4 5 6 7 8 9)) (1 9 25 49 81))
(deftest :f.2 (filter #'(lambda (x) (when (oddp x) (* x x)))
- '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9))
+ '(0 1 2 3 4 5 6 7 8 9)) (1 3 5 7 9))
(deftest :an.1 (appendnew '(a b c d) '(c c e f)) (a b c d e f))
(multiple-value-bind (r g b) (hsv->rgb h s v)
(multiple-value-bind (h2 s2 v2) (rgb->hsv r g b)
(unless (hsv-equal h s v h2 s2 v2)
- (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+ (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
(float r) (float g) (float b)
(when (typep h 'number) (float h))
(when (typep h2 'number) (float h2))
(unless (hsv-similar h s v h2 (/ s2 255) (/ v2 255)
:hue-range 10 :saturation-range .1
:value-range 1 :black-limit 0 :gray-limit 0)
- (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+ (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
r g b
(when (typep h 'number) (float h))
(when (typep h2 'number) (float h2))
(unless (hsv-similar h s v h2 s2 v2
:hue-range 10 :saturation-range .1
:value-range 1 :black-limit 0 :gray-limit 0)
- (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
+ (warn "Colors not equal: ~4D ~4D ~4D | ~6D:~6D ~6D:~6D ~6D:~6D~%"
r g b
(when (typep h 'number) (float h))
(when (typep h2 'number) (float h2))
(float s) (float (/ s2 255)) (float v) (float (/ v2 255)))
(return-from test-color-conversion-255-float nil))))))))
t)
-
+
(defun test-color-conversion-255 ()
(dotimes (ih 11)
(dotimes (is 11)
(unless (hsv255-similar h s v h2 s2 v2 :hue-range 10 :saturation-range 5
:value-range 5 :black-limit 0 :gray-limit 0)
(warn "Colors not equal: ~D ~D ~D |~
- ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%"
+ ~3,'0D:~3,'0D ~3,'0D:~3,'0D ~3,'0D:~3,'0D~%"
r g b
h h2 s s2 v v2)
(return-from test-color-conversion-255 nil))))))))
(deftest :color.conv (test-color-conversion) t)
(deftest :color.conv.float.255 (test-color-conversion-float-255) t)
(deftest :color.conv.255.float (test-color-conversion-255-float) t)
-(deftest :color.conv.255 (test-color-conversion-255) t)
+(deftest :color.conv.255 (test-color-conversion-255) t)
(deftest :hue.diff.1 (hue-difference 10 10) 0)
(deftest :hue.diff.2 (hue-difference 10 9) -1)
(defclass test-unique ()
((a :initarg :a)
(b :initarg :b)))
-
+
(deftest :unique.1
(let ((list (list (make-instance 'test-unique :a 1 :b 1)
- (make-instance 'test-unique :a 2 :b 2)
- (make-instance 'test-unique :a 3 :b 2))))
+ (make-instance 'test-unique :a 2 :b 2)
+ (make-instance 'test-unique :a 3 :b 2))))
(values
(unique-slot-values list 'a)
(unique-slot-values list 'b)))
(unique-slot-values nil 'a)
nil)
-(deftest :nwp.1
+(deftest :nwp.1
(numbers-within-percentage 1. 1.1 9)
nil)
(deftest :pfs.2 (prefixed-fixnum-string 1 #\A 5) "A00001")
(deftest :pfs.3 (prefixed-fixnum-string 21 #\B 3) "B021")
-
+
(deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134")
-
+
;;; MOP Testing
;; Disable attrib class until understand changes in sbcl/cmucl
(setf (find-class 'monitored-credit-rating) nil)
#+kmrtest-mop
(setf (find-class 'credit-rating) nil)
-
+
#+kmrtest-mop
(defclass credit-rating ()
((level :attributes (date-set time-set))
#+lispworks (:optimize-slot-access nil)
(:metaclass attributes-class))
-
+
#+kmrtest-mop
(defclass monitored-credit-rating ()
((level :attributes (last-checked interval date-set))
(setf (slot-attribute cr 'level 'date-set) nil)
result))
"12/15/1990")
-
+
#+kmrtest-mop
(deftest :attrib.mop.3
(let ((mcr (make-instance 'monitored-credit-rating)))
(let ((result (slot-attribute mcr 'level 'date-set)))
(setf (slot-attribute mcr 'level 'date-set) nil)
result))
- "01/05/2002")
-
+ "01/05/2002")
+
#+kmrtest-mop
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; HTML/XML constants
-(defvar *standard-xml-header*
+(defvar *standard-xml-header*
#.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))
(defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
(defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor)
(let ((amp (case format
- (:html
- "&")
- ((:xml :ie-xml)
- "&"))))
- (concatenate 'string
+ (:html
+ "&")
+ ((:xml :ie-xml)
+ "&"))))
+ (concatenate 'string
base-dir page-name
(if vars
- (let ((first-var (first vars)))
- (concatenate 'string
- "?" (car first-var) "=" (cdr first-var)
- (mapcar-append-string
- #'(lambda (var)
- (when (and (car var) (cdr var))
- (concatenate 'string
- amp (string-downcase (car var)) "=" (cdr var))))
- (rest vars))))
- "")
+ (let ((first-var (first vars)))
+ (concatenate 'string
+ "?" (car first-var) "=" (cdr first-var)
+ (mapcar-append-string
+ #'(lambda (var)
+ (when (and (car var) (cdr var))
+ (concatenate 'string
+ amp (string-downcase (car var)) "=" (cdr var))))
+ (rest vars))))
+ "")
(if anchor
- (concatenate 'string "#" anchor)
- ""))))
+ (concatenate 'string "#" anchor)
+ ""))))
(defun decode-uri-query-string (s)
"Decode a URI query string field"
(declare (simple-string s)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((old-len (length s))
- (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%)))))
- (new (make-string new-len))
- (p-old 0)
- (p-new 0 (1+ p-new)))
+ (new-len (- old-len (* 2 (the fixnum (count-string-char s #\%)))))
+ (new (make-string new-len))
+ (p-old 0)
+ (p-new 0 (1+ p-new)))
((= p-new new-len) new)
(declare (simple-string new)
- (fixnum p-old p-new old-len new-len))
- (let ((c (schar s p-old)))
- (when (char= c #\+)
- (setq c #\space))
- (case c
- (#\%
- (unless (>= old-len (+ p-old 3))
- (error "#\% not followed by enough characters"))
- (setf (schar new p-new)
- (code-char
- (parse-integer (subseq s (1+ p-old) (+ p-old 3))
- :radix 16)))
- (incf p-old 3))
- (t
- (setf (schar new p-new) c)
- (incf p-old))))))
+ (fixnum p-old p-new old-len new-len))
+ (let ((c (schar s p-old)))
+ (when (char= c #\+)
+ (setq c #\space))
+ (case c
+ (#\%
+ (unless (>= old-len (+ p-old 3))
+ (error "#\% not followed by enough characters"))
+ (setf (schar new p-new)
+ (code-char
+ (parse-integer (subseq s (1+ p-old) (+ p-old 3))
+ :radix 16)))
+ (incf p-old 3))
+ (t
+ (setf (schar new p-new) c)
+ (incf p-old))))))
(defun split-uri-query-string (s)
(mapcar
(lambda (pair)
(let ((pos (position #\= pair)))
(when pos
- (cons (subseq pair 0 pos)
- (when (> (length pair) pos)
- (decode-uri-query-string (subseq pair (1+ pos))))))))
+ (cons (subseq pair 0 pos)
+ (when (> (length pair) pos)
+ (decode-uri-query-string (subseq pair (1+ pos))))))))
(delimited-string-to-list s #\&)))
(defun find-start-tag (tag taglen xmlstr start end)
"Searches for the start of a tag in an xmlstring. Returns STARTPOS ATTRIBUTE-LIST)"
(declare (simple-string tag xmlstr)
- (fixnum taglen start end)
- (optimize (speed 3) (safety 0) (space 0)))
+ (fixnum taglen start end)
+ (optimize (speed 3) (safety 0) (space 0)))
(do* ((search-str (concatenate 'string "<" tag))
- (search-len (1+ taglen))
- (bracketpos (fast-string-search search-str xmlstr search-len start end)
- (fast-string-search search-str xmlstr search-len start end)))
+ (search-len (1+ taglen))
+ (bracketpos (fast-string-search search-str xmlstr search-len start end)
+ (fast-string-search search-str xmlstr search-len start end)))
((null bracketpos) nil)
(let* ((endtag (+ bracketpos 1 taglen))
- (char-after-tag (schar xmlstr endtag)))
+ (char-after-tag (schar xmlstr endtag)))
(when (or (char= #\> char-after-tag)
- (char= #\space char-after-tag))
- (if (char= #\> char-after-tag)
- (return-from find-start-tag (values (1+ endtag) nil))
- (let ((endbrack (position-char #\> xmlstr (1+ endtag) end)))
- (if endbrack
- (return-from find-start-tag
- (values (1+ endbrack)
- (string-to-list-skip-delimiter
- (subseq xmlstr endtag endbrack))))
- (values nil nil)))))
+ (char= #\space char-after-tag))
+ (if (char= #\> char-after-tag)
+ (return-from find-start-tag (values (1+ endtag) nil))
+ (let ((endbrack (position-char #\> xmlstr (1+ endtag) end)))
+ (if endbrack
+ (return-from find-start-tag
+ (values (1+ endbrack)
+ (string-to-list-skip-delimiter
+ (subseq xmlstr endtag endbrack))))
+ (values nil nil)))))
(setq start endtag))))
(fast-string-search
(concatenate 'string "</" tag ">") xmlstr
(+ taglen 3) start end))
-
+
(defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
- (end-xmlstr (length xmlstr)))
+ (end-xmlstr (length xmlstr)))
"Returns three values: the start and end positions of contents between
the xml tags and the position following the close of the end tag."
(let* ((taglen (length tag)))
(multiple-value-bind (start attributes)
- (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
+ (find-start-tag tag taglen xmlstr start-xmlstr end-xmlstr)
(unless start
- (return-from positions-xml-tag-contents (values nil nil nil nil)))
+ (return-from positions-xml-tag-contents (values nil nil nil nil)))
(let ((end (find-end-tag tag taglen xmlstr start end-xmlstr)))
- (unless end
- (return-from positions-xml-tag-contents (values nil nil nil nil)))
- (values start end (+ end taglen 3) attributes)))))
+ (unless end
+ (return-from positions-xml-tag-contents (values nil nil nil nil)))
+ (values start end (+ end taglen 3) attributes)))))
(defun xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
- (end-xmlstr (length xmlstr)))
- "Returns two values: the string between XML start and end tag
+ (end-xmlstr (length xmlstr)))
+ "Returns two values: the string between XML start and end tag
and position of character following end tag."
- (multiple-value-bind
- (startpos endpos nextpos attributes)
+ (multiple-value-bind
+ (startpos endpos nextpos attributes)
(positions-xml-tag-contents tag xmlstr start-xmlstr end-xmlstr)
(if (and startpos endpos)
- (values (subseq xmlstr startpos endpos) nextpos attributes)
+ (values (subseq xmlstr startpos endpos) nextpos attributes)
(values nil nil nil))))
(defun cdata-string (str)
(declare (fixnum i len))
(let ((c (schar str i)))
(case c
- (#\< (write-string "<" s))
- (#\& (write-string "&" s))
- (t (write-char c s))))))
+ (#\< (write-string "<" s))
+ (#\& (write-string "&" s))
+ (t (write-char c s))))))
(defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
(format stream "<?xml version=\"~A\"~A~A ?>~%"
- version
- (if encoding
- (format nil " encoding=\"~A\"" encoding)
- ""
- )
- (if standalone
- (format nil " standalone=\"~A\"" standalone)
- "")))
+ version
+ (if encoding
+ (format nil " encoding=\"~A\"" encoding)
+ ""
+ )
+ (if standalone
+ (format nil " standalone=\"~A\"" standalone)
+ "")))
(defun doctype-stream (stream top-element availability registered organization type
- label language url entities)
+ label language url entities)
(format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element
- availability (if registered "+" "-") organization type label language)
-
+ availability (if registered "+" "-") organization type label language)
+
(when url
(write-char #\space stream)
(write-char #\" stream)
(write-string url stream)
(write-char #\" stream))
-
+
(when entities
(format stream " [~%~A~%]" entities))
(write-char #\newline stream))
(defun doctype-format (stream format &key top-element (availability "PUBLIC")
- (registered nil) organization (type "DTD") label
- (language "EN") url entities)
+ (registered nil) organization (type "DTD") label
+ (language "EN") url entities)
(case format
((:xhtml11 :xhtml)
(doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language
- (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
- entities))
+ (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
+ entities))
(:xhtml10-strict
(doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language
- (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
- entities))
+ (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
+ entities))
(:xhtml10-transitional
(doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language
- (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
- entities))
+ (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
+ entities))
(:xhtml-frameset
(doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language
- (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
- entities))
+ (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
+ entities))
(:html2
(doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
(:html3
(doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
((:docbook :docbook42)
(doctype-stream stream (if top-element top-element "book")
- availability registered "OASIS" type "Docbook XML 4.2" language
- (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
- entities))
+ availability registered "OASIS" type "Docbook XML 4.2" language
+ (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
+ entities))
(t
(unless top-element (warn "Missing top-element in doctype-format"))
(unless organization (warn "Missing organization in doctype-format"))
- (unless label (warn "Missing label in doctype-format"))
+ (unless label (warn "Missing label in doctype-format"))
(doctype-stream stream top-element availability registered organization type label language url
- entities))))
+ entities))))
(defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0")
- top-element (availability "PUBLIC") registered organization (type "DTD")
- label (language "EN") url)
+ top-element (availability "PUBLIC") registered organization (type "DTD")
+ label (language "EN") url)
(when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook)
(xml-declaration-stream stream :version version :encoding encoding :standalone standalone))
(unless (eq :xml format)
(doctype-format stream format :top-element top-element
- :availability availability :registered registered
- :organization organization :type type :label label :language language
- :url url :entities entities))
+ :availability availability :registered registered
+ :organization organization :type type :label label :language language
+ :url url :entities entities))
stream)
projects / kmrcl.git / commitdiff