mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

load parameters earlier in boot-9

Browse source 
* module/ice-9/boot-9.scm: Move parameters earlier in the boot process.
  The new with-output-to-port code will use it.
This commit is contained in:
Andy Wingo 2012-03-06 00:44:01 +01:00
parent d867c7496c
commit 124bc316a6
1 changed files with 90 additions and 92 deletions
Download patch file Download diff file Expand all files Collapse all files

182
module/ice-9/boot-9.scm
View file

@ -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}
@ -3143,98 +3233,6 @@ 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) (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}