X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=bbd6604adfe6a7356a5d050be84d1645d5c5c34c;hb=2710f01699cb548df453b64786a2eb0e711315a5;hp=da33f873fed27787e0eb017efbff65dd0db798d0;hpb=7a312cdf8e1e8b5013bad08343c806460e05d6eb;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index da33f87..bbd6604 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.12 2002/12/13 22:00:05 kevin Exp $
+;;;; $Id: mop.lisp,v 1.36 2003/04/01 16:56:46 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -38,7 +38,7 @@
    (version :initarg :version :initform nil
 	    :accessor version
 	    :documentation "Version number for class")
-   (sql-name :initarg :table-name :initform nil)
+   (sql-name :initarg :sql-name :initform nil)
 
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
@@ -48,11 +48,14 @@
 	       "List of fields that contain a list of subobjects objects.")
    (hyperlinks :type list :initform nil :accessor hyperlinks
 	       :documentation "List of fields that have hyperlinks")
-   (direct-rules :type list :initform nil :accessor direct-rules
+   (direct-rules :type list :initform nil :initarg :direct-rules
+		 :accessor direct-rules
 		 :documentation "List of rules to fire on slot changes.")
    (class-id :type integer :initform nil
 	     :accessor class-id
 	     :documentation "Unique ID for the class")
+   (default-view :initform nil :initarg :default-view :accessor default-view
+		 :documentation "The default view for a class")
 
    ;; SQL commands
    (create-table-cmd :initform nil :reader create-table-cmd)
@@ -61,8 +64,8 @@
 
    (views :type list :initform nil :initarg :views :accessor views
 	  :documentation "List of views")
-   (default-view :initform nil :initarg :default-view :accessor default-view
-		 :documentation "The default view for a class")
+   (rules :type list :initform nil :initarg :rules :accessor rules
+	  :documentation "List of rules")
    )
   (:documentation "Metaclass for Markup Language classes."))
 
@@ -179,42 +182,47 @@
     (t
      obj)))
 
+(defun canonicalize-value-type (vt)
+  (typecase vt
+    (atom
+     (ensure-keyword vt))
+    (cons
+     (cons (ensure-keyword (car vt)) (cdr vt)))
+    (t
+     t)))
+
 (defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
 						      #+(or allegro lispworks) name
 						      dsds)
-  #+allergo (declare (ignore name))
+  #+allegro (declare (ignore name))
   (let* ((dsd (car dsds))
-	 (ho-type (intern-in-keyword (slot-value dsd 'type)))
-	 (sql-type (ho-type-to-sql-type ho-type))
-	 (length (when (consp ho-type) (cadr ho-type))))
-  #+allergo (declare (ignore name))
-    (setf (slot-value dsd 'ho-type) ho-type)
-    (setf (slot-value dsd 'sql-type) sql-type)
-    (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type))
-    (let ((ia (compute-effective-slot-definition-initargs
-	       cl #+lispworks name dsds)))
-      (apply
-       #'make-instance 'hyperobject-esd 
-       :ho-type ho-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))))
-
-(defun ho-type-to-lisp-type (ho-type)
-  (when (consp ho-type)
-    (setq ho-type (car ho-type)))
-  (check-type ho-type symbol)
-  (case ho-type
-    ((or :string :cdata :varchar :char)
+	 (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)))))
+  
+(defun value-type-to-lisp-type (value-type)
+  (case (if (atom value-type)
+	    value-type
+	    (car value-type))
+    ((:string :cdata :varchar :char)
      'string)
     (:character
      'character)
@@ -224,37 +232,35 @@
      'boolean)
     (:integer
      'integer)
-    ((or :float :single-float)
-     'single-float)
-    (:double-float
-     'double-float)
-    (nil
-     t)
-    (otherwise
-     ho-type)))
-
-(defun ho-type-to-sql-type (ho-type)
-  (when (consp ho-type)
-    (setq ho-type (car ho-type)))
-  (check-type ho-type symbol)
-  (case ho-type
-    ((or :string :cdata)
-     'string)
-    (:fixnum
-     'integer)
-    (:boolean
-     'boolean)
-    (:integer
-     'integer)
-    ((or :float :single-float)
+    ((:float :single-float)
      'single-float)
     (:double-float
      'double-float)
-    (nil
-     t)
     (otherwise
-     ho-type)))
-
+     t)))
+
+(defun value-type-to-sql-type (value-type)
+  "Return two values, the sql type and field length."
+  (let ((type (if (atom value-type)
+		  value-type
+		  (car value-type)))
+	(length (when (consp value-type)
+		  (cadr value-type))))
+    (values
+     (case type
+       ((:string :cdata)
+	:string)
+       ((:fixnum :integer)
+	:integer)
+       (:boolean
+	:boolean)
+       ((:float :single-float)
+	:single-float)
+       (:double-float
+	:double-float)
+       (otherwise
+	:text))
+     length)))
 
 ;;;; Class initialization function
 
@@ -275,6 +281,35 @@
        (setf (slot-value ,the-instance ,the-slot-name)
 	   (,reader ,@keys)))))
 
+#+lispworks
+(defun intern-eql-specializer (slot)
+  `(eql ,slot))
+
+#+(or sbcl scl 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 (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)
@@ -291,9 +326,15 @@
 							   nil
 							   (cdr subobj-def)))))
 	    (unless (eq (lookup subobject) t)
-	      (eval `(def-lazy-reader ,(name-class subobject)
-			 ,(name-slot subobject) ,(lookup subobject)
-			 ,@(lookup-keys subobject))))
+	      #-(or sbcl cmu scl lispworks)
+	      (eval
+	       `(hyperobject::def-lazy-reader ,(name-class subobject)
+		 ,(name-slot subobject) ,(lookup subobject)
+		 ,@(lookup-keys subobject)))
+	      #+(or sbcl cmu scl lispworks)
+	      (apply #'ensure-lazy-reader 
+		     (name-class subobject) (name-slot subobject) (lookup subobject) (lookup-keys subobject))
+	      )
 	    (push subobject subobjects))))
       subobjects)))
 
@@ -341,6 +382,7 @@
   (finalize-views cl)
   (finalize-hyperlinks cl)
   (finalize-sql cl)
+  (finalize-rules cl)
   (finalize-documentation cl))
 
 
@@ -366,31 +408,3 @@
 (defun hyperobject-class-fields (obj)
   (class-slots (class-of obj)))
 
-;;; Slot accessor and class rules
-
-(defun fire-class-rules (cl obj)
-  "Fire all class rules. Called after a slot is modified."
-  (dolist (rule (direct-rules cl))
-    (cmsg "firing rule: ~a" rule)))
-
-
-(defmethod (setf slot-value-using-class) 
-    :around (new-value (cl hyperobject-class) obj
-	     (slot standard-effective-slot-definition))
-  (cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value)
-  (let ((func (esd-value-constraint slot)))
-    (cond
-     ((and func (not (funcall func new-value obj)))
-      (warn "Rejected change to value of slot ~a of object ~a"
-	    (slot-definition-name slot) obj)
-      (slot-value obj (slot-definition-name slot)))
-     (t
-      (call-next-method)
-      (fire-class-rules cl obj)
-      new-value))))
-  
-(defmethod slot-value-using-class :around ((cl hyperobject-class) obj
-					   (slot standard-effective-slot-definition))
-  (let ((value (call-next-method)))
-    (cmsg-c :verbose "slot value: class: ~s, obj: ~s, slot: ~s" cl (class-of obj) slot)
-    value))