-(defun delistify-dsd (list)
- "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
- (if (and (listp list) (null (cdr list)))
- (car list)
- list))
-
-(defmethod initialize-instance :around ((obj view-class-direct-slot-definition)
- &rest initargs)
- (do* ((parsed (list obj))
- (name (first initargs) (first initargs))
- (val (second initargs) (second initargs))
- (type nil)
- (db-constraints nil))
- ((null initargs)
- (setq parsed
- (append parsed
- (list 'specified-type type
- :type (compute-lisp-type-from-specified-type
- type db-constraints))))
- (apply #'call-next-method parsed))
- (case name
- (:db-constraints
- (setq db-constraints val)
- (setq parsed (append parsed (list name val))))
- (:type
- (setq type val))
- (t
- (setq parsed (append parsed (list name val)))))
- (setq initargs (cddr initargs))))
+;; there is an :after method below too
+(defmethod initialize-instance :around
+ ((obj view-class-direct-slot-definition)
+ &rest initargs &key db-constraints db-kind type &allow-other-keys)
+ (when (and (not db-kind) (member :primary-key (listify db-constraints)))
+ (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
+ (slot-definition-name obj)))
+ (apply #'call-next-method obj
+ 'specified-type type
+ :type (if (and (eql db-kind :virtual) (null type))
+ t
+ (compute-lisp-type-from-specified-type
+ type db-constraints))
+ initargs))
+
+(defun compute-column-name (arg)
+ (database-identifier arg nil))
+
+(defmethod initialize-instance :after
+ ((obj view-class-direct-slot-definition)
+ &key &allow-other-keys)
+ (setf (view-class-slot-column obj) (compute-column-name obj)))