;;;; 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
;;;;
-
-(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)
(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)
(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)
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: hyperobject.asd,v 1.4 2002/11/22 10:49:24 kevin Exp $
+;;;; $Id: hyperobject.asd,v 1.5 2002/11/22 12:16:03 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;; *************************************************************************
(pushnew :hyperobject cl:*features*))
:components
((:file "package")
- #+(or allegro lispworks)
+ #+(or allegro lispworks sbcl cmucl scl)
(:file "hyperobject-mop" :depends-on ("package"))
(:file "hyperobject" :depends-on ("package")))
:depends-on (:kmrcl))