r11859: Canonicalize whitespace

diff --git a/attrib-class.lisp b/attrib-class.lisp
index 12572a290e458f671d0ee2553589abbf32687349..b102eca9300d33edb1e92ac8ce42dfc507b50cd6 100644 (file)
--- 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
 
 (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)
 
 (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)
 
 ;; 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)
   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))
 
 (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
 
     (cons (make-instance

-          'attributes-esd
-          :name 'all-attributes
-          :initform `',alist
-          :initfunction #'(lambda () alist)
-          :allocation :instance
-          :documentation "Attribute bucket"
-          :type t
-          )
-         normal-slots)))
-  
+           'attributes-esd
+           :name 'all-attributes
+           :initform `',alist
+           :initfunction #'(lambda () alist)
+           :allocation :instance
+           :documentation "Attribute bucket"
+           :type t
+           )
+          normal-slots)))
+

 (defun slot-attribute (instance slot-name attribute)
   (cdr (slot-attribute-bucket instance slot-name attribute)))
 
 (defun slot-attribute (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))
 
 (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."
     (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
     (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)))
 
 
       attr-bucket)))
 
 

diff --git a/buff-input.lisp b/buff-input.lisp
index 4868ba1690e293a9ab036b85159c5c11228239fd..0e98ad2ca3c3459c5442e180df2e4d855d425df1 100644 (file)
--- a/buff-input.lisp
+++ b/buff-input.lisp
@@ -28,82 +28,82 @@
 (defconstant +newline+ #\Newline)
 
 (declaim (type character +eof-char+ +field-delim+ +newline+)
 (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
 
 
 ;; 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+)
   (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)
   "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)
   (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)
     (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
 
 ;; 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))
 
   (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))
   (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)
     (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+)
     (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)
   "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)
        (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)
     (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))
 
 (defun bfield (fields i)
   (if (>= i (field-buffers-nfields fields))


@@ -151,22 +151,22 @@
 
 (defconstant +max-line+ 20000)
 (let ((linebuffer (make-array +max-line+
 
 (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)
   (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+)
       (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))
          ((>= pos +max-line+)
           (warn "Line overflow")
           (setf done t))

diff --git a/byte-stream.lisp b/byte-stream.lisp
index a375cdcd6f5ca6ab3860d95dcdecd20f089d8470..6e785fa2fa90d883ce1aca8ba3f784151f4fdf44 100644 (file)
--- 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
 #+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
     (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)
                        (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))
 
 (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))
     (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)
     (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)
   (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)
     (: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))
 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)
       (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))
 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))
 
     (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"))
 (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"))
     (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
 #+(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))
 
   (byte-array nil :type vector)
   (current nil)
   (end nil))
 

-  
+

 (defun %print-byte-array-input-stream (s stream d)
   (declare (ignore s d))
   (write-string "#<Byte-Array-Input Stream>" stream))
 
 (defun byte-array-inch (stream eof-errorp eof-value)
   (let ((byte-array (byte-array-input-stream-byte-array stream))
 (defun %print-byte-array-input-stream (s stream d)
   (declare (ignore s d))
   (write-string "#<Byte-Array-Input Stream>" stream))
 
 (defun byte-array-inch (stream eof-errorp eof-value)
   (let ((byte-array (byte-array-input-stream-byte-array stream))

-       (index (byte-array-input-stream-current stream)))
+        (index (byte-array-input-stream-current stream)))

     (cond ((= index (byte-array-input-stream-end stream))
     (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))
 
 (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))
     (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))
 
 (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)
     (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)
       #+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)
       #+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)
     (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
 
 (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))
     (: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)))
     (: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."
 (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."
     "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)))
       (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))
   (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))
       (replace result (slot-value stream 'excl::buffer))
       result))

-  
+

   (defmethod excl:device-extend ((stream extendable-buffer-output-stream)
   (defmethod excl:device-extend ((stream extendable-buffer-output-stream)

-                                need action)
+                                 need action)

     (declare (ignore action))
     (let* ((len (file-position stream))
     (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)
       (declare (fixnum len)

-              (optimize (speed 3) (safety 0)))
+               (optimize (speed 3) (safety 0)))

       (dotimes (i len)
       (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)
       (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)
 )
 
 #+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
 
     (excl:make-buffer-input-stream buffer start end :octets))
   ) ;; progn
 

diff --git a/color.lisp b/color.lisp
index 77741f2afbded1864452ed404f4aeb2b512e9ffe..b18bd2d00df115ff22f15408165e38426e0549b1 100644 (file)
--- a/color.lisp
+++ b/color.lisp
@@ -32,7 +32,7 @@
 ;; point in the plane. The disks on the right show this for various
 ;; values.
 
 ;; 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)))
   (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))
          (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))
   (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)
             (q (* v (- 1 (* s h-frac))))
             (t_ (* v (- 1 (* s (- 1 h-frac)))))
             r g b)

-        
+

         (cond
          ((zerop h-int)
           (setf r v
         (cond
          ((zerop h-int)
           (setf r v

-                g t_  
+                g t_

                 b p))
          ((= 1 h-int)
           (setf r q
                 b p))
          ((= 1 h-int)
           (setf r q


@@ -78,7 +78,7 @@
         (values r g b)))))
 
 
         (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)
   (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))
       (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))
     (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)
                (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
           (cond
            ((zerop h-int)
             (setf r v

-                  g t_  
+                  g t_

                   b p))
            ((= 1 h-int)
             (setf r q
                   b p))
            ((= 1 h-int)
             (setf r q


@@ -131,7 +131,7 @@
 
 (defun rgb->hsv (r g b)
   (declare (optimize (speed 3) (safety 0)))
 
 (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))
   (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)))
       (setq h (the fixnum (* 60 h)))
       (when (minusp h)
         (incf h 360)))

-    
+

     (values h s v)))
 
 (defun rgb255->hsv255 (r g b)
     (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))
          (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)))
 
     (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)))
                      (+ 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)
     (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))
             ((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))
            (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))
             ((and (null a) (null b))
              t)
             ((or (null a) (null b))


@@ -232,7 +232,7 @@
       (when (~= h1 h2) (~= s1 s2) (~= v1 v2)
         t)))))
 
       (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."
                        (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))))
 
 
       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."
                           &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))))
 
 
       t))))
 
 

-   
+

 (defun hue-difference (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond
 (defun hue-difference (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond


@@ -292,8 +292,8 @@
         (- (- 360 diff)))
        (t
         diff))))))
         (- (- 360 diff)))
        (t
         diff))))))

- 
-  
+
+

 (defun hue-difference-fixnum (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond
 (defun hue-difference-fixnum (h1 h2)
   "Return difference between two hues around 360 degree circle"
   (cond


@@ -312,4 +312,4 @@
           (- (- 360 diff)))
          (t
           diff)))))))
           (- (- 360 diff)))
          (t
           diff)))))))

- 
+

diff --git a/datetime.lisp b/datetime.lisp
index 8357da030b95b5e028d80711e072e6fb83cfdc30..b01bf33d323a8b0cb9c601a62a80609244f8a9de 100644 (file)
--- 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"
     (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 "~A" yr)

-           (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))
+            (format nil "~2,'0D:~2,'0D:~2,'0D" hr min sec))))

 
 (defun pretty-date-ut (&optional (tm (get-universal-time)))
   (multiple-value-bind (sec min hr dy mn yr) (decode-universal-time tm)
 
 (defun 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)
 (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"))
 
 (defun print-seconds (secs)
   (print-float-units secs "sec"))

diff --git a/docbook.lisp b/docbook.lisp
index 4f7447a695c27d94bff9e7d10e85a9493a24bb4b..4be1529f00d293922e7d08cd336b5bf6de29972b 100644 (file)
--- a/docbook.lisp
+++ b/docbook.lisp
@@ -34,11 +34,11 @@
   (let ((%name (gensym)))
     `(let ((,%name ,name))
       (with-open-file (stream ,%name :direction :output
   (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))))
 
       (values))))
 

-#+allegro 
+#+allegro

 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require 'pxml)
   (require 'uri))
 (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)
   (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)
     nil)
    (t
     (let ((path (net.uri:uri-path var)))
       (if (probe-file path)

-         (ignore-errors (open path))
-       (make-string-input-stream 
-        (let ((*print-circle* nil))
-          (format nil "<!ENTITY ~A '~A'>" path path))))))))
-   
+          (ignore-errors (open path))
+        (make-string-input-stream
+         (let ((*print-circle* nil))
+           (format nil "<!ENTITY ~A '~A'>" path path))))))))
+

 #+allegro
 (defun xml-file->sexp-file (file &key (preprocess nil))
   (let* ((path (etypecase file
 #+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
     (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)
       (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
 
     (with-open-file (output new-path :direction :output

-                    :if-exists :supersede)
+                     :if-exists :supersede)

       (let ((filtered (kmrcl:remove-from-tree-if #'is-whitespace-string
       (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))
 
 
   (values))
 
 

diff --git a/equal.lisp b/equal.lisp
index abc8e399f4f3ce1ebd137da1cf9a936d7f8ce73c..2b063b99caa675a446c37738cb698900e879b8a1 100644 (file)
--- 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
 (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))))
     (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))
       (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
       (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))
     (dotimes (i (array-total-size obj1))
       (unless (generalized-equal (aref obj1 i) (aref obj2 i))

-       (return-from test nil)))
+        (return-from test nil)))

     (return-from test t)))
 
 (defun generalized-equal-hash-table (obj1 obj2)
     (return-from test t)))
 
 (defun generalized-equal-hash-table (obj1 obj2)


@@ -71,9 +71,9 @@
       (return-from test nil))
     (maphash
      #'(lambda (k v)
       (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)))
 
      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))
     (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
     (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)
   #+(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
   "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
   #+(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
   #+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%))
   #+(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)))
   #-(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
   (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
       (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 80f22211aa19474edc12e43f0530fce76b854dd6..9b4f6ed876bee6115b4b3a3b3d5a9c693759453c 100644 (file)
--- a/functions.lisp
+++ b/functions.lisp
@@ -25,7 +25,7 @@
         (multiple-value-bind (val foundp) (gethash args cache)
           (if foundp
               val
         (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))))
 
 (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)
   `(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)))
                        (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)
       (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))
                     :from-end t
                     :initial-value (apply fn1 args))))
       #'identity))

diff --git a/ifstar.lisp b/ifstar.lisp
index b0c85cd1a1c411f6dee26d373a494f7621647614..62e3bc7f59a9867067b1f66b8f9f00ca2cbcb827 100644 (file)
--- a/ifstar.lisp
+++ b/ifstar.lisp
@@ -10,52 +10,52 @@
 
 (defmacro if* (&rest args)
    (do ((xx (reverse args) (cdr xx))
 
 (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)
        ((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))
        (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 ((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 7862ca5cec71b0e205babbf368202d304a4f7316..52193ab12880360d0e638fa16c7b266c2327b7f6 100644 (file)
--- a/impl.lisp
+++ b/impl.lisp
@@ -20,53 +20,53 @@
 
 (defun canonicalize-directory-name (filename)
   (flet ((un-unspecific (value)
 
 (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))
     (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
       (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))
 
 
 (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
     (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)
 
 (defun cwd (&optional dir)
   "Change directory and set default pathname"
   (cond
    ((not (null dir))
     (when (and (typep dir 'logical-pathname)

-              (translate-logical-pathname dir))
+               (translate-logical-pathname dir))

       (setq dir (translate-logical-pathname dir)))
     (when (stringp dir)
       (setq dir (parse-namestring dir)))
       (setq 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
     (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)
       (when (stringp dir)

-       (setq dir (parse-namestring dir)))
+        (setq dir (parse-namestring dir)))

       dir))))
 
 
       dir))))
 
 


@@ -116,12 +116,12 @@
   )
 
 (defun copy-file (from to &key link overwrite preserve-symbolic-links
   )
 
 (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
   #+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
   #-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)
      (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)
        (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
     (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)))))
        (run-shell-command cmd)))))

diff --git a/io.lisp b/io.lisp
index 8f38e0e6ca5fac9c9c016528d90b4a41990a5b72..851c3718eae62f98c828b812fefbc691c70db937 100644 (file)
--- 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)
   (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)
                    (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)
 
 (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)
 (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))
   "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)
       (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)))
       usb8)))

-      
+

 
 (defun read-stream-to-strings (in)
   (let ((lines '())
 
 (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)))
       (push line lines))
     (nreverse lines)))

-    
+

 (defun read-file-to-strings (file)
   "Opens a reads a file. Returns the contents as a list of strings"
   (with-open-file (in file :direction :input)
 (defun 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
 (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)
       (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 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*))
 
 (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)))
 
 
   (dolist (r rows) (format ostrm "~{~A~^ ~}~%" r)))
 
 


@@ -125,7 +125,7 @@
   (setf (bref b (incf (buf-end b))) x))
 
 (defun buf-pop (b)
   (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))))
     (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")
 
 (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))
   )
 
 
 (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
     (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)
 
 
 (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))
 
      (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
   (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)
 
 (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
 (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
        (if ,zone

-          (with-utime-decoding (,utime ,zone)
-            ,@body)
-        (with-utime-decoding (,utime)
-          ,@body)))))
+           (with-utime-decoding (,utime ,zone)
+             ,@body)
+         (with-utime-decoding (,utime)
+           ,@body)))))

 
 
 (defun write-utime-hms (utime &key utc-offset stream)
 
 
 (defun 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)))
 
 (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)))
 
       ((zerop pos))
     (write-sequence buf out :end pos)))
 

diff --git a/listener.lisp b/listener.lisp
index 0b31cefd745d2eb174890d541bbb4505d9a3da4a..6c511cf9260b08976e2658af04b0ce106f7689f9 100644 (file)
--- a/listener.lisp
+++ b/listener.lisp
@@ -30,24 +30,24 @@
     "List of active listeners")
 
 (defclass listener ()
     "List of active listeners")
 
 (defclass listener ()

-  ((port :initarg :port :accessor port) 
+  ((port :initarg :port :accessor port)

    (function :initarg :function :accessor listener-function
    (function :initarg :function :accessor listener-function

-            :initform nil)
+             :initform nil)

    (function-args :initarg :function-args :accessor function-args
    (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
    (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
    (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
    (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 ()
    (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)))))
 (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)
 ;; High-level API
 
 (defun init/listener (listener state)


@@ -98,11 +98,11 @@
 (defun listener-startup (listener)
   (handler-case
       (progn
 (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)
     (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)
       (decf *listener-count*)
       nil)
     (:no-error (res)


@@ -112,9 +112,9 @@
 (defun listener-shutdown (listener)
   (dolist (worker (workers listener))
     (when (and (typep worker 'worker)
 (defun listener-shutdown (listener)
   (dolist (worker (workers listener))
     (when (and (typep worker 'worker)

-              (connection worker))
+               (connection worker))

       (errorset (close-active-socket
       (errorset (close-active-socket

-                (connection worker)) nil)
+                 (connection worker)) nil)

       (setf (connection worker) nil))
     (when (process worker)
       (errorset (destroy-process (process 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)
 ;; 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))
 
 (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)
   (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
   #-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)
     (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 ()
   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)
     (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)
 
 (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))
       (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
 
 (defun start-socket-server (listener)
   (unwind-protect

-      (loop 
+      (loop

        (let ((connection (accept-and-check-tcp-connection listener)))
        (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
     (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)
     (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
 
 
 ;; Fixed pool of workers
 


@@ -251,38 +251,38 @@
     (let ((name (next-worker-name (base-name listener))))
       (push
        (make-instance 'fixed-worker
     (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)
        (workers listener)))))
 
 
 (defun fixed-worker (name listener)

-  (loop 
+  (loop

    (let ((connection (accept-and-check-tcp-connection listener)))
      (when connection
        (flet ((do-work ()
    (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 dfa9d386d25d5c9f100c317372442b3ef15adcff..b51c41a5072c396e1bf0a3f7ead8d292d14226be 100644 (file)
--- 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)
   "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))
     (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))
       (cond
        ((and car-strip (atom (cadr tree)) (null cdr-strip))

-       (list car-strip))
+        (list car-strip))

        ((and car-strip cdr-strip)
        ((and car-strip cdr-strip)

-       (cons car-strip cdr-strip))
+        (cons car-strip cdr-strip))

        (car-strip
        (car-strip

-       car-strip)
+        car-strip)

        (cdr-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))
 
 (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))
       (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)
 
 (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)
 
 ;;; 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
 
 (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)
 
 (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)
   (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 ""))
        ""))
 
 
 (defun mapcar-append-string (func v &optional (accum ""))

-  "Concatenate results of mapcar lambda calls"  
+  "Concatenate results of mapcar lambda calls"

   (aif (car v)
   (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)
        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))
   (let ((a (car la))

-       (b (car lb)))
+        (b (car lb)))

     (if (and a b)
       (concatenate 'string (funcall func a b)
     (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 ""))
 (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))
   (let ((a (car la))

-       (b (car lb)))
+        (b (car lb)))

     (if (and a b)
     (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)
       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-"))
 (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))
     `(let ((,elem (assoc ,akey ,alist :test ,test :key ,key))

-          (,val ,value))
+           (,val ,value))

        (cond
        (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))
        ,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
   (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)))
 
 
 (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 d0ba63c629d8e698cc011c6072ce82c20e7d604d..eb2cef0d6decff1728ed820450c18017a084eae2 100644 (file)
--- 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-when ((var test-form) &body body)
   `(let ((,var ,test-form))
       (when ,var ,@body)))

-  
+

 (defmacro let-if ((var test-form) if-true &optional if-false)
   `(let ((,var ,test-form))
       (if ,var ,if-true ,if-false)))
 (defmacro 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))
 
 (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)
     `(let ((,strm ,stream)

-          (,eof ',eof-value))
+           (,eof ',eof-value))

       (do ((,var (read-line ,strm nil ,eof) (read-line ,strm nil ,eof)))
       (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)
 
 (defmacro with-each-file-line ((var file) &body body)
   (let ((stream (gensym)))
     `(with-open-file (,stream ,file :direction :input)
       (with-each-stream-line (,var ,stream)

-       ,@body))))
+        ,@body))))

 
 
 (defmacro in (obj &rest choices)
 
 
 (defmacro in (obj &rest choices)


@@ -143,7 +143,7 @@
 
 (defmacro with-gensyms (syms &body body)
   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))
 
 (defmacro with-gensyms (syms &body body)
   `(let ,(mapcar #'(lambda (s) `(,s (gensym)))

-         syms)
+          syms)

      ,@body))
 
 
      ,@body))
 
 


@@ -151,35 +151,35 @@
   (let ((t1 (gensym)))
     `(let ((,t1 (get-internal-real-time)))
        (values
   (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))
 (defmacro time-iterations (n &body body)
   (let ((i (gensym))

-       (count (gensym)))
+        (count (gensym)))

     `(progn
        (let ((,count ,n))
     `(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)
 
 (defmacro mv-bind (vars form &body body)

-  `(multiple-value-bind ,vars ,form 
+  `(multiple-value-bind ,vars ,form

      ,@body))
 
 ;; From USENET
      ,@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
   "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-)))
       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
     `(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"))
       (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))
     `(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"))
 
 (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))
     `(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
 
 (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))
 
 (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)
      (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)
      (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 ""))
      ,@(when doc (list doc))))
 
 (defmacro defvar-unbound (sym &optional (doc ""))

diff --git a/math.lisp b/math.lisp
index c03b27f5d54238e5cfc1a48df0e43d7e3d3d5f8c..327de3f6f5b87cea8c2422d735d62dceb8492188 100644 (file)
--- a/math.lisp
+++ b/math.lisp
@@ -22,7 +22,7 @@
 (defun deriv (f dx)
   #'(lambda (x)
       (/ (- (funcall f (+ x dx)) (funcall f x))
 (defun deriv (f dx)
   #'(lambda (x)
       (/ (- (funcall f (+ x dx)) (funcall f x))

-        dx)))
+         dx)))

 
 (defun sin^ (x)
     (funcall (deriv #'sin 1d-8) x))
 
 (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))
   (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)
     (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)
       (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
       (unless min

-       (setq min found-min))
+        (setq min found-min))

       (unless max
       (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 ((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)))
     (values bins min max)))

-             
+

 
 (defun fixnum-width ()
   (nth-value 0 (truncate (+ (/ (log (1+ most-positive-fixnum)) (log 2)) .5))))
 
 (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)
   (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 '-)
       (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)
 
 (defun sinc (x)
   (if (zerop x)

diff --git a/mop.lisp b/mop.lisp
index f85912b88e7c97410544a356c054dbc03d5a0beb..f6bd037d1fb8cba81ba694c2ed969fd2ebd45723 100644 (file)
--- 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)
 #+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*)))
 
       (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)
 (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))
     (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)
 (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))
     (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)   ))
      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
 (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*)))
   #+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*)))
   #+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
   (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*))
     (pushnew :kmr-normal-cesd cl:*features*))

-  
+

   (when (>= (length (generic-function-lambda-list
   (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
     (pushnew :kmr-normal-dsdc cl:*features*))
 
   )  ;; eval-when

diff --git a/os.lisp b/os.lisp
index 5db6be7895700eee4ae2c86f8dfc92bb709ee73e..7b7da44e5fa23adac19e668e0010fff7f192dfea 100644 (file)
--- 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
   (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
       (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
 
     #+(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))
 
       (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)
 
     #+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
       (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
 
     #+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
 
     #+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
       (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")
 
     #-(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
 
     #+allegro
     (excl:run-shell-command command :input nil :output nil

-                           :wait t)
+                            :wait t)

 
     #+lispworks
     (system:call-system-showing-output
 
     #+lispworks
     (system:call-system-showing-output


@@ -124,15 +124,15 @@ returns (VALUES output-string pid)"
      :prefix ""
      :output-stream nil)
 
      :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
     (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")
 
     #-(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
 
 (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
   #-(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))))
 
 (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))))
     #-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)
   #+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 70de5fb0178859c4e7331d3bc27a18f810badd5b..b598639f3b1b6a92c802e788fd0d43cc1f94770c 100644 (file)
--- a/processes.lisp
+++ b/processes.lisp
@@ -69,7 +69,7 @@
   #-(or allegro cmu sb-thread openmcl)
   `(progn ,@body)
   )
   #-(or allegro cmu sb-thread openmcl)
   `(progn ,@body)
   )

-  
+

 (defun process-sleep (n)
   #+allegro (mp:process-sleep n)
   #-allegro (sleep n))
 (defun process-sleep (n)
   #+allegro (mp:process-sleep n)
   #-allegro (sleep n))

diff --git a/random.lisp b/random.lisp
index b9ac6272d154579bc79977c449f48bc9e47cd383..756cc5f38d902c6a6926587595cd2c0f6dc18b11 100644 (file)
--- a/random.lisp
+++ b/random.lisp
@@ -20,22 +20,22 @@
 
 (defun seed-random-generator ()
   "Evaluate a random number of items"
 
 (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)
     (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)
 
 
 (defmacro random-choice (&rest exprs)

diff --git a/repl.lisp b/repl.lisp
index dc173040695c12489ba513db9b265eb49d2f04bc..6848b47497f12f0af5d2cdf44a176b3e11272989 100644 (file)
--- a/repl.lisp
+++ b/repl.lisp
@@ -22,13 +22,13 @@
 
 (defclass repl ()
   ((listener :initarg :listener :accessor listener
 
 (defclass repl ()
   ((listener :initarg :listener :accessor listener

-            :initform nil)))
+             :initform nil)))

 
 (defun make-repl (&key (port +default-repl-server-port+)
 
 (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
     :port port

-    :base-name "repl"                   
+    :base-name "repl"

     :function 'repl-worker
     :function-args (list user-checker announce)
     :format :text
     :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)
       (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
   #+allegro
   (tpl::start-interactive-top-level
    conn


@@ -67,7 +67,7 @@
 
 (defun read-socket-line (stream)
   (string-right-trim-one-char #\return
 
 (defun read-socket-line (stream)
   (string-right-trim-one-char #\return

-                             (read-line stream nil nil)))
+                              (read-line stream nil nil)))

 
 (defun print-prompt (stream)
   (format stream "~&~A> " (package-name *package*))
 
 (defun print-prompt (stream)
   (format stream "~&~A> " (package-name *package*))


@@ -75,15 +75,15 @@
 
 (defun repl-on-stream (stream)
   (let ((*standard-input* stream)
 
 (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)
     #|
     #+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)))
     #-sbcl
     |#
     (%repl)))


@@ -93,4 +93,4 @@
     (print-prompt *standard-output*)
     (let ((form (read *standard-input*)))
       (format *standard-output* "~&~S~%" (eval form)))))
     (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 bec0dbaca7f863fe72601dd481a98eb8b9bd3900..607bf2179dbc8aa62fee7ec23da73a3b5912bad0 100644 (file)
--- 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)
 
 (defpackage #:run-tests (:use #:cl))
 (in-package #:run-tests)
 

diff --git a/seqs.lisp b/seqs.lisp
index 302f5d5d04c62448af26475837bf7583f752350d..4cc4659e9ba7abff3f7c3a4168ff31e407eba790 100644 (file)
--- 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)
   "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 41c751ccd496ad8934baa72ad3aa8721328af558..dc8965cc4e91374cf84f5f376ce478a8ee55183a 100644 (file)
--- 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
   "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
     (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
   #+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))
   #+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
   (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")
   )
   #-(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
 (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
   #+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
   )
   #-(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
       (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
     (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)))
        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
   #+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")
   #+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)))
   "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
     (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))
       (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 #\.)))
   (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 #\.)))
     (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)
 
 #+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
   "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
     (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
     (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"
   (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
 
 (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)))
   #+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 bc5f4bde8c178e0ae257d025dc12509bdfa9da1f..1178b5d5426e24c727f804de200625d6d3e4ed02 100644 (file)
--- a/strings.lisp
+++ b/strings.lisp
@@ -30,24 +30,24 @@
 
 (defun count-string-words (str)
   (declare (simple-string str)
 
 (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)
   (let ((n-words 0)

-       (in-word nil))
+        (in-word nil))

     (declare (fixnum n-words))
     (do* ((len (length str))
     (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))
       (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))
 
 ;; 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))
   (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))
 
 (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)
   (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))
   "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))
   (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)
        ((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)
     (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))))
 
     (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
   (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)
       (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))
 (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
     (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
       (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)
       (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)
 
 (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)
 
 (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)))))
     (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
   (zerop (length str)))
 
 (defvar *whitespace-chars* '(#\space #\tab #\return #\linefeed

-                            #+allegro #\%space
-                            #+lispworks #\No-Break-Space))
+                             #+allegro #\%space
+                             #+lispworks #\No-Break-Space))

 
 (defun is-char-whitespace (c)
   (declare (character c) (optimize (speed 3) (safety 0)))
 
 (defun 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)
 
 (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))
     (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))
       (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)
 
 (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))
   (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))
       ((>= 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
       (declare (character c))
       (if match

-         (let* ((subst (cdr match))
-                (len (length subst)))
-           (declare (fixnum len)
-                    (simple-string subst))
-           (dotimes (j len)
-             (declare (fixnum j))
-             (setf (char new-string dpos) (char subst j))
-             (incf dpos)))
-       (progn
-         (setf (char new-string dpos) c)
-         (incf dpos))))))
+          (let* ((subst (cdr match))
+                 (len (length subst)))
+            (declare (fixnum len)
+                     (simple-string subst))
+            (dotimes (j len)
+              (declare (fixnum j))
+              (setf (char new-string dpos) (char subst j))
+              (incf dpos)))
+        (progn
+          (setf (char new-string dpos) c)
+          (incf dpos))))))

 
 (defun escape-xml-string (string)
   "Escape invalid XML characters"
 
 (defun 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)
 
 (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))
   (unless end
     (setq end (length vec)))
   (let* ((len (- end start))

-        (str (make-string len)))
+         (str (make-string len)))

     (declare (fixnum 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)))
     (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))
       (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)
     (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)))
     (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) "~}")
       (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)
 
 (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))
   (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))
        ((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 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)
 
 (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)
             (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))
                 (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))
   "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))
   (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)
       ((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)
 (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))
   (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)))
        ((> 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))
       (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)
 
 (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))
   (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)
        ((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)
     (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)
     (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 '())
   (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))
        ((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)
     (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)
     (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)
 (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))
   (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)
   "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))
   (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+
 (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+)
 
 (defun charhex (ch)
   "convert hex character to decimal"
   (let ((code (char-code (char-upcase ch))))
     (declare (fixnum ch))
     (if (>= code +char-code-upper-a+)

-       (+ 10 (- code +char-code-upper-a+))
-       (- code +char-code-0+))))
+        (+ 10 (- code +char-code-upper-a+))
+        (- code +char-code-0+))))

 
 (defun binary-sequence-to-hex-string (seq)
   (let ((list (etypecase seq
 
 (defun 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)
 (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))
   (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)
       ((= 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 ((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)
 
 (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 #\%))
   (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)
       ((= 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 ((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)
 
 
 (defun uri-query-to-alist (query)


@@ -516,8 +516,8 @@ for characters in a string"
     (:lower-alphanumeric
      (let ((n (random 36)))
        (if (>= n 26)
     (:lower-alphanumeric
      (let ((n (random 36)))
        (if (>= n 26)

-          (code-char (+ +char-code-0+ (- n 26)))
-        (code-char (+ +char-code-lower-a+ n)))))
+           (code-char (+ +char-code-0+ (- n 26)))
+         (code-char (+ +char-code-lower-a+ n)))))

     (:upper-alpha
      (code-char (+ +char-code-upper-a+ (random 26))))
     (:unambiguous
     (:upper-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)
     (:upper-lower-alpha
      (let ((n (random 52)))
        (if (>= n 26)

-          (code-char (+ +char-code-upper-a+ (- n 26)))
-        (code-char (+ +char-code-lower-a+ n)))))))
+           (code-char (+ +char-code-upper-a+ (- n 26)))
+         (code-char (+ +char-code-lower-a+ n)))))))

 
 
 (defun random-string (&key (length 10) (set :lower-alpha))
 
 
 (defun 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))
 (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))
     (declare (fixnum len last))
     (if (char= char (schar str last))

-       (subseq str 0 last)
+        (subseq str 0 last)

       str)))
 
 
       str)))
 
 


@@ -573,11 +573,11 @@ for characters in a string"
   (let ((len (length str)))
     (dolist (ending endings str)
       (when (and (>= len (length ending))
   (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)
 
 
 (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)
       "...")
      ((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)) "...")))))
 
      ((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)
 (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)
   (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)
     (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)
 (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)
   (let* ((start 0)

-        (len (length word))
-        (end len))
+         (len (length word))
+         (end len))

     (declare (fixnum start end len))
     (do ((done nil))
     (declare (fixnum start end len))
     (do ((done nil))

-       ((or done (= start end)))
+        ((or done (= start end)))

       (if (alphanumericp (schar word start))
       (if (alphanumericp (schar word start))

-         (setq done t)
-       (incf start)))
+          (setq done t)
+        (incf start)))

     (when (> end start)
       (do ((done nil))
     (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))
     (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)
       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))
   (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 (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)))
 
 (defun string->list (string)
   (let ((eof (list nil)))

diff --git a/strmatch.lisp b/strmatch.lisp
index 6d7b89eb62a6a4d868220c28f2299cbd49d76de6..e48e2309728be96d07adbdbc2416e09cafbb94a6 100644 (file)
--- 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)
   "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))
     (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))
 
     (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))
 (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)
     (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)))
 
 
       t)))
 
 

-              
-  
-  
+
+
+

diff --git a/symbols.lisp b/symbols.lisp
index 870426e3e426169733930484047e168791a43908..d14f4f28bfc1e6a03e6efece890489a4e339869b 100644 (file)
--- a/symbols.lisp
+++ b/symbols.lisp
@@ -25,22 +25,22 @@
   (let ((vars '()))
     (do-symbols (s 'common-lisp)
       (multiple-value-bind (sym status)
   (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)
     (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
     (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)
   (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)
     (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)
               (symbol-name arg)))))
     (let ((str (apply #'concatenate 'string (mapcar #'stringify args))))
       (nth-value 0 (intern (string-default-case str)

-                          (if pkg pkg *package*))))))
+                           (if pkg pkg *package*))))))

 
 
 (defun concat-symbol (&rest args)
 
 
 (defun concat-symbol (&rest args)


@@ -85,11 +85,11 @@
 
 (defun ensure-keyword-upcase (desig)
   (nth-value 0 (intern (string-upcase
 
 (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
 
 (defun ensure-keyword-default-case (desig)
   (nth-value 0 (intern (string-default-case

-                       (symbol-name (ensure-keyword desig))) :keyword)))
+                        (symbol-name (ensure-keyword desig))) :keyword)))

 
 (defun show (&optional (what :variables) (package *package*))
   (ecase what
 
 (defun show (&optional (what :variables) (package *package*))
   (ecase what


@@ -99,46 +99,46 @@
 (defun show-variables (package)
   (do-symbols (s package)
     (multiple-value-bind (sym status)
 (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)
       (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)
 
 (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)
       (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)
 
 (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)
     (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)
     (nreverse res)))
 
 (defun run-tests-for-instance (instance)

diff --git a/tests.lisp b/tests.lisp
index b33befd2bb140d1a3fc51bd086e2eb48f9869c96..4cbc915f430f61d6e8f4079c79672b1e769b748e 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -17,7 +17,7 @@
 (defpackage #:kmrcl-tests
   (:use #:kmrcl #:cl #:rtest))
 (in-package #:kmrcl-tests)
 (defpackage #:kmrcl-tests
   (:use #:kmrcl #:cl #:rtest))
 (in-package #:kmrcl-tests)

- 
+

 (rem-all-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" #\|)
 (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)
 (deftest :str.19 (delimited-string-to-list "ab|cd|ef" #\| t)

-                                         ("ab" "cd" "ef"))
+                                          ("ab" "cd" "ef"))

 (deftest :str.20 (delimited-string-to-list "") (""))
 (deftest :str.21 (delimited-string-to-list "" #\space t) (""))
 (deftest :str.22 (delimited-string-to-list "ab") ("ab"))
 (deftest :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 :apsl.4 (append-sublists '((a))) (a))
 (deftest :apsl.5 (append-sublists '((a) (b) (c d (e f g)))) (a b c d (e f g)))
 

-(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil)) 
+(deftest :pss.0 (with-output-to-string (s) (print-separated-strings s "|" nil))

   "")
 
 (deftest :pss.1
   "")
 
 (deftest :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)))
 (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)))
 (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))
 
 
 (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)
           (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))
                         (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)
               (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))
                       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)
               (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)
                       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)
 (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 |~
               (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))))))))
                       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 (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)
 
 (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)))
 (defclass test-unique ()
   ((a :initarg :a)
    (b :initarg :b)))

-     
+

 
 (deftest :unique.1
     (let ((list (list (make-instance 'test-unique :a 1 :b 1)
 
 (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)))
       (values
        (unique-slot-values list 'a)
        (unique-slot-values list 'b)))


@@ -413,7 +413,7 @@
     (unique-slot-values nil 'a)
   nil)
 
     (unique-slot-values nil 'a)
   nil)
 

-(deftest :nwp.1     
+(deftest :nwp.1

        (numbers-within-percentage 1. 1.1 9)
   nil)
 
        (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 :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")
 (deftest :pis.4 (prefixed-integer-string 234134 #\C 7) "C0234134")

-          
+

  ;;; MOP Testing
 
 ;; Disable attrib class until understand changes in sbcl/cmucl
  ;;; 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)
 (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))
 #+kmrtest-mop
 (defclass credit-rating ()
   ((level :attributes (date-set time-set))


@@ -453,7 +453,7 @@
   #+lispworks (:optimize-slot-access nil)
   (:metaclass attributes-class))
 
   #+lispworks (:optimize-slot-access nil)
   (:metaclass attributes-class))
 

-  
+

 #+kmrtest-mop
 (defclass monitored-credit-rating ()
   ((level :attributes (last-checked interval date-set))
 #+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")
              (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)))
 #+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))
            (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)
 
 #+kmrtest-mop
 (eval-when (:compile-toplevel :load-toplevel :execute)

diff --git a/web-utils.lisp b/web-utils.lisp
index da7d6b73918bdd50e21b27c9be90628eec154c54..ecd8565f3114cb455f38963db9d934ec0133ef73 100644 (file)
--- a/web-utils.lisp
+++ b/web-utils.lisp
@@ -21,7 +21,7 @@
 
 ;;; HTML/XML constants
 
 
 ;;; HTML/XML constants
 

-(defvar *standard-xml-header* 
+(defvar *standard-xml-header*

   #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))
 
 (defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
   #.(format nil "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))
 
 (defvar *standard-html-header* "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")


@@ -47,61 +47,61 @@
 
 (defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor)
   (let ((amp (case format
 
 (defun make-url (page-name &key (base-dir *base-url*) (format :html) vars anchor)
   (let ((amp (case format

-              (:html
-               "&")
-              ((:xml :ie-xml)
-               "&amp;"))))
-    (concatenate 'string 
+               (:html
+                "&")
+               ((:xml :ie-xml)
+                "&amp;"))))
+    (concatenate 'string

       base-dir page-name
       (if vars
       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
       (if anchor

-         (concatenate 'string "#" anchor)
-       ""))))
+          (concatenate 'string "#" anchor)
+        ""))))

 
 (defun decode-uri-query-string (s)
   "Decode a URI query string field"
   (declare (simple-string s)
 
 (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))
   (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)
        ((= 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
 
 (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 #\&)))
    (delimited-string-to-list s #\&)))

diff --git a/xml-utils.lisp b/xml-utils.lisp
index 6ef3bb98fd8a69c94b995efcee8ece0a6575d51b..860d6750a4e4a7e28686a2c4e2f6419935975558 100644 (file)
--- 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)
 (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))
   (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))
        ((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)
       (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))))
 
 
       (setq start endtag))))
 
 


@@ -51,31 +51,31 @@
   (fast-string-search
    (concatenate 'string "</" tag ">") xmlstr
    (+ taglen 3) start end))
   (fast-string-search
    (concatenate 'string "</" tag ">") xmlstr
    (+ taglen 3) start end))

-  
+

 (defun positions-xml-tag-contents (tag xmlstr &optional (start-xmlstr 0)
 (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)
   "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
       (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)))
       (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)
 
 
 (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."
 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)
       (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)
       (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
     (declare (fixnum i len))
     (let ((c (schar str i)))
       (case c

-       (#\< (write-string "&lt;" s))
-       (#\& (write-string "&amp;" s))
-       (t   (write-char c s))))))
+        (#\< (write-string "&lt;" s))
+        (#\& (write-string "&amp;" s))
+        (t   (write-char c s))))))

 
 (defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
   (format stream "<?xml version=\"~A\"~A~A ?>~%"
 
 (defun xml-declaration-stream (stream &key (version "1.0") standalone encoding)
   (format stream "<?xml version=\"~A\"~A~A ?>~%"

-         version
-         (if encoding
-             (format nil " encoding=\"~A\"" encoding)
-             ""
-             )
-         (if standalone
-             (format nil " standalone=\"~A\"" standalone)
-             "")))
+          version
+          (if encoding
+              (format nil " encoding=\"~A\"" encoding)
+              ""
+              )
+          (if standalone
+              (format nil " standalone=\"~A\"" standalone)
+              "")))

 
 (defun doctype-stream (stream top-element availability registered organization type
 
 (defun doctype-stream (stream top-element availability registered organization type

-                      label language url entities)
+                       label language url entities)

   (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element
   (format stream "<!DOCTYPE ~A ~A \"~A//~A//~A ~A//~A\"" top-element

-         availability (if registered "+" "-") organization type label language)
-  
+          availability (if registered "+" "-") organization type label language)
+

   (when url
     (write-char #\space stream)
     (write-char #\" stream)
     (write-string url stream)
     (write-char #\" stream))
   (when url
     (write-char #\space stream)
     (write-char #\" stream)
     (write-string url stream)
     (write-char #\" stream))

-  
+

   (when entities
     (format stream " [~%~A~%]" entities))
 
   (when entities
     (format stream " [~%~A~%]" entities))
 


@@ -122,25 +122,25 @@ and position of character following end tag."
   (write-char #\newline stream))
 
 (defun doctype-format (stream format &key top-element (availability "PUBLIC")
   (write-char #\newline stream))
 
 (defun doctype-format (stream format &key top-element (availability "PUBLIC")

-                      (registered nil) organization (type "DTD") label
-                      (language "EN") url entities)
+                       (registered nil) organization (type "DTD") label
+                       (language "EN") url entities)

   (case format
     ((:xhtml11 :xhtml)
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language
   (case format
     ((:xhtml11 :xhtml)
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.1" language

-                    (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
-                    entities))
+                     (if url url "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd")
+                     entities))

     (:xhtml10-strict
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language
     (:xhtml10-strict
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Strict" language

-                    (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
-                    entities))
+                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-strict.dtd")
+                     entities))

     (:xhtml10-transitional
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language
     (:xhtml10-transitional
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Transitional" language

-                    (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
-                    entities))
+                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-transitional.dtd")
+                     entities))

     (:xhtml-frameset
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language
     (:xhtml-frameset
      (doctype-stream stream "html" availability registered "W3C" type "XHTML 1.0 Frameset" language

-                    (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
-                    entities))
+                     (if url url "http://www.w3.org/TR/xhtml10/DTD/xhtml10-frameset.dtd")
+                     entities))

     (:html2
      (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
     (:html3
     (:html2
      (doctype-stream stream "HTML" availability registered "IETF" type "HTML" language url entities))
     (:html3


@@ -151,26 +151,26 @@ and position of character following end tag."
      (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
     ((:docbook :docbook42)
      (doctype-stream stream (if top-element top-element "book")
      (doctype-stream stream "HTML" availability registered "W3C" type "HTML 4.01 Final" language url entities))
     ((:docbook :docbook42)
      (doctype-stream stream (if top-element top-element "book")

-                    availability registered "OASIS" type "Docbook XML 4.2" language
-                    (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
-                    entities))
+                     availability registered "OASIS" type "Docbook XML 4.2" language
+                     (if url url "http://www.oasis-open.org/docbook/xml/4.2/docbookx.dtd")
+                     entities))

     (t
      (unless top-element (warn "Missing top-element in doctype-format"))
      (unless organization (warn "Missing organization in doctype-format"))
     (t
      (unless top-element (warn "Missing top-element in doctype-format"))
      (unless organization (warn "Missing organization in doctype-format"))

-     (unless label (warn "Missing label in doctype-format")) 
+     (unless label (warn "Missing label in doctype-format"))

      (doctype-stream stream top-element availability registered organization type label language url
      (doctype-stream stream top-element availability registered organization type label language url

-                    entities))))
+                     entities))))

 
 
 (defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0")
 
 
 (defun sgml-header-stream (format stream &key entities (encoding "iso-8859-1") standalone (version "1.0")

-                         top-element (availability "PUBLIC") registered organization (type "DTD")
-                          label (language "EN") url)
+                          top-element (availability "PUBLIC") registered organization (type "DTD")
+                           label (language "EN") url)

   (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook)
     (xml-declaration-stream stream :version version :encoding encoding :standalone standalone))
   (unless (eq :xml format)
     (doctype-format stream format :top-element top-element
   (when (in format :xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml :docbook)
     (xml-declaration-stream stream :version version :encoding encoding :standalone standalone))
   (unless (eq :xml format)
     (doctype-format stream format :top-element top-element

-                   :availability availability :registered registered
-                   :organization organization :type type :label label :language language
-                   :url url :entities entities))
+                    :availability availability :registered registered
+                    :organization organization :type type :label label :language language
+                    :url url :entities entities))

   stream)
 
   stream)