From: Kevin M. Rosenberg Date: Fri, 22 Nov 2002 16:05:08 +0000 (+0000) Subject: r3455: *** empty log message *** X-Git-Tag: debian-2.11.0-2~269 X-Git-Url: http://git.kpe.io/?a=commitdiff_plain;h=56d53b357e4771cf5d394188c3ec82aa9b9216c2;p=hyperobject.git r3455: *** empty log message *** --- diff --git a/hyperobject.lisp b/hyperobject.lisp index ee71a8f..921f6f8 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.6 2002/11/22 15:43:22 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.7 2002/11/22 16:05:08 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -19,56 +19,57 @@ (in-package :hyperobject-mop) - (eval-when (:compile-toplevel :execute) (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3)))) -;; Utilities - -(defun portable-class-of (obj) - #-(or cmu sbcl) (class-of obj) - #+sbcl (sb-pcl:class-of obj) - #+cmu (pcl:class-of obj)) - -(defun portable-class-name (obj) - #-(or cmu sbcl) (class-name obj) - #+sbcl (sb-pcl:class-name obj) - #+cmu (pcl:class-name obj)) - -(defun portable-class-slots (obj) - #+allegro (mop:class-slots obj) - #+lispworks (clos:class-slots obj) - #+sbcl (sb-pcl:class-slots obj) - #+(or cmu scl) (pcl:class-slots obj)) +#+allegro +(shadowing-import + 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 +) -(defun portable-slot-name (obj) - #+allegro (mop::slot-definition-name obj) - #+lispworks (clos::slot-definition-name obj) - #+sbcl (sb-pcl::slot-definition-name obj) - #+(or cmu scl) (pcl::slot-definition-name obj)) +#+lispworks +(shadowing-import + 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 + ) + +#+(or cmu scl) +(shadowing-import + 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 +) +#+sbcl +(shadowing-import + 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 + ) ;; Slot definitions - -(defclass hyperobject-dsd (#+allegro mop::standard-direct-slot-definition - #+lispworks clos:standard-direct-slot-definition - #+sbcl sb-pcl::standard-direct-slot-definition - #+(or scl cmucl) pcl::standard-direct-slot-definition - ) +(defclass hyperobject-dsd (standard-direct-slot-definition) ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type) (format-func :initarg :format-func :initform nil :accessor dsd-format-func) (subobject :initarg :subobject :initform nil :accessor dsd-subobject) (reference :initarg :reference :initform nil :accessor dsd-reference) )) -(defclass hyperobject-esd (#+allegro mop::standard-effective-slot-definition - #+lispworks clos:standard-effective-slot-definition - #+sbcl sb-pcl::standard-effective-slot-definition - #+(or scl cmucl) pcl::standard-effective-slot-definition - ) +(defclass hyperobject-esd (standard-effective-slot-definition) ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type) (format-func :initarg :format-func :initform nil :accessor esd-format-func) (subobject :initarg :subobject :initform nil :accessor esd-subobject) @@ -77,9 +78,7 @@ ;; Main class -(defclass hyperobject-class (#-(or cmu sbcl) standard-class - #+cmu pcl::standard-class - #+sbcl sb-pcl::standard-class) +(defclass hyperobject-class (standard-class) ((title :initarg :title :type string :reader ml-std-title :documentation "Print Title for class") @@ -129,59 +128,18 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (print-unreadable-object (obj s :type t :identity t) (format s "~S" (name obj)))) -#+cmu -(defmethod pcl:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+scl -(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - - -#+sbcl -(defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - - -#+cmu -(defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class)) - t) - -#+scl -(defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class)) +#+(or cmu scl sbcl) +(defmethod validate-superclass ((class hyperobject-class) (superclass standard-class)) t) -#+sbcl -(defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class)) - t) - -#+allegro -(defmethod mop:finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) - -#+lispworks -(defmethod clos:finalize-inheritance :after ((cl hyperobject-class)) +(defmethod finalize-inheritance :after ((cl hyperobject-class)) (init-hyperobject-class cl)) ;; Slot definitions -#+allegro -(defmethod mop:direct-slot-definition-class ((cl hyperobject-class) +(defmethod direct-slot-definition-class ((cl hyperobject-class) &rest iargs) (find-class 'hyperobject-dsd)) -#+lispworks -(defmethod clos:direct-slot-definition-class ((cl hyperobject-class) iargs) - (find-class 'hyperobject-dsd)) - -#+sbcl -(defmethod sb-pcl:direct-slot-definition-class ((cl hyperobject-class) iargs) - (find-class 'hyperobject-dsd)) - -#+(or cmucl scl) -(defmethod pcl:direct-slot-definition-class ((cl hyperobject-class) iargs) - (find-class 'hyperobject-dsd)) - - #+lispworks @@ -194,23 +152,15 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (list name (car value)) (list name `',value))) -(defmethod - #+allegro clos:compute-effective-slot-definition - #+lispworks clos:compute-effective-slot-definition - #+sbcl sb-pcl::compute-effective-slot-definition - #+(or cmucl scl) pcl::compute-effective-slot-definition - :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) +(defmethod (compute-effective-slot-definition) :around + ((cl hyperobject-class) #+(or allegro lispworks) slot dsds) (declare (ignorable slot)) (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 - #+allegro (excl::compute-effective-slot-definition-initargs cl dsds) - #+lispworks (clos::compute-effective-slot-definition-initargs cl slot dsds) - #+sbcl (sb-pcl::compute-effective-slot-definition-initargs cl dsds) - #+(or cmucl scl) (pcl::compute-effective-slot-definition-initargs cl dsds) - )) + (let ((ia (computer-effective-slot-definition-initargs + cl #+lispworks slot dsds))) (apply #'make-instance 'hyperobject-esd :ho-type ho-type @@ -254,21 +204,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (first-field t) (value-func '()) (xmlvalue-func '()) - (classname (portable-class-name cl)) - (package (symbol-package (portable-class-name cl))) + (classname (class-name cl)) + (package (symbol-package (class-name cl))) (references nil) (subobjects nil)) (declare (ignore classname)) - (dolist (f (portable-class-slots cl)) + (dolist (f (class-slots cl)) (if (slot-value f 'subobject) - (push (make-instance 'subobject :name (portable-slot-name f) + (push (make-instance 'subobject :name (slot-definition-name f) :reader (if (eq t (esd-subobject f)) - (portable-slot-name f) + (slot-definition-name f) (esd-subobject f))) subobjects) - (let ((name (portable-slot-name f)) - (namestr (symbol-name (portable-slot-name f))) - (namestr-lower (string-downcase (symbol-name (portable-slot-name f)))) + (let ((name (slot-definition-name f)) + (namestr (symbol-name (slot-definition-name f))) + (namestr-lower (string-downcase (symbol-name (slot-definition-name f)))) (type (slot-value f 'ho-type)) (formatter (slot-value f 'format-func)) (value-fmt "~a") @@ -365,66 +315,57 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defun hyperobject-class-fmtstr-text (obj) - (slot-value (portable-class-of obj) 'fmtstr-text)) + (slot-value (class-of obj) 'fmtstr-text)) (defun hyperobject-class-fmtstr-html (obj) - (slot-value (portable-class-of obj) 'fmtstr-html)) + (slot-value (class-of obj) 'fmtstr-html)) (defun hyperobject-class-fmtstr-xml (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml)) + (slot-value (class-of obj) 'fmtstr-xml)) (defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-text-labels)) + (slot-value (class-of obj) 'fmtstr-text-labels)) (defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-labels)) + (slot-value (class-of obj) 'fmtstr-html-labels)) (defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-labels)) + (slot-value (class-of obj) 'fmtstr-xml-labels)) (defun hyperobject-class-value-func (obj) - (slot-value (portable-class-of obj) 'value-func)) + (slot-value (class-of obj) 'value-func)) (defun hyperobject-class-xmlvalue-func (obj) - (slot-value (portable-class-of obj) 'xmlvalue-func)) + (slot-value (class-of obj) 'xmlvalue-func)) (eval-when (:compile-toplevel :load-toplevel :execute) (defun hyperobject-class-title (obj) - (awhen (slot-value (portable-class-of obj) 'title) + (awhen (slot-value (class-of obj) 'title) (if (consp it) (car it) it)))) (defun hyperobject-class-subobjects (obj) - (slot-value (portable-class-of obj) 'subobjects)) + (slot-value (class-of obj) 'subobjects)) (defun hyperobject-class-references (obj) - (slot-value (portable-class-of obj) 'references)) + (slot-value (class-of obj) 'references)) (defun hyperobject-class-fields (obj) - (portable-class-slots (portable-class-of obj))) + (class-slots (class-of obj))) (defun hyperobject-class-fmtstr-html-ref (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-ref)) + (slot-value (class-of obj) 'fmtstr-html-ref)) (defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-ref)) + (slot-value (class-of obj) 'fmtstr-xml-ref)) (defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels)) + (slot-value (class-of obj) 'fmtstr-html-ref-labels)) (defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels)) - -;;; Class name functions + (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) -(defgeneric hyperobject-class-stdname (x)) -(defmethod hyperobject-class-stdname ((name string)) - (string-downcase (subseq name 1))) - -(defmethod hyperobject-class-stdname ((cl standard-object)) - (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1))) - ;;;; Generic Print functions (defparameter *default-textformat* nil) @@ -516,7 +457,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (defun class-name-of (obj) - (string-downcase (portable-class-name (portable-class-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))) @@ -766,7 +707,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (nth (position (name ref) (hyperobject-class-fields x) :key #'(lambda (x) - (portable-slot-name x))) + (slot-definition-name x))) field-values) (append (link-parameters ref) refvars))) (link-end (make-link-end x (link-ref fmt) (name ref))))