X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=mop.lisp;h=e42ee8bfbc991b33ceca85ea3eccd4015a405c54;hp=4ea60683b33184e8e93e2d66b54380639512baf1;hb=7e2d980b24a9fb31501fe3911582a6d85c374494;hpb=6ff5ef506bb52b4a98cb7a0b3726f5d3a9637944 diff --git a/mop.lisp b/mop.lisp index 4ea6068..e42ee8b 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.83 2003/07/11 18:02:41 kevin Exp $ +;;;; $Id: mop.lisp,v 1.84 2003/07/14 04:10:02 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -78,12 +78,14 @@ (:documentation "Metaclass for Markup Language classes.")) (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 (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")) + ((name-class :type symbol :initarg :name-class :reader name-class) + (name-slot :type symbol :initarg :name-slot :reader name-slot) + (subobj-class :type symbol :initarg :subobj-class :reader subobj-class) + (lookup :type (or function symbol) :initarg :lookup :reader lookup) + (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys)) + (:documentation "subobject information") + (:default-initargs :name-class nil :name-slot nil :subobj-class nil + :lookup nil :lookup-keys nil)) (defmethod print-object ((obj subobject) (s stream)) @@ -344,89 +346,37 @@ SQL name" ;;;; Class initialization function -;; defines a slot-unbound method for class and slot-name, fills -;; the slot by calling reader function with the slot values of -;; the instance's reader-keys -(defmacro def-lazy-reader (class slot-name reader &rest reader-keys) - (let* ((the-slot-name (gensym)) - (the-class (gensym)) - (the-instance (gensym)) - (keys '())) - (dolist (key reader-keys) - (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))))) - - -#+lispworks -(defun intern-eql-specializer (slot) - `(eql ,slot)) - -#+(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)) - #-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))))) - -#+(or allegro scl openmcl) -(progn - ;; One entry for each class with lazy readers defined. The value is a plist mapping - ;; slot-name to a lazy reader, each of which is a list of a function and slot-names. - (defvar *lazy-readers* (make-hash-table)) +;; One entry for each class with lazy readers defined. The value is a plist mapping +;; slot-name to a lazy reader, each of which is a list of a function and slot-names. +(defvar *lazy-readers* (make-hash-table)) (defmethod slot-unbound :around ((class hyperobject-class) instance slot-name) (let ((lazy-reader (loop for super in (class-precedence-list class) - as lazy-reader = (getf (gethash super *lazy-readers*) slot-name) - when lazy-reader return it))) + as lazy-reader = (getf (gethash super *lazy-readers*) slot-name) + when lazy-reader return it))) (if lazy-reader (setf (slot-value instance slot-name) - (apply (car lazy-reader) - (loop for arg-slot-name in (cdr lazy-reader) - collect (slot-value instance arg-slot-name)))) - ;; No lazy reader -- defer to regular slot-unbound handling. - (call-next-method)))) - - ;; The reader is a function and the reader-keys are slot names. The slot is lazily set to - ;; the result of applying the function to the slot-values of those slots, and that value - ;; is also returned. - (defun ensure-lazy-reader (class-name slot-name reader &rest reader-keys) - (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) - (list* reader (copy-list reader-keys)))) - - (defun remove-lazy-reader (class-name slot-name) - (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) - nil)) - - ) ;; #+(or allegro sc openmcll) + (if (atom lazy-reader) + (make-instance lazy-reader) + (apply (car lazy-reader) + (loop for arg-slot-name in (cdr lazy-reader) + collect (slot-value instance arg-slot-name))))) + ;; No lazy reader -- defer to regular slot-unbound handling. + (call-next-method)))) + +;; The reader is a function and the reader-keys are slot names. The slot is lazily set to +;; the result of applying the function to the slot-values of those slots, and that value +;; is also returned. +(defun ensure-lazy-reader (class-name slot-name subobj-class reader + &rest reader-keys) + (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) + (aif subobj-class + it + (list* reader (copy-list reader-keys))))) + +(defun remove-lazy-reader (class-name slot-name) + (setf (getf (gethash (find-class class-name) *lazy-readers*) slot-name) + nil)) (defun finalize-subobjects (cl) @@ -440,30 +390,24 @@ SQL name" (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))))) + :subobj-class (when (atom subobj-def) + subobj-def) + :lookup (when (listp subobj-def) + (car subobj-def)) + :lookup-keys (when (listp subobj-def) + (cdr subobj-def))))) (unless (eq (lookup subobject) t) - #+ignore ;; #-(or sbcl cmu lispworks) - (eval - `(hyperobject::def-lazy-reader ,(name-class subobject) - ,(name-slot subobject) ,(lookup subobject) - ,@(lookup-keys subobject))) - #+(or sbcl cmu lispworks allegro scl openmcl) (apply #'ensure-lazy-reader (name-class subobject) (name-slot subobject) - (lookup subobject) (lookup-keys subobject))) - (push subobject subobjects)))) + (subobj-class 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-class-slots (cl) "Make sure all class slots have an expected value" (unless (user-name cl) @@ -477,13 +421,12 @@ SQL name" (user-name cl)) 2))) - (dolist (name '(user-name description version guid sql-name - direct-views direct-rules)) + (dolist (name '(user-name description version guid sql-name)) (awhen (slot-value cl name) (setf (slot-value cl name) - (etypecase (slot-value cl name) - (cons (car it)) - ((or string symbol) it))))) + (if (listp it) + (car it) + it)))) (unless (sql-name cl) (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl))))