-(defun compute-lisp-type-from-slot-specification (slotd specified-type)
- "Computes the Lisp type for a user-specified type. Needed for OpenMCL
-which does type checking before storing a value in a slot."
- #-openmcl (declare (ignore slotd))
- ;; This function is called after the base compute-effective-slots is called.
- ;; OpenMCL sets the type-predicate based on the initial value of the slots type.
- ;; so we have to override the type-predicates here
- (cond
- ((consp specified-type)
- (cond
- ((and (symbolp (car specified-type))
- (string-equal (symbol-name (car specified-type)) "string"))
- #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'stringp)
- 'string)
- (t
- #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
- specified-type)))
- ((eq (ensure-keyword specified-type) :bigint)
- 'integer)
- #+openmcl
- ((null specified-type)
- ;; setting this here is not enough since openmcl later sets the
- ;; type-predicate to ccl:false. So, have to check slots again
- ;; in finalize-inheritance
- #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
- t)
- (t
- ;; This can be improved for OpenMCL to set a more specific type
- ;; predicate based on the value specified-type
- #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true)
- specified-type)))
+(defun compute-lisp-type-from-specified-type (specified-type db-constraints)
+ "Computes the Lisp type for a user-specified type."
+ (let ((type
+ (cond
+ ((consp specified-type)
+ (let* ((first (first specified-type))
+ (name (etypecase first
+ (symbol (symbol-name first))
+ (string first))))
+ (cond
+ ((or (string-equal name "string")
+ (string-equal name "varchar")
+ (string-equal name "char"))
+ 'string)
+ (t
+ specified-type))))
+ ((eq (ensure-keyword specified-type) :bigint)
+ 'integer)
+ ((eq (ensure-keyword specified-type) :char)
+ 'character)
+ ((eq (ensure-keyword specified-type) :varchar)
+ 'string)
+ (t
+ specified-type))))
+ (if (and type (not (member :not-null (listify db-constraints))))
+ `(or null ,type)
+ type)))