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 ,data-type) (,query-var ,(first in-phrase))
90 (,db-var ,(first from-phrase))
93 ((multiple-value-bind (%rs %cols)
94 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
95 (setq ,result-set-var %rs ,step-var (make-list %cols))))
98 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
100 (not ,result-set-var)
102 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
103 (,variable ,step-var))))
105 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
106 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
107 (result-set-var (ansi-loop::loop-gentemp
108 'loop-record-result-set-)))
109 (push `(when ,result-set-var
110 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
111 ansi-loop::*loop-epilogue*)
112 `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
113 (,db-var ,(first from-phrase))
114 (,result-set-var nil))
115 ((multiple-value-bind (%rs %cols)
116 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
117 (setq ,result-set-var %rs ,variable (make-list %cols))))
120 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
122 (not ,result-set-var)
124 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
127 #+(or cmu scl sbcl openmcl allegro)
128 (ansi-loop::add-loop-path '(record records tuple tuples)
129 'loop-record-iteration-path
130 ansi-loop::*loop-ansi-universe*
131 :preposition-groups '((:of :in) (:from))
132 :inclusive-permitted nil)
134 #+lispworks (in-package loop)
137 (cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from))
140 (defun ansi-loop::clsql-loop-method (method-name iter-var iter-var-data-type
141 prep-phrases inclusive? allowed-preps
142 method-specific-data)
143 (let ((in-phrase nil)
145 (loop for (prep . rest) in prep-phrases
148 ((or (eq prep 'in) (eq prep 'of))
151 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
152 (setq in-phrase rest))
156 "Duplicate FROM iteration path: ~S." (cons prep rest)))
157 (setq from-phrase rest))
160 "Unknown preposition: ~S." prep))))
162 (error "Missing OF or IN iteration path."))
164 (setq from-phrase '(clsql-base-sys:*default-database*)))
167 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
168 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
169 (result-set-var (ansi-loop::loop-gentemp
170 'loop-record-result-set-))
171 (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
173 (push `(when ,result-set-var
174 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
175 ansi-loop::*epilogue*)
176 `(((,iter-var nil ,iter-var-data-type) (,query-var ,(first in-phrase))
177 (,db-var ,(first from-phrase))
178 (,result-set-var nil)
180 ((multiple-value-bind (%rs %cols)
181 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
182 (setq ,result-set-var %rs ,step-var (make-list %cols))))
185 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
186 (,iter-var ,step-var)
187 (not ,result-set-var)
189 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
190 (,iter-var ,step-var))))
192 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
193 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
194 (result-set-var (ansi-loop::loop-gentemp
195 'loop-record-result-set-)))
197 (push `(when ,result-set-var
198 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
199 ansi-loop::*epilogue*)
200 `(((,iter-var nil ,iter-var-data-type) (,query-var ,(first in-phrase))
201 (,db-var ,(first from-phrase))
202 (,result-set-var nil))
203 ((multiple-value-bind (%rs %cols)
204 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
205 (setq ,result-set-var %rs ,iter-var (make-list %cols))))
208 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var))
210 (not ,result-set-var)
212 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var))