+ ((atom obj)
+ (intern (symbol-name obj) (find-package 'keyword)))
+ ((consp obj)
+ (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj))))
+ (t
+ obj)))
+
+(defun canonicalize-value-type (vt)
+ (typecase vt
+ (atom
+ (ensure-keyword vt))
+ (cons
+ (list (ensure-keyword (car vt)) (cadr vt)))
+ (t
+ t)))
+
+(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs)
+ (do* ((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 unbound-lookup
+ 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))))))
+
+#+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 lisp-type-is-a-string (type)
+ (or (eq type 'string)
+ (and (listp type) (some #'(lambda (x) (eq x 'string)) type))))
+
+(defun base-value-type (value-type)
+ (if (atom value-type)
+ value-type
+ (car value-type)))
+
+(defun value-type-to-lisp-type (value-type)
+ (case (base-value-type value-type)
+ ((:string :cdata :varchar :char)
+ '(or null string))
+ (:datetime
+ '(or null integer))
+ (:character
+ '(or null character))