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 ,@(and data-type (list data-type)))
  90             (,query-var ,(first in-phrase))
  91             (,db-var ,(first from-phrase))
  92             (,result-set-var nil)
  93             (,step-var nil))
  94            ((multiple-value-bind (%rs %cols)
  95                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
  96               (setq ,result-set-var %rs ,step-var (make-list %cols))))
  97            ()
  98            ()
  99            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
 100            (,variable ,step-var)
 101            (not ,result-set-var)
 102            ()
 103            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
 104            (,variable ,step-var))))
 105       (t
 106        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 107              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 108              (result-set-var (ansi-loop::loop-gentemp
 109                               'loop-record-result-set-)))
 110          (push `(when ,result-set-var
 111                  (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 112                ansi-loop::*loop-epilogue*)
 113          `(((,variable nil ,@(and data-type (list data-type)))
 114             (,query-var ,(first in-phrase))
 115             (,db-var ,(first from-phrase))
 116             (,result-set-var nil))
 117            ((multiple-value-bind (%rs %cols)
 118                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 119               (setq ,result-set-var %rs ,variable (make-list %cols))))
 120            ()
 121            ()
 122            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 123            ()
 124            (not ,result-set-var)
 125            ()
 126            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 127            ()))))))
 128
 129 #+(or cmu scl sbcl openmcl allegro)
 130 (ansi-loop::add-loop-path '(record records tuple tuples)
 131                           'loop-record-iteration-path
 132                           ansi-loop::*loop-ansi-universe*
 133                           :preposition-groups '((:of :in) (:from))
 134                           :inclusive-permitted nil)
 135
 136 #+lispworks (in-package loop)
 137
 138 #+lispworks
 139 (cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from))
 140
 141 #+lispworks
 142 (defun ansi-loop::clsql-loop-method (method-name iter-var iter-var-data-type
 143                                      prep-phrases inclusive? allowed-preps
 144                                      method-specific-data)
 145   (let ((in-phrase nil)
 146         (from-phrase nil))
 147     (loop for (prep . rest) in prep-phrases
 148           do
 149           (cond
 150             ((or (eq prep 'in) (eq prep 'of))
 151              (when in-phrase
 152                (error
 153                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
 154              (setq in-phrase rest))
 155             ((eq prep 'from)
 156              (when from-phrase
 157                (error
 158                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
 159              (setq from-phrase rest))
 160             (t
 161              (error
 162               "Unknown preposition: ~S." prep))))
 163     (unless in-phrase
 164       (error "Missing OF or IN iteration path."))
 165     (unless from-phrase
 166       (setq from-phrase '(clsql-base-sys:*default-database*)))
 167     (cond
 168       ((consp iter-var)
 169        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 170              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 171              (result-set-var (ansi-loop::loop-gentemp
 172                               'loop-record-result-set-))
 173              (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
 174          (values
 175           t
 176           nil
 177           `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
 178             (,query-var ,in-phrase)
 179             (,db-var ,(first from-phrase))
 180             (,result-set-var nil)
 181             (,step-var nil))
 182           `((multiple-value-bind (%rs %cols)
 183                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 184               (setq ,result-set-var %rs ,step-var (make-list %cols))))
 185           ()
 186           ()
 187           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 188               (when ,result-set-var
 189                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 190               t))
 191           `(,iter-var ,step-var)
 192           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 193               (when ,result-set-var
 194                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 195               t))
 196           `(,iter-var ,step-var)
 197           ()
 198           ())))
 199       (t
 200        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 201              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 202              (result-set-var (ansi-loop::loop-gentemp
 203                               'loop-record-result-set-)))
 204          (values
 205           t
 206           nil
 207           `((,iter-var nil ,iter-var-data-type) (,query-var ,in-phrase)
 208             (,db-var ,(first from-phrase))
 209             (,result-set-var nil))
 210           `((multiple-value-bind (%rs %cols)
 211                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 212               (setq ,result-set-var %rs ,iter-var (make-list %cols))))
 213           ()
 214           ()
 215           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
 216               (when ,result-set-var
 217                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 218               t))
 219            ()
 220           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
 221               (when ,result-set-var
 222                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 223               t))
 224           ()
 225           ()
 226           ()))))))
 227