/usr/share/scheme48-1.9/srfi/srfi-39.scm is in scheme48 1.9-5.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | ; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; Parameters are like fluids, but support mutation, and have a really
; awkward API.
; Note that the parameter cells are shared among threads, which gives
; us semantics different from, say, MzScheme, but probably the same as
; Gambit-C.
(define *return-fluid* (list 'return-fluid))
(define *return-converter* (list 'return-converter))
(define make-parameter
(lambda (init . conv)
(let* ((converter
(if (null? conv) (lambda (x) x) (car conv)))
(global-cell
(make-cell (converter init)))
($fluid (make-fluid global-cell)))
(letrec ((parameter
(lambda new-val
(let ((cell (fluid $fluid)))
(cond ((null? new-val)
(cell-ref cell))
((not (null? (cdr new-val)))
(apply assertion-violation
'make-parameter
"parameter object called with more than one argument"
parameter new-val))
((eq? (car new-val) *return-fluid*)
$fluid)
((eq? (car new-val) *return-converter*)
converter)
(else
(cell-set! cell (converter (car new-val)))))))))
parameter))))
(define-syntax parameterize
(syntax-rules ()
((parameterize ((?expr1 ?expr2) ...) ?body ...)
(parameterize-helper ((?expr1 ?expr2) ...) () ?body ...))))
(define-syntax parameterize-helper
(syntax-rules ()
((parameterize-helper ((?expr1 ?expr2) ?binding ...) (?args ...) ?body ...)
(let ((val1 ?expr1)
(val2 ?expr2))
(parameterize-helper (?binding ...)
(?args ...
(val1 *return-fluid*)
(make-cell ((val1 *return-converter*) val2)))
?body ...)))
((parameterize-helper () (?args ...) ?body ...)
(let-fluids ?args ... (lambda () ?body ...)))))
|