From 03712fbb06acbb103602bae10f41aeae7fa05127 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 31 Aug 2007 18:04:31 +0000 Subject: [PATCH] r11859: Canonicalize whitespace --- attrib-class.lisp | 48 +++--- buff-input.lisp | 146 ++++++++--------- byte-stream.lisp | 172 ++++++++++---------- color.lisp | 40 ++--- datetime.lisp | 32 ++-- docbook.lisp | 70 ++++---- equal.lisp | 52 +++--- functions.lisp | 6 +- ifstar.lisp | 88 +++++----- impl.lisp | 106 ++++++------ io.lisp | 104 ++++++------ listener.lisp | 220 ++++++++++++------------- lists.lisp | 100 ++++++------ macros.lisp | 158 +++++++++--------- math.lisp | 66 ++++---- mop.lisp | 66 ++++---- os.lisp | 92 +++++------ processes.lisp | 2 +- random.lisp | 28 ++-- repl.lisp | 30 ++-- run-tests.lisp | 2 +- seqs.lisp | 6 +- sockets.lisp | 64 ++++---- strings.lisp | 400 +++++++++++++++++++++++----------------------- strmatch.lisp | 74 ++++----- symbols.lisp | 82 +++++----- tests.lisp | 46 +++--- web-utils.lisp | 84 +++++----- xml-utils.lisp | 126 +++++++-------- 29 files changed, 1255 insertions(+), 1255 deletions(-) diff --git a/attrib-class.lisp b/attrib-class.lisp index 12572a2..b102eca 100644 --- a/attrib-class.lisp +++ b/attrib-class.lisp @@ -32,18 +32,18 @@ on example from AMOP")) (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) @@ -65,24 +65,24 @@ on example from AMOP")) (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))) @@ -92,14 +92,14 @@ on example from AMOP")) (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))) diff --git a/buff-input.lisp b/buff-input.lisp index 4868ba1..0e98ad2 100644 --- a/buff-input.lisp +++ b/buff-input.lisp @@ -28,82 +28,82 @@ (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) @@ -112,35 +112,35 @@ (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)) @@ -151,22 +151,22 @@ (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)) diff --git a/byte-stream.lisp b/byte-stream.lisp index a375cdc..6e785fa 100644 --- a/byte-stream.lisp +++ b/byte-stream.lisp @@ -26,16 +26,16 @@ #+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) @@ -55,13 +55,13 @@ (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) @@ -69,7 +69,7 @@ (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) @@ -77,8 +77,8 @@ 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) @@ -86,7 +86,7 @@ clears buffer." 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)) @@ -97,107 +97,107 @@ Make-Byte-Array-Output-Stream since the last call to this function." (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 "#" 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." @@ -228,41 +228,41 @@ Make-Byte-Array-Output-Stream since the last call to this function." "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 diff --git a/color.lisp b/color.lisp index 77741f2..b18bd2d 100644 --- a/color.lisp +++ b/color.lisp @@ -32,7 +32,7 @@ ;; 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))) @@ -41,7 +41,7 @@ (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)) @@ -49,11 +49,11 @@ (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 @@ -78,7 +78,7 @@ (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) @@ -89,7 +89,7 @@ (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)) @@ -99,11 +99,11 @@ (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 @@ -131,7 +131,7 @@ (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)) @@ -153,7 +153,7 @@ (setq h (the fixnum (* 60 h))) (when (minusp h) (incf h 360))) - + (values h s v))) (defun rgb255->hsv255 (r g b) @@ -169,7 +169,7 @@ (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))) @@ -185,14 +185,14 @@ (+ 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)) @@ -215,7 +215,7 @@ (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)) @@ -232,7 +232,7 @@ (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." @@ -251,7 +251,7 @@ 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." @@ -274,7 +274,7 @@ t)))) - + (defun hue-difference (h1 h2) "Return difference between two hues around 360 degree circle" (cond @@ -292,8 +292,8 @@ (- (- 360 diff))) (t diff)))))) - - + + (defun hue-difference-fixnum (h1 h2) "Return difference between two hues around 360 degree circle" (cond @@ -312,4 +312,4 @@ (- (- 360 diff))) (t diff))))))) - + diff --git a/datetime.lisp b/datetime.lisp index 8357da0..b01bf33 100644 --- a/datetime.lisp +++ b/datetime.lisp @@ -26,15 +26,15 @@ (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) @@ -43,14 +43,14 @@ (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")) diff --git a/docbook.lisp b/docbook.lisp index 4f7447a..4be1529 100644 --- a/docbook.lisp +++ b/docbook.lisp @@ -34,11 +34,11 @@ (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)) @@ -61,50 +61,50 @@ (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 "" path path)))))))) - + (ignore-errors (open path)) + (make-string-input-stream + (let ((*print-circle* nil)) + (format nil "" 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)) diff --git a/equal.lisp b/equal.lisp index abc8e39..2b063b9 100644 --- a/equal.lisp +++ b/equal.lisp @@ -23,19 +23,19 @@ (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 @@ -62,7 +62,7 @@ (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) @@ -71,9 +71,9 @@ (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))) @@ -83,14 +83,14 @@ (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) @@ -106,17 +106,17 @@ "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))) @@ -129,10 +129,10 @@ Allegro implementation-dependent features." (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)))))) diff --git a/functions.lisp b/functions.lisp index 80f2221..9b4f6ed 100644 --- a/functions.lisp +++ b/functions.lisp @@ -25,7 +25,7 @@ (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)))) @@ -35,7 +35,7 @@ `(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))) @@ -46,7 +46,7 @@ (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)) diff --git a/ifstar.lisp b/ifstar.lisp index b0c85cd..62e3bc7 100644 --- a/ifstar.lisp +++ b/ifstar.lisp @@ -10,52 +10,52 @@ (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))))) diff --git a/impl.lisp b/impl.lisp index 7862ca5..52193ab 100644 --- a/impl.lisp +++ b/impl.lisp @@ -20,53 +20,53 @@ (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))) @@ -81,16 +81,16 @@ (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)))) @@ -116,12 +116,12 @@ ) (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 @@ -133,16 +133,16 @@ (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))))) diff --git a/io.lisp b/io.lisp index 8f38e0e..851c371 100644 --- a/io.lisp +++ b/io.lisp @@ -23,7 +23,7 @@ (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) @@ -31,12 +31,12 @@ (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) @@ -46,22 +46,22 @@ "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) @@ -70,7 +70,7 @@ (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) @@ -93,14 +93,14 @@ (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))) @@ -125,7 +125,7 @@ (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)))) @@ -191,28 +191,28 @@ (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) @@ -223,15 +223,15 @@ (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) @@ -241,19 +241,19 @@ (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) @@ -323,7 +323,7 @@ (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))) diff --git a/listener.lisp b/listener.lisp index 0b31cef..6c511cf 100644 --- a/listener.lisp +++ b/listener.lisp @@ -30,24 +30,24 @@ "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 () @@ -67,7 +67,7 @@ (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) @@ -98,11 +98,11 @@ (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) @@ -112,9 +112,9 @@ (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) @@ -131,7 +131,7 @@ ;; 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)) @@ -141,62 +141,62 @@ (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)) @@ -204,45 +204,45 @@ (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 @@ -251,38 +251,38 @@ (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))))))) + diff --git a/lists.lisp b/lists.lisp index dfa9d38..b51c41a 100644 --- a/lists.lisp +++ b/lists.lisp @@ -46,88 +46,88 @@ "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) @@ -152,16 +152,16 @@ (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)) @@ -186,18 +186,18 @@ (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)))))) diff --git a/macros.lisp b/macros.lisp index d0ba63c..eb2cef0 100644 --- a/macros.lisp +++ b/macros.lisp @@ -21,7 +21,7 @@ (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))) @@ -117,19 +117,19 @@ (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) @@ -143,7 +143,7 @@ (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) - syms) + syms) ,@body)) @@ -151,35 +151,35 @@ (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 @@ -187,88 +187,88 @@ 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 "")) diff --git a/math.lisp b/math.lisp index c03b27f..327de3f 100644 --- a/math.lisp +++ b/math.lisp @@ -22,7 +22,7 @@ (defun deriv (f dx) #'(lambda (x) (/ (- (funcall f (+ x dx)) (funcall f x)) - dx))) + dx))) (defun sin^ (x) (funcall (deriv #'sin 1d-8) x)) @@ -42,34 +42,34 @@ (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)))) @@ -81,21 +81,21 @@ (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) diff --git a/mop.lisp b/mop.lisp index f85912b..f6bd037 100644 --- a/mop.lisp +++ b/mop.lisp @@ -30,7 +30,7 @@ #+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*))) @@ -57,8 +57,8 @@ (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)) @@ -69,10 +69,10 @@ (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)) @@ -143,45 +143,45 @@ 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 diff --git a/os.lisp b/os.lisp index 5db6be7..7b7da44 100644 --- a/os.lisp +++ b/os.lisp @@ -20,11 +20,11 @@ returns (VALUES string-output error-output exit-status)" (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 @@ -35,11 +35,11 @@ returns (VALUES string-output error-output exit-status)" #+(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)) @@ -50,21 +50,21 @@ returns (VALUES string-output error-output exit-status)" #+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 @@ -75,17 +75,17 @@ returns (VALUES string-output error-output exit-status)" #+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") @@ -114,7 +114,7 @@ returns (VALUES output-string pid)" #+allegro (excl:run-shell-command command :input nil :output nil - :wait t) + :wait t) #+lispworks (system:call-system-showing-output @@ -124,15 +124,15 @@ returns (VALUES output-string pid)" :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") @@ -141,21 +141,21 @@ returns (VALUES output-string pid)" (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)))) @@ -170,10 +170,10 @@ returns (VALUES output-string pid)" #+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"))) ) diff --git a/processes.lisp b/processes.lisp index 70de5fb..b598639 100644 --- a/processes.lisp +++ b/processes.lisp @@ -69,7 +69,7 @@ #-(or allegro cmu sb-thread openmcl) `(progn ,@body) ) - + (defun process-sleep (n) #+allegro (mp:process-sleep n) #-allegro (sleep n)) diff --git a/random.lisp b/random.lisp index b9ac627..756cc5f 100644 --- a/random.lisp +++ b/random.lisp @@ -20,22 +20,22 @@ (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) diff --git a/repl.lisp b/repl.lisp index dc17304..6848b47 100644 --- a/repl.lisp +++ b/repl.lisp @@ -22,13 +22,13 @@ (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 @@ -53,9 +53,9 @@ (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 @@ -67,7 +67,7 @@ (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*)) @@ -75,15 +75,15 @@ (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))) @@ -93,4 +93,4 @@ (print-prompt *standard-output*) (let ((form (read *standard-input*))) (format *standard-output* "~&~S~%" (eval form))))) - + diff --git a/run-tests.lisp b/run-tests.lisp index bec0dba..607bf21 100644 --- a/run-tests.lisp +++ b/run-tests.lisp @@ -1,4 +1,4 @@ -(in-package #:cl-user) +(in-package #:cl-user) (defpackage #:run-tests (:use #:cl)) (in-package #:run-tests) diff --git a/seqs.lisp b/seqs.lisp index 302f5d5..4cc4659 100644 --- a/seqs.lisp +++ b/seqs.lisp @@ -23,6 +23,6 @@ "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)) diff --git a/sockets.lisp b/sockets.lisp index 41c751c..dc8965c 100644 --- a/sockets.lisp +++ b/sockets.lisp @@ -23,8 +23,8 @@ "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 @@ -37,13 +37,13 @@ setsockopt SO_REUSEADDR if :reuse is not nil" #+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)) @@ -52,7 +52,7 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (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") ) @@ -60,10 +60,10 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (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 ) @@ -84,11 +84,11 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (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))) @@ -111,7 +111,7 @@ setsockopt SO_REUSEADDR if :reuse is not nil" #+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") @@ -126,11 +126,11 @@ setsockopt SO_REUSEADDR if :reuse is not nil" "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)) @@ -138,16 +138,16 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (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) @@ -171,15 +171,15 @@ setsockopt SO_REUSEADDR if :reuse is not nil" "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 @@ -202,13 +202,13 @@ setsockopt SO_REUSEADDR if :reuse is not nil" (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))) diff --git a/strings.lisp b/strings.lisp index bc5f4bd..1178b5d 100644 --- a/strings.lisp +++ b/strings.lisp @@ -30,24 +30,24 @@ (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)) @@ -55,31 +55,31 @@ (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)))) @@ -94,10 +94,10 @@ (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) @@ -113,38 +113,38 @@ (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))))) @@ -154,8 +154,8 @@ (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))) @@ -179,46 +179,46 @@ (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" @@ -229,53 +229,53 @@ list of characters and replacement strings." (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) @@ -298,7 +298,7 @@ list of characters and replacement strings." (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)) @@ -316,15 +316,15 @@ Leading zeros are present. LEN must be an integer.") "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) @@ -334,55 +334,55 @@ Leading zeros are present." (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) @@ -392,8 +392,8 @@ Leading zeros are present." (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)) @@ -406,8 +406,8 @@ Leading zeros are present." "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)) @@ -433,15 +433,15 @@ for characters in a string" (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 @@ -452,48 +452,48 @@ for characters in a string" (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) @@ -516,8 +516,8 @@ for characters in a string" (: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 @@ -525,8 +525,8 @@ for characters in a string" (: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)) @@ -560,10 +560,10 @@ for characters in a string" (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))) @@ -573,11 +573,11 @@ for characters in a string" (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) @@ -594,9 +594,9 @@ for characters in a string" "...") ((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)) "..."))))) @@ -634,11 +634,11 @@ for characters in a string" (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) @@ -656,47 +656,47 @@ for characters in a 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))) diff --git a/strmatch.lisp b/strmatch.lisp index 6d7b89e..e48e230 100644 --- a/strmatch.lisp +++ b/strmatch.lisp @@ -23,38 +23,38 @@ "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)) @@ -62,19 +62,19 @@ S1 can be a string or a list or strings/conses" (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))) - - - + + + diff --git a/symbols.lisp b/symbols.lisp index 870426e..d14f4f2 100644 --- a/symbols.lisp +++ b/symbols.lisp @@ -25,22 +25,22 @@ (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 @@ -49,7 +49,7 @@ (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) @@ -70,7 +70,7 @@ (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) @@ -85,11 +85,11 @@ (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 @@ -99,46 +99,46 @@ (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) diff --git a/tests.lisp b/tests.lisp index b33befd..4cbc915 100644 --- a/tests.lisp +++ b/tests.lisp @@ -17,7 +17,7 @@ (defpackage #:kmrcl-tests (:use #:kmrcl #:cl #:rtest)) (in-package #:kmrcl-tests) - + (rem-all-tests) @@ -45,9 +45,9 @@ (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")) @@ -86,7 +86,7 @@ (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 @@ -119,9 +119,9 @@ (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)) @@ -213,7 +213,7 @@ (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)) @@ -236,7 +236,7 @@ (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)) @@ -261,14 +261,14 @@ (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) @@ -281,7 +281,7 @@ (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)))))))) @@ -290,7 +290,7 @@ (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) @@ -398,12 +398,12 @@ (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))) @@ -413,7 +413,7 @@ (unique-slot-values nil 'a) nil) -(deftest :nwp.1 +(deftest :nwp.1 (numbers-within-percentage 1. 1.1 9) nil) @@ -426,9 +426,9 @@ (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 @@ -445,7 +445,7 @@ (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)) @@ -453,7 +453,7 @@ #+lispworks (:optimize-slot-access nil) (:metaclass attributes-class)) - + #+kmrtest-mop (defclass monitored-credit-rating () ((level :attributes (last-checked interval date-set)) @@ -475,7 +475,7 @@ (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))) @@ -483,8 +483,8 @@ (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) diff --git a/web-utils.lisp b/web-utils.lisp index da7d6b7..ecd8565 100644 --- a/web-utils.lisp +++ b/web-utils.lisp @@ -21,7 +21,7 @@ ;;; HTML/XML constants -(defvar *standard-xml-header* +(defvar *standard-xml-header* #.(format nil "~%")) (defvar *standard-html-header* "") @@ -47,61 +47,61 @@ (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 #\&))) diff --git a/xml-utils.lisp b/xml-utils.lisp index 6ef3bb9..860d675 100644 --- a/xml-utils.lisp +++ b/xml-utils.lisp @@ -24,26 +24,26 @@ (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)))) @@ -51,31 +51,31 @@ (fast-string-search (concatenate 'string "") 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) @@ -89,32 +89,32 @@ and position of character following end tag." (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 "~%" - 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 "