X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=base%2Floop-extension.lisp;h=39a6dfd366461e74d5e3549fd2ffef031c25b81d;hb=fd11963eb2f46ffac6da2b18fab3d7ff2a4390cf;hp=52144885982b56372fab1fe0451e25845b40d355;hpb=c4da3cfcbb955395d8a556e1f89aadad696302b7;p=clsql.git diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp index 5214488..39a6dfd 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,8 +48,13 @@ (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*))) (cond + ;; Object query resulting in a list of returned object instances + #+ignore + ((consp (car in-phrase)) + (ansi-loop::loop-error "object query not yet supported")) + ((consp variable) (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) @@ -77,7 +62,7 @@ '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)) @@ -85,15 +70,15 @@ (,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) (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)) + (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 ,step-var)) + (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)) (,variable ,step-var)))) (t (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) @@ -101,22 +86,22 @@ (result-set-var (ansi-loop::loop-gentemp 'loop-record-result-set-))) (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)) ((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) (setq ,result-set-var %rs ,variable (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 ,variable)) () (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 ,variable)) ())))))) #+(or cmu scl sbcl openmcl allegro) @@ -126,19 +111,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 +145,19 @@ (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*))) + (cond + ;; Object query resulting in a list of returned object instances + #+ignore + ((consp (car in-phrase)) + (error "Object query not yet supported.")) + ((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,27 +167,26 @@ (,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) (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-))) + (let ((query-var (gensym "LOOP-RECORD-")) + (db-var (gensym "LOOP-RECORD-DATABASE-")) + (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))) (values t nil @@ -205,18 +194,18 @@ (,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) + (clsql-base: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) + `((unless (clsql-base: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)) + (clsql-base: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) + `((unless (clsql-base: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)) + (clsql-base:database-dump-result-set ,result-set-var ,db-var)) t)) () ()