diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 82 | ||||
-rw-r--r-- | module/ice-9/poll.scm | 3 | ||||
-rw-r--r-- | module/system/base/message.scm | 12 | ||||
-rw-r--r-- | module/system/repl/command.scm | 1 | ||||
-rw-r--r-- | module/system/repl/repl.scm | 5 | ||||
-rw-r--r-- | module/web/client.scm | 2 | ||||
-rw-r--r-- | module/web/uri.scm | 20 |
7 files changed, 101 insertions, 24 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index cf3f5d8c0..3ae933aec 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -213,9 +213,11 @@ If there is no handler at all, Guile prints an error and then exits." (define pk peek) +;; Temporary definition; replaced later. +(define current-warning-port current-error-port) (define (warn . stuff) - (with-output-to-port (current-error-port) + (with-output-to-port (current-warning-port) (lambda () (newline) (display ";;; WARNING ") @@ -1373,7 +1375,7 @@ VALUE." (define (%load-announce file) (if %load-verbosely - (with-output-to-port (current-error-port) + (with-output-to-port (current-warning-port) (lambda () (display ";;; ") (display "loading ") @@ -2825,6 +2827,68 @@ 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* ...))))))) + + +;;; +;;; 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} ;;; @@ -3288,7 +3352,7 @@ module '(ice-9 q) '(make-q q-length))}." #f)) (define (warn module name int1 val1 int2 val2 var val) - (format (current-error-port) + (format (current-warning-port) "WARNING: ~A: `~A' imported from both ~A and ~A\n" (module-name module) name @@ -3310,7 +3374,7 @@ module '(ice-9 q) '(make-q q-length))}." (define (warn-override-core module name int1 val1 int2 val2 var val) (and (eq? int1 the-scm-module) (begin - (format (current-error-port) + (format (current-warning-port) "WARNING: ~A: imported module ~A overrides core binding `~A'\n" (module-name module) (module-name int2) @@ -3432,13 +3496,13 @@ module '(ice-9 q) '(make-q q-length))}." go-path (begin (if gostat - (format (current-error-port) + (format (current-warning-port) ";;; note: source file ~a\n;;; newer than compiled ~a\n" name go-path)) (cond (%load-should-auto-compile (%warn-auto-compilation-enabled) - (format (current-error-port) ";;; compiling ~a\n" name) + (format (current-warning-port) ";;; compiling ~a\n" name) (let ((cfn ((module-ref (resolve-interface '(system base compile)) @@ -3446,15 +3510,15 @@ module '(ice-9 q) '(make-q q-length))}." name #:opts %auto-compilation-options #:env (current-module)))) - (format (current-error-port) ";;; compiled ~a\n" cfn) + (format (current-warning-port) ";;; compiled ~a\n" cfn) cfn)) (else #f)))))) (lambda (k . args) - (format (current-error-port) + (format (current-warning-port) ";;; WARNING: compilation of ~a failed:\n" name) (for-each (lambda (s) (if (not (string-null? s)) - (format (current-error-port) ";;; ~a\n" s))) + (format (current-warning-port) ";;; ~a\n" s))) (string-split (call-with-output-string (lambda (port) (print-exception port #f k args))) diff --git a/module/ice-9/poll.scm b/module/ice-9/poll.scm index cf61294d7..2ba868748 100644 --- a/module/ice-9/poll.scm +++ b/module/ice-9/poll.scm @@ -38,6 +38,9 @@ (load-extension (string-append "libguile-" (effective-version)) "scm_init_poll")) +(if (not (= %sizeof-struct-pollfd 8)) + (error "Unexpected struct pollfd size" %sizeof-struct-pollfd)) + (if (defined? 'POLLIN) (export POLLIN)) diff --git a/module/system/base/message.scm b/module/system/base/message.scm index aed35021c..75e14ea1e 100644 --- a/module/system/base/message.scm +++ b/module/system/base/message.scm @@ -54,11 +54,13 @@ ;;; Warnings ;;; +;; This name existed before %current-warning-port was introduced, but +;; otherwise it is a deprecated binding. (define *current-warning-port* - ;; The port where warnings are sent. - (make-fluid (current-error-port))) - -(fluid-set! *current-warning-port* (current-error-port)) + ;; Can't play the identifier-syntax deprecation game in Guile 2.0, as + ;; other modules might depend on this being a normal binding and not a + ;; syntax binding. + (parameter-fluid current-warning-port)) (define *current-warning-prefix* ;; Prefix string when emitting a warning. @@ -194,7 +196,7 @@ "Emit a warning of type TYPE for source location LOCATION (a source property alist) using the data in ARGS." (let ((wt (lookup-warning-type type)) - (port (fluid-ref *current-warning-port*))) + (port (current-warning-port))) (if (warning-type? wt) (apply (warning-type-printer wt) port (location-string location) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 3fead7cac..a709c8dd6 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -441,6 +441,7 @@ Change languages." (cur (repl-language repl))) (format #t "Happy hacking with ~a! To switch back, type `,L ~a'.\n" (language-title lang) (language-name cur)) + (fluid-set! *current-language* lang) (set! (repl-language repl) lang))) diff --git a/module/system/repl/repl.scm b/module/system/repl/repl.scm index 1cffa7187..f7b022999 100644 --- a/module/system/repl/repl.scm +++ b/module/system/repl/repl.scm @@ -132,7 +132,10 @@ ;;; (define* (start-repl #:optional (lang (current-language)) #:key debug) - (run-repl (make-repl lang debug))) + ;; ,language at the REPL will fluid-set! the *current-language*. Make + ;; sure that it does so in a new scope. + (with-fluids ((*current-language* lang)) + (run-repl (make-repl lang debug)))) ;; (put 'abort-on-error 'scheme-indent-function 1) (define-syntax-rule (abort-on-error string exp) diff --git a/module/web/client.scm b/module/web/client.scm index 6a04497cf..b0356680d 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -27,7 +27,7 @@ ;;; the web server. ;;; ;;; Another option, good but not as performant, would be to use threads, -;;; possibly via par-map or futures. +;;; possibly via a thread pool. ;;; ;;; Code: diff --git a/module/web/uri.scm b/module/web/uri.scm index 6f9377c19..67ecbaeb2 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -125,14 +125,18 @@ consistency checks to make sure that the constructed URI is valid." userinfo-pat host-pat port-pat))) (define (parse-authority authority fail) - (let ((m (regexp-exec authority-regexp authority))) - (if (and m (valid-host? (match:substring m 3))) - (values (match:substring m 2) - (match:substring m 3) - (let ((port (match:substring m 5))) - (and port (not (string-null? port)) - (string->number port)))) - (fail)))) + (if (equal? authority "//") + ;; Allow empty authorities: file:///etc/hosts is a synonym of + ;; file:/etc/hosts. + (values #f #f #f) + (let ((m (regexp-exec authority-regexp authority))) + (if (and m (valid-host? (match:substring m 3))) + (values (match:substring m 2) + (match:substring m 3) + (let ((port (match:substring m 5))) + (and port (not (string-null? port)) + (string->number port)))) + (fail))))) ;;; RFC 3986, #3. |