summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm82
-rw-r--r--module/ice-9/poll.scm3
-rw-r--r--module/system/base/message.scm12
-rw-r--r--module/system/repl/command.scm1
-rw-r--r--module/system/repl/repl.scm5
-rw-r--r--module/web/client.scm2
-rw-r--r--module/web/uri.scm20
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.