X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=hyperobject.lisp;h=60d34831d14e5165d62de1f5c6868f02a0a97681;hb=9d3930d7b2bacd5327ce55ad9fb0ce1392fe746b;hp=34a60a9d774c62ba738e1dc79b91949012b08616;hpb=310528f335c81365343ca5503e4db4be062080a2;p=hyperobject.git diff --git a/hyperobject.lisp b/hyperobject.lisp index 34a60a9..60d3483 100644 --- 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.12 2002/11/24 17:47:50 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.14 2002/11/25 04:47:23 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -22,33 +22,35 @@ (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 @@ -58,7 +60,7 @@ (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) @@ -66,7 +68,7 @@ (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 @@ -130,36 +132,59 @@ ;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) - &rest iargs) + #+allegro &rest + 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) + (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)) + ) -(defmacro define-class-slot (slot-name &optional required) +(defmacro define-slot-option (slot-name) #+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)) + `(defmethod clos:process-a-slot-option ((class hyperobject-class) + (option (eql ,slot-name)) + value + already-processed-other-options + slot) (if (null (cdr value)) - (list name (car value)) - (list name `',value))) + (list option (car value)) + (list option `',value))) + #-lispworks + (declare (ignore slot-name)) ) -(define-class-slot :title) -(define-class-slot :print-slots) -(define-class-slot :description) +(define-class-option :title) +(define-class-option :print-slots) +(define-class-option :description) + +(define-slot-option :ho-type) +(define-slot-option :print-formatter) +(define-slot-option :subobject) +(define-slot-option :reference) +(define-slot-option :description) + (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 @@ -196,21 +221,36 @@ (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" @@ -229,8 +269,7 @@ (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))) @@ -332,8 +371,8 @@ (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)) @@ -820,17 +859,3 @@ (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)))))) -