r3474: *** empty log message ***

diff --git a/hyperobject-no-mop.lisp b/hyperobject-no-mop.lisp
index af75982a53178d398e378e7a5916639e2ffb91ed..bb104d35b48a86523986729933742a75424d8302 100644 (file)
--- a/hyperobject-no-mop.lisp
+++ b/hyperobject-no-mop.lisp
@@ -9,12 +9,28 @@
 ;;;;
 ;;;; This is a rewrite of hyperobjec't to avoid using metaclasses.
 ;;;;
-;;;; $Id: hyperobject-no-mop.lisp,v 1.5 2002/11/25 02:10:38 kevin Exp $
+;;;; $Id: hyperobject-no-mop.lisp,v 1.6 2002/11/25 07:45:35 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
 ;;;; *************************************************************************
- 
+
+
+(defpackage #:hyperobject-no-mop
+  (:nicknames #:ho-no-mop)
+  (:use #:common-lisp #:kmrcl)
+  (:export
+   #:define-hyperobject
+   #:hyperobject
+   #:hyperobject-base-url!
+   #:load-all-subobjects
+   #:print-hyperobject
+   ))
+
+(defpackage #:hyperobject-no-mop-user
+  (:nicknames #:ho-no-mop-user)
+  (:use #:hyperobject-no-mop #:cl #:cl-user))
+
 (in-package :hyperobject-no-mop)
 
 

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)

diff --git a/package.lisp b/package.lisp
index 0a2be5018e56c541f3fbf882cee03d50b6dc87fb..3cccf37ec8917be01bdb7955475599de3b8c582d 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: package.lisp,v 1.11 2002/11/25 04:49:22 kevin Exp $
+;;;; $Id: package.lisp,v 1.12 2002/11/25 07:45:35 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;; *************************************************************************
@@ -25,27 +25,11 @@
    #:hyperobject-class
    #:hyperobject-class-title
    #:load-all-subobjects
-   #:print-hyperobject
-   ))
-
-(defpackage #:hyperobject-no-mop
-  (:nicknames #:ho-no-mop)
-  (:use #:common-lisp #:kmrcl)
-  (:export
-   #:define-hyperobject
-   #:hyperobject
-   #:hyperobject-base-url!
-   #:load-all-subobjects
-   #:print-hyperobject
+   #:view
    ))
 
 (defpackage #:hyperobject-user
   (:nicknames #:ho-user)
   (:use #:hyperobject #:cl #:cl-user))
 
-(defpackage #:hyperobject-no-mop-user
-  (:nicknames #:ho-no-mop-user)
-  (:use #:hyperobject-no-mop #:cl #:cl-user))
-
-
 

diff --git a/views.lisp b/views.lisp
index cf92ed09dec131e097849e21fc964bb0d53c4ab6..e9a89e3cd9c9d02eef285ec640d85546ca73a5b5 100644 (file)
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.1 2002/11/25 04:47:23 kevin Exp $
+;;;; $Id: views.lisp,v 1.2 2002/11/25 07:45:35 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -404,11 +404,11 @@
               (load-all-subobjects it))))))
     objs))
 
-(defgeneric print-hyperobject-class (objs fmt strm
+(defgeneric view-hyperobject (objs fmt strm
                                  &optional label english-only-function
                                  indent subobjects refvars))
 
-(defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream) 
+(defmethod view-hyperobject (objs (fmt dataformat) (strm stream) 
                                 &optional (label nil) (indent 0)
                                 (english-only-function nil)
                                 (subobjects nil) (refvars nil))
@@ -427,7 +427,7 @@
               (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
                         (dolist (child-obj it)   ;; for each child function
                           (awhen (funcall (reader child-obj) obj) ;; access set of child objects
-                                    (print-hyperobject-class it fmt strm label 
+                                    (view-hyperobject it fmt strm label 
                                                      (1+ indent) english-only-function
                                                     subobjects refvars)))))
           (fmt-obj-end obj fmt strm indent)))
@@ -435,16 +435,15 @@
     t))
 
 
-
-(defun print-hyperobject (objs &key (os *standard-output*) (format :text)
+(defun view (objs &key (os *standard-output*) (format :text)
                      (label nil) (english-only-function nil)
                      (subobjects nil) (file-wrapper t) (refvars nil))
-  "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class"
+  "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
   (let ((fmt (make-format-instance format)))
     (if file-wrapper
        (fmt-file-start fmt os))
     (when objs
-      (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars))
+      (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars))
     (if file-wrapper
        (fmt-file-end fmt os)))
   objs)