X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=hyperobject-mop.lisp;h=affddc85d17797e88b993e113806ad5dbea87806;hb=c207475b8343981e273151b300f9c59d928f7c28;hp=26627d0e481ee9a059af1f0dc18c94c7997dc089;hpb=63b552ae64bb098d42c4f23c2850a03ff707f12a;p=hyperobject.git

diff --git a/hyperobject-mop.lisp b/hyperobject-mop.lisp
index 26627d0..affddc8 100644
--- a/hyperobject-mop.lisp
+++ b/hyperobject-mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: hyperobject-mop.lisp,v 1.1 2002/11/22 10:49:24 kevin Exp $
+;;;; $Id: hyperobject-mop.lisp,v 1.2 2002/11/22 12:16:03 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -41,21 +41,23 @@
 
 
 
-
-(defclass sql-dsd 
-    #+allegro (mop::standard-direct-slot-definition)
-    #+lispworks (clos:standard-direct-slot-definition)
-  ((ho-type :initarg :subobject :initform nil :accessor dsd-ho-type)
+(defclass hyperobject-dsd (#+allegro mop::standard-direct-slot-definition
+			   #+lispworks clos:standard-direct-slot-definition
+			   #+sbcl sb-pcl::standard-direct-slot-definition
+			   #+(or scl cmucl) pcl::standard-direct-slot-definition
+			   )
+  ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type)
    (subobject :initarg :subobject :initform nil :accessor dsd-subobject)
    (reference :initarg :reference :initform nil :accessor dsd-reference)
    (format-func :initarg :format-func :initform nil :accessor dsd-format-func)
    ))
 
-
-(defclass sql-esd
-    #+allegro (mop::standard-effective-slot-definition)
-    #+lispworks (clos:standard-effective-slot-definition)
-  ((ho-type :initarg :subobject :initform nil :accessor esd-ho-type)
+(defclass hyperobject-esd (#+allegro mop::standard-effective-slot-definition
+			   #+lispworks clos:standard-effective-slot-definition
+			   #+sbcl sb-pcl::standard-effective-slot-definition
+			   #+(or scl cmucl) pcl::standard-effective-slot-definition
+			   )
+  ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type)
    (suboject :initarg :subobject :initform nil :accessor esd-subobject)
    (reference :initarg :reference :initform nil :accessor esd-reference)
    (format-func :initarg :format-func :initform nil :accessor esd-format-func)
@@ -146,6 +148,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 (defmethod clos:direct-slot-definition-class ((cl hyperobject-class) iargs)
   (find-class 'hyperobject-dsd))
 
+#+sbcl
+(defmethod sb-pcl:direct-slot-definition-class ((cl hyperobject-class) iargs)
+  (find-class 'hyperobject-dsd))
+
+#+(or cmucl scl)
+(defmethod pcl:direct-slot-definition-class ((cl hyperobject-class) iargs)
+  (find-class 'hyperobject-dsd))
+		   
+
+
 
 #+lispworks
 (defmethod clos:process-a-class-option ((class hyperobject-class)
@@ -184,23 +196,45 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 (defmethod 
     #+allegro clos:compute-effective-slot-definition 
     #+lispworks clos:compute-effective-slot-definition 
+    #+sbcl sb-pcl::compute-effective-slot-definition 
+    #+(or cmucl scl) pcl::compute-effective-slot-definition 
     :around
 	   ((cl hyperobject-class) slot dsds)
   (declare (ignorable slot))
   (let* ((dsd (car dsds))
 	 (ho-type (slot-value dsd 'type)))
     (setf (slot-value dsd 'ho-type) ho-type)
-    (setf (slot-value dsd 'type) (convert-from-ho-type ho-type))
+    (setf (slot-value dsd 'type) (convert-ho-type ho-type))
     (let ((ia 
 	   #+allegro (excl::compute-effective-slot-definition-initargs cl dsds)
 	   #+lispworks (clos::compute-effective-slot-definition-initargs cl slot dsds)
+	   #+sbcl (sb-cl::compute-effective-slot-definition-initargs cl slot dsds)
+	   #+(or cmucl scl) (pcl::compute-effective-slot-definition-initargs cl slot dsds)
 	   ))
       (apply
        #'make-instance 'hyperobject-esd 
-       :ho-type type
+       :ho-type ho-type
        ia)))
   )
 
+(defun convert-ho-type (ho-type)
+  (check-type ho-type symbol)
+  (case (intern (symbol-name ho-type) (symbol-name :keyword))
+    (:string
+     'string)
+    (:fixnum
+     'fixnum)
+    (:boolean
+     'boolean)
+    (:integer
+     'integer)
+    (:cdata
+     'string)
+    (:float
+     'float)
+    (otherwise
+     ho-type)))
+
 ;;;; Class initialization function
       
 (defun init-hyperobject-class (cl)