From 124bc316a6831bc842c25769731e92181fd8a711 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Tue, 6 Mar 2012 00:44:01 +0100 Subject: 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. --- module/ice-9/boot-9.scm | 182 ++++++++++++++++++++++++------------------------ 1 file 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 + ;; 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) (let ((prev (fluid-ref fluid))) + (fluid-set! fluid (conv x)) + prev))) + 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* ...))))))) + + + +;;; Current ports as parameters. +;;; + +(let ((fluid->parameter + (lambda (fluid conv) + (make-struct 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} @@ -3143,98 +3233,6 @@ module '(ice-9 q) '(make-q q-length))}." (define (unspecified? v) (eq? v *unspecified*)) - - -;;; {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) (let ((prev (fluid-ref fluid))) - (fluid-set! fluid (conv x)) - prev))) - 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* ...))))))) - - -;;; -;;; Current ports as parameters. -;;; - -(let ((fluid->parameter - (lambda (fluid conv) - (make-struct 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} -- cgit v1.2.3