base/loop-extension.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          loop-extension.lisp
   6 ;;;; Purpose:       Extensions to the Loop macro for CMUCL
   7 ;;;; Programmer:    Pierre R. Mai
   8 ;;;;
   9 ;;;; Copyright (c) 1999-2001 Pierre R. Mai
  10 ;;;;
  11 ;;;; $Id$
  12 ;;;;
  13 ;;;; The functions in this file were orignally distributed in the
  14 ;;;; MaiSQL package in the file sql/sql.cl
  15 ;;;; *************************************************************************
  16
  17 (in-package #:cl-user)
  18
  19 ;;;; MIT-LOOP extension
  20
  21 #+sbcl
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23   (defpackage #:ansi-loop
  24     (:import-from #:sb-loop
  25                   #:loop-error
  26                   #:*loop-epilogue*
  27                   #:*loop-ansi-universe*
  28                   #:add-loop-path)))
  29
  30 #+lispworks
  31 (eval-when (:compile-toplevel :load-toplevel :execute)
  32   (defpackage #:ansi-loop
  33     (:import-from #:loop
  34                   #:*epilogue*)))
  35
  36 #+allegro
  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
  41                       (cons '#:ansi-loop
  42                             (package-nicknames (find-package '#:excl)))))))
  43
  44 #+lispworks
  45 (eval-when (:compile-toplevel :load-toplevel :execute)
  46   (unless (find-package '#:ansi-loop)
  47     (rename-package '#:loop '#:loop
  48                     (cons '#:ansi-loop
  49                           (package-nicknames (find-package '#:loop))))))
  50
  51 #+(or sbcl lispworks)
  52 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
  53   (gensym (string pref)))
  54
  55 #+(or cmu scl sbcl openmcl allegro)
  56 (defun loop-record-iteration-path (variable data-type prep-phrases)
  57   (let ((in-phrase nil)
  58         (from-phrase nil))
  59     (loop for (prep . rest) in prep-phrases
  60           do
  61           (case prep
  62             ((:in :of)
  63              (when in-phrase
  64                (ansi-loop::loop-error
  65                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
  66              (setq in-phrase rest))
  67             ((:from)
  68              (when from-phrase
  69                (ansi-loop::loop-error
  70                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
  71              (setq from-phrase rest))
  72             (t
  73              (ansi-loop::loop-error
  74               "Unknown preposition: ~S." prep))))
  75     (unless in-phrase
  76       (ansi-loop::loop-error "Missing OF or IN iteration path."))
  77     (unless from-phrase
  78       (setq from-phrase '(clsql-base-sys:*default-database*)))
  79     (cond
  80       ((consp variable)
  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))
  91             (,result-set-var nil)
  92             (,step-var nil))
  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))))
  96            ()
  97            ()
  98            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  99            (,variable ,step-var)
 100            (not ,result-set-var)
 101            ()
 102            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
 103            (,variable ,step-var))))
 104       (t
 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))))
 118            ()
 119            ()
 120            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 121            ()
 122            (not ,result-set-var)
 123            ()
 124            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 125            ()))))))
 126
 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)
 133
 134 #+lispworks (in-package loop)
 135
 136 #+lispworks
 137 (cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from))
 138
 139 #+lispworks
 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)
 144         (from-phrase nil))
 145     (loop for (prep . rest) in prep-phrases
 146           do
 147           (cond
 148             ((or (eq prep 'in) (eq prep 'of))
 149              (when in-phrase
 150                (error
 151                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
 152              (setq in-phrase rest))
 153             ((eq prep 'from)
 154              (when from-phrase
 155                (error
 156                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
 157              (setq from-phrase rest))
 158             (t
 159              (error
 160               "Unknown preposition: ~S." prep))))
 161     (unless in-phrase
 162       (error "Missing OF or IN iteration path."))
 163     (unless from-phrase
 164       (setq from-phrase '(clsql-base-sys:*default-database*)))
 165     (cond
 166       ((consp iter-var)
 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-)))
 172          #+ignore
 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)
 179             (,step-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))))
 183            ()
 184            ()
 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)
 188            ()
 189            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
 190            (,iter-var ,step-var))))
 191       (t
 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-)))
 196          #+ignore
 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))))
 206            ()
 207            ()
 208            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var))
 209            ()
 210            (not ,result-set-var)
 211            ()
 212            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var))
 213            ()))))))
 214
 215
 216