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
))
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
)
136 (cl-user::define-loop-method
(loop::record loop
::records loop
::tuple loop
::tuples
)
138 (loop::in loop
::of loop
::from
))
141 (defun clsql-loop-method (method-name iter-var iter-var-data-type
142 prep-phrases inclusive? allowed-preps
143 method-specific-data
)
144 (declare (ignore method-name iter-var-data-type inclusive? allowed-preps method-specific-data
))
145 (let ((in-phrase nil
)
147 (loop for
(prep . rest
) in prep-phrases
150 ((or (eq prep
'loop
::in
) (eq prep
'loop
::of
))
152 (error 'clsql
:sql-user-error
154 (format nil
"Duplicate OF or IN iteration path: ~S."
156 (setq in-phrase rest
))
157 ((eq prep
'loop
::from
)
159 (error 'clsql
:sql-user-error
161 (format nil
"Duplicate FROM iteration path: ~S."
163 (setq from-phrase rest
))
165 (error 'clsql
:sql-user-error
166 :message
(format nil
"Unknown preposition: ~S." prep
)))))
168 (error 'clsql
:sql-user-error
169 :message
"Missing OF or IN iteration path."))
171 (setq from-phrase
'(clsql:*default-database
*)))
173 (unless (consp iter-var
)
174 (setq iter-var
(list iter-var
)))
178 ((and (consp in-phrase
)
179 (string-equal "sql-query" (symbol-name (car in-phrase
)))
180 (consp (second in-phrase
))
181 (eq 'quote
(first (second in-phrase
)))
182 (symbolp (second (second in-phrase
))))
184 (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
185 (step-var (gensym "LOOP-RECORD-STEP-")))
189 `(,@(mapcar (lambda (v) `(,v nil
)) iter-var
)
190 (,result-var
(clsql:query
,in-phrase
))
195 `((if (null ,result-var
)
198 (setq ,step-var
(first ,result-var
))
199 (setq ,result-var
(rest ,result-var
))
201 `(,iter-var
,step-var
)
202 `((if (null ,result-var
)
205 (setq ,step-var
(first ,result-var
))
206 (setq ,result-var
(rest ,result-var
))
208 `(,iter-var
,step-var
)
214 (let ((query-var (gensym "LOOP-RECORD-"))
215 (db-var (gensym "LOOP-RECORD-DATABASE-"))
216 (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
217 (step-var (gensym "LOOP-RECORD-STEP-")))
221 `(,@(mapcar (lambda (v) `(,v nil
)) iter-var
)
222 (,query-var
,in-phrase
)
223 (,db-var
,(first from-phrase
))
224 (,result-set-var nil
)
226 `((multiple-value-bind (%rs %cols
)
227 (clsql-sys:database-query-result-set
,query-var
,db-var
:result-types
:auto
)
228 (setq ,result-set-var %rs
,step-var
(make-list %cols
))))
231 `((unless (clsql-sys:database-store-next-row
,result-set-var
,db-var
,step-var
)
232 (when ,result-set-var
233 (clsql-sys:database-dump-result-set
,result-set-var
,db-var
))
235 `(,iter-var
,step-var
)
236 `((unless (clsql-sys:database-store-next-row
,result-set-var
,db-var
,step-var
)
237 (when ,result-set-var
238 (clsql-sys:database-dump-result-set
,result-set-var
,db-var
))
240 `(,iter-var
,step-var
)
246 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
247 (setq cl
:*features
* (delete :clisp-aloop cl
:*features
*)))