r8906: fixes for allegro loop, start of lispworks loop - not working

diff --git a/ChangeLog b/ChangeLog
index c4f8a957a0071a2bcaa0d1cadfbc025ca8dcc347..e7b049f51da8744c0a7f91d2e68945e9ee0adb58 100644 (file)
--- 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 977095af2f58fce3825ce9b494bb1650ac054889..226c26f87d744a555e1d3f78a2573d7fad09c725 100644 (file)
--- 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 6ac4368b40e4669d4a3d25cae2aa05223939327b..2290f2736696b8adb1d7efb27f443882224d6ba7 100644 (file)
--- 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 e83776f679abafde3522dadd02cb15fdcbe9c156..4a46cdd499715692c79a021d5639fcf8297a8a88 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+cl-sql (2.4.2-1) unstable; urgency=low
+
+  * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org>  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 a0b94716461ac2683559dab24189eeb57e79c5a4..af8e461b774ba05b7e8fce2122642e630633b698 100644 (file)
--- 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 0d87e0ed65850e91dea75f3048a1395bc4fbd8d1..e4b0ca13c50c328d9035cc0a46899b04995ce983 100644 (file)
--- 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)))))