r11037: changes for sbcl mop / whitespace canonicalization

diff --git a/debian/changelog b/debian/changelog
index 091a0943e780e3b8c0687c3d18af7f52ede11070..0f8819ed5a349e55746a3992a2558ca204d69571 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-hyperobject (2.9.1-1) unstable; urgency=low
+
+  * Support change in SBCL MOP
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Thu, 17 Aug 2006 12:12:58 -0600
+

 cl-hyperobject (2.9.0-1) unstable; urgency=low
 
   * New upstream URI
 cl-hyperobject (2.9.0-1) unstable; urgency=low
 
   * New upstream URI

diff --git a/debian/control b/debian/control
index 45e825d957ea521be730daea6a78e97d7866a7f9..86ee0614152b29dad6b4353e8f7b2f4cd0da7734 100644 (file)
--- a/debian/control
+++ b/debian/control
@@ -2,8 +2,8 @@ Source: cl-hyperobject
 Section: devel
 Priority: optional
 Maintainer: Kevin M. Rosenberg <kmr@debian.org>
 Section: devel
 Priority: optional
 Maintainer: Kevin M. Rosenberg <kmr@debian.org>

-Build-Depends-Indep: debhelper (>= 4.0.0)
-Standards-Version: 3.6.2.1
+Build-Depends: debhelper (>= 4.0.0)
+Standards-Version: 3.7.2.1

 
 Package: cl-hyperobject
 Architecture: all
 
 Package: cl-hyperobject
 Architecture: all

diff --git a/mop.lisp b/mop.lisp
index 5307f3ed545f07ed60be74ca9ee88378f1ab2cce..7d6a77b419dd04a38a7bef97e9c1a26bb8a6c1ae 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -15,7 +15,7 @@
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 ;;;;
 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
 ;;;; *************************************************************************

- 
+

 (in-package #:hyperobject)
 
 ;; Main class
 (in-package #:hyperobject)
 
 ;; Main class


@@ -47,7 +47,7 @@
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.

-   
+

    (subobjects :initform nil :accessor subobjects
               :documentation
               "List of fields that contain a list of subobjects objects.")
    (subobjects :initform nil :accessor subobjects
               :documentation
               "List of fields that contain a list of subobjects objects.")


@@ -66,7 +66,7 @@
                 :documentation "The default view for a class")
    (documementation :initform nil :initarg :documentation
                    :documentation "Documentation string for hyperclass.")
                 :documentation "The default view for a class")
    (documementation :initform nil :initarg :documentation
                    :documentation "Documentation string for hyperclass.")

-   
+

    ;; SQL commands
    (create-table-cmd :initform nil :reader create-table-cmd)
    (create-indices-cmds :initform nil :reader create-index-cmds)
    ;; SQL commands
    (create-table-cmd :initform nil :reader create-table-cmd)
    (create-indices-cmds :initform nil :reader create-index-cmds)


@@ -116,7 +116,7 @@
   #+ignore
   (unless (find-class (class-name cl))
     (setf (find-class (class-name cl)) cl))
   #+ignore
   (unless (find-class (class-name cl))
     (setf (find-class (class-name cl)) cl))

-  
+

   (init-hyperobject-class cl)
   )
 
   (init-hyperobject-class cl)
   )
 


@@ -126,13 +126,13 @@
                      'compute-effective-slot-definition)))
            3)
     (pushnew :ho-normal-cesd cl:*features*))
                      'compute-effective-slot-definition)))
            3)
     (pushnew :ho-normal-cesd cl:*features*))

-  
+

     (when (>= (length (generic-function-lambda-list
                       (ensure-generic-function
                        'direct-slot-definition-class)))
            3)
       (pushnew :ho-normal-dsdc cl:*features*))
     (when (>= (length (generic-function-lambda-list
                       (ensure-generic-function
                        'direct-slot-definition-class)))
            3)
       (pushnew :ho-normal-dsdc cl:*features*))

-    
+

     (when (>= (length (generic-function-lambda-list
                       (ensure-generic-function
                        'effective-slot-definition-class)))
     (when (>= (length (generic-function-lambda-list
                       (ensure-generic-function
                        'effective-slot-definition-class)))


@@ -144,7 +144,7 @@
                                         #+ho-normal-dsdc &rest iargs)
   (find-class 'hyperobject-dsd))
 
                                         #+ho-normal-dsdc &rest iargs)
   (find-class 'hyperobject-dsd))
 

-(defmethod effective-slot-definition-class ((cl hyperobject-class) 
+(defmethod effective-slot-definition-class ((cl hyperobject-class)

                                            #+ho-normal-esdc &rest iargs)
   (find-class 'hyperobject-esd))
 
                                            #+ho-normal-esdc &rest iargs)
   (find-class 'hyperobject-esd))
 


@@ -175,7 +175,7 @@
     #-lispworks
     (declare (ignore slot-name))
     )
     #-lispworks
     (declare (ignore slot-name))
     )

-  
+

   (dolist (option *class-options*)
     (eval `(process-class-option ,option)))
   (dolist (option *slot-options*)
   (dolist (option *class-options*)
     (eval `(process-class-option ,option)))
   (dolist (option *slot-options*)


@@ -245,11 +245,13 @@
 (defun compute-hyperobject-esd (esd dsds)
   (let* ((dsd (car dsds))
         (value-type (canonicalize-value-type (slot-value dsd 'value-type))))
 (defun compute-hyperobject-esd (esd dsds)
   (let* ((dsd (car dsds))
         (value-type (canonicalize-value-type (slot-value dsd 'value-type))))

-    (multiple-value-bind (sql-type sql-length) 
+    (multiple-value-bind (sql-type sql-length)

        (value-type-to-sql-type value-type)
       (setf (esd-sql-type esd) sql-type)
       (setf (esd-sql-length esd) sql-length))
        (value-type-to-sql-type value-type)
       (setf (esd-sql-type esd) sql-type)
       (setf (esd-sql-length esd) sql-length))

-    (setf (slot-value esd 'type) (value-type-to-lisp-type value-type))
+    (setf (slot-value esd #-sbcl 'type
+                          #+sbcl 'sb-pcl::%type)
+          (value-type-to-lisp-type value-type))

     (setf (esd-value-type esd) value-type)
     (setf (esd-user-name esd)
          (aif (dsd-user-name dsd)
     (setf (esd-value-type esd) value-type)
     (setf (esd-user-name esd)
          (aif (dsd-user-name dsd)


@@ -379,7 +381,7 @@ SQL name"
 ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
 ;; the result of applying the function to the slot-values of those slots, and that value
 ;; is also returned.
 ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
 ;; the result of applying the function to the slot-values of those slots, and that value
 ;; is also returned.

-(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader 
+(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader

                           &rest reader-keys)
   (setf (getf (gethash cl *lazy-readers*) slot-name)
     (aif subobj-class
                           &rest reader-keys)
   (setf (getf (gethash cl *lazy-readers*) slot-name)
     (aif subobj-class


@@ -425,7 +427,7 @@ SQL name"
   "Make sure all class slots have an expected value"
   (unless (user-name cl)
     (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))
   "Make sure all class slots have an expected value"
   (unless (user-name cl)
     (setf (user-name cl) (format nil "~:(~A~)" (class-name cl))))

-  
+

   (setf (user-name-plural cl)
        (if (and (consp (user-name cl)) (cadr (user-name cl)))
            (cadr (user-name cl))
   (setf (user-name-plural cl)
        (if (and (consp (user-name cl)) (cadr (user-name cl)))
            (cadr (user-name cl))


@@ -440,7 +442,7 @@ SQL name"
             (if (listp it)
                 (car it)
               it))))
             (if (listp it)
                 (car it)
               it))))

-  
+

   (unless (sql-name cl)
     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))
   )
   (unless (sql-name cl)
     (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))
   )

diff --git a/views.lisp b/views.lisp
index 8d43e6995ac21af847bb9fa4d7df8d7f9fd38b20..b9274aafb7834e10e19c95505d9dc0cbec94e07c 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -11,7 +11,7 @@
 ;;;;
 ;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg
 ;;;; *************************************************************************
 ;;;;
 ;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg
 ;;;; *************************************************************************

- 
+

 (in-package #:hyperobject)
 
 
 (in-package #:hyperobject)
 
 


@@ -23,7 +23,7 @@
          :documentation "List of effective slots for object to be viewed.")
    (id :initform nil :initarg :id :accessor id
        :documentation "id for this view.")
          :documentation "List of effective slots for object to be viewed.")
    (id :initform nil :initarg :id :accessor id
        :documentation "id for this view.")

-   (source-code :initform nil :initarg :source-code :accessor source-code 
+   (source-code :initform nil :initarg :source-code :accessor source-code

                :documentation "Source code for generating view.")
    (country-language :initform :en :initarg :country-language
                     :documentation "Country's Language for this view.")
                :documentation "Source code for generating view.")
    (country-language :initform :en :initarg :country-language
                     :documentation "Country's Language for this view.")


@@ -111,8 +111,8 @@
               (make-instance (class-name obj-cl))
               (setq cpl (class-precedence-list obj-cl))))
           (find-view-id-in-class-precedence (second cpl) vid)))))
               (make-instance (class-name obj-cl))
               (setq cpl (class-precedence-list obj-cl))))
           (find-view-id-in-class-precedence (second cpl) vid)))))

-                                           
-  
+
+

 (defun get-view-id (obj vid &optional slots)
   "Find or make a category view for an object"
   (let ((obj-cl (class-of obj)))
 (defun get-view-id (obj vid &optional slots)
   "Find or make a category view for an object"
   (let ((obj-cl (class-of obj)))


@@ -147,7 +147,7 @@
     ((typep view-def 'object-view)
      view-def)
     ((eq view-def :default)
     ((typep view-def 'object-view)
      view-def)
     ((eq view-def :default)

-     (make-instance 'object-view 
+     (make-instance 'object-view

        :object-class (class-name cl)
        :id :compact-text))
     ((consp view-def)
        :object-class (class-name cl)
        :id :compact-text))
     ((consp view-def)


@@ -160,11 +160,11 @@
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
 (defmethod initialize-instance :after ((self object-view)
      (error "Invalid parameter to make-object-view: ~S" view-def))))
 
 (defmethod initialize-instance :after ((self object-view)

-                                      &rest initargs 
+                                      &rest initargs

                                       &key
                                       &allow-other-keys)
   (initialize-view self))
                                       &key
                                       &allow-other-keys)
   (initialize-view self))

-  
+

 (defun initialize-view (view)
   "Calculate all view slots for a hyperobject class"
   (let ((obj-cl (find-class (object-class view))))
 (defun initialize-view (view)
   "Calculate all view slots for a hyperobject class"
   (let ((obj-cl (find-class (object-class view))))


@@ -183,20 +183,20 @@
   "Initialize a view based upon a source code"
   (let* ((source-code (source-code view))
         (printer `(lambda
   "Initialize a view based upon a source code"
   (let* ((source-code (source-code view))
         (printer `(lambda

-                      (,(intern (symbol-name '#:self) 
+                      (,(intern (symbol-name '#:self)

                                 (symbol-package (object-class view)))
                                 (symbol-package (object-class view)))

-                       ,(intern (symbol-name '#:s) 
+                       ,(intern (symbol-name '#:s)

                                 (symbol-package (object-class view))))
                                 (symbol-package (object-class view))))

-                    (declare (ignorable 
-                              ,(intern (symbol-name '#:self) 
+                    (declare (ignorable
+                              ,(intern (symbol-name '#:self)

                                        (symbol-package (object-class view)))
                                        (symbol-package (object-class view)))

-                              ,(intern (symbol-name '#:s) 
+                              ,(intern (symbol-name '#:s)

                                        (symbol-package (object-class view)))))
                                        (symbol-package (object-class view)))))

-                    (with-slots ,(slots view) 
-                        ,(intern (symbol-name '#:self) 
+                    (with-slots ,(slots view)
+                        ,(intern (symbol-name '#:self)

                                  (symbol-package (object-class view)))
                       ,@source-code))))
                                  (symbol-package (object-class view)))
                       ,@source-code))))

-    (setf (printer view) 
+    (setf (printer view)

       (compile nil (eval printer)))))
 
 (defmacro write-simple (v s)
       (compile nil (eval printer)))))
 
 (defmacro write-simple (v s)


@@ -240,7 +240,7 @@
   (vector-push-extend '(write-string "<td>" s) print-func)
   (ppfc-html title name type formatter cdata print-func)
   (vector-push-extend '(write-string "</td>" s) print-func))
   (vector-push-extend '(write-string "<td>" s) print-func)
   (ppfc-html title name type formatter cdata print-func)
   (vector-push-extend '(write-string "</td>" s) print-func))

-                     
+

 (defun ppfc-html-labels (label name type formatter cdata print-func)
   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
   (vector-push-extend `(write-string ,label s) print-func)
 (defun ppfc-html-labels (label name type formatter cdata print-func)
   (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
   (vector-push-extend `(write-string ,label s) print-func)


@@ -262,11 +262,11 @@
 (defun ppfc-html-link (name type formatter cdata nlink print-func)
   (declare (fixnum nlink))
   (vector-push-extend '(write-char #\< s) print-func)
 (defun ppfc-html-link (name type formatter cdata nlink print-func)
   (declare (fixnum nlink))
   (vector-push-extend '(write-char #\< s) print-func)

-  (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) 
+  (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)

   (vector-push-extend '(write-char #\> s) print-func)
   (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
   (vector-push-extend '(write-string "</" s) print-func)
   (vector-push-extend '(write-char #\> s) print-func)
   (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
   (vector-push-extend '(write-string "</" s) print-func)

-  (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func) 
+  (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)

   (vector-push-extend '(write-char #\> s) print-func))
 
 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
   (vector-push-extend '(write-char #\> s) print-func))
 
 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)


@@ -281,7 +281,8 @@
         (user-name (esd-user-name slot))
         (xml-user-name (escape-xml-string user-name))
         (xml-tag (escape-xml-string user-name))
         (user-name (esd-user-name slot))
         (xml-user-name (escape-xml-string user-name))
         (xml-tag (escape-xml-string user-name))

-        (type (slot-value slot 'type))
+        (type (slot-value slot #-sbcl 'type
+                                #+sbcl 'sb-pcl::%type))

         (cdata (not (null
                      (and (in vid :xml :xhtml :xml-link :xhtml-link
                               :xml-labels :ie-xml-labels
         (cdata (not (null
                      (and (in vid :xml :xhtml :xml-link :xhtml-link
                               :xml-labels :ie-xml-labels


@@ -290,7 +291,7 @@
                           (or formatter
                               (lisp-type-is-a-string type))))))
         (hyperlink (esd-hyperlink slot)))
                           (or formatter
                               (lisp-type-is-a-string type))))))
         (hyperlink (esd-hyperlink slot)))

-    
+

     (case vid
       (:compact-text
        (vector-push-extend
     (case vid
       (:compact-text
        (vector-push-extend


@@ -359,7 +360,7 @@
   "Initialize a view based upon a preset vid"
   (unless (creatable-view-id-p obj-cl (id view))
     (error "Unable to automatically create view id ~A" (id view)))
   "Initialize a view based upon a preset vid"
   (unless (creatable-view-id-p obj-cl (id view))
     (error "Unable to automatically create view id ~A" (id view)))

-  
+

   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
 
   (let ((links '())
   (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
 
   (let ((links '())


@@ -372,7 +373,7 @@
         ((null slots))
       (unless slot
        (error "Slot ~A is not found in class ~S" slot-name obj-cl))
         ((null slots))
       (unless slot
        (error "Slot ~A is not found in class ~S" slot-name obj-cl))

-      
+

       (push-print-fun-code (id view) slot (length links) print-func)
       (when (> (length slots) 1)
        (vector-push-extend '(write-char #\space s) print-func))
       (push-print-fun-code (id view) slot (length links) print-func)
       (when (> (length slots) 1)
        (vector-push-extend '(write-char #\space s) print-func))


@@ -386,7 +387,7 @@
                                       ,@(map 'list #'identity print-func)))
     (setf (obj-data-printer view)
          (compile nil (eval (obj-data-print-code view))))
                                       ,@(map 'list #'identity print-func)))
     (setf (obj-data-printer view)
          (compile nil (eval (obj-data-print-code view))))

-    
+

     (setf (link-slots view) (nreverse links)))
 
   (finalize-view-by-id view)
     (setf (link-slots view) (nreverse links)))
 
   (finalize-view-by-id view)


@@ -641,7 +642,7 @@
 (defun fmt-obj-end (obj view strm indent)
   (when (obj-end-indent view)
     (awhen (indenter view)
 (defun fmt-obj-end (obj view strm indent)
   (when (obj-end-indent view)
     (awhen (indenter view)

-          (funcall it indent strm))) 
+          (funcall it indent strm)))

   (awhen (obj-end-printer view)
         (if (stringp it)
             (write-string it strm)
   (awhen (obj-end-printer view)
         (if (stringp it)
             (write-string it strm)


@@ -659,13 +660,13 @@
 (defun fmt-subobj-end (obj view strm indent)
   (when (subobj-end-indent view)
     (awhen (indenter view)
 (defun fmt-subobj-end (obj view strm indent)
   (when (subobj-end-indent view)
     (awhen (indenter view)

-          (funcall it indent strm))) 
+          (funcall it indent strm)))

   (awhen (subobj-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))
   (awhen (subobj-end-printer view)
         (if (stringp it)
             (write-string it strm)
             (funcall it obj strm))))

-  
-;;; Object Data 
+
+;;; Object Data

 
 
 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
 
 
 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)


@@ -689,7 +690,7 @@
        (link-printer
         (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
     (write-char #\" s)))
        (link-printer
         (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
     (write-char #\" s)))

-  
+

 (defun make-link-end (obj view fieldname)
   (declare (ignore obj fieldname))
   (link-href-end view))
 (defun make-link-end (obj view fieldname)
   (declare (ignore obj fieldname))
   (link-href-end view))


@@ -752,7 +753,7 @@
            strm vid (1+ indent) filter subobjects refvars
            link-printer)))))
 
            strm vid (1+ indent) filter subobjects refvars
            link-printer)))))
 

-         
+

 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
                         subobjects refvars link-printer)
   "Display a single or list of hyperobject-class instances and their subobjects"
 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
                         subobjects refvars link-printer)
   "Display a single or list of hyperobject-class instances and their subobjects"


@@ -772,7 +773,7 @@
          (fmt-obj-start obj view strm indent)
          (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
          (fmt-obj-end obj view strm indent)
          (fmt-obj-start obj view strm indent)
          (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
          (fmt-obj-end obj view strm indent)

-         (if subobjects 
+         (if subobjects

              (progn
                (fmt-subobj-start obj view strm indent)
                (view-subobjects obj strm vid indent filter subobjects
              (progn
                (fmt-subobj-start obj view strm indent)
                (view-subobjects obj strm vid indent filter subobjects