X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=b34541c11d7982647d1638cda566bd52fb438b38;hb=7f6cbd20ca01e6f29b4fa7d68a0908864e400320;hp=613031565164a14fbadedc754242473ae0cc6ebf;hpb=5fe53d4fd03d9339c06850dd54dcbcae10b3678e;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 6130315..b34541c 100644 --- 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.28 2003/03/29 20:22:37 kevin Exp $ +;;;; $Id: mop.lisp,v 1.69 2003/05/06 22:19:09 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -72,7 +72,7 @@ (defclass subobject () ((name-class :type symbol :initform nil :initarg :name-class :reader name-class) (name-slot :type symbol :initform nil :initarg :name-slot :reader name-slot) - (lookup :type symbol :initform nil :initarg :lookup :reader lookup) + (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup) (lookup-keys :type list :initform nil :initarg :lookup-keys :reader lookup-keys)) (:documentation "Contains subobject information")) @@ -84,7 +84,11 @@ (defclass hyperlink () ((name :type symbol :initform nil :initarg :name :reader name) - (lookup :type function :initform nil :initarg :lookup :reader lookup) + (lookup + ;; The type specifier seems to break sbcl + :type (or function symbol) + ;; :type t + :initform nil :initarg :lookup :reader lookup) (link-parameters :type list :initform nil :initarg :link-parameters :reader link-parameters))) @@ -100,14 +104,36 @@ (init-hyperobject-class cl) ) +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) + (pushnew :ho-normal-cesd cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'direct-slot-definition-class))) + 3) + (pushnew :ho-normal-dsdc cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'effective-slot-definition-class))) + 3) + (pushnew :ho-normal-esdc cl:*features*))) + ;; Slot definitions -(defmethod direct-slot-definition-class ((cl hyperobject-class) - #+allegro &rest - iargs) +(defmethod direct-slot-definition-class ((cl hyperobject-class) + #+ho-normal-dsdc &rest iargs) (find-class 'hyperobject-dsd)) +(defmethod effective-slot-definition-class ((cl hyperobject-class) + #+ho-normal-esdc &rest iargs) + (find-class 'hyperobject-esd)) -; Slot definitions + +;;; Slot definitions (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro process-class-option (slot-name &optional required) @@ -115,9 +141,9 @@ `(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)) - (list name `',value)) + (when (and ,required (null value)) + (error "hyperobject class slot ~A must have a value" name)) + (list name `',value)) #+(or allegro sbcl cmu scl) (declare (ignore slot-name required)) ) @@ -127,9 +153,9 @@ `(defmethod clos:process-a-slot-option ((class hyperobject-class) (option (eql ,slot-name)) value - already-processed-other-options + already-processed-options slot) - (list option `',value)) + (list* option `',value already-processed-options)) #-lispworks (declare (ignore slot-name)) ) @@ -141,32 +167,32 @@ (eval `(defclass hyperobject-dsd (standard-direct-slot-definition) - (,@(mapcar #'(lambda (x) - `(,(intern (symbol-name x)) - :initform nil)) - *slot-options-no-initarg*) - ,@(mapcar #'(lambda (x) - `(,(intern (symbol-name x)) - :initarg - ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil - :accessor - ,(intern (concatenate 'string - (symbol-name :dsd-) - (symbol-name x))))) - *slot-options*)))) + (,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initform nil)) + *slot-options-no-initarg*) + ,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initarg + ,(intern (symbol-name x) (symbol-name :keyword)) + :initform nil + :accessor + ,(intern (concatenate 'string + (symbol-name :dsd-) + (symbol-name x))))) + *slot-options*)))) (eval `(defclass hyperobject-esd (standard-effective-slot-definition) - (,@(mapcar #'(lambda (x) - `(,(intern (symbol-name x)) - :initarg - ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil - :accessor - ,(intern (concatenate 'string - (symbol-name :esd-) - (symbol-name x))))) - (append *slot-options* *slot-options-no-initarg*))))) + (,@(mapcar #'(lambda (x) + `(,(intern (symbol-name x)) + :initarg + ,(intern (symbol-name x) (symbol-name :keyword)) + :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) @@ -191,17 +217,15 @@ (t t))) -(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) - #+(or allegro lispworks) name - dsds) - #+allergo (declare (ignore name)) +#+ignore +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) + #+allegro (declare (ignore name)) (let* ((dsd (car dsds)) (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type) (setf (slot-value dsd 'sql-type) sql-type) (setf (slot-value dsd 'type) (value-type-to-lisp-type value-type)) - (let ((ia (compute-effective-slot-definition-initargs - cl #+lispworks name dsds))) + (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks name dsds))) (apply #'make-instance 'hyperobject-esd :value-type value-type @@ -217,25 +241,52 @@ :value-constraint (slot-value dsd 'value-constraint) :null-allowed (slot-value dsd 'null-allowed) ia))))) - + +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) + #+ho-normal-cesd (declare (ignore name)) + (let* ((esd (call-next-method)) + (dsd (car dsds)) + (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) + (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type) + (setf (slot-value esd 'sql-type) sql-type) + (setf (slot-value esd 'length) length) + (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) + (setf (slot-value esd 'value-type) value-type) + (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters description user-name + value-constraint index null-allowed)) + (setf (slot-value esd name) (slot-value dsd name))) + esd))) + + +#+ho-normal-cesd +(setq cl:*features* (delete :ho-normal-cesd cl:*features*)) +#+ho-normal-dsdc +(setq cl:*features* (delete :ho-normal-dsdc cl:*features*)) +#+ho-normal-esdc +(setq cl:*features* (delete :ho-normal-esdc cl:*features*)) + +(defun lisp-type-is-a-string (type) + (or (eq type 'string) + (and (listp type) (some #'(lambda (x) (eq x 'string)) type)))) + (defun value-type-to-lisp-type (value-type) (case (if (atom value-type) value-type (car value-type)) ((:string :cdata :varchar :char) - 'string) + '(or null string)) (:character - 'character) + '(or null character)) (:fixnum - 'fixnum) + '(or null fixnum)) (:boolean - 'boolean) + '(or null boolean)) (:integer - 'integer) + '(or null integer)) ((:float :single-float) - 'single-float) + '(or null single-float)) (:double-float - 'double-float) + '(or null double-float)) (otherwise t))) @@ -276,98 +327,120 @@ (push (list 'slot-value the-instance (list 'quote key)) keys)) (setq keys (nreverse keys)) `(defmethod slot-unbound (,the-class (,the-instance ,class) - (,the-slot-name (eql ',slot-name))) - (declare (ignore ,the-class)) - (setf (slot-value ,the-instance ,the-slot-name) - (,reader ,@keys))))) + (,the-slot-name (eql ',slot-name))) + (declare (ignore ,the-class)) + (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys))))) + + +#+lispworks +(defun intern-eql-specializer (slot) + `(eql ,slot)) -#+(or sbcl scl cmu) -(defun ensure-lazy-reader (class slot-name reader &rest reader-keys) +#+(or sbcl cmu lispworks) +(defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys) (let ((keys nil) (gf (ensure-generic-function 'slot-unbound))) (dolist (key reader-keys) (push (list 'slot-value 'the-instance (list 'quote key)) keys)) (setq keys (nreverse keys)) (multiple-value-bind (method-lambda init-args-values) - (make-method-lambda - gf - (class-prototype (generic-function-method-class gf)) - `(lambda (the-class the-instance the-slot-name) - (declare (ignore the-class)) - (setf (slot-value the-instance the-slot-name) (,reader ,@keys))) - nil) - (add-method gf - (apply - #'make-instance (generic-function-method-class gf) - ':specializers (list t class (intern-eql-specializer slot-name)) - ':lambda-list '(the-class the-instance the-slot-name) - ':function `(function ,method-lambda) - init-args-values))))) + (make-method-lambda + gf + (class-prototype (generic-function-method-class gf)) + #-lispworks + `(lambda (the-class the-instance the-slot-name) + (declare (ignore the-class)) + (setf (slot-value the-instance the-slot-name) (,reader ,@keys))) + #+lispworks + '(the-class the-instance the-slot-name) + #+lispworks + nil + #+lispworks + `(setf (slot-value the-instance the-slot-name) (,reader ,@keys)) + nil) + (add-method gf + (apply + #'make-instance (generic-function-method-class gf) + ':specializers (list (class-of (find-class class-name)) + (find-class class-name) + (intern-eql-specializer slot-name)) + ':lambda-list '(the-class the-instance the-slot-name) + ':function (compile nil method-lambda) + init-args-values))))) (defun finalize-subobjects (cl) "Process class subobjects slot" (setf (subobjects cl) - (let ((subobjects '())) - (dolist (slot (class-slots cl)) - (let-when (subobj-def (esd-subobject slot)) - (let ((subobject (make-instance 'subobject - :name-class (class-name cl) - :name-slot (slot-definition-name slot) - :lookup (if (atom subobj-def) - subobj-def - (car subobj-def)) - :lookup-keys (if (atom subobj-def) - nil - (cdr subobj-def))))) - (unless (eq (lookup subobject) t) - #-(or sbcl cmu scl) - (eval - `(hyperobject::def-lazy-reader ,(name-class subobject) - ,(name-slot subobject) ,(lookup subobject) - ,@(lookup-keys subobject))) - #+(or sbcl cmu scl) - (apply #'ensure-lazy-reader - (name-class subobject) (name-slot subobject) (lookup subobject) (lookup-keys subobject)) - ) - (push subobject subobjects)))) - subobjects))) + (let ((subobjects '())) + (dolist (slot (class-slots cl)) + (let-when + (subobj-def (esd-subobject slot)) + (let ((subobject + (make-instance 'subobject + :name-class (class-name cl) + :name-slot (slot-definition-name slot) + :lookup (if (atom subobj-def) + subobj-def + (car subobj-def)) + :lookup-keys (if (atom subobj-def) + nil + (cdr subobj-def))))) + (unless (eq (lookup subobject) t) + #-(or sbcl cmu lispworks) + (eval + `(hyperobject::def-lazy-reader ,(name-class subobject) + ,(name-slot subobject) ,(lookup subobject) + ,@(lookup-keys subobject))) + #+(or sbcl cmu lispworks) + (apply #'ensure-lazy-reader + (name-class subobject) (name-slot subobject) + (lookup subobject) (lookup-keys subobject))) + (push subobject subobjects)))) + ;; sbcl/cmu reverse class-slots compared to the defclass form + ;; so re-reverse on cmu/sbcl + #+(or cmu sbcl) subobjects + #-(or cmu sbcl) (nreverse subobjects) + ))) (defun finalize-documentation (cl) "Calculate class documentation slot" (awhen (slot-value cl 'user-name) (setf (slot-value cl 'user-name) (etypecase (slot-value cl 'user-name) - (cons (car it)) - ((or string symbol) it)))) + (cons (car it)) + ((or string symbol) it)))) (awhen (slot-value cl 'description) (setf (slot-value cl 'description) (etypecase (slot-value cl 'description) - (cons (car it)) - ((or string symbol) it)))) + (cons (car it)) + ((or string symbol) it)))) (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) - (format nil "Hyperobject~A~A~A~A" - (aif (user-name cl) - (format nil ": ~A" it "")) - (aif (description cl) - (format nil "~%Class description: ~A" it) "") - (aif (subobjects cl) - (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") - (aif (default-print-slots cl) - (format nil "~%Default print slots:~{ ~A~}" it) "") - )))) + (format nil "Hyperobject~A~A~A~A" + (aif (user-name cl) + (format nil ": ~A" it "")) + (aif (description cl) + (format nil "~%Class description: ~A" it) "") + (aif (subobjects cl) + (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") + (aif (default-print-slots cl) + (format nil "~%Default print slots:~{ ~A~}" it) "") + )))) (defun finalize-hyperlinks (cl) (let ((hyperlinks '())) (dolist (esd (class-slots cl)) (awhen (slot-value esd 'hyperlink) - (push - (make-instance 'hyperlink - :name (slot-definition-name esd) - :lookup it - :link-parameters (slot-value esd 'hyperlink-parameters)) - hyperlinks))) + (push + (make-instance 'hyperlink + :name (slot-definition-name esd) + :lookup it + :link-parameters (slot-value esd 'hyperlink-parameters)) + hyperlinks))) + ;; cmu/sbcl reverse class-slots compared to the defclass form + ;; hyperlinks is already reversed from the dolist/push loop, so re-reverse on sbcl/cmu + #-(or cmu sbcl) (setq hyperlinks (nreverse hyperlinks)) (setf (slot-value cl 'hyperlinks) hyperlinks))) (defun init-hyperobject-class (cl) @@ -399,6 +472,8 @@ (defun hyperobject-class-hyperlinks (obj) (hyperlinks (class-of obj))) -(defun hyperobject-class-fields (obj) - (class-slots (class-of obj))) +(defun hyperobject-class-slots (obj) + ;; cmucl/sbcl reverse class-slots + #+(or cmu sbcl) (reverse (class-slots (class-of obj))) + #-(or cmu sbcl) (class-slots (class-of obj)))