r4688: Auto commit for Debian build

diff --git a/mop.lisp b/mop.lisp
index a8d5f6fd8d817518c38f084eb4aa7beedfea78b5..3075517d85aae7a38ba8172cf7250f253f0f7638 100644 (file)
--- 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.65 2003/04/29 09:24:27 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,23 @@
         :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)))
+    (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)  (canonicalize-value-type (slot-value (car dsds) 'value-type)))
+      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 value-type-to-lisp-type (value-type)
   (case (if (atom value-type)