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 #+sbcl #:sb-loop #+allegro #:excl
27 #:*loop-ansi-universe*
31 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
32 (gensym (string pref)))
34 #+(or cmu scl sbcl openmcl allegro)
35 (defun loop-record-iteration-path (variable data-type prep-phrases)
38 (loop for (prep . rest) in prep-phrases
43 (ansi-loop::loop-error
44 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
45 (setq in-phrase rest))
48 (ansi-loop::loop-error
49 "Duplicate FROM iteration path: ~S." (cons prep rest)))
50 (setq from-phrase rest))
52 (ansi-loop::loop-error
53 "Unknown preposition: ~S." prep))))
55 (ansi-loop::loop-error "Missing OF or IN iteration path."))
57 (setq from-phrase '(clsql-base-sys:*default-database*)))
60 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
61 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
62 (result-set-var (ansi-loop::loop-gentemp
63 'loop-record-result-set-))
64 (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
65 (push `(when ,result-set-var
66 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
67 ansi-loop::*loop-epilogue*)
68 `(((,variable nil ,@(and data-type (list data-type)))
69 (,query-var ,(first in-phrase))
70 (,db-var ,(first from-phrase))
73 ((multiple-value-bind (%rs %cols)
74 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
75 (setq ,result-set-var %rs ,step-var (make-list %cols))))
78 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
82 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
83 (,variable ,step-var))))
85 (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
86 (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
87 (result-set-var (ansi-loop::loop-gentemp
88 'loop-record-result-set-)))
89 (push `(when ,result-set-var
90 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
91 ansi-loop::*loop-epilogue*)
92 `(((,variable nil ,@(and data-type (list data-type)))
93 (,query-var ,(first in-phrase))
94 (,db-var ,(first from-phrase))
95 (,result-set-var nil))
96 ((multiple-value-bind (%rs %cols)
97 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
98 (setq ,result-set-var %rs ,variable (make-list %cols))))
101 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
103 (not ,result-set-var)
105 (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
108 #+(or cmu scl sbcl openmcl allegro)
109 (ansi-loop::add-loop-path '(record records tuple tuples)
110 'loop-record-iteration-path
111 ansi-loop::*loop-ansi-universe*
112 :preposition-groups '((:of :in) (:from))
113 :inclusive-permitted nil)
115 #+lispworks (in-package loop)
118 (cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
122 (defun clsql-loop-method (method-name iter-var iter-var-data-type
123 prep-phrases inclusive? allowed-preps
124 method-specific-data)
125 (let ((in-phrase nil)
127 (loop for (prep . rest) in prep-phrases
130 ((or (eq prep 'in) (eq prep 'of))
133 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
134 (setq in-phrase rest))
138 "Duplicate FROM iteration path: ~S." (cons prep rest)))
139 (setq from-phrase rest))
142 "Unknown preposition: ~S." prep))))
144 (error "Missing OF or IN iteration path."))
146 (setq from-phrase '(clsql-base-sys:*default-database*)))
149 (let ((query-var (gensym 'loop-record-))
150 (db-var (gensym 'loop-record-database-))
151 (result-set-var (gensym 'loop-record-result-set-))
152 (step-var (gensym 'loop-record-step-)))
156 `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
157 (,query-var ,in-phrase)
158 (,db-var ,(first from-phrase))
159 (,result-set-var nil)
161 `((multiple-value-bind (%rs %cols)
162 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
163 (setq ,result-set-var %rs ,step-var (make-list %cols))))
166 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
167 (when ,result-set-var
168 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
170 `(,iter-var ,step-var)
171 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
172 (when ,result-set-var
173 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
175 `(,iter-var ,step-var)
179 (let ((query-var (gensym 'loop-record-))
180 (db-var (gensym 'loop-record-database-))
181 (result-set-var (gensym 'loop-record-result-set-)))
185 `((,iter-var nil ,iter-var-data-type) (,query-var ,in-phrase)
186 (,db-var ,(first from-phrase))
187 (,result-set-var nil))
188 `((multiple-value-bind (%rs %cols)
189 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
190 (setq ,result-set-var %rs ,iter-var (make-list %cols))))
193 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
194 (when ,result-set-var
195 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
198 `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
199 (when ,result-set-var
200 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))