From 90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 5 Dec 2011 14:20:09 +0100 Subject: [PATCH] add srfi-39 parameters to boot-9 * module/ice-9/boot-9.scm (, make-parameter, parameter?) (parameter-fluid, parameter-converter, parameterize): New top-level bindings, implementing SRFI-39 parameters. Currently, current-input-port and similar procedures are not yet parameters. * test-suite/Makefile.am: * test-suite/tests/parameters.test: Add tests, taken from srfi-39 tests. --- module/ice-9/boot-9.scm | 47 ++++++++++++++++++++++ test-suite/Makefile.am | 1 + test-suite/tests/parameters.test | 69 ++++++++++++++++++++++++++++++++ 3 files changed, 117 insertions(+) create mode 100644 test-suite/tests/parameters.test diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5ac01b85e..73d897c41 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2859,6 +2859,53 @@ module '(ice-9 q) '(make-q q-length))}." +;;; {Parameters} +;;; + +(define + ;; Three fields: the procedure itself, the fluid, and the converter. + (make-struct 0 'pwprpr)) +(set-struct-vtable-name! ') + +(define* (make-parameter init #:optional (conv (lambda (x) x))) + (let ((fluid (make-fluid (conv init)))) + (make-struct 0 + (case-lambda + (() (fluid-ref fluid)) + ((x) (fluid-set! fluid (conv x)))) + fluid conv))) + +(define (parameter? x) + (and (struct? x) (eq? (struct-vtable x) ))) + +(define (parameter-fluid p) + (if (parameter? p) + (struct-ref p 1) + (scm-error 'wrong-type-arg "parameter-fluid" + "Not a parameter: ~S" (list p) #f))) + +(define (parameter-converter p) + (if (parameter? p) + (struct-ref p 2) + (scm-error 'wrong-type-arg "parameter-fluid" + "Not a parameter: ~S" (list p) #f))) + +(define-syntax parameterize + (lambda (x) + (syntax-case x () + ((_ ((param value) ...) body body* ...) + (with-syntax (((p ...) (generate-temporaries #'(param ...)))) + #'(let ((p param) ...) + (if (not (parameter? p)) + (scm-error 'wrong-type-arg "parameterize" + "Not a parameter: ~S" (list p) #f)) + ... + (with-fluids (((struct-ref p 1) ((struct-ref p 2) value)) + ...) + body body* ...))))))) + + + ;;; {Running Repls} ;;; diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 05aee7837..f825cc73c 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -74,6 +74,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/numbers.test \ tests/optargs.test \ tests/options.test \ + tests/parameters.test \ tests/print.test \ tests/procprop.test \ tests/procs.test \ diff --git a/test-suite/tests/parameters.test b/test-suite/tests/parameters.test new file mode 100644 index 000000000..9d0a092ab --- /dev/null +++ b/test-suite/tests/parameters.test @@ -0,0 +1,69 @@ +;;;; srfi-39.test --- -*- scheme -*- +;;;; +;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;; Testing the parameters implementation in boot-9. +;; +(define-module (test-parameters) + #:use-module (srfi srfi-34) + #:use-module (test-suite lib)) + +(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 "parameters" + + (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)))))) + + (pass-if "SRFI-34" + (let ((inside? (make-parameter #f))) + (call/cc (lambda (return) + (with-exception-handler + (lambda (c) + ;; This handler should be called in the dynamic + ;; environment installed by `parameterize'. + (return (inside?))) + (lambda () + (parameterize ((inside? #t)) + (raise 'some-exception))))))))) -- 2.20.1