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 #+sbcl
  31 (defun ansi-loop::loop-gentemp (&optional (pref 'loopva-))
  32   (gensym (string pref)))
  33
  34 #+(or cmu scl sbcl openmcl)
  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 ,data-type) (,query-var ,(first in-phrase))
  69             (,db-var ,(first from-phrase))
  70             (,result-set-var nil)
  71             (,step-var nil))
  72            ((multiple-value-bind (%rs %cols)
  73                 (clsql-base-sys:database-query-result-set ,query-var ,db-var)
  74               (setq ,result-set-var %rs ,step-var (make-list %cols))))
  75            ()
  76            ()
  77            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  78            (,variable ,step-var)
  79            (not ,result-set-var)
  80            ()
  81            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,step-var))
  82            (,variable ,step-var))))
  83       (t
  84        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
  85              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
  86              (result-set-var (ansi-loop::loop-gentemp
  87                               'loop-record-result-set-)))
  88          (push `(when ,result-set-var
  89                  (clsql-base-sys:database-dump-result-set ,result-set-var ,db-var))
  90                ansi-loop::*loop-epilogue*)
  91          `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
  92             (,db-var ,(first from-phrase))
  93             (,result-set-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 ,variable (make-list %cols))))
  97            ()
  98            ()
  99            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 100            ()
 101            (not ,result-set-var)
 102            ()
 103            (not (clsql-base-sys:database-store-next-row ,result-set-var ,db-var ,variable))
 104            ()))))))
 105
 106 #+(or cmu scl sbcl openmcl)
 107 (ansi-loop::add-loop-path '(record records tuple tuples)
 108                           'loop-record-iteration-path
 109                           ansi-loop::*loop-ansi-universe*
 110                           :preposition-groups '((:of :in) (:from))
 111                           :inclusive-permitted nil)