r3491: *** empty log message ***

diff --git a/debian/changelog b/debian/changelog
index e9639ec6f70f9919f7c34e686a5858bf49eea2e7..b6e25035bc7138669e864f59dbd51b5edd27399f 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-hyperobject (2.0.1-1) unstable; urgency=low
+
+  * Rework definition of class and slot options
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  Tue, 26 Nov 2002 14:52:22 -0700
+
 cl-hyperobject (2.0.0-1) unstable; urgency=low
 
   * New version, incompatibe with version 1.x

diff --git a/examples/example.lisp b/examples/example.lisp
index 0e97b03f9e2a730d6aeda6e6ae699675a2ca737e..0d6b3d5ac76858b20eeea370591f0632420e69fa 100644 (file)
--- a/examples/example.lisp
+++ b/examples/example.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; A simple example file for hyperobjects
 ;;;;
-;;;; $Id: example.lisp,v 1.1 2002/11/25 04:47:23 kevin Exp $
+;;;; $Id: example.lisp,v 1.2 2002/11/26 21:51:10 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -84,7 +84,7 @@
 
 
 (format t "~&Text Format~%")
-(print-hyperobject mary :subobjects t)
+(view mary :subobjects t)
 
 (format t "~&XML Format with field labels and hyperlinks~%")
-(print-hyperobject mary :subobjects t :label t :format :xmlref)
+(view mary :subobjects t :label t :format :xmlref)

diff --git a/hyperobject.lisp b/hyperobject.lisp
index 574d1b6c9a764b351ccf52f4a780682a1efaa98d..8f585f0b399ae82bff9f648c2ee2f1bd5c04658f 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.16 2002/11/25 07:45:35 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.17 2002/11/26 21:51:10 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -69,6 +69,8 @@
                :documentation "List of slots to print")
    (description :initarg :description :initform nil
                :documentation "Class description")
+   (version :initarg :version :initform nil
+               :documentation "Version number for class")
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
@@ -77,6 +79,8 @@
               "List of fields that contain a list of subobjects objects.")
    (references :type list :initform nil :documentation 
               "List of fields that have references")
+   (class-id :type integer :initform nil :documentation
+            "Unique ID for the class")
    
    (value-func :initform nil :type function)
    (xmlvalue-func :initform nil :type function)
@@ -124,59 +128,71 @@
                                                   iargs)
   (find-class 'hyperobject-dsd))
 
-(defmacro define-class-option (slot-name &optional required)
-  #+lispworks
-  `(defmethod clos:process-a-class-option ((class hyperobject-class)
-                                          (name (eql ,slot-name))
-                                          value)
+
+; Slot definitions
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defmacro process-class-option (slot-name &optional required)
+    #+lispworks
+    `(defmethod clos:process-a-class-option ((class hyperobject-class)
+                                            (name (eql ,slot-name))
+                                            value)
     (when (and ,required (null value))
       (error "hyperobject class slot ~A must have a value" name))
     (list name `',value))
-  #+(or allegro sbcl cmu scl)
-  (declare (ignore slot-name required))
-  )
-
-(defmacro define-slot-option (slot-name)
-  #+lispworks
-  `(defmethod clos:process-a-slot-option ((class hyperobject-class)
-                                         (option (eql ,slot-name))
-                                         value
+    #+(or allegro sbcl cmu scl)
+    (declare (ignore slot-name required))
+    )
+
+  (defmacro process-slot-option (slot-name)
+    #+lispworks
+    `(defmethod clos:process-a-slot-option ((class hyperobject-class)
+                                           (option (eql ,slot-name))
+                                           value
                                          already-processed-other-options
-                                         slot)
-    (list option `',value))
-  #-lispworks
-  (declare (ignore slot-name))
-  )
-
-(define-class-option :title)
-(define-class-option :print-slots)
-(define-class-option :description)
-
-(define-slot-option :print-formatter)
-(define-slot-option :subobject)
-(define-slot-option :reference)
-(define-slot-option :description)
-
-;; Slot definitions
-
-(defclass hyperobject-dsd (standard-direct-slot-definition)
-  ((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 :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)
-  ))
-
-
+                                           slot)
+       (list option `',value))
+    #-lispworks
+    (declare (ignore slot-name))
+    )
+  
+  (defparameter *class-options*
+    '(:title :print-slots :description :version :sql-name)
+    "List of class options for hyperobjects.")
+  (defparameter *slot-options*
+    '(:print-formatter :subobject :reference :description :unique :sql-name)
+    "List of slot options that can appear as an initarg")
+  (defparameter *slot-options-no-initarg*
+    '(:ho-type)
+    "List of slot options that do not have an initarg")
+
+  (dolist (option *class-options*)
+    (eval `(process-class-option ,option)))
+  (dolist (option *slot-options*)
+    (eval `(process-slot-option ,option)))
+
+  (eval
+   `(defclass hyperobject-dsd (standard-direct-slot-definition)
+      (,@(mapcar #'(lambda (x)
+                    `(,(intern (symbol-name x))
+                       :initform nil))
+                *slot-options-no-initarg*)
+        ,@(mapcar #'(lambda (x)
+                      `(,(intern (symbol-name x))
+                         :initarg
+                         ,(intern (symbol-name x) (symbol-name :keyword))
+                         :initform nil))
+                  *slot-options*))))
+  (eval
+   `(defclass hyperobject-esd (standard-effective-slot-definition)
+      (,@(mapcar #'(lambda (x)
+                    `(,(intern (symbol-name x))
+                       :initarg
+                       ,(intern (symbol-name x) (symbol-name :keyword))
+                       :initform nil))
+                 (append *slot-options* *slot-options-no-initarg*)))))
+  ) ;; eval-when
+  
 (defmethod compute-effective-slot-definition :around
     ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
   #+allergo (declare (ignore name))
@@ -229,9 +245,9 @@
       (dolist (slot (class-slots cl))
        (when (slot-value slot 'subobject)
          (push (make-instance 'subobject :name (slot-definition-name slot)
-                              :reader (if (eq t (esd-subobject slot))
+                              :reader (if (eq t (slot-value slot 'subobject))
                                           (slot-definition-name slot)
-                                        (esd-subobject slot)))
+                                        (slot-value slot 'subobject)))
                subobjects)))
       subobjects)))
 
@@ -320,13 +336,14 @@
          (string-append fmtstr-html-labels html-label-str)
          (string-append fmtstr-xml-labels xml-label-str)
          
-         (if (esd-reference slot)
+         (if (slot-value slot 'reference)
              (progn
                (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
                (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
                (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
                (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
-               (push (make-instance 'reference :name name :lookup (esd-reference slot))
+               (push (make-instance 'reference :name name
+                                    :lookup (slot-value slot 'reference))
                      references))
              (progn
                (string-append fmtstr-html-ref html-str)
@@ -403,11 +420,11 @@
   (slot-value (class-of obj) 'xmlvalue-func))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-(defun hyperobject-class-title (obj)
-  (awhen (slot-value (class-of obj) 'title)
-           (if (consp it)
-               (car it)
-             it))))
+  (defun hyperobject-class-title (obj)
+    (awhen (slot-value (class-of obj) 'title)
+          (if (consp it)
+              (car it)
+              it))))
 
 (defun hyperobject-class-subobjects (obj)
   (slot-value (class-of obj) 'subobjects))