diff --git a/srfi/srfi-39.scm b/srfi/srfi-39.scm new file mode 100644 index 000000000..b8bb1d364 --- /dev/null +++ b/srfi/srfi-39.scm @@ -0,0 +1,107 @@ +;;; srfi-39.scm --- Parameter objects + +;; Copyright (C) 2004 Free Software Foundation, Inc. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this software; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;; Boston, MA 02111-1307 USA +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +;;; Author: Jose Antonio Ortega Ruiz +;;; Date: 2004-05-05 + +;;; Commentary: + +;; This is an implementation of SRFI-39 (Parameter objects). +;; +;; The implementation is based on Guile's fluid objects, and is, therefore, +;; thread-safe (parameters are thread-local). +;; +;; In addition to the forms defined in SRFI-39 (`make-parameter', +;; `parameterize'), a new procedure `with-parameters*' is provided. +;; This procedures is analogous to `with-fluids*' but taking as first +;; argument a list of parameter objects instead of a list of fluids. +;; + +;;; Code: + +(define-module (srfi srfi-39) + #:use-module (ice-9 syncase) + #:use-module (srfi srfi-16) + + #:export (make-parameter) + #:export-syntax (parameterize) + + ;; helper procedure not in srfi-39. + #:export (with-parameters*)) + +;; Make 'srfi-39 available as a feature identifiere to `cond-expand'. +;; +(cond-expand-provide (current-module) '(srfi-39)) + +(define make-parameter + (case-lambda + ((val) (make-parameter/helper val (lambda (x) x))) + ((val conv) (make-parameter/helper val conv)))) + +(define get-fluid-tag (lambda () 'get-fluid)) ;; arbitrary unique (as per eq?) value +(define get-conv-tag (lambda () 'get-conv)) ;; arbitrary unique (as per eq?) value + +(define (make-parameter/helper val conv) + (let ((value (make-fluid)) + (conv conv)) + (begin + (fluid-set! value (conv val)) + (lambda new-value + (cond + ((null? new-value) (fluid-ref value)) + ((eq? (car new-value) get-fluid-tag) value) + ((eq? (car new-value) get-conv-tag) conv) + ((null? (cdr new-value)) (fluid-set! value (conv (car new-value)))) + (else (error "make-parameter expects 0 or 1 arguments" new-value))))))) + +(define-syntax parameterize + (syntax-rules () + ((_ ((?param ?value) ...) ?body ...) + (with-parameters* (list ?param ...) + (list ?value ...) + (lambda () ?body ...))))) + +(define (with-parameters* params values thunk) + (with-fluids* (map (lambda (p) (p get-fluid-tag)) params) + (map (lambda (p v) ((p get-conv-tag) v)) params values) + thunk)) diff --git a/test-suite/tests/srfi-39.test b/test-suite/tests/srfi-39.test new file mode 100644 index 000000000..22d2bd056 --- /dev/null +++ b/test-suite/tests/srfi-39.test @@ -0,0 +1,54 @@ +;;;; srfi-39.test --- -*- scheme -*- +;;;; +;;;; Copyright (C) 2004 Free Software Foundation, Inc. +;;;; +;;;; This program is free software; you can redistribute it and/or modify +;;;; it under the terms of the GNU General Public License as published by +;;;; the Free Software Foundation; either version 2, or (at your option) +;;;; any later version. +;;;; +;;;; This program is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;;; GNU General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU General Public License +;;;; along with this software; see the file COPYING. If not, write to +;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, +;;;; Boston, MA 02111-1307 USA + +(use-modules (srfi srfi-39)) + +(define a (make-parameter 3)) +(define b (make-parameter 4)) + +(define (check a b a-val b-val) + (and (eqv? (a) a-val)) (eqv? (b) b-val)) + +(define c (make-parameter 2 (lambda (x) (if (< x 10) x 10)))) +(define d (make-parameter 15 (lambda (x) (if (< x 10) x 10)))) + +(with-test-prefix "SRFI-39" + + (pass-if "test 1" + (check a b 3 4)) + + (pass-if "test 2" + (parameterize ((a 2) (b 1)) + (and (check a b 2 1) + (parameterize ((b 8)) + (check a b 2 8))))) + + (pass-if "test 3" + (check a b 3 4)) + + (pass-if "test 4" + (check c d 2 10)) + + (pass-if "test 5" + (parameterize ((a 0) (b 1) (c 98) (d 9)) + (and (check a b 0 1) + (check c d 10 9) + (parameterize ((c (a)) (d (b))) + (and (check a b 0 1) + (check c d 0 1)))))))