X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=base%2Floop-extension.lisp;h=1746832147e8e3e28f0e827e49107ca1eb79e9f6;hp=52144885982b56372fab1fe0451e25845b40d355;hb=09f07ac9d914a83f9426609f3264f4e66b5a6d97;hpb=c4da3cfcbb955395d8a556e1f89aadad696302b7 diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp index 5214488..1746832 100644 --- a/base/loop-extension.lisp +++ b/base/loop-extension.lisp @@ -2,46 +2,26 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: loop-extension.lisp -;;;; Purpose: Extensions to the Loop macro for CMUCL -;;;; Programmer: Pierre R. Mai +;;;; Name: loop-extension.lisp +;;;; Purpose: Extensions to the Loop macro for CLSQL ;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai +;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai ;;;; ;;;; $Id$ -;;;; -;;;; 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 - -#+sbcl +#+(or allegro sbcl) (eval-when (:compile-toplevel :load-toplevel :execute) (defpackage #:ansi-loop - (:import-from #:sb-loop + (:import-from #+sbcl #:sb-loop #+allegro #:excl #:loop-error #:*loop-epilogue* #:*loop-ansi-universe* #:add-loop-path))) -#+lispworks -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:ansi-loop - (:import-from #:loop - #:*epilogue*))) - -#+allegro -(defpackage #:ansi-loop - (:import-from #:excl - #:loop-error - #:*loop-epilogue* - #:*loop-ansi-universe* - #:add-loop-path)) - -#+sbcl +#+(or allegro sbcl) (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) (gensym (string pref))) @@ -68,56 +48,70 @@ (unless in-phrase (ansi-loop::loop-error "Missing OF or IN iteration path.")) (unless from-phrase - (setq from-phrase '(clsql-base-sys:*default-database*))) + (setq from-phrase '(clsql-base:*default-database*))) + + (unless (consp variable) + (setq variable (list variable))) + (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-)) + ;; 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-))) - (push `(when ,result-set-var - (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) `(((,variable nil ,@(and data-type (list data-type))) - (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var nil) + (,result-var (clsql-base:query ,(first in-phrase))) (,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)) + () + (if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil)) (,variable ,step-var) - (not ,result-set-var) + (null ,result-var) () - (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)) + (if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil)) (,variable ,step-var)))) - (t + + ((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-))) + 'loop-record-result-set-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) (push `(when ,result-set-var - (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) + (clsql-base:database-dump-result-set ,result-set-var ,db-var)) ansi-loop::*loop-epilogue*) `(((,variable nil ,@(and data-type (list data-type))) (,query-var ,(first in-phrase)) (,db-var ,(first from-phrase)) - (,result-set-var nil)) + (,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 ,variable (make-list %cols)))) - () + (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) () - (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable)) () + (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) (not ,result-set-var) () - (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable)) - ())))))) + (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var))))))) #+(or cmu scl sbcl openmcl allegro) (ansi-loop::add-loop-path '(record records tuple tuples) @@ -126,19 +120,19 @@ :preposition-groups '((:of :in) (:from)) :inclusive-permitted nil) -#+lispworks (in-package loop) - -#+lispworks -(defun loop::loop-gentemp (&optional (pref 'loopva-)) - (gensym (string pref))) +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (in-package loop)) #+lispworks -(cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from)) +(cl-user::define-loop-method (record records tuple tuples) 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) +(defun clsql-loop-method (method-name iter-var iter-var-data-type + prep-phrases inclusive? allowed-preps + method-specific-data) + (declare (ignore method-name inclusive? allowed-preps method-specific-data)) (let ((in-phrase nil) (from-phrase nil)) (loop for (prep . rest) in prep-phrases @@ -160,14 +154,53 @@ (unless in-phrase (error "Missing OF or IN iteration path.")) (unless from-phrase - (setq from-phrase '(clsql-base-sys:*default-database*))) + (setq from-phrase '(clsql-base:*default-database*))) + + (unless (consp iter-var) + (setq iter-var (list iter-var))) + (cond + ;; 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 (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-))) + (let ((query-var (gensym "LOOP-RECORD-")) + (db-var (gensym "LOOP-RECORD-DATABASE-")) + (result-set-var (gensym "LOOP-RECORD-RESULT-SET-")) + (step-var (gensym "LOOP-RECORD-STEP-"))) (values t nil @@ -177,48 +210,20 @@ (,result-set-var nil) (,step-var nil)) `((multiple-value-bind (%rs %cols) - (clsql-base-sys:database-query-result-set ,query-var ,db-var) + (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto) (setq ,result-set-var %rs ,step-var (make-list %cols)))) () () - `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var) + `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var) (when ,result-set-var - (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) + (clsql-base:database-dump-result-set ,result-set-var ,db-var)) t)) `(,iter-var ,step-var) - `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var) + `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var) (when ,result-set-var - (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) + (clsql-base:database-dump-result-set ,result-set-var ,db-var)) t)) `(,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-))) - (values - t - nil - `((,iter-var nil ,iter-var-data-type) (,query-var ,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)))) - () - () - `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var) - (when ,result-set-var - (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) - t)) - () - `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var) - (when ,result-set-var - (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var)) - t)) - () - () ()))))))