X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=9e2706c9f4477375b3d8dcc5caab573aa0f54813;hb=647d539c69157228c414905a06253e5d3b193718;hp=7fc7ca56d5233b62fe98abacb8e27102910edd03;hpb=32eea1ddb0d1863126d145b77826b620f3d01ab1;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 7fc7ca5..9e2706c 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,10 +11,9 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.53 2003/04/16 19:20:51 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; $Id: mop.lisp,v 1.73 2003/05/15 06:30:19 kevin Exp $ ;;;; +;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* (in-package :hyperobject) @@ -29,6 +28,9 @@ (user-name :initarg :user-name :type string :initform nil :accessor user-name :documentation "User name for class") + (user-name-plural :initarg :user-name-plural :type string :initform nil + :accessor user-name-plural + :documentation "Plural user name for class") (default-print-slots :initarg :default-print-slots :type list :initform nil :accessor default-print-slots :documentation "Defaults slots for a view") @@ -72,7 +74,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 +86,11 @@ (defclass hyperlink () ((name :type symbol :initform nil :initarg :name :reader name) - (lookup :type (or function symbol) :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 +106,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) @@ -191,16 +219,8 @@ (t t))) -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'compute-effective-slot-definition))) - 3) - (push :ho-named-cesd-fun cl:*features*))) - -(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) - #+ho-named-cesd-fun name - dsds) +#+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)))) @@ -219,33 +239,57 @@ :hyperlink-parameters (slot-value dsd 'hyperlink-parameters) :description (slot-value dsd 'description) :user-name (slot-value dsd 'user-name) + :user-name-plural (slot-value dsd 'user-name-plural) :index (slot-value dsd 'index) :value-constraint (slot-value dsd 'value-constraint) :null-allowed (slot-value dsd 'null-allowed) ia))))) - -#+ho-named-cesd-fun -(setq cl:*features* (delete :ho-named-cesd-fun cl:*features*)) +(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 value-constraint index null-allowed user-name)) + (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))) @@ -288,8 +332,8 @@ `(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))))) + (setf (slot-value ,the-instance ,the-slot-name) (,reader ,@keys))))) + #+lispworks (defun intern-eql-specializer (slot) @@ -327,51 +371,95 @@ ':function (compile nil method-lambda) init-args-values))))) +#+(or allegro scl) +(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)) + +(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))) + (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 scl) + + (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 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)))) + (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) + #+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) + (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 - ;; subobject is already reversed from the dolist/push loop, so re-reverse on cmu/sbcl + ;; 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) + (setf (user-name cl) (format nil "~:(~A~)" (class-name cl)))) + + (setf (user-name-plural cl) + (if (and (consp (user-name cl)) (cadr (user-name cl))) + (cadr (user-name cl)) + (format nil "~A~P" (if (consp (user-name cl)) + (car (user-name cl)) + (user-name cl)) + 2))) + + (dolist (name '(user-name description)) + (awhen (slot-value cl name) + (setf (slot-value cl name) + (etypecase (slot-value cl name) + (cons (car it)) + ((or string symbol) it)))))) + (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)))) - (awhen (slot-value cl 'description) - (setf (slot-value cl 'description) - (etypecase (slot-value cl 'description) - (cons (car it)) - ((or string symbol) it)))) - (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) (format nil "Hyperobject~A~A~A~A" @@ -407,6 +495,7 @@ (finalize-hyperlinks cl) (finalize-sql cl) (finalize-rules cl) + (finalize-class-slots cl) (finalize-documentation cl)) @@ -418,10 +507,10 @@ (find name (class-slots cl) :key #'slot-definition-name)) (defun hyperobject-class-user-name (obj) - (awhen (user-name (class-of obj)) - (if (consp it) - (car it) - it))) + (user-name (class-of obj))) + +(defun hyperobject-class-user-name-plural (obj) + (user-name-plural (class-of obj))) (defun hyperobject-class-subobjects (obj) (subobjects (class-of obj)))