X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=b34541c11d7982647d1638cda566bd52fb438b38;hb=7f6cbd20ca01e6f29b4fa7d68a0908864e400320;hp=a8d5f6fd8d817518c38f084eb4aa7beedfea78b5;hpb=7b3ca1025e0b572b6511c044e948aeab2147af45;p=hyperobject.git

diff --git a/mop.lisp b/mop.lisp
index a8d5f6f..b34541c 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.64 2003/04/28 19:06:13 kevin Exp $
+;;;; $Id: mop.lisp,v 1.69 2003/05/06 22:19:09 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -104,14 +104,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)
@@ -195,16 +217,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))))
@@ -228,9 +242,32 @@
 	 :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 user-name
+		      value-constraint index null-allowed))
+	(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)