summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2011-12-05 14:20:09 +0100
committerAndy Wingo <wingo@pobox.com>2011-12-05 14:25:25 +0100
commit90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9 (patch)
treec4422bfd5b040a32cfc84d0b18193d016b8ba72c
parent6d346bb61a2256515a969e4c4683dfa4a692c426 (diff)
downloadguile-90de5c4c2e4fc177c18f6cdd035dad5d8b6895f9.tar.gz
add srfi-39 parameters to boot-9
* module/ice-9/boot-9.scm (<parameter>, 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.
-rw-r--r--module/ice-9/boot-9.scm47
-rw-r--r--test-suite/Makefile.am1
-rw-r--r--test-suite/tests/parameters.test69
3 files changed, 117 insertions, 0 deletions
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 <parameter>
+ ;; Three fields: the procedure itself, the fluid, and the converter.
+ (make-struct <applicable-struct-vtable> 0 'pwprpr))
+(set-struct-vtable-name! <parameter> '<parameter>)
+
+(define* (make-parameter init #:optional (conv (lambda (x) x)))
+ (let ((fluid (make-fluid (conv init))))
+ (make-struct <parameter> 0
+ (case-lambda
+ (() (fluid-ref fluid))
+ ((x) (fluid-set! fluid (conv x))))
+ fluid conv)))
+
+(define (parameter? x)
+ (and (struct? x) (eq? (struct-vtable x) <parameter>)))
+
+(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)))))))))