-#+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))))
- (multiple-value-bind (sql-type length) (value-type-to-sql-type value-type)
- (setf (slot-value dsd 'sql-type) sql-type)
- (setf (slot-value dsd 'type) (value-type-to-lisp-type value-type))
- (let ((ia (compute-effective-slot-definition-initargs cl #+lispworks name dsds)))
- (apply
- #'make-instance 'hyperobject-esd
- :value-type value-type
- :sql-type sql-type
- :length length
- :print-formatter (slot-value dsd 'print-formatter)
- :subobject (slot-value dsd 'subobject)
- :hyperlink (slot-value dsd 'hyperlink)
- :hyperlink-parameters (slot-value dsd 'hyperlink-parameters)
- :description (slot-value dsd 'description)
- :user-name (slot-value dsd 'user-name)
- :index (slot-value dsd 'index)
- :value-constraint (slot-value dsd 'value-constraint)
- :null-allowed (slot-value dsd 'null-allowed)
- ia)))))
-
-(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))
- (value-type (canonicalize-value-type (slot-value (car dsds) '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)
- esd)))
-
+(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs)
+ (do* ((saved-initargs initargs)
+ (parsed (list obj))
+ (name (first initargs) (first initargs))
+ (val (second initargs) (second initargs)))
+ ((null initargs)
+ (apply #'call-next-method parsed))
+ (if (eql name :value-type)
+ (progn
+ (setq val (canonicalize-value-type val))
+ (setq parsed (append parsed (list name val)))
+ (setq parsed (append parsed (list :type
+ (value-type-to-lisp-type
+ (canonicalize-value-type val))))))
+ (setq parsed (append parsed (list name val))))
+ (setq initargs (cddr initargs))))
+
+(defmethod compute-effective-slot-definition :around ((cl hyperobject-class)
+ #+ho-normal-cesd name
+ dsds)
+ (declare (ignore #+ho-normal-cesd name))
+ (let ((esd (call-next-method)))
+ (if (typep esd 'hyperobject-esd)
+ (compute-hyperobject-esd esd dsds)
+ esd)))
+
+(defun compute-hyperobject-esd (esd dsds)
+ (let* ((dsd (car dsds)))
+ (multiple-value-bind (sql-type sql-length)
+ (value-type-to-sql-type (dsd-value-type dsd))
+ (setf (esd-sql-type esd) sql-type)
+ (setf (esd-sql-length esd) sql-length))
+ (setf (esd-user-name esd)
+ (aif (dsd-user-name dsd)
+ it
+ (string-downcase (symbol-name (slot-definition-name dsd)))))
+ (setf (esd-sql-name esd)
+ (aif (dsd-sql-name dsd)
+ it
+ (lisp-name-to-sql-name (slot-definition-name dsd))))
+ (setf (esd-sql-name esd)
+ (aif (dsd-sql-name dsd)
+ it
+ (lisp-name-to-sql-name (slot-definition-name dsd))))
+ (dolist (name '(value-type print-formatter subobject hyperlink
+ hyperlink-parameters
+ description value-constraint indexed null-allowed
+ unique short-description void-text read-only-groups
+ hidden-groups unit disable-predicate view-type
+ list-of-values stored))
+ (setf (slot-value esd name) (slot-value dsd name)))
+ esd))
+
+(defun lisp-name-to-sql-name (lisp)
+ "Convert a lisp name (atom or list, string or symbol) into a canonical
+SQL name"
+ (unless (stringp lisp)
+ (setq lisp
+ (typecase lisp
+ (symbol (symbol-name lisp))
+ (t (write-to-string lisp)))))
+ (do* ((len (length lisp))
+ (sql (make-string len))
+ (i 0 (1+ i)))
+ ((= i len) (string-upcase sql))
+ (declare (fixnum i)
+ (simple-string sql))
+ (setf (schar sql i)
+ (let ((c (char lisp i)))
+ (case c
+ ((#\- #\$ #\+ #\#) #\_)
+ (otherwise c))))))