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.
This commit is contained in:
parent
6d346bb61a
commit
90de5c4c2e
3 changed files with 117 additions and 0 deletions
|
|
@ -2857,6 +2857,53 @@ module '(ice-9 q) '(make-q q-length))}."
|
|||
(define (unspecified? v) (eq? v *unspecified*))
|
||||
|
||||
|
||||
|
||||
|
||||
;;; {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}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue