r3474: *** empty log message ***

[hyperobject.git] / hyperobject.lisp

diff --git a/hyperobject.lisp b/hyperobject.lisp
index f6ad52c20c617fc41e2b96aa74c0dbe978e6b6ac..574d1b6c9a764b351ccf52f4a780682a1efaa98d 100644 (file)
--- a/hyperobject.lisp
+++ b/hyperobject.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: hyperobject.lisp,v 1.15 2002/11/25 04:49:22 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.16 2002/11/25 07:45:35 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -48,6 +48,13 @@
      pcl::validate-superclass pcl:direct-slot-definition-class
      pcl:compute-effective-slot-definition
      pcl::compute-effective-slot-definition-initargs)
+   #+scl
+   `(class-of  class-name clos:class-slots clos::standard-class
+     clos::slot-definition-name clos:finalize-inheritance
+     clos::standard-direct-slot-definition clos::standard-effective-slot-definition
+     clos::validate-superclass clos:direct-slot-definition-class
+     clos:compute-effective-slot-definition
+     clos::compute-effective-slot-definition-initargs)
    
    :hyperobject))
 
@@ -124,9 +131,7 @@
                                           value)
     (when (and ,required (null value))
       (error "hyperobject class slot ~A must have a value" name))
-    (if (null (cdr value))
-       `(name ,(car value))
-       `(name (quote value))))
+    (list name `',value))
   #+(or allegro sbcl cmu scl)
   (declare (ignore slot-name required))
   )
@@ -138,7 +143,7 @@
                                          value
                                          already-processed-other-options
                                          slot)
-    (list option value))
+    (list option `',value))
   #-lispworks
   (declare (ignore slot-name))
   )
@@ -155,23 +160,23 @@
 ;; Slot definitions
 
 (defclass hyperobject-dsd (standard-direct-slot-definition)
-  ((ho-type :initarg :ho-type)
-   (print-formatter :initarg :print-formatter)
-   (subobject :initarg :subobject :initarg nil)
-   (reference :initarg :reference :initarg nil)
-   (description :initarg :description :initarg nil)
+  ((ho-type :initarg :ho-type :initform nil)
+   (print-formatter :initarg :print-formatter :initform nil)
+   (subobject :initarg :subobject :initform nil)
+   (reference :initarg :reference :initform nil)
+   (description :initarg :description :initform nil)
    ))
 
 (defclass hyperobject-esd (standard-effective-slot-definition)
-  ((ho-type :initarg :ho-type :accessor esd-ho-type)
-   (print-formatter :initarg :print-formatter :accessor esd-print-formatter)
-   (subobject :initarg :subobject :accessor esd-subobject)
-   (reference :initarg :reference :accessor esd-reference)
-   (description :initarg :description :accessor esd-description)
+  ((ho-type :initarg :ho-type :accessor esd-ho-type :initform nil)
+   (print-formatter :initarg :print-formatter :accessor esd-print-formatter
+                   :initform nil)
+   (subobject :initarg :subobject :accessor esd-subobject :initform nil)
+   (reference :initarg :reference :accessor esd-reference :initform nil)
+   (description :initarg :description :accessor esd-description :initform nil)
   ))
 
 
-
 (defmethod compute-effective-slot-definition :around
     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
   #+allergo (declare (ignore name))
@@ -206,6 +211,8 @@
      'string)
     (:float
      'float)
+    (:nil
+     t)
     (otherwise
      ho-type)))
 
@@ -267,6 +274,7 @@
        (package (symbol-package (class-name cl)))
        (references nil))
     (declare (ignore classname))
+    (check-type (slot-value cl 'print-slots) list)
     (dolist (slot-name (slot-value cl 'print-slots))
       (let ((slot (find-slot-by-name cl slot-name)))
        (unless slot
@@ -328,9 +336,9 @@
          
          (if print-formatter
              (setq plain-value-func 
-                   (list `(,print-formatter (,(intern namestr package) x))))
+                   (list `(,print-formatter (slot-value x ',(intern namestr package)))))
              (setq plain-value-func 
-                   (list `(,(intern namestr package) x))))
+                   (list `(slot-value x ',(intern namestr package)))))
          (setq value-func (append value-func plain-value-func))
          
          (if (eql type :cdata)