X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=891dc0c11044d778634c0eac4570219c1930048e;hb=9b510e908bfe486b2d99f870fcd3f512d1ae2fb1;hp=f10dd7388a9ef6b989412a2656a3b32432a7f7be;hpb=6c6ef7e865aba5106164df13ceefb4e4454c54cb;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index f10dd73..891dc0c 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.44 2003/04/12 05:16:54 kevin Exp $ +;;;; $Id: mop.lisp,v 1.60 2003/04/16 22:00:15 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -84,7 +84,7 @@ (defclass hyperlink () ((name :type symbol :initform nil :initarg :name :reader name) - (lookup :type function :initform nil :initarg :lookup :reader lookup) + (lookup :type (or function symbol) :initform nil :initarg :lookup :reader lookup) (link-parameters :type list :initform nil :initarg :link-parameters :reader link-parameters))) @@ -117,7 +117,7 @@ value) (when (and ,required (null value)) (error "hyperobject class slot ~A must have a value" name)) - (list name value)) + (list name `',value)) #+(or allegro sbcl cmu scl) (declare (ignore slot-name required)) ) @@ -129,7 +129,7 @@ value already-processed-options slot) - (list* option value already-processed-options)) + (list* option `',value already-processed-options)) #-lispworks (declare (ignore slot-name)) ) @@ -191,33 +191,15 @@ (t t))) -#+(or sbcl cmu scl) -(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) dsds) - (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))) - (apply - #'make-instance 'hyperobject-esd - :value-type value-type - :sql-type sql-type - :length length - :print-formatter (slot-value dsd 'print-formatter) - :subobject (slot-value dsd 'subobject) - :hyperlink (slot-value dsd 'hyperlink) - :hyperlink-parameters (slot-value dsd 'hyperlink-parameters) - :description (slot-value dsd 'description) - :user-name (slot-value dsd 'user-name) - :index (slot-value dsd 'index) - :value-constraint (slot-value dsd 'value-constraint) - :null-allowed (slot-value dsd 'null-allowed) - ia))))) +(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) - #+(or lispworks allegro) + #+ho-named-cesd-fun name dsds) #+allegro (declare (ignore name)) (let* ((dsd (car dsds)) @@ -241,7 +223,11 @@ :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*)) + (defun value-type-to-lisp-type (value-type) (case (if (atom value-type) value-type @@ -302,8 +288,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)