projects
/
clsql.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r9242: make update-records-from-instance on make-instance selectable
[clsql.git]
/
sql
/
metaclasses.lisp
diff --git
a/sql/metaclasses.lisp
b/sql/metaclasses.lisp
index a9f188950c52f3762bcf51a986c6c7f83b0fef86..edb794298f3d374b088409c6e361185f592db15c 100644
(file)
--- a/
sql/metaclasses.lisp
+++ b/
sql/metaclasses.lisp
@@
-12,7
+12,7
@@
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************
-(in-package #:clsql
-sys
)
+(in-package #:clsql)
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (>= (length (generic-function-lambda-list
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (>= (length (generic-function-lambda-list
@@
-60,9
+60,11
@@
:db-writer :db-info))
(defvar +extra-class-options+ '(:base-table))
:db-writer :db-info))
(defvar +extra-class-options+ '(:base-table))
+#+lispworks
(dolist (slot-option +extra-slot-options+)
(process-slot-option standard-db-class slot-option))
(dolist (slot-option +extra-slot-options+)
(process-slot-option standard-db-class slot-option))
+#+lispworks
(dolist (class-option +extra-class-options+)
(process-class-option standard-db-class class-option))
(dolist (class-option +extra-class-options+)
(process-class-option standard-db-class class-option))
@@
-198,15
+200,6
@@
#+(or allegro openmcl)
(defmethod finalize-inheritance :after ((class standard-db-class))
#+(or allegro openmcl)
(defmethod finalize-inheritance :after ((class standard-db-class))
- ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
- ;; for standard-db-class
- #+openmcl
- (mapcar
- #'(lambda (s)
- (if (eq 'ccl:false (slot-value s 'ccl::type-predicate))
- (setf (slot-value s 'ccl::type-predicate) 'ccl:true)))
- (class-slots class))
-
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
@@
-387,7
+380,7
@@
implementations."
(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."
(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))
+ (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
;; 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
@@
-396,24
+389,15
@@
which does type checking before storing a value in a slot."
(cond
((and (symbolp (car specified-type))
(string-equal (symbol-name (car specified-type)) "string"))
(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
'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)
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
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)))
;; Compute the slot definition for slots in a view-class. Figures out
specified-type)))
;; Compute the slot definition for slots in a view-class. Figures out