diff options
author | Andy Wingo <wingo@pobox.com> | 2012-03-06 00:44:01 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2012-03-06 00:51:49 +0100 |
commit | 124bc316a6831bc842c25769731e92181fd8a711 (patch) | |
tree | a8728b7aecaf8bb52eec71db18e0a15dfc96c642 | |
parent | d867c7496ce6caea7f449658306b85db3c95616c (diff) | |
download | guile-124bc316a6831bc842c25769731e92181fd8a711.tar.gz |
load parameters earlier in boot-9
* module/ice-9/boot-9.scm: Move parameters earlier in the boot process.
The new with-output-to-port code will use it.
-rw-r--r-- | module/ice-9/boot-9.scm | 182 |
1 files changed, 90 insertions, 92 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index a8b771e33..5cd59d9be 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -1397,6 +1397,96 @@ VALUE." (provide 'record) + + +;;; {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) (let ((prev (fluid-ref fluid))) + (fluid-set! fluid (conv x)) + prev))) + 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* ...))))))) + + + +;;; Current ports as parameters. +;;; + +(let ((fluid->parameter + (lambda (fluid conv) + (make-struct <parameter> 0 + (case-lambda + (() (fluid-ref fluid)) + ((x) (let ((prev (fluid-ref fluid))) + (fluid-set! fluid (conv x)) + prev))) + fluid conv)))) + (define-syntax-rule (port-parameterize! binding fluid predicate msg) + (begin + (set! binding (fluid->parameter (module-ref (current-module) 'fluid) + (lambda (x) + (if (predicate x) x + (error msg x))))) + (hashq-remove! (%get-pre-modules-obarray) 'fluid))) + + (port-parameterize! current-input-port %current-input-port-fluid + input-port? "expected an input port") + (port-parameterize! current-output-port %current-output-port-fluid + output-port? "expected an output port") + (port-parameterize! current-error-port %current-error-port-fluid + output-port? "expected an output port")) + + + +;;; {Warnings} +;;; + +(define current-warning-port + (make-parameter (current-error-port) + (lambda (x) + (if (output-port? x) + x + (error "expected an output port" x))))) + ;;; {Booleans} @@ -3145,98 +3235,6 @@ 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) (let ((prev (fluid-ref fluid))) - (fluid-set! fluid (conv x)) - prev))) - 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* ...))))))) - - -;;; -;;; Current ports as parameters. -;;; - -(let ((fluid->parameter - (lambda (fluid conv) - (make-struct <parameter> 0 - (case-lambda - (() (fluid-ref fluid)) - ((x) (let ((prev (fluid-ref fluid))) - (fluid-set! fluid (conv x)) - prev))) - fluid conv)))) - (define-syntax-rule (port-parameterize! binding fluid predicate msg) - (begin - (set! binding (fluid->parameter (module-ref (current-module) 'fluid) - (lambda (x) - (if (predicate x) x - (error msg x))))) - (module-remove! (current-module) 'fluid))) - - (port-parameterize! current-input-port %current-input-port-fluid - input-port? "expected an input port") - (port-parameterize! current-output-port %current-output-port-fluid - output-port? "expected an output port") - (port-parameterize! current-error-port %current-error-port-fluid - output-port? "expected an output port")) - - - -;;; -;;; Warnings. -;;; - -(define current-warning-port - (make-parameter (current-error-port) - (lambda (x) - (if (output-port? x) - x - (error "expected an output port" x))))) - - - - ;;; {Running Repls} ;;; |