From: Kevin M. Rosenberg Date: Sat, 12 Apr 2003 05:16:54 +0000 (+0000) Subject: r4450: Auto commit for Debian build X-Git-Tag: debian-2.11.0-2~161 X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=commitdiff_plain;h=6c6ef7e865aba5106164df13ceefb4e4454c54cb r4450: Auto commit for Debian build --- diff --git a/mop.lisp b/mop.lisp index 9e6eee6..f10dd73 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.43 2003/04/12 03:37:52 kevin Exp $ +;;;; $Id: mop.lisp,v 1.44 2003/04/12 05:16:54 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -103,11 +103,11 @@ ;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) #+allegro &rest - iargs) + iargs) (find-class 'hyperobject-dsd)) -; Slot definitions + ; Slot definitions (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro process-class-option (slot-name &optional required) @@ -115,9 +115,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 +127,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 +141,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,8 +191,33 @@ (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))))) + (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) - #+(or allegro lispworks) name + #+(or lispworks allegro) dsds) #+allegro (declare (ignore name)) (let* ((dsd (car dsds)) @@ -200,8 +225,7 @@ (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 @@ -276,10 +300,10 @@ (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) @@ -293,98 +317,98 @@ (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))))) + (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 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 - ;; subobject is already reversed from the dolist/push loop, so re-reverse on cmu/sbcl - #+(or cmu sbcl) subobjects - #-(or cmu sbcl) (nreverse 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 + ;; subobject is already reversed from the dolist/push loop, 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))