;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
-;;;; $Id: hyperobject.lisp,v 1.12 2002/11/24 17:47:50 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.13 2002/11/25 02:10:38 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
(eval-when (:compile-toplevel :execute)
(declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (shadowing-import
+ #+allegro
+ `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance
+ mop::standard-direct-slot-definition mop::standard-effective-slot-definition
+ mop:direct-slot-definition-class mop:compute-effective-slot-definition
+ excl::compute-effective-slot-definition-initargs)
+ #+lispworks
+ `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance
+ clos::standard-direct-slot-definition clos::standard-effective-slot-definition
+ clos:direct-slot-definition-class clos:compute-effective-slot-definition
+ clos::compute-effective-slot-definition-initargs)
+ #+sbcl
+ `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class
+ sb-pcl::slot-definition-name sb-pcl:finalize-inheritance
+ sb-pcl::standard-direct-slot-definition
+ sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
+ sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition
+ sb-pcl::compute-effective-slot-definition-initargs)
+ #+cmu
+ `(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class
+ pcl::slot-definition-name pcl:finalize-inheritance
+ pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
+ pcl::validate-superclass pcl:direct-slot-definition-class
+ pcl:compute-effective-slot-definition
+ pcl::compute-effective-slot-definition-initargs)
+
+ :hyperobject))
-(shadowing-import
- #+allegro
- `(mop::class-slots mop::slot-definition-name mop:finalize-inheritance
- mop::standard-direct-slot-definition mop::standard-effective-slot-definition
- mop:direct-slot-definition-class mop:compute-effective-slot-definition
- excl::compute-effective-slot-definition-initargs)
- #+lispworks
- `(clos:class-slots clos::slot-definition-name clos:finalize-inheritance
- clos::standard-direct-slot-definition clos::standard-effective-slot-definition
- clos:direct-slot-definition-class clos:compute-effective-slot-definition
- clos::compute-effective-slot-definition-initargs)
- #+sbcl
- `(sb-pcl:class-of sb-pcl:class-name sb-pcl:class-slots sb-pcl::standard-class
- sb-pcl::slot-definition-name sb-pcl:finalize-inheritance
- sb-pcl::standard-direct-slot-definition
- sb-pcl::standard-effective-slot-definition sb-pcl::validate-superclass
- sb-pcl:direct-slot-definition-class sb-pcl:compute-effective-slot-definition
- sb-pcl::compute-effective-slot-definition-initargs)
-#+(or cmu scl)
-`(pcl:class-of pcl:class-name pcl:class-slots pcl::standard-class
- pcl::slot-definition-name pcl:finalize-inheritance
- pcl::standard-direct-slot-definition pcl::standard-effective-slot-definition
- pcl::validate-superclass pcl:direct-slot-definition-class
- pcl:compute-effective-slot-definition
- pcl::compute-effective-slot-definition-initargs)
- :hyperobject)
;; Slot definitions
(print-formatter :initarg :print-formatter :initform nil)
(subobject :initarg :subobject :initform nil)
(reference :initarg :reference :initform nil)
- (description :initarg :reference :initform nil)
+ (description :initarg :description :initform nil)
))
(defclass hyperobject-esd (standard-effective-slot-definition)
(print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter)
(subobject :initarg :subobject :initform nil :accessor esd-subobject)
(reference :initarg :reference :initform nil :accessor esd-reference)
- (description :initarg :reference :initform nil :accessor esd-description)
+ (description :initarg :description :initform nil :accessor esd-description)
))
;; Main class
;; Slot definitions
(defmethod direct-slot-definition-class ((cl hyperobject-class)
- &rest iargs)
+ #+allegro &rest
+ iargs)
(find-class 'hyperobject-dsd))
-
(defmacro define-class-slot (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))
- (if (null (cdr value))
- (list name (car value))
- (list name `',value)))
+ `(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))
+ (if (null (cdr value))
+ (list name (car value))
+ (list name `',value)))
+ #+(or allegro sbcl cmu scl)
+ (declare (ignore slot-name required))
)
(define-class-slot :title)
(defmethod compute-effective-slot-definition :around
- ((cl hyperobject-class) #+(or allegro lispworks) slot dsds)
- (declare (ignorable slot))
+ ((cl hyperobject-class) #+(or allegro lispworks) name dsds)
+ #+allergo (declare (ignore name))
(let* ((dsd (car dsds))
(ho-type (slot-value dsd 'type)))
(setf (slot-value dsd 'ho-type) ho-type)
(setf (slot-value dsd 'type) (convert-ho-type ho-type))
(let ((ia (compute-effective-slot-definition-initargs
- cl #+lispworks slot dsds)))
+ cl #+lispworks name dsds)))
(apply
#'make-instance 'hyperobject-esd
:ho-type ho-type
(defun process-subobjects (cl)
"Process class subobjects slot"
- (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))
- (slot-definition-name slot)
- (esd-subobject slot)))
- subobjects)))
- (setf (slot-value cl 'subobjects) subobjects))
+ (setf (slot-value cl 'subobjects)
+ (let ((subobjects '()))
+ (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))
+ (slot-definition-name slot)
+ (esd-subobject slot)))
+ subobjects)))
+ subobjects)))
(defun process-documentation (cl)
"Calculate class documentation slot"
- (setf (slot-value cl 'documentation)
- (format nil "Hyperobject class: ~A" (slot-value cl 'description)))
- )
-
+ (awhen (slot-value cl 'title)
+ (setf (slot-value cl 'title) (car it)))
+ (awhen (slot-value cl 'description)
+ (setf (slot-value cl 'description) (car it)))
+
+ (let ((*print-circle* nil))
+ (setf (documentation (class-name cl) 'class)
+ (format nil "Hyperobject~A~A~A~A"
+ (aif (slot-value cl 'title)
+ (format nil ": ~A" it ""))
+ (aif (slot-value cl 'description)
+ (format nil "~%Class description: ~A" it) "")
+ (aif (slot-value cl 'subobjects)
+ (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name it)) "")
+ (aif (slot-value cl 'print-slots)
+ (format nil "~%Print-slots:~{ ~A~}" it) "")
+ ))))
(defun process-views (cl)
"Calculate all view slots for a hyperobject class"
(xmlvalue-func '())
(classname (class-name cl))
(package (symbol-package (class-name cl)))
- (references nil)
- (subobjects nil))
+ (references nil))
(declare (ignore classname))
(dolist (slot-name (slot-value cl 'print-slots))
(let ((slot (find-slot-by-name cl slot-name)))
(defun init-hyperobject-class (cl)
"Initialize a hyperobject class. Calculates all class slots"
(process-subobjects cl)
- (process-documentation cl)
- (process-views cl))
+ (process-views cl)
+ (process-documentation cl))
(defun hyperobject-class-fmtstr-text (obj)
(slot-value (class-of obj) 'fmtstr-text))
(fmt-file-end fmt os)))
objs)
-
-(defclass hyperobject ()
- ()
- (:metaclass hyperobject-class))
-
-
-(defmethod print-object ((obj hyperobject) (s stream))
- (print-unreadable-object (obj s :type t :identity t)
- (let ((fmt (make-instance 'hyperobject::textformat)))
- (apply #'format
- s (funcall (obj-data-fmtstr fmt) obj)
- (multiple-value-list
- (funcall (funcall (obj-data-value-func fmt) obj) obj))))))
-
projects / hyperobject.git / commitdiff