From: Kevin M. Rosenberg Date: Fri, 9 Apr 2004 12:41:07 +0000 (+0000) Subject: r8906: fixes for allegro loop, start of lispworks loop - not working X-Git-Tag: v3.8.6~691 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=c50e9039c1b0d99d121f3d2dc48aa5e397fb2cc3 r8906: fixes for allegro loop, start of lispworks loop - not working --- diff --git a/ChangeLog b/ChangeLog index c4f8a95..e7b049f 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,14 @@ +09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.4.2 released: + loop extension now supported on Allegro, all + CLSQL-TESTS pass on Allegro. + * sql/metaclasses.lisp: Some optimization + of compute-slots, be selective when + ordered-class-slots needs to be called + instead of class-slots + * TODO: add URL with documentation on + extending Lispworks LOOP form + 09 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.4.1 released: CLSQL-TESt suite passes all tests for postgresql and CMUCL, SBCL, OpenMCL. diff --git a/TODO b/TODO index 977095a..226c26f 100644 --- a/TODO +++ b/TODO @@ -50,7 +50,8 @@ COMMONSQL SPEC o should return list of (attribute datatype precision scale nullable) LOOP - o the extension is currently CMUCL specific + o Port to lispworks. Potentially useful documentation: + http://www.lispworks.com/reference/lcl50/loop/loop-52.html >> The object-oriented sql interface diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp index 6ac4368..2290f27 100644 --- a/base/loop-extension.lisp +++ b/base/loop-extension.lisp @@ -26,12 +26,33 @@ #:*loop-epilogue* #:*loop-ansi-universe* #:add-loop-path))) - -#+sbcl + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:ansi-loop + (:import-from #:loop + #:*epilogue*))) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:ansi-loop) + (let ((excl::*enable-package-locked-errors* nil)) + (rename-package '#:excl '#:excl + (cons '#:ansi-loop + (package-nicknames (find-package '#:excl))))))) + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:ansi-loop) + (rename-package '#:loop '#:loop + (cons '#:ansi-loop + (package-nicknames (find-package '#:loop)))))) + +#+(or sbcl lispworks) (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) (gensym (string pref))) -#+(or cmu scl sbcl openmcl) +#+(or cmu scl sbcl openmcl allegro) (defun loop-record-iteration-path (variable data-type prep-phrases) (let ((in-phrase nil) (from-phrase nil)) @@ -103,9 +124,93 @@ (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable)) ())))))) -#+(or cmu scl sbcl openmcl) +#+(or cmu scl sbcl openmcl allegro) (ansi-loop::add-loop-path '(record records tuple tuples) 'loop-record-iteration-path ansi-loop::*loop-ansi-universe* :preposition-groups '((:of :in) (:from)) :inclusive-permitted nil) + +#+lispworks (in-package loop) + +#+lispworks +(cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from)) + +#+lispworks +(defun ansi-loop::clsql-loop-method (method-name iter-var iter-var-data-type + prep-phrases inclusive? allowed-preps + method-specific-data) + (let ((in-phrase nil) + (from-phrase nil)) + (loop for (prep . rest) in prep-phrases + do + (cond + ((or (eq prep 'in) (eq prep 'of)) + (when in-phrase + (error + "Duplicate OF or IN iteration path: ~S." (cons prep rest))) + (setq in-phrase rest)) + ((eq prep 'from) + (when from-phrase + (error + "Duplicate FROM iteration path: ~S." (cons prep rest))) + (setq from-phrase rest)) + (t + (error + "Unknown preposition: ~S." prep)))) + (unless in-phrase + (error "Missing OF or IN iteration path.")) + (unless from-phrase + (setq from-phrase '(clsql-base-sys:*default-database*))) + (cond + ((consp iter-var) + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + #+ignore + (push `(when ,result-set-var + (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*epilogue*) + `(((,iter-var nil ,iter-var-data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (clsql-base-sys:database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)) + (,iter-var ,step-var) + (not ,result-set-var) + () + (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)) + (,iter-var ,step-var)))) + (t + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-))) + #+ignore + (push `(when ,result-set-var + (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*epilogue*) + `(((,iter-var nil ,iter-var-data-type) (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil)) + ((multiple-value-bind (%rs %cols) + (clsql-base-sys:database-query-result-set ,query-var ,db-var) + (setq ,result-set-var %rs ,iter-var (make-list %cols)))) + () + () + (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)) + () + (not ,result-set-var) + () + (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)) + ())))))) + + + diff --git a/debian/changelog b/debian/changelog index e83776f..4a46cdd 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.4.2-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Fri, 9 Apr 2004 03:17:20 -0600 + cl-sql (2.4.1-1) unstable; urgency=low * New upstream diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index a0b9471..af8e461 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -461,19 +461,16 @@ implementations." (let ((slots (call-next-method)) desired-sequence output-slots) - (dolist (c (compute-class-precedence-list class)) (dolist (s (class-direct-slots c)) (let ((name (slot-definition-name s))) (unless (find name desired-sequence) - (setq desired-sequence (append desired-sequence (list name))))))) - ;; desired-sequence is reversed at this time + (push name desired-sequence))))) (dolist (desired desired-sequence) (let ((slot (find desired slots :key #'slot-definition-name))) (assert slot) (push slot output-slots))) - - (nreverse output-slots))) + output-slots)) (defun compute-lisp-type-from-slot-specification (slotd specified-type) "Computes the Lisp type for a user-specified type. Needed for OpenMCL @@ -592,7 +589,7 @@ which does type checking before storing a value in a slot." (defun slotdef-for-slot-with-class (slot class) (find-if #'(lambda (d) (eql slot (slot-definition-name d))) - (ordered-class-slots class))) + (class-slots class))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute) diff --git a/sql/objects.lisp b/sql/objects.lisp index 0d87e0e..e4b0ca1 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -113,7 +113,7 @@ &key (database *default-database*)) (let ((schemadef nil) (tclass (find-class view-class-name))) - (dolist (slotdef (ordered-class-slots tclass)) + (dolist (slotdef (class-slots tclass)) (let ((res (database-generate-column-definition view-class-name slotdef database))) (when res (setf schemadef (cons res schemadef)))))