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 CLSQL
8 ;;;; Copyright (c) 2001-2006 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
11 ;;;; *************************************************************************
13 (in-package #:clsql-sys
)
16 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
17 (defpackage #:ansi-loop
18 (:import-from
#+sbcl
#:sb-loop
#+allegro
#:excl
20 #:*loop-ansi-universe
*
24 (defun ansi-loop::loop-gentemp
(&optional
(pref 'loopva-
))
25 (gensym (string pref
)))
28 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
29 (when (find-package "ANSI-LOOP") (push :clisp-aloop cl
:*features
*)))
31 #+(or allegro clisp-aloop cmu openmcl sbcl scl
)
32 (defun loop-record-iteration-path (variable data-type prep-phrases
)
35 (loop for
(prep . rest
) in prep-phrases
40 (error 'clsql
:sql-user-error
43 "Duplicate OF or IN iteration path: ~S."
45 (setq in-phrase rest
))
48 (error 'clsql
:sql-user-error
51 "Duplicate FROM iteration path: ~S."
53 (setq from-phrase rest
))
55 (error 'clsql
:sql-user-error
57 (format nil
"Unknown preposition: ~S." prep
)))))
59 (error 'clsql
:sql-user-error
60 :message
"Missing OF or IN iteration path."))
62 (setq from-phrase
'(*default-database
*)))
64 (unless (consp variable
)
65 (setq variable
(list variable
)))
69 ((and (consp (first in-phrase
))
70 (string-equal "sql-query" (symbol-name (caar in-phrase
)))
71 (consp (second (first in-phrase
)))
72 (eq 'quote
(first (second (first in-phrase
))))
73 (symbolp (second (second (first in-phrase
)))))
75 (let ((result-var (ansi-loop::loop-gentemp
76 'loop-record-result-
))
77 (step-var (ansi-loop::loop-gentemp
'loop-record-step-
)))
78 `(((,variable nil
,@(and data-type
(list data-type
)))
79 (,result-var
(query ,(first in-phrase
)))
84 (if (null ,result-var
)
87 (setq ,step-var
(first ,result-var
))
88 (setq ,result-var
(rest ,result-var
))
93 (if (null ,result-var
)
96 (setq ,step-var
(first ,result-var
))
97 (setq ,result-var
(rest ,result-var
))
99 (,variable
,step-var
))))
102 (let ((query-var (ansi-loop::loop-gentemp
'loop-record-
))
103 (db-var (ansi-loop::loop-gentemp
'loop-record-database-
))
104 (result-set-var (ansi-loop::loop-gentemp
105 'loop-record-result-set-
))
106 (step-var (ansi-loop::loop-gentemp
'loop-record-step-
)))
107 (push `(when ,result-set-var
108 (database-dump-result-set ,result-set-var
,db-var
))
109 ansi-loop
::*loop-epilogue
*)
110 `(((,variable nil
,@(and data-type
(list data-type
)))
111 (,query-var
,(first in-phrase
))
112 (,db-var
,(first from-phrase
))
113 (,result-set-var nil
)
115 ((multiple-value-bind (%rs %cols
)
116 (database-query-result-set ,query-var
,db-var
:result-types
:auto
)
117 (setq ,result-set-var %rs
,step-var
(make-list %cols
))))
120 (not (database-store-next-row ,result-set-var
,db-var
,step-var
))
121 (,variable
,step-var
)
122 (not ,result-set-var
)
124 (not (database-store-next-row ,result-set-var
,db-var
,step-var
))
125 (,variable
,step-var
)))))))
127 #+(or allegro clisp-aloop cmu openmcl sbcl scl
)
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
)
135 (cl-user::define-loop-method
(record records tuple tuples
) clsql-loop-method
139 (defun clsql-loop-method (method-name iter-var iter-var-data-type
140 prep-phrases inclusive? allowed-preps
141 method-specific-data
)
142 (declare (ignore method-name inclusive? allowed-preps method-specific-data
))
143 (let ((in-phrase nil
)
145 (loop for
(prep . rest
) in prep-phrases
148 ((or (eq prep
'in
) (eq prep
'of
))
150 (error 'clsql
:sql-user-error
152 (format nil
"Duplicate OF or IN iteration path: ~S."
154 (setq in-phrase rest
))
157 (error 'clsql
:sql-user-error
159 (format nil
"Duplicate FROM iteration path: ~S."
161 (setq from-phrase rest
))
163 (error 'clsql
:sql-user-error
164 :message
(format nil
"Unknown preposition: ~S." prep
)))))
166 (error 'clsql
:sql-user-error
167 :message
"Missing OF or IN iteration path."))
169 (setq from-phrase
'(clsql:*default-database
*)))
171 (unless (consp iter-var
)
172 (setq iter-var
(list iter-var
)))
176 ((and (consp in-phrase
)
177 (string-equal "sql-query" (symbol-name (car in-phrase
)))
178 (consp (second in-phrase
))
179 (eq 'quote
(first (second in-phrase
)))
180 (symbolp (second (second in-phrase
))))
182 (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
183 (step-var (gensym "LOOP-RECORD-STEP-")))
187 `(,@(mapcar (lambda (v) `(,v nil
)) iter-var
)
188 (,result-var
(clsql:query
,in-phrase
))
193 `((if (null ,result-var
)
196 (setq ,step-var
(first ,result-var
))
197 (setq ,result-var
(rest ,result-var
))
199 `(,iter-var
,step-var
)
200 `((if (null ,result-var
)
203 (setq ,step-var
(first ,result-var
))
204 (setq ,result-var
(rest ,result-var
))
206 `(,iter-var
,step-var
)
212 (let ((query-var (gensym "LOOP-RECORD-"))
213 (db-var (gensym "LOOP-RECORD-DATABASE-"))
214 (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
215 (step-var (gensym "LOOP-RECORD-STEP-")))
219 `(,@(mapcar (lambda (v) `(,v nil
)) iter-var
)
220 (,query-var
,in-phrase
)
221 (,db-var
,(first from-phrase
))
222 (,result-set-var nil
)
224 `((multiple-value-bind (%rs %cols
)
225 (database-query-result-set ,query-var
,db-var
:result-types
:auto
)
226 (setq ,result-set-var %rs
,step-var
(make-list %cols
))))
229 `((unless (database-store-next-row ,result-set-var
,db-var
,step-var
)
230 (when ,result-set-var
231 (database-dump-result-set ,result-set-var
,db-var
))
233 `(,iter-var
,step-var
)
234 `((unless (database-store-next-row ,result-set-var
,db-var
,step-var
)
235 (when ,result-set-var
236 (database-dump-result-set ,result-set-var
,db-var
))
238 `(,iter-var
,step-var
)
244 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
245 (setq cl
:*features
* (delete :clisp-aloop cl
:*features
*)))