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 #+(or allegro sbcl)
  22 (eval-when (:compile-toplevel :load-toplevel :execute)
  23   (defpackage #:ansi-loop
  24     (:import-from #+sbcl #:sb-loop #+allegro #:excl
  25                   #:loop-error
  26                   #:*loop-epilogue*
  27                   #:*loop-ansi-universe*
  28                   #:add-loop-path)))
  29
  30 #+(or allegro sbcl)
  31 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
  32   (gensym (string pref)))
  33
  34 #+(or cmu scl sbcl openmcl allegro)
  35 (defun loop-record-iteration-path (variable data-type prep-phrases)
  36   (let ((in-phrase nil)
  37         (from-phrase nil))
  38     (loop for (prep . rest) in prep-phrases
  39           do
  40           (case prep
  41             ((:in :of)
  42              (when in-phrase
  43                (ansi-loop::loop-error
  44                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
  45              (setq in-phrase rest))
  46             ((:from)
  47              (when from-phrase
  48                (ansi-loop::loop-error
  49                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
  50              (setq from-phrase rest))
  51             (t
  52              (ansi-loop::loop-error
  53               "Unknown preposition: ~S." prep))))
  54     (unless in-phrase
  55       (ansi-loop::loop-error "Missing OF or IN iteration path."))
  56     (unless from-phrase
  57       (setq from-phrase '(clsql-base-sys:*default-database*)))
  58     (cond
  59       ((consp variable)
  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))
  71             (,result-set-var nil)
  72             (,step-var nil))
  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))))
  76            ()
  77            ()
  78            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  79            (,variable ,step-var)
  80            (not ,result-set-var)
  81            ()
  82            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  83            (,variable ,step-var))))
  84       (t
  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))))
  99            ()
 100            ()
 101            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 102            ()
 103            (not ,result-set-var)
 104            ()
 105            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 106            ()))))))
 107
 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)
 114
 115 #+lispworks (in-package loop)
 116
 117 #+lispworks
 118 (cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
 119   (in of from))
 120
 121 #+lispworks
 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)
 126         (from-phrase nil))
 127     (loop for (prep . rest) in prep-phrases
 128           do
 129           (cond
 130             ((or (eq prep 'in) (eq prep 'of))
 131              (when in-phrase
 132                (error
 133                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
 134              (setq in-phrase rest))
 135             ((eq prep 'from)
 136              (when from-phrase
 137                (error
 138                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
 139              (setq from-phrase rest))
 140             (t
 141              (error
 142               "Unknown preposition: ~S." prep))))
 143     (unless in-phrase
 144       (error "Missing OF or IN iteration path."))
 145     (unless from-phrase
 146       (setq from-phrase '(clsql-base-sys:*default-database*)))
 147     (cond
 148       ((consp iter-var)
 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-)))
 153          (values
 154           t
 155           nil
 156           `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
 157             (,query-var ,in-phrase)
 158             (,db-var ,(first from-phrase))
 159             (,result-set-var nil)
 160             (,step-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))))
 164           ()
 165           ()
 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))
 169               t))
 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))
 174               t))
 175           `(,iter-var ,step-var)
 176           ()
 177           ())))
 178       (t
 179        (let ((query-var (gensym 'loop-record-))
 180              (db-var (gensym 'loop-record-database-))
 181              (result-set-var (gensym 'loop-record-result-set-)))
 182          (values
 183           t
 184           nil
 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))))
 191           ()
 192           ()
 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))
 196               t))
 197            ()
 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))
 201               t))
 202           ()
 203           ()
 204           ()))))))
 205