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 cmu scl)
  22 (defun loop-record-iteration-path (variable data-type prep-phrases)
  23   (let ((in-phrase nil)
  24         (from-phrase nil))
  25     (loop for (prep . rest) in prep-phrases
  26           do
  27           (case prep
  28             ((:in :of)
  29              (when in-phrase
  30                (ansi-loop::loop-error
  31                 "Duplicate OF or IN iteration path: ~S." (cons prep rest)))
  32              (setq in-phrase rest))
  33             ((:from)
  34              (when from-phrase
  35                (ansi-loop::loop-error
  36                 "Duplicate FROM iteration path: ~S." (cons prep rest)))
  37              (setq from-phrase rest))
  38             (t
  39              (ansi-loop::loop-error
  40               "Unknown preposition: ~S." prep))))
  41     (unless in-phrase
  42       (ansi-loop::loop-error "Missing OF or IN iteration path."))
  43     (unless from-phrase
  44       (setq from-phrase '(*default-database*)))
  45     (cond
  46       ((consp variable)
  47        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
  48              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
  49              (result-set-var (ansi-loop::loop-gentemp
  50                               'loop-record-result-set-))
  51              (step-var (ansi-loop::loop-gentemp 'loop-record-step-)))
  52          (push `(when ,result-set-var
  53                  (database-dump-result-set ,result-set-var ,db-var))
  54                ansi-loop::*loop-epilogue*)
  55          `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
  56             (,db-var ,(first from-phrase))
  57             (,result-set-var nil)
  58             (,step-var nil))
  59            ((multiple-value-bind (%rs %cols)
  60                 (database-query-result-set ,query-var ,db-var)
  61               (setq ,result-set-var %rs ,step-var (make-list %cols))))
  62            ()
  63            ()
  64            (not (database-store-next-row ,result-set-var ,db-var ,step-var))
  65            (,variable ,step-var)
  66            (not ,result-set-var)
  67            ()
  68            (not (database-store-next-row ,result-set-var ,db-var ,step-var))
  69            (,variable ,step-var))))
  70       (t
  71        (let ((query-var (ansi-loop::loop-gentemp 'loop-record-))
  72              (db-var (ansi-loop::loop-gentemp 'loop-record-database-))
  73              (result-set-var (ansi-loop::loop-gentemp
  74                               'loop-record-result-set-)))
  75          (push `(when ,result-set-var
  76                  (database-dump-result-set ,result-set-var ,db-var))
  77                ansi-loop::*loop-epilogue*)
  78          `(((,variable nil ,data-type) (,query-var ,(first in-phrase))
  79             (,db-var ,(first from-phrase))
  80             (,result-set-var nil))
  81            ((multiple-value-bind (%rs %cols)
  82                 (database-query-result-set ,query-var ,db-var)
  83               (setq ,result-set-var %rs ,variable (make-list %cols))))
  84            ()
  85            ()
  86            (not (database-store-next-row ,result-set-var ,db-var ,variable))
  87            ()
  88            (not ,result-set-var)
  89            ()
  90            (not (database-store-next-row ,result-set-var ,db-var ,variable))
  91            ()))))))
  92
  93 #+(or cmu scl)
  94 (ansi-loop::add-loop-path '(record records tuple tuples)
  95                           'loop-record-iteration-path
  96                           ansi-loop::*loop-ansi-universe*
  97                           :preposition-groups '((:of :in) (:from))
  98                           :inclusive-permitted nil)