1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: loop-extension.lisp
6 ;;;; Purpose: Extensions to the Loop macro for CMUCL
7 ;;;; Programmer: Pierre R. Mai
9 ;;;; Copyright (c) 1999-2001 Pierre R. Mai
13 ;;;; The functions in this file were orignally distributed in the
14 ;;;; MaiSQL package in the file sql/sql.cl
15 ;;;; *************************************************************************
17 (in-package #:cl-user)
19 ;;;; MIT-LOOP extension
22 (eval-when (:compile-toplevel :load-toplevel :execute)
23 (defpackage #:ansi-loop
24 (:import-from #:sb-loop
27 #:*loop-ansi-universe*
31 (eval-when (:compile-toplevel :load-toplevel :execute)
32 (defpackage #:ansi-loop
37 (eval-when (:compile-toplevel :load-toplevel :execute)
38 (unless (find-package '#:ansi-loop)
39 (let ((excl::*enable-package-locked-errors* nil))
40 (rename-package '#:excl '#:excl
42 (package-nicknames (find-package '#:excl)))))))
45 (eval-when (:compile-toplevel :load-toplevel :execute)
46 (unless (find-package '#:ansi-loop)
47 (rename-package '#:loop '#:loop
49 (package-nicknames (find-package '#:loop))))))
52 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
53 (gensym (string pref)))
55 #+(or cmu scl sbcl openmcl allegro)
56 (defun loop-record-iteration-path (variable data-type prep-phrases)
59 (loop for (prep . rest) in prep-phrases
64 (ansi-loop::loop-error
65 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
66 (setq in-phrase rest))
69 (ansi-loop::loop-error
70 "Duplicate FROM iteration path: ~S." (cons prep rest)))
71 (setq from-phrase rest))
73 (ansi-loop::loop-error
74 "Unknown preposition: ~S." prep))))
76 (ansi-loop::loop-error "Missing OF or IN iteration path."))
78 (setq from-phrase '(clsql-base-sys:*default-database*)))
81 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
82 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
83 (result-set-var (ansi-loop::loop-gentemp
84 'loop-record-result-set-))
85 (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
86 (push `(when ,result-set-var
87 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
88 ansi-loop::*loop-epilogue*)
89 `(((,variable nil ,@(and data-type (list data-type)))
90 (,query-var ,(first in-phrase))
91 (,db-var ,(first from-phrase))
94 ((multiple-value-bind (%rs %cols)
95 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
96 (setq ,result-set-var %rs ,step-var (make-list %cols))))
99 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
100 (,variable ,step-var)
101 (not ,result-set-var)
103 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
104 (,variable ,step-var))))
106 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
107 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
108 (result-set-var (ansi-loop::loop-gentemp
109 'loop-record-result-set-)))
110 (push `(when ,result-set-var
111 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
112 ansi-loop::*loop-epilogue*)
113 `(((,variable nil ,@(and data-type (list data-type)))
114 (,query-var ,(first in-phrase))
115 (,db-var ,(first from-phrase))
116 (,result-set-var nil))
117 ((multiple-value-bind (%rs %cols)
118 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
119 (setq ,result-set-var %rs ,variable (make-list %cols))))
122 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
124 (not ,result-set-var)
126 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
129 #+(or cmu scl sbcl openmcl allegro)
130 (ansi-loop::add-loop-path '(record records tuple tuples)
131 'loop-record-iteration-path
132 ansi-loop::*loop-ansi-universe*
133 :preposition-groups '((:of :in) (:from))
134 :inclusive-permitted nil)
136 #+lispworks (in-package loop)
139 (cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from))
142 (defun ansi-loop::clsql-loop-method (method-name iter-var iter-var-data-type
143 prep-phrases inclusive? allowed-preps
144 method-specific-data)
145 (let ((in-phrase nil)
147 (loop for (prep . rest) in prep-phrases
150 ((or (eq prep 'in) (eq prep 'of))
153 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
154 (setq in-phrase rest))
158 "Duplicate FROM iteration path: ~S." (cons prep rest)))
159 (setq from-phrase rest))
162 "Unknown preposition: ~S." prep))))
164 (error "Missing OF or IN iteration path."))
166 (setq from-phrase '(clsql-base-sys:*default-database*)))
169 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
170 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
171 (result-set-var (ansi-loop::loop-gentemp
172 'loop-record-result-set-))
173 (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
177 `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
178 (,query-var ,in-phrase)
179 (,db-var ,(first from-phrase))
180 (,result-set-var nil)
182 `((multiple-value-bind (%rs %cols)
183 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
184 (setq ,result-set-var %rs ,step-var (make-list %cols))))
187 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
188 (when ,result-set-var
189 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
191 `(,iter-var ,step-var)
192 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
193 (when ,result-set-var
194 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
196 `(,iter-var ,step-var)
200 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
201 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
202 (result-set-var (ansi-loop::loop-gentemp
203 'loop-record-result-set-)))
207 `((,iter-var nil ,iter-var-data-type) (,query-var ,in-phrase)
208 (,db-var ,(first from-phrase))
209 (,result-set-var nil))
210 `((multiple-value-bind (%rs %cols)
211 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
212 (setq ,result-set-var %rs ,iter-var (make-list %cols))))
215 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
216 (when ,result-set-var
217 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
220 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
221 (when ,result-set-var
222 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))