sql/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 CLSQL
   7 ;;;;
   8 ;;;; Copyright (c) 2001-2006 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai
   9 ;;;;
  10 ;;;; *************************************************************************
  11
  12 (in-package #:clsql-sys)
  13
  14 #+(or allegro sbcl)
  15 (eval-when (:compile-toplevel :load-toplevel :execute)
  16   (defpackage #:ansi-loop
  17     (:import-from #+sbcl #:sb-loop #+allegro #:excl
  18                   #:*loop-epilogue*
  19                   #:*loop-ansi-universe*
  20                   #:add-loop-path)))
  21
  22 #+(or allegro sbcl)
  23 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
  24   (gensym (string pref)))
  25
  26 #+clisp
  27 (eval-when (:compile-toplevel :load-toplevel :execute)
  28   (when (find-package "ANSI-LOOP") (push :clisp-aloop cl:*features*)))
  29
  30 #+(or allegro clisp-aloop cmu openmcl sbcl scl)
  31 (defun loop-record-iteration-path (variable data-type prep-phrases)
  32   (let ((in-phrase nil)
  33         (from-phrase nil))
  34     (loop for (prep . rest) in prep-phrases
  35           do
  36           (case prep
  37             ((:in :of)
  38              (when in-phrase
  39                (error 'clsql:sql-user-error
  40                       :message
  41                       (format nil
  42                               "Duplicate OF or IN iteration path: ~S."
  43                               (cons prep rest))))
  44              (setq in-phrase rest))
  45             ((:from)
  46              (when from-phrase
  47                (error 'clsql:sql-user-error
  48                       :message
  49                       (format nil
  50                               "Duplicate FROM iteration path: ~S."
  51                               (cons prep rest))))
  52              (setq from-phrase rest))
  53             (t
  54              (error 'clsql:sql-user-error
  55                     :message
  56                     (format nil"Unknown preposition: ~S." prep)))))
  57     (unless in-phrase
  58       (error 'clsql:sql-user-error
  59              :message "Missing OF or IN iteration path."))
  60     (unless from-phrase
  61       (setq from-phrase '(*default-database*)))
  62
  63     (unless (consp variable)
  64       (setq variable (list variable)))
  65
  66     (cond
  67      ;; object query
  68      ((and (consp (first in-phrase))
  69            (string-equal "sql-query" (symbol-name (caar in-phrase)))
  70            (consp (second (first in-phrase)))
  71            (eq 'quote (first (second (first in-phrase))))
  72            (symbolp (second (second (first in-phrase)))))
  73
  74        (let ((result-var (ansi-loop::loop-gentemp
  75                               'loop-record-result-))
  76              (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
  77          `(((,variable nil ,@(and data-type (list data-type)))
  78             (,result-var (query ,(first in-phrase)))
  79             (,step-var nil))
  80            ()
  81            ()
  82            ()
  83            (if (null ,result-var)
  84                t
  85                (progn
  86                  (setq ,step-var (first ,result-var))
  87                  (setq ,result-var (rest ,result-var))
  88                  nil))
  89            (,variable ,step-var)
  90            (null ,result-var)
  91            ()
  92            (if (null ,result-var)
  93                t
  94                (progn
  95                  (setq ,step-var (first ,result-var))
  96                  (setq ,result-var (rest ,result-var))
  97                  nil))
  98            (,variable ,step-var))))
  99
 100       ((consp variable)
 101        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
 102              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
 103              (result-set-var (ansi-loop::loop-gentemp
 104                               'loop-record-result-set-))
 105              (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
 106          (push `(when ,result-set-var
 107                   (database-dump-result-set ,result-set-var ,db-var))
 108                ansi-loop::*loop-epilogue*)
 109          `(((,variable nil ,@(and data-type (list data-type)))
 110             (,query-var ,(first in-phrase))
 111             (,db-var ,(first from-phrase))
 112             (,result-set-var t)
 113             (,step-var nil))
 114            ((multiple-value-bind (%rs %cols)
 115                 (database-query-result-set ,query-var ,db-var :result-types :auto)
 116               (setq ,result-set-var %rs ,step-var (make-list %cols))))
 117            ()
 118            ()
 119            (not (database-store-next-row ,result-set-var ,db-var ,step-var))
 120            (,variable ,step-var)
 121            (not ,result-set-var)
 122            ()
 123            (not (database-store-next-row ,result-set-var ,db-var ,step-var))
 124            (,variable ,step-var)))))))
 125
 126 #+(or allegro clisp-aloop cmu openmcl sbcl scl)
 127 (ansi-loop::add-loop-path '(record records tuple tuples)
 128                           'loop-record-iteration-path
 129                           ansi-loop::*loop-ansi-universe*
 130                           :preposition-groups '((:of :in) (:from))
 131                           :inclusive-permitted nil)
 132
 133
 134 #+lispworks
 135 (cl-user::define-loop-method (loop::record loop::records loop::tuple loop::tuples)
 136     clsql-loop-method
 137   (loop::in loop::of loop::from))
 138
 139 #+lispworks
 140 (defun clsql-loop-method (method-name iter-var iter-var-data-type
 141                           prep-phrases inclusive? allowed-preps
 142                           method-specific-data)
 143   (declare (ignore method-name iter-var-data-type inclusive? allowed-preps method-specific-data))
 144   (let ((in-phrase nil)
 145         (from-phrase nil))
 146     (loop for (prep . rest) in prep-phrases
 147           do
 148           (cond
 149             ((or (eq prep 'loop::in) (eq prep 'loop::of))
 150              (when in-phrase
 151                (error 'clsql:sql-user-error
 152                       :message
 153                       (format nil "Duplicate OF or IN iteration path: ~S."
 154                               (cons prep rest))))
 155              (setq in-phrase rest))
 156             ((eq prep 'loop::from)
 157              (when from-phrase
 158                (error 'clsql:sql-user-error
 159                       :message
 160                       (format nil "Duplicate FROM iteration path: ~S."
 161                               (cons prep rest))))
 162              (setq from-phrase rest))
 163             (t
 164              (error 'clsql:sql-user-error
 165                     :message (format nil "Unknown preposition: ~S." prep)))))
 166     (unless in-phrase
 167       (error 'clsql:sql-user-error
 168              :message "Missing OF or IN iteration path."))
 169     (unless from-phrase
 170       (setq from-phrase '(clsql:*default-database*)))
 171
 172     (unless (consp iter-var)
 173       (setq iter-var (list iter-var)))
 174
 175     (cond
 176      ;; object query
 177      ((and (consp in-phrase)
 178            (string-equal "sql-query" (symbol-name (car in-phrase)))
 179            (consp (second in-phrase))
 180            (eq 'quote (first (second in-phrase)))
 181            (symbolp (second (second in-phrase))))
 182
 183        (let ((result-var (gensym "LOOP-RECORD-RESULT-"))
 184              (step-var (gensym "LOOP-RECORD-STEP-")))
 185          (values
 186           t
 187           nil
 188           `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
 189               (,result-var (clsql:query ,in-phrase))
 190               (,step-var nil))
 191           ()
 192           ()
 193           ()
 194           `((if (null ,result-var)
 195                 t
 196                 (progn
 197                   (setq ,step-var (first ,result-var))
 198                   (setq ,result-var (rest ,result-var))
 199                   nil)))
 200           `(,iter-var ,step-var)
 201           `((if (null ,result-var)
 202                 t
 203                 (progn
 204                   (setq ,step-var (first ,result-var))
 205                   (setq ,result-var (rest ,result-var))
 206                   nil)))
 207            `(,iter-var ,step-var)
 208            ()
 209            ()
 210            )))
 211
 212       ((consp iter-var)
 213        (let ((query-var (gensym "LOOP-RECORD-"))
 214              (db-var (gensym "LOOP-RECORD-DATABASE-"))
 215              (result-set-var (gensym "LOOP-RECORD-RESULT-SET-"))
 216              (step-var (gensym "LOOP-RECORD-STEP-")))
 217          (values
 218           t
 219           nil
 220           `(,@(mapcar (lambda (v) `(,v nil)) iter-var)
 221             (,query-var ,in-phrase)
 222             (,db-var ,(first from-phrase))
 223             (,result-set-var nil)
 224             (,step-var nil))
 225           `((multiple-value-bind (%rs %cols)
 226                 (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto)
 227               (setq ,result-set-var %rs ,step-var (make-list %cols))))
 228           ()
 229           ()
 230           `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 231               (when ,result-set-var
 232                 (clsql-sys:database-dump-result-set ,result-set-var ,db-var))
 233               t))
 234           `(,iter-var ,step-var)
 235           `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var)
 236               (when ,result-set-var
 237                 (clsql-sys:database-dump-result-set ,result-set-var ,db-var))
 238               t))
 239           `(,iter-var ,step-var)
 240           ()
 241           ()))))))
 242
 243
 244 #+clisp-aloop
 245 (eval-when (:compile-toplevel :load-toplevel :execute)
 246   (setq cl:*features* (delete :clisp-aloop cl:*features*)))
 247