r2049: moved cmucl-compat files

diff --git a/Makefile b/Makefile
index 1b2e4fb1aed441cf7cbefb0a7169ca46e13f160a..5e2958182686c73cdc5d1bf7eed601e13fdd6fbb 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -5,7 +5,7 @@
 #  Programer:    Kevin M. Rosenberg
 #  Date Started: Mar 2002
 #
 #  Programer:    Kevin M. Rosenberg
 #  Date Started: Mar 2002
 #

-#  CVS Id:   $Id: Makefile,v 1.18 2002/05/13 03:24:41 kevin Exp $
+#  CVS Id:   $Id: Makefile,v 1.19 2002/05/15 17:10:28 kevin Exp $

 #
 # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 #
 #
 # This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 #


@@ -15,7 +15,7 @@
 
 PKG:=clsql
 DEBPKG=cl-sql
 
 PKG:=clsql
 DEBPKG=cl-sql

-SUBDIRS:=interfaces sql cmucl-compat
+SUBDIRS:=interfaces sql base

 DOCSUBDIRS:=doc
 
 include Makefile.common
 DOCSUBDIRS:=doc
 
 include Makefile.common

diff --git a/base/Makefile b/base/Makefile
new file mode 100644 (file)
index 0000000..31dc910
--- /dev/null
+++ b/base/Makefile
@@ -0,0 +1,6 @@
+SUBDIRS                := 
+
+include ../Makefile.common
+
+.PHONY: distclean
+distclean: clean

diff --git a/base/cmucl-compat.cl b/base/cmucl-compat.cl
new file mode 100644 (file)
index 0000000..85cc280
--- /dev/null
+++ b/base/cmucl-compat.cl
@@ -0,0 +1,115 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          cmucl-compat.sql
+;;;; Purpose:       Compatiblity library for CMUCL functions
+;;;; Programmer:    Kevin M. Rosenberg
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: cmucl-compat.cl,v 1.1 2002/05/15 17:10:28 kevin Exp $
+;;;;
+;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; CLSQL users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser GNU Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :cl-user)
+
+(defpackage :cmucl-compat
+  (:export
+   #:shrink-vector
+   #:make-sequence-of-type
+   #:result-type-or-lose
+   #:required-argument
+   ))
+(in-package :cmucl-compat)
+
+#+cmu
+(defmacro required-argument ()
+  `(ext:required-argument))
+
+#-cmu
+(defun required-argument ()
+  (error "~&A required keyword argument was not supplied"))
+
+#+cmu
+(defmacro shrink-vector (vec len)
+  `(lisp::shrink-vector ,vec ,len))
+
+#-cmu
+(defmacro shrink-vector (vec len)
+  "Shrinks a vector. Optimized if vector has a fill pointer.
+Needs to be a macro to overwrite value of VEC."
+  (let ((new-vec (gensym)))
+    `(cond
+      ((adjustable-array-p ,vec)
+       (adjust-array ,vec ,len))
+      ((typep ,vec 'simple-array)
+       (let ((,new-vec (make-array ,len :element-type
+                                  (array-element-type ,vec))))
+        (dotimes (i ,len)
+          (declare (fixnum i))
+          (setf (aref ,new-vec i) (aref ,vec i)))
+        (setq ,vec ,new-vec)))
+      ((typep ,vec 'vector)
+       (setf (fill-pointer ,vec) ,len)
+       ,vec)
+      (t
+       (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) 
+       )))
+
+
+
+#-cmu
+(defun make-sequence-of-type (type length)
+  "Returns a sequence of the given TYPE and LENGTH."
+  (declare (fixnum length))
+  (case type
+    (list 
+     (make-list length))
+    ((bit-vector simple-bit-vector) 
+     (make-array length :element-type '(mod 2)))
+    ((string simple-string base-string simple-base-string)
+     (make-string length))
+    (simple-vector 
+     (make-array length))
+    ((array simple-array vector)
+     (if (listp type)
+        (make-array length :element-type (cadr type))
+       (make-array length)))
+    (t
+     (make-sequence-of-type (result-type-or-lose type t) length))))
+
+
+#+cmu
+(if (fboundp 'lisp::make-sequence-of-type)
+    (defun make-sequence-of-type (type len)
+      (lisp::make-sequence-of-type type len))
+  (defun make-sequence-of-type (type len)
+    (system::make-sequence-of-type type len)))
+  
+
+#-cmu
+(defun result-type-or-lose (type nil-ok)
+  (unless (or type nil-ok)
+    (error "NIL output type invalid for this sequence function"))
+  (case type
+    ((list cons)
+     'list)
+    ((string simple-string base-string simple-base-string)
+     'string)
+    (simple-vector
+     'simple-vector)
+    (vector
+     'vector)
+    (t
+     (error "~S is a bad type specifier for sequence functions." type))
+    ))
+
+#+cmu
+(defun result-type-or-lose (type nil-ok)
+  (lisp::result-type-or-lose type nil-ok))

diff --git a/clsql-base.system b/clsql-base.system
index 8a1315227d69749bf0bbf6f569df04c00008ea92..51b0c5845fd4cf29b64eb5c942f7ef8db75cdc36 100644 (file)
--- a/clsql-base.system
+++ b/clsql-base.system
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;

-;;;; $Id: clsql-base.system,v 1.4 2002/05/14 16:23:37 kevin Exp $
+;;;; $Id: clsql-base.system,v 1.5 2002/05/15 17:10:28 kevin Exp $

 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -31,7 +31,8 @@
     :source-pathname "CL-LIBRARY:clsql;base;"
     :source-extension "cl"
     :binary-pathname "CL-LIBRARY:clsql;base;bin;"
     :source-pathname "CL-LIBRARY:clsql;base;"
     :source-extension "cl"
     :binary-pathname "CL-LIBRARY:clsql;base;bin;"

-    :components ((:file "package")
+    :components ((:file "cmucl-compat")
+                (:file "package")

                 (:file "classes" :depends-on ("package"))
                 (:file "conditions" :depends-on ("classes"))
                 (:file "db-interface" :depends-on ("conditions"))
                 (:file "classes" :depends-on ("package"))
                 (:file "conditions" :depends-on ("classes"))
                 (:file "db-interface" :depends-on ("conditions"))

diff --git a/clsql.system b/clsql.system
index 9b3fa3437d17fe12b7e387358876634fb08ec2b4..aa634762040ab4d9505bd917909a4309fbd53006 100644 (file)
--- a/clsql.system
+++ b/clsql.system
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Feb 2002
 ;;;;

-;;;; $Id: clsql.system,v 1.12 2002/05/13 05:24:57 kevin Exp $
+;;;; $Id: clsql.system,v 1.13 2002/05/15 17:10:28 kevin Exp $

 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;;


@@ -27,24 +27,18 @@
 
 ;;; System definitions
 
 
 ;;; System definitions
 

-(mk:defsystem :cmucl-compat
-    :source-pathname "CL-LIBRARY:clsql;cmucl-compat;"
-    :source-extension "cl"
-    :binary-pathname "CL-LIBRARY:clsql;cmucl-compat;bin;"
-    :components ((:file "cmucl-compat")
-                (:file "loop-extension")))
-

 (mk:defsystem :clsql
     :source-pathname "CL-LIBRARY:clsql;sql;"
     :source-extension "cl"
     :binary-pathname "CL-LIBRARY:clsql;sql;bin;"
     :components ((:file "pool")
 (mk:defsystem :clsql
     :source-pathname "CL-LIBRARY:clsql;sql;"
     :source-extension "cl"
     :binary-pathname "CL-LIBRARY:clsql;sql;bin;"
     :components ((:file "pool")

+                (:file "loop-extension")

                 (:file "sql" :depends-on ("pool"))
                 (:file "transactions" :depends-on ("sql"))
                 (:file "utils")
                 (:file "functional" :depends-on ("sql"))
                 (:file "usql" :depends-on ("sql")))
                 (:file "sql" :depends-on ("pool"))
                 (:file "transactions" :depends-on ("sql"))
                 (:file "utils")
                 (:file "functional" :depends-on ("sql"))
                 (:file "usql" :depends-on ("sql")))

-    :depends-on (:clsql-base :cmucl-compat)
+    :depends-on (:clsql-base)

     :finally-do
     (pushnew :clsql cl:*features*)
     )
     :finally-do
     (pushnew :clsql cl:*features*)
     )

diff --git a/cmucl-compat/.cvsignore b/cmucl-compat/.cvsignore
deleted file mode 100755 (executable)
index ca8d09f..0000000
--- a/cmucl-compat/.cvsignore
+++ /dev/null
@@ -1 +0,0 @@
-.bin

diff --git a/cmucl-compat/Makefile b/cmucl-compat/Makefile
deleted file mode 100644 (file)
index 31dc910..0000000
--- a/cmucl-compat/Makefile
+++ /dev/null
@@ -1,6 +0,0 @@
-SUBDIRS                := 
-
-include ../Makefile.common
-
-.PHONY: distclean
-distclean: clean

diff --git a/cmucl-compat/cmucl-compat.cl b/cmucl-compat/cmucl-compat.cl
deleted file mode 100644 (file)
index f2dde00..0000000
--- a/cmucl-compat/cmucl-compat.cl
+++ /dev/null
@@ -1,115 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          cmucl-compat.sql
-;;;; Purpose:       Compatiblity library for CMUCL functions
-;;;; Programmer:    Kevin M. Rosenberg
-;;;; Date Started:  Feb 2002
-;;;;
-;;;; $Id: cmucl-compat.cl,v 1.1 2002/03/23 14:04:49 kevin Exp $
-;;;;
-;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
-;;;;
-;;;; CLSQL users are granted the rights to distribute and use this software
-;;;; as governed by the terms of the Lisp Lesser GNU Public License
-;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
-;;;; *************************************************************************
-
-(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
-(in-package :cl-user)
-
-(defpackage :cmucl-compat
-  (:export
-   #:shrink-vector
-   #:make-sequence-of-type
-   #:result-type-or-lose
-   #:required-argument
-   ))
-(in-package :cmucl-compat)
-
-#+cmu
-(defmacro required-argument ()
-  `(ext:required-argument))
-
-#-cmu
-(defun required-argument ()
-  (error "~&A required keyword argument was not supplied"))
-
-#+cmu
-(defmacro shrink-vector (vec len)
-  `(lisp::shrink-vector ,vec ,len))
-
-#-cmu
-(defmacro shrink-vector (vec len)
-  "Shrinks a vector. Optimized if vector has a fill pointer.
-Needs to be a macro to overwrite value of VEC."
-  (let ((new-vec (gensym)))
-    `(cond
-      ((adjustable-array-p ,vec)
-       (adjust-array ,vec ,len))
-      ((typep ,vec 'simple-array)
-       (let ((,new-vec (make-array ,len :element-type
-                                  (array-element-type ,vec))))
-        (dotimes (i ,len)
-          (declare (fixnum i))
-          (setf (aref ,new-vec i) (aref ,vec i)))
-        (setq ,vec ,new-vec)))
-      ((typep ,vec 'vector)
-       (setf (fill-pointer ,vec) ,len)
-       ,vec)
-      (t
-       (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) 
-       )))
-
-
-
-#-cmu
-(defun make-sequence-of-type (type length)
-  "Returns a sequence of the given TYPE and LENGTH."
-  (declare (fixnum length))
-  (case type
-    (list 
-     (make-list length))
-    ((bit-vector simple-bit-vector) 
-     (make-array length :element-type '(mod 2)))
-    ((string simple-string base-string simple-base-string)
-     (make-string length))
-    (simple-vector 
-     (make-array length))
-    ((array simple-array vector)
-     (if (listp type)
-        (make-array length :element-type (cadr type))
-       (make-array length)))
-    (t
-     (make-sequence-of-type (result-type-or-lose type t) length))))
-
-
-#+cmu
-(if (fboundp 'lisp::make-sequence-of-type)
-    (defun make-sequence-of-type (type len)
-      (lisp::make-sequence-of-type type len))
-  (defun make-sequence-of-type (type len)
-    (system::make-sequence-of-type type len)))
-  
-
-#-cmu
-(defun result-type-or-lose (type nil-ok)
-  (unless (or type nil-ok)
-    (error "NIL output type invalid for this sequence function"))
-  (case type
-    ((list cons)
-     'list)
-    ((string simple-string base-string simple-base-string)
-     'string)
-    (simple-vector
-     'simple-vector)
-    (vector
-     'vector)
-    (t
-     (error "~S is a bad type specifier for sequence functions." type))
-    ))
-
-#+cmu
-(defun result-type-or-lose (type nil-ok)
-  (lisp::result-type-or-lose type nil-ok))

diff --git a/cmucl-compat/loop-extension.cl b/cmucl-compat/loop-extension.cl
deleted file mode 100644 (file)
index 4eec894..0000000
--- a/cmucl-compat/loop-extension.cl
+++ /dev/null
@@ -1,98 +0,0 @@
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; *************************************************************************
-;;;; FILE IDENTIFICATION
-;;;;
-;;;; Name:          loop-extension.cl
-;;;; Purpose:       Extensions to the Loop macro for CMUCL
-;;;; Programmer:    Pierre R. Mai
-;;;;
-;;;; Copyright (c) 1999-2001 Pierre R. Mai
-;;;;
-;;;; $Id: loop-extension.cl,v 1.1 2002/03/23 14:04:49 kevin Exp $
-;;;;
-;;;; The functions in this file were orignally distributed in the
-;;;; MaiSQL package in the file sql/sql.cl
-;;;; *************************************************************************
-
-(in-package :cl-user)
-
-;;;; MIT-LOOP extension
-
-#+cmu
-(defun loop-record-iteration-path (variable data-type prep-phrases)
-  (let ((in-phrase nil)
-       (from-phrase nil))
-    (loop for (prep . rest) in prep-phrases
-         do
-         (case prep
-           ((:in :of)
-            (when in-phrase
-              (ansi-loop::loop-error
-               "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
-            (setq in-phrase rest))
-           ((:from)
-            (when from-phrase
-              (ansi-loop::loop-error
-               "Duplicate FROM iteration path: ~S." (cons prep rest)))
-            (setq from-phrase rest))
-           (t
-            (ansi-loop::loop-error
-             "Unknown preposition: ~S." prep))))
-    (unless in-phrase
-      (ansi-loop::loop-error "Missing OF or IN iteration path."))
-    (unless from-phrase
-      (setq from-phrase '(*default-database*)))
-    (cond
-      ((consp variable)
-       (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-)))
-        (push `(when ,result-set-var
-                (database-dump-result-set ,result-set-var ,db-var))
-              ansi-loop::*loop-epilogue*)
-        `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
-           (,db-var ,(first from-phrase))
-           (,result-set-var nil)
-           (,step-var nil))
-          ((multiple-value-bind (%rs %cols)
-               (database-query-result-set ,query-var ,db-var)
-             (setq ,result-set-var %rs ,step-var (make-list %cols))))
-          ()
-          ()
-          (not (database-store-next-row ,result-set-var ,db-var ,step-var))
-          (,variable ,step-var)
-          (not ,result-set-var)
-          ()
-          (not (database-store-next-row ,result-set-var ,db-var ,step-var))
-          (,variable ,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-)))
-        (push `(when ,result-set-var
-                (database-dump-result-set ,result-set-var ,db-var))
-              ansi-loop::*loop-epilogue*)
-        `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
-           (,db-var ,(first from-phrase))
-           (,result-set-var nil))
-          ((multiple-value-bind (%rs %cols)
-               (database-query-result-set ,query-var ,db-var)
-             (setq ,result-set-var %rs ,variable (make-list %cols))))
-          ()
-          ()
-          (not (database-store-next-row ,result-set-var ,db-var ,variable))
-          ()
-          (not ,result-set-var)
-          ()
-          (not (database-store-next-row ,result-set-var ,db-var ,variable))
-          ()))))))
-
-#+cmu
-(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)

diff --git a/interfaces/postgresql/postgresql-usql.cl b/interfaces/postgresql/postgresql-usql.cl
index eeee53b3e33505fecd64bd40f73e7cd6eac58c5c..4633f390e964b57cb4d8a7fd3a2dd267e8a24552 100644 (file)
--- a/interfaces/postgresql/postgresql-usql.cl
+++ b/interfaces/postgresql/postgresql-usql.cl
@@ -7,7 +7,7 @@
 ;;;; Programmers:   Kevin M. Rosenberg and onShore Development Inc
 ;;;; Date Started:  Mar 2002
 ;;;;
 ;;;; Programmers:   Kevin M. Rosenberg and onShore Development Inc
 ;;;; Date Started:  Mar 2002
 ;;;;

-;;;; $Id: postgresql-usql.cl,v 1.3 2002/05/15 17:03:43 kevin Exp $
+;;;; $Id: postgresql-usql.cl,v 1.4 2002/05/15 17:10:28 kevin Exp $

 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and by onShore Development Inc.
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and by onShore Development Inc.


@@ -39,7 +39,7 @@
          (mapcar #'car
                  (database-query
                   (format nil
          (mapcar #'car
                  (database-query
                   (format nil

-                          "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'" relname)
+                          "SELECT attname FROM pg_class,pg_attribute WHERE pg_class.oid=attrelid AND relname='~A'" table)

                   database nil))))
     (if result
        (reverse
                   database nil))))
     (if result
        (reverse

diff --git a/sql/loop-extension.cl b/sql/loop-extension.cl
new file mode 100644 (file)
index 0000000..a36e1cc
--- /dev/null
+++ b/sql/loop-extension.cl
@@ -0,0 +1,98 @@
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name:          loop-extension.cl
+;;;; Purpose:       Extensions to the Loop macro for CMUCL
+;;;; Programmer:    Pierre R. Mai
+;;;;
+;;;; Copyright (c) 1999-2001 Pierre R. Mai
+;;;;
+;;;; $Id: loop-extension.cl,v 1.1 2002/05/15 17:10:28 kevin Exp $
+;;;;
+;;;; The functions in this file were orignally distributed in the
+;;;; MaiSQL package in the file sql/sql.cl
+;;;; *************************************************************************
+
+(in-package :cl-user)
+
+;;;; MIT-LOOP extension
+
+#+cmu
+(defun loop-record-iteration-path (variable data-type prep-phrases)
+  (let ((in-phrase nil)
+       (from-phrase nil))
+    (loop for (prep . rest) in prep-phrases
+         do
+         (case prep
+           ((:in :of)
+            (when in-phrase
+              (ansi-loop::loop-error
+               "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
+            (setq in-phrase rest))
+           ((:from)
+            (when from-phrase
+              (ansi-loop::loop-error
+               "Duplicate FROM iteration path: ~S." (cons prep rest)))
+            (setq from-phrase rest))
+           (t
+            (ansi-loop::loop-error
+             "Unknown preposition: ~S." prep))))
+    (unless in-phrase
+      (ansi-loop::loop-error "Missing OF or IN iteration path."))
+    (unless from-phrase
+      (setq from-phrase '(*default-database*)))
+    (cond
+      ((consp variable)
+       (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-)))
+        (push `(when ,result-set-var
+                (database-dump-result-set ,result-set-var ,db-var))
+              ansi-loop::*loop-epilogue*)
+        `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
+           (,db-var ,(first from-phrase))
+           (,result-set-var nil)
+           (,step-var nil))
+          ((multiple-value-bind (%rs %cols)
+               (database-query-result-set ,query-var ,db-var)
+             (setq ,result-set-var %rs ,step-var (make-list %cols))))
+          ()
+          ()
+          (not (database-store-next-row ,result-set-var ,db-var ,step-var))
+          (,variable ,step-var)
+          (not ,result-set-var)
+          ()
+          (not (database-store-next-row ,result-set-var ,db-var ,step-var))
+          (,variable ,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-)))
+        (push `(when ,result-set-var
+                (database-dump-result-set ,result-set-var ,db-var))
+              ansi-loop::*loop-epilogue*)
+        `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
+           (,db-var ,(first from-phrase))
+           (,result-set-var nil))
+          ((multiple-value-bind (%rs %cols)
+               (database-query-result-set ,query-var ,db-var)
+             (setq ,result-set-var %rs ,variable (make-list %cols))))
+          ()
+          ()
+          (not (database-store-next-row ,result-set-var ,db-var ,variable))
+          ()
+          (not ,result-set-var)
+          ()
+          (not (database-store-next-row ,result-set-var ,db-var ,variable))
+          ()))))))
+
+#+cmu
+(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)