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 (defpackage #:ansi-loop
  38   (:import-from #:excl
  39                 #:loop-error
  40                 #:*loop-epilogue*
  41                 #:*loop-ansi-universe*
  42                 #:add-loop-path))
  43
  44 #+sbcl
  45 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
  46   (gensym (string pref)))
  47
  48 #+(or cmu scl sbcl openmcl allegro)
  49 (defun loop-record-iteration-path (variable data-type prep-phrases)
  50   (let ((in-phrase nil)
  51         (from-phrase nil))
  52     (loop for (prep . rest) in prep-phrases
  53           do
  54           (case prep
  55             ((:in :of)
  56              (when in-phrase
  57                (ansi-loop::loop-error
  58                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
  59              (setq in-phrase rest))
  60             ((:from)
  61              (when from-phrase
  62                (ansi-loop::loop-error
  63                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
  64              (setq from-phrase rest))
  65             (t
  66              (ansi-loop::loop-error
  67               "Unknown preposition: ~S." prep))))
  68     (unless in-phrase
  69       (ansi-loop::loop-error "Missing OF or IN iteration path."))
  70     (unless from-phrase
  71       (setq from-phrase '(clsql-base-sys:*default-database*)))
  72     (cond
  73       ((consp variable)
  74        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
  75              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
  76              (result-set-var (ansi-loop::loop-gentemp
  77                               'loop-record-result-set-))
  78              (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
  79          (push `(when ,result-set-var
  80                   (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
  81                ansi-loop::*loop-epilogue*)
  82          `(((,variable nil ,@(and data-type (list data-type)))
  83             (,query-var ,(first in-phrase))
  84             (,db-var ,(first from-phrase))
  85             (,result-set-var nil)
  86             (,step-var nil))
  87            ((multiple-value-bind (%rs %cols)
  88                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
  89               (setq ,result-set-var %rs ,step-var (make-list %cols))))
  90            ()
  91            ()
  92            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  93            (,variable ,step-var)
  94            (not ,result-set-var)
  95            ()
  96            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  97            (,variable ,step-var))))
  98       (t
  99        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 100              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 101              (result-set-var (ansi-loop::loop-gentemp
 102                               'loop-record-result-set-)))
 103          (push `(when ,result-set-var
 104                  (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 105                ansi-loop::*loop-epilogue*)
 106          `(((,variable nil ,@(and data-type (list data-type)))
 107             (,query-var ,(first in-phrase))
 108             (,db-var ,(first from-phrase))
 109             (,result-set-var nil))
 110            ((multiple-value-bind (%rs %cols)
 111                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 112               (setq ,result-set-var %rs ,variable (make-list %cols))))
 113            ()
 114            ()
 115            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 116            ()
 117            (not ,result-set-var)
 118            ()
 119            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 120            ()))))))
 121
 122 #+(or cmu scl sbcl openmcl allegro)
 123 (ansi-loop::add-loop-path '(record records tuple tuples)
 124                           'loop-record-iteration-path
 125                           ansi-loop::*loop-ansi-universe*
 126                           :preposition-groups '((:of :in) (:from))
 127                           :inclusive-permitted nil)
 128
 129 #+lispworks (in-package loop)
 130
 131 #+lispworks
 132 (defun loop::loop-gentemp (&optional (pref 'loopva-))
 133   (gensym (string pref)))
 134
 135 #+lispworks
 136 (cl-user::define-loop-method (record records tuple tuples) ansi-loop::clsql-loop-method (in of from))
 137
 138 #+lispworks
 139 (defun ansi-loop::clsql-loop-method (method-name iter-var iter-var-data-type
 140                                      prep-phrases inclusive? allowed-preps
 141                                      method-specific-data)
 142   (let ((in-phrase nil)
 143         (from-phrase nil))
 144     (loop for (prep . rest) in prep-phrases
 145           do
 146           (cond
 147             ((or (eq prep 'in) (eq prep 'of))
 148              (when in-phrase
 149                (error
 150                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
 151              (setq in-phrase rest))
 152             ((eq prep 'from)
 153              (when from-phrase
 154                (error
 155                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
 156              (setq from-phrase rest))
 157             (t
 158              (error
 159               "Unknown preposition: ~S." prep))))
 160     (unless in-phrase
 161       (error "Missing OF or IN iteration path."))
 162     (unless from-phrase
 163       (setq from-phrase '(clsql-base-sys:*default-database*)))
 164     (cond
 165       ((consp iter-var)
 166        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 167              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 168              (result-set-var (ansi-loop::loop-gentemp
 169                               'loop-record-result-set-))
 170              (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
 171          (values
 172           t
 173           nil
 174           `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
 175             (,query-var ,in-phrase)
 176             (,db-var ,(first from-phrase))
 177             (,result-set-var nil)
 178             (,step-var nil))
 179           `((multiple-value-bind (%rs %cols)
 180                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 181               (setq ,result-set-var %rs ,step-var (make-list %cols))))
 182           ()
 183           ()
 184           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 185               (when ,result-set-var
 186                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 187               t))
 188           `(,iter-var ,step-var)
 189           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 190               (when ,result-set-var
 191                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 192               t))
 193           `(,iter-var ,step-var)
 194           ()
 195           ())))
 196       (t
 197        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 198              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 199              (result-set-var (ansi-loop::loop-gentemp
 200                               'loop-record-result-set-)))
 201          (values
 202           t
 203           nil
 204           `((,iter-var nil ,iter-var-data-type) (,query-var ,in-phrase)
 205             (,db-var ,(first from-phrase))
 206             (,result-set-var nil))
 207           `((multiple-value-bind (%rs %cols)
 208                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 209               (setq ,result-set-var %rs ,iter-var (make-list %cols))))
 210           ()
 211           ()
 212           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
 213               (when ,result-set-var
 214                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 215               t))
 216            ()
 217           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
 218               (when ,result-set-var
 219                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 220               t))
 221           ()
 222           ()
 223           ()))))))
 224