r9299: 10 May 2004 Kevin Rosenberg (kevin@rosenberg.net)

[clsql.git] / base / loop-extension.lisp

diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp
index 335a9d234b93a0b5ef37d16c872ab6c8f8840c10..1746832147e8e3e28f0e827e49107ca1eb79e9f6 100644 (file)
--- a/base/loop-extension.lisp
+++ b/base/loop-extension.lisp
@@ -2,7 +2,7 @@
 ;;;; *************************************************************************
 ;;;; FILE IDENTIFICATION
 ;;;;
-;;;; Name: loop-extension.lisp
+;;;; Name:    loop-extension.lisp
 ;;;; Purpose: Extensions to the Loop macro for CLSQL
 ;;;;
 ;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
@@ -54,21 +54,22 @@
       (setq variable (list variable)))
 
     (cond
-      ;; Object query resulting in a list of returned object instances
-      #+ignore
-      ((and (consp (first in-phrase))
-           (consp (second (first in-phrase)))
-           (eq 'quote (first (second (first in-phrase))))
-           (symbolp (second (second (first in-phrase)))))
+     ;; object query
+     ((and (consp (first in-phrase))
+          (string-equal "sql-query" (symbol-name (caar in-phrase)))
+          (consp (second (first in-phrase)))
+          (eq 'quote (first (second (first in-phrase))))
+          (symbolp (second (second (first in-phrase)))))
 
        (let ((result-var (ansi-loop::loop-gentemp
                              'loop-record-result-))
             (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
         `(((,variable nil ,@(and data-type (list data-type)))
-           (,result-var ,(first in-phrase))
+           (,result-var (clsql-base:query ,(first in-phrase)))
            (,step-var nil))
           ()
           ()
+          ()
           (if (null ,result-var)
               t
               (progn
@@ -159,12 +160,41 @@
       (setq iter-var (list iter-var)))
 
     (cond
-      ;; Object query resulting in a list of returned object instances
-      ((and (consp (car in-phrase))
-           (consp (second (car in-phrase)))
-           (eq 'quote (first (second (car in-phrase))))
-           (symbolp (second (second (car in-phrase)))))
-       (loop-error "object query not yet supported"))
+     ;; object query
+     ((and (consp in-phrase)
+          (string-equal "sql-query" (symbol-name (car in-phrase)))
+          (consp (second in-phrase))
+          (eq 'quote (first (second in-phrase)))
+          (symbolp (second (second in-phrase))))
+
+       (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
+            (step-var (gensym "LOOP-RECORD-STEP-")))
+        (values
+         t
+         nil
+         `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
+             (,result-var (clsql-base:query ,in-phrase))
+             (,step-var nil))
+         ()
+         ()
+         ()
+         `((if (null ,result-var)
+               t
+               (progn
+                 (setq ,step-var (first ,result-var))
+                 (setq ,result-var (rest ,result-var))
+                 nil)))
+         `(,iter-var ,step-var)
+         `((if (null ,result-var)
+               t
+               (progn
+                 (setq ,step-var (first ,result-var))
+                 (setq ,result-var (rest ,result-var))
+                 nil)))
+          `(,iter-var ,step-var)
+          ()
+          ()
+          )))
       
       ((consp iter-var)
        (let ((query-var (gensym "LOOP-RECORD-"))