r3615: *** empty log message ***

[hyperobject.git] / mop.lisp

diff --git a/mop.lisp b/mop.lisp
index 1094c56f0fd4595ab9b97dc7db90a14f6be3bd71..d1567ab5ac4254c6c9df828328f106355c348a48 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: mop.lisp,v 1.10 2002/12/13 05:44:19 kevin Exp $
+;;;; $Id: mop.lisp,v 1.11 2002/12/13 08:25:45 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -27,24 +27,30 @@
 (defclass hyperobject-class (standard-class)
   ( ;; slots initialized in defclass
    (user-name :initarg :user-name :type string :initform nil
-         :documentation "User name for class")
+             :accessor user-name
+             :documentation "User name for class")
    (default-print-slots :initarg :default-print-slots :type list :initform nil
+                       :accessor default-print-slots
                        :documentation "Defaults slots for a view")
    (description :initarg :description :initform nil
+               :accessor description
                :documentation "Class description")
    (version :initarg :version :initform nil
-               :documentation "Version number for class")
+           :accessor version
+           :documentation "Version number for class")
    (sql-name :initarg :table-name :initform nil)
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
    
-   (subobjects :initform nil :documentation
+   (subobjects :initform nil :accessor subobjects
+              :documentation
               "List of fields that contain a list of subobjects objects.")
-   (hyperlinks :type list :initform nil :documentation 
-              "List of fields that have hyperlinks")
-   (class-id :type integer :initform nil :documentation
-            "Unique ID for the class")
+   (hyperlinks :type list :initform nil :accessor hyperlinks
+              :documentation "List of fields that have hyperlinks")
+   (class-id :type integer :initform nil
+            :accessor class-id
+            :documentation "Unique ID for the class")
 
    ;; SQL commands
    (create-table-cmd :initform nil :reader create-table-cmd)
@@ -138,7 +144,11 @@
                       `(,(intern (symbol-name x))
                          :initarg
                          ,(intern (symbol-name x) (symbol-name :keyword))
-                         :initform nil))
+                         :initform nil
+                         :accessor
+                         ,(intern (concatenate 'string
+                                               (symbol-name :dsd-)
+                                               (symbol-name x)))))
                   *slot-options*))))
   (eval
    `(defclass hyperobject-esd (standard-effective-slot-definition)
@@ -146,8 +156,12 @@
                     `(,(intern (symbol-name x))
                        :initarg
                        ,(intern (symbol-name x) (symbol-name :keyword))
-                       :initform nil))
-                 (append *slot-options* *slot-options-no-initarg*)))))
+                       :initform nil
+                       :accessor
+                       ,(intern (concatenate 'string
+                                             (symbol-name :esd-)
+                                             (symbol-name x)))))
+                (append *slot-options* *slot-options-no-initarg*)))))
   ) ;; eval-when
 
 (defun intern-in-keyword (obj)
@@ -163,13 +177,15 @@
     (t
      obj)))
 
-(defmethod compute-effective-slot-definition :around
-    ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
+(defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
+                                                     #+(or allegro lispworks) name
+                                                     dsds)
   #+allergo (declare (ignore name))
   (let* ((dsd (car dsds))
         (ho-type (intern-in-keyword (slot-value dsd 'type)))
         (sql-type (ho-type-to-sql-type ho-type))
         (length (when (consp ho-type) (cadr ho-type))))
+  #+allergo (declare (ignore name))
     (setf (slot-value dsd 'ho-type) ho-type)
     (setf (slot-value dsd 'sql-type) sql-type)
     (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
@@ -257,10 +273,10 @@
 
 (defun finalize-subobjects (cl)
   "Process class subobjects slot"
-  (setf (slot-value cl 'subobjects)
+  (setf (subobjects cl)
     (let ((subobjects '()))
       (dolist (slot (class-slots cl))
-       (let-when (subobj-def (slot-value slot 'subobject))
+       (let-when (subobj-def (esd-subobject slot))
           (let ((subobject (make-instance 'subobject
                                          :name-class (class-name cl)
                                          :name-slot (slot-definition-name slot)
@@ -293,13 +309,13 @@
   (let ((*print-circle* nil))
     (setf (documentation (class-name cl) 'class)
       (format nil "Hyperobject~A~A~A~A"
-             (aif (slot-value cl 'user-name)
+             (aif (user-name cl)
                   (format nil ": ~A" it ""))
-             (aif (slot-value cl 'description)
+             (aif (description cl)
                   (format nil "~%Class description: ~A" it) "")
-             (aif (slot-value cl 'subobjects)
+             (aif (subobjects cl)
                   (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "")
-             (aif (slot-value cl 'default-print-slots)
+             (aif (default-print-slots cl)
                   (format nil "~%Default print slots:~{ ~A~}" it) "")
              ))))
 
@@ -332,16 +348,16 @@
   (find name (class-slots cl) :key #'slot-definition-name))
 
 (defun hyperobject-class-user-name (obj)
-  (awhen (slot-value (class-of obj) 'user-name)
+  (awhen (user-name (class-of obj))
         (if (consp it)
             (car it)
             it)))
 
 (defun hyperobject-class-subobjects (obj)
-  (slot-value (class-of obj) 'subobjects))
+  (subobjects (class-of obj)))
 
 (defun hyperobject-class-hyperlinks (obj)
-  (slot-value (class-of obj) 'hyperlinks))
+  (hyperlinks (class-of obj)))
 
 (defun hyperobject-class-fields (obj)
   (class-slots (class-of obj)))