r4820: *** empty log message ***

[umlisp.git] / sql-classes.lisp

diff --git a/sql-classes.lisp b/sql-classes.lisp
index 8a400e10d3000cc7fd233fcc0fdf4c341e31220b..728c7560fe9fc9bed4fa2e84823e1a24e733f60d 100644 (file)
--- a/sql-classes.lisp
+++ b/sql-classes.lisp
@@ -7,7 +7,7 @@
 ;;;; Author:        Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: sql-classes.lisp,v 1.69 2003/05/04 04:41:07 kevin Exp $
+;;;; $Id: sql-classes.lisp,v 1.70 2003/05/05 23:13:28 kevin Exp $
 ;;;;
 ;;;; This file, part of UMLisp, is
 ;;;;    Copyright (c) 2000-2002 by Kevin M. Rosenberg, M.D.
@@ -68,7 +68,7 @@
                      " where ~A='~A'")))
               where-name where-value)
        "")
-   (if srl (format nil " and ~:@(~A~) <= ~D" lrl srl) "")
+   (if srl (format nil " and ~:@(~A~)<=~D" lrl srl) "")
    (if order (format nil " order by ~{~:@(~A~) ~(~A~)~^,~}" order) "")
    (if single " limit 1" "")))
 
@@ -94,7 +94,8 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                                    &key (lrl "KCUILRL") distinct single
                                    order like)
                             &body body)
-  (let ((value (gensym)))
+  (let ((value (gensym))
+       (r (gensym))) 
     (if single
        `(let* ((,value ,where-value)
                (tuple (car (umlisp-query ,table ,fields ,srl ,where-name ,value
@@ -106,19 +107,26 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
                (destructuring-bind ,fields tuple
                  ,@body)))
        `(let ((,value ,where-value))
-         ,@(unless where-name `((declare (ignore ,value))))
-         (loop for tuple in
-          (umlisp-query ,table ,fields ,srl ,where-name ,value
-           :lrl ,lrl :single ,single :distinct ,distinct
-           :order ,order :like ,like)
-          collect (destructuring-bind ,fields tuple
-                    ,@body))))))
+          ,@(unless where-name `((declare (ignore ,value))))
+          (let ((,r '()))
+            (dolist (tuple (umlisp-query ,table ,fields ,srl ,where-name ,value
+                                         :lrl ,lrl :single ,single :distinct ,distinct
+                                         :order ,order :like ,like))
+              (push (destructuring-bind ,fields tuple ,@body) ,r))
+            (nreverse ,r))
+          #+ignore
+          (loop for tuple in
+                (umlisp-query ,table ,fields ,srl ,where-name ,value
+                              :lrl ,lrl :single ,single :distinct ,distinct
+                              :order ,order :like ,like)
+              collect (destructuring-bind ,fields tuple ,@body))))))
 
 (defmacro with-umlisp-query-eval ((table fields srl where-name where-value
                                         &key (lrl "KCUILRL") distinct single
                                         order like)
                                  &body body)
   (let ((value (gensym))
+       (r (gensym))
        (eval-fields (cadr fields)))
     (if single
        `(let* ((,value ,where-value)
@@ -129,13 +137,19 @@ is OBJNAME from TABLE where WHERE-NAME field = WHERE-VALUE with FIELDS"
          (when tuple
            (destructuring-bind ,eval-fields tuple
              ,@body)))
-       `(let ((,value ,where-value))
-         (loop for tuple in
-          (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
-           :lrl ,lrl :single ,single :distinct ,distinct
-           :order ,order :like ,like)
-          collect (destructuring-bind ,eval-fields tuple
-                    ,@body))))))
+       `(let ((,value ,where-value)
+              (,r '()))
+          (dolist (tuple (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+                                            :lrl ,lrl :single ,single :distinct ,distinct
+                                            :order ,order :like ,like))
+            (push (destructuring-bind ,eval-fields tuple ,@body) ,r))
+          (nreverse ,r)
+          #+ignore
+          (loop for tuple in
+                (umlisp-query-eval ,table ,fields ,srl ,where-name ,value
+                                   :lrl ,lrl :single ,single :distinct ,distinct
+                                   :order ,order :like ,like)
+              collect (destructuring-bind ,eval-fields tuple ,@body))))))
 
 ;;;
 ;;; Read from SQL database