From f6ab1b1e5f2cac1257f2a37de4260840c3204d51 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 9 May 2006 14:02:11 +0000 Subject: [PATCH] r10933: 08 May 2006 Kevin Rosenberg * sql/metaclasses.lisp: Patch from James Bielman for checking slot constraints. --- ChangeLog | 4 ++++ sql/metaclasses.lisp | 52 +++++++++++++++++++++++--------------------- 2 files changed, 31 insertions(+), 25 deletions(-) diff --git a/ChangeLog b/ChangeLog index 2b89a07..7496e5d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,7 @@ +08 May 2006 Kevin Rosenberg + * sql/metaclasses.lisp: Patch from James Bielman for + checking slot constraints. + 06 May 2006 Kevin Rosenberg * doc/ref-fdml.xml: Documentation patch from Marcus Pearce for limit keyword diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index f3a377e..594211c 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -386,31 +386,33 @@ which does type checking before storing a value in a slot." ;; 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")) - 'string) - ((and (symbolp (car specified-type)) - (string-equal (symbol-name (car specified-type)) "varchar")) - 'string) - ((and (symbolp (car specified-type)) - (string-equal (symbol-name (car specified-type)) "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) - ((and specified-type - (not (eql :not-null (slot-value slotd 'db-constraints)))) - `(or null ,specified-type)) - (t - specified-type))) + (let ((type + (cond + ((consp specified-type) + (cond + ((and (symbolp (car specified-type)) + (string-equal (symbol-name (car specified-type)) "string")) + 'string) + ((and (symbolp (car specified-type)) + (string-equal (symbol-name (car specified-type)) "varchar")) + 'string) + ((and (symbolp (car specified-type)) + (string-equal (symbol-name (car specified-type)) "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))) + (constraints (slot-value slotd 'db-constraints))) + (if (and type (not (member :not-null (listify constraints)))) + `(or null ,type) + type))) ;; Compute the slot definition for slots in a view-class. Figures out ;; what kind of database value (if any) is stored there, generates and -- 2.34.1