srfi/srfi-39.scm

   1 ;;; srfi-39.scm --- Parameter objects
   2
   3 ;;      Copyright (C) 2004, 2005 Free Software Foundation, Inc.
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation; either version 2, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this software; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301 USA
  19 ;;
  20 ;; As a special exception, the Free Software Foundation gives permission
  21 ;; for additional uses of the text contained in its release of GUILE.
  22 ;;
  23 ;; The exception is that, if you link the GUILE library with other files
  24 ;; to produce an executable, this does not by itself cause the
  25 ;; resulting executable to be covered by the GNU General Public License.
  26 ;; Your use of that executable is in no way restricted on account of
  27 ;; linking the GUILE library code into it.
  28 ;;
  29 ;; This exception does not however invalidate any other reasons why
  30 ;; the executable file might be covered by the GNU General Public License.
  31 ;;
  32 ;; This exception applies only to the code released by the
  33 ;; Free Software Foundation under the name GUILE.  If you copy
  34 ;; code from other Free Software Foundation releases into a copy of
  35 ;; GUILE, as the General Public License permits, the exception does
  36 ;; not apply to the code that you add in this way.  To avoid misleading
  37 ;; anyone as to the status of such modified files, you must delete
  38 ;; this exception notice from them.
  39 ;;
  40 ;; If you write modifications of your own for GUILE, it is your choice
  41 ;; whether to permit this exception to apply to your modifications.
  42 ;; If you do not wish that, delete this exception notice.
  43
  44 ;;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
  45 ;;; Date: 2004-05-05
  46
  47 ;;; Commentary:
  48
  49 ;; This is an implementation of SRFI-39 (Parameter objects).
  50 ;;
  51 ;; The implementation is based on Guile's fluid objects, and is, therefore,
  52 ;; thread-safe (parameters are thread-local).
  53 ;;
  54 ;; In addition to the forms defined in SRFI-39 (`make-parameter',
  55 ;; `parameterize'), a new procedure `with-parameters*' is provided.
  56 ;; This procedures is analogous to `with-fluids*' but taking as first
  57 ;; argument a list of parameter objects instead of a list of fluids.
  58 ;;
  59
  60 ;;; Code:
  61
  62 (define-module (srfi srfi-39)
  63   #:use-module (ice-9 syncase)
  64   #:use-module (srfi srfi-16)
  65
  66   #:export (make-parameter)
  67   #:export-syntax (parameterize)
  68
  69   ;; helper procedure not in srfi-39.
  70   #:export (with-parameters*)
  71   #:replace (current-input-port current-output-port current-error-port))
  72
  73 ;; Make 'srfi-39 available as a feature identifiere to `cond-expand'.
  74 ;;
  75 (cond-expand-provide (current-module) '(srfi-39))
  76
  77 (define make-parameter
  78   (case-lambda
  79     ((val) (make-parameter/helper val (lambda (x) x)))
  80     ((val conv) (make-parameter/helper val conv))))
  81
  82 (define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value
  83 (define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value
  84
  85 (define (make-parameter/helper val conv)
  86   (let ((value (make-fluid))
  87         (conv conv))
  88     (begin
  89       (fluid-set! value (conv val))
  90       (lambda new-value
  91         (cond
  92          ((null? new-value) (fluid-ref value))
  93          ((eq? (car new-value) get-fluid-tag) value)
  94          ((eq? (car new-value) get-conv-tag) conv)
  95          ((null? (cdr new-value)) (fluid-set! value (conv (car new-value))))
  96          (else (error "make-parameter expects 0 or 1 arguments" new-value)))))))
  97
  98 (define-syntax parameterize
  99   (syntax-rules ()
 100     ((_ ((?param ?value) ...) ?body ...)
 101      (with-parameters* (list ?param ...)
 102                        (list ?value ...)
 103                        (lambda () ?body ...)))))
 104
 105 (define (current-input-port . new-value)
 106   (if (null? new-value)
 107       ((@ (guile) current-input-port))
 108       (apply set-current-input-port new-value)))
 109
 110 (define (current-output-port . new-value)
 111   (if (null? new-value)
 112       ((@ (guile) current-output-port))
 113       (apply set-current-output-port new-value)))
 114
 115 (define (current-error-port . new-value)
 116   (if (null? new-value)
 117       ((@ (guile) current-error-port))
 118       (apply set-current-error-port new-value)))
 119
 120 (define port-list
 121   (list current-input-port current-output-port current-error-port))
 122
 123 ;; There are no fluids behind current-input-port etc, so those parameter
 124 ;; objects are picked out of the list and handled separately with a
 125 ;; dynamic-wind to swap their values to and from a location (the "value"
 126 ;; variable in the swapper procedure "let").
 127 ;;
 128 ;; current-input-port etc are already per-dynamic-root, so this arrangement
 129 ;; works the same as a fluid.  Perhaps they could become fluids for ease of
 130 ;; implementation here.
 131 ;;
 132 ;; Notice the use of a param local variable for the swapper procedure.  It
 133 ;; ensures any application changes to the PARAMS list won't affect the
 134 ;; winding.
 135 ;;
 136 (define (with-parameters* params values thunk)
 137   (let more ((params params)
 138              (values values)
 139              (fluids '())     ;; fluids from each of PARAMS
 140              (convs  '())     ;; VALUES with conversion proc applied
 141              (swapper noop))  ;; wind/unwind procedure for ports handling
 142     (if (null? params)
 143         (if (eq? noop swapper)
 144             (with-fluids* fluids convs thunk)
 145             (dynamic-wind
 146                 swapper
 147                 (lambda ()
 148                   (with-fluids* fluids convs thunk))
 149                 swapper))
 150         (if (memq (car params) port-list)
 151             (more (cdr params) (cdr values)
 152                   fluids convs
 153                   (let ((param (car params))
 154                         (value (car values))
 155                         (prev-swapper swapper))
 156                     (lambda ()
 157                       (set! value (param value))
 158                       (prev-swapper))))
 159             (more (cdr params) (cdr values)
 160                   (cons ((car params) get-fluid-tag) fluids)
 161                   (cons (((car params) get-conv-tag) (car values)) convs)
 162                   swapper)))))