X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=hyperobject.lisp;h=f6ad52c20c617fc41e2b96aa74c0dbe978e6b6ac;hb=a332fc23291a68f46d2e973df7c28ec07a4abcfe;hp=34a60a9d774c62ba738e1dc79b91949012b08616;hpb=310528f335c81365343ca5503e4db4be062080a2;p=hyperobject.git diff --git a/hyperobject.lisp b/hyperobject.lisp index 34a60a9..f6ad52c 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.15 2002/11/25 04:49:22 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -22,52 +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 - - -(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 :reference :initform nil) - )) - -(defclass hyperobject-esd (standard-effective-slot-definition) - ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type) - (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) - )) ;; Main class @@ -130,36 +113,74 @@ ;; 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) +(defmacro define-class-option (slot-name &optional required) #+lispworks - (defmethod clos:process-a-class-option ((class hyperobject-class) - (name (eql ,slot-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))) + `(name ,(car value)) + `(name (quote 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 + already-processed-other-options + slot) + (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 :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) + (print-formatter :initarg :print-formatter) + (subobject :initarg :subobject :initarg nil) + (reference :initarg :reference :initarg nil) + (description :initarg :description :initarg 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) + )) + (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 +217,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 +265,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 +367,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)) @@ -387,450 +422,3 @@ (defun hyperobject-class-fmtstr-xml-ref-labels (obj) (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) -;;;; Generic Print functions - -(defparameter *default-textformat* nil) -(defparameter *default-htmlformat* nil) -(defparameter *default-htmlrefformat* nil) -(defparameter *default-xhtmlformat* nil) -(defparameter *default-xhtmlrefformat* nil) -(defparameter *default-xmlformat* nil) -(defparameter *default-xmlrefformat* nil) -(defparameter *default-ie-xmlrefformat* nil) -(defparameter *default-nullformat* nil) -(defparameter *default-init-format?* nil) - -(defun make-format-instance (fmt) - (unless *default-init-format?* - (setq *default-textformat* (make-instance 'textformat)) - (setq *default-htmlformat* (make-instance 'htmlformat)) - (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) - (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) - (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) - (setq *default-xmlformat* (make-instance 'xmlformat)) - (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) - (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) - (setq *default-nullformat* (make-instance 'nullformat)) - (setq *default-init-format?* t)) - - (case fmt - (:text *default-textformat*) - (:html *default-htmlformat*) - (:htmlref *default-htmlrefformat*) - (:xhtml *default-xhtmlformat*) - (:xhtmlref *default-xhtmlrefformat*) - (:xml *default-xmlformat*) - (:xmlref *default-xmlrefformat*) - (:ie-xmlref *default-ie-xmlrefformat*) - (:null *default-nullformat*) - (otherwise *default-textformat*))) - -;;;; Output format classes for print hyperobject-classes - -(defclass dataformat () - ((file-start-str :type string :initarg :file-start-str :reader file-start-str) - (file-end-str :type string :initarg :file-end-str :reader file-end-str) - (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) - (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) - (list-start-indent :initarg :list-start-indent :reader list-start-indent) - (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) - (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) - (list-end-indent :initarg :list-end-indent :reader list-end-indent) - (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) - (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) - (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) - (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) - (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) - (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) - (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) - (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) - (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) - (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) - (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) - (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil - :obj-data-value-func nil :link-ref nil) - (:documentation "Parent for all dataformat objects")) - -(defclass binaryformat (dataformat) - ()) - -(defclass nullformat (dataformat) - ()) - -(defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-title obj) nitems)) - -(defclass textformat (dataformat) - () - (:default-initargs :list-start-fmtstr "~a~P:~%" - :list-start-value-func #'text-list-start-value-func - :list-start-indent t - :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-text - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels - :obj-data-end-fmtstr "~%" - :obj-data-value-func #'hyperobject-class-value-func)) - - -(defun class-name-of (obj) - (string-downcase (class-name (class-of obj)))) - -(defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-title x) nitems (class-name-of x))) - -(defclass htmlformat (textformat) - () - (:default-initargs :file-start-str "
~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "~a~p:
~a~p: