From 581bb46d7007c98198cdebec4a7ebf1c2feb81ef Mon Sep 17 00:00:00 2001
From: "Kevin M. Rosenberg" <kevin@rosenberg.net>
Date: Tue, 29 Apr 2003 09:24:27 +0000
Subject: [PATCH] r4688: Auto commit for Debian build

---
 mop.lisp | 64 ++++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 46 insertions(+), 18 deletions(-)

diff --git a/mop.lisp b/mop.lisp
index a8d5f6f..3075517 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.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)
-- 
2.34.1