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
 116 (eval-when (:compile-toplevel :load-toplevel :execute)
 117   (in-package loop))
 118
 119 #+lispworks
 120 (cl-user::define-loop-method (record records tuple tuples) clsql-loop-method
 121   (in of from))
 122
 123 #+lispworks
 124 (defun clsql-loop-method (method-name iter-var iter-var-data-type
 125                           prep-phrases inclusive? allowed-preps
 126                           method-specific-data)
 127   (declare (ignore method-name inclusive? allowed-preps method-specific-data))
 128   (let ((in-phrase nil)
 129         (from-phrase nil))
 130     (loop for (prep . rest) in prep-phrases
 131           do
 132           (cond
 133             ((or (eq prep 'in) (eq prep 'of))
 134              (when in-phrase
 135                (error
 136                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
 137              (setq in-phrase rest))
 138             ((eq prep 'from)
 139              (when from-phrase
 140                (error
 141                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
 142              (setq from-phrase rest))
 143             (t
 144              (error
 145               "Unknown preposition: ~S." prep))))
 146     (unless in-phrase
 147       (error "Missing OF or IN iteration path."))
 148     (unless from-phrase
 149       (setq from-phrase '(clsql-base-sys:*default-database*)))
 150     (cond
 151       ((consp iter-var)
 152        (let ((query-var (gensym "LOOP-RECORD-"))
 153              (db-var (gensym "LOOP-RECORD-DATABASE-"))
 154              (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
 155              (step-var (gensym "LOOP-RECORD-STEP-")))
 156          (values
 157           t
 158           nil
 159           `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
 160             (,query-var ,in-phrase)
 161             (,db-var ,(first from-phrase))
 162             (,result-set-var nil)
 163             (,step-var nil))
 164           `((multiple-value-bind (%rs %cols)
 165                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 166               (setq ,result-set-var %rs ,step-var (make-list %cols))))
 167           ()
 168           ()
 169           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 170               (when ,result-set-var
 171                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 172               t))
 173           `(,iter-var ,step-var)
 174           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 175               (when ,result-set-var
 176                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 177               t))
 178           `(,iter-var ,step-var)
 179           ()
 180           ())))
 181       (t
 182        (let ((query-var (gensym "LOOP-RECORD-"))
 183              (db-var (gensym "LOOP-RECORD-DATABASE-"))
 184              (result-set-var (gensym "LOOP-RECORD-RESULT-SET-")))
 185          (values
 186           t
 187           nil
 188           `((,iter-var nil ,iter-var-data-type) (,query-var ,in-phrase)
 189             (,db-var ,(first from-phrase))
 190             (,result-set-var nil))
 191           `((multiple-value-bind (%rs %cols)
 192                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
 193               (setq ,result-set-var %rs ,iter-var (make-list %cols))))
 194           ()
 195           ()
 196           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
 197               (when ,result-set-var
 198                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 199               t))
 200            ()
 201           `((unless (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,iter-var)
 202               (when ,result-set-var
 203                 (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
 204               t))
 205           ()
 206           ()
 207           ()))))))
 208