summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm14
-rw-r--r--module/ice-9/command-line.scm14
-rw-r--r--module/ice-9/curried-definitions.scm14
-rw-r--r--module/ice-9/format.scm14
-rw-r--r--module/ice-9/regex.scm3
-rw-r--r--module/language/tree-il/primitives.scm21
-rw-r--r--module/srfi/srfi-19.scm8
-rw-r--r--module/srfi/srfi-31.scm26
-rw-r--r--module/system/base/compile.scm19
-rw-r--r--module/texinfo.scm28
-rw-r--r--module/web/client.scm46
-rw-r--r--module/web/uri.scm6
12 files changed, 140 insertions, 73 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 14dfb605e..1285c8364 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3137,8 +3137,11 @@ module '(ice-9 q) '(make-q q-length))}."
(lambda (option)
(apply (lambda (name value documentation)
(display name)
- (if (< (string-length (symbol->string name)) 8)
- (display #\tab))
+ (let ((len (string-length (symbol->string name))))
+ (when (< len 16)
+ (display #\tab)
+ (when (< len 8)
+ (display #\tab))))
(display #\tab)
(display value)
(display #\tab)
@@ -3509,7 +3512,9 @@ module '(ice-9 q) '(make-q q-length))}."
(define-syntax define-public
(syntax-rules ()
((_ (name . args) . body)
- (define-public name (lambda args . body)))
+ (begin
+ (define name (lambda args . body))
+ (export name)))
((_ name val)
(begin
(define name val)
@@ -3899,7 +3904,7 @@ module '(ice-9 q) '(make-q q-length))}."
;;;
;;; Currently, the following feature identifiers are supported:
;;;
-;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61
+;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105
;;;
;;; Remember to update the features list when adding more SRFIs.
;;;
@@ -3919,6 +3924,7 @@ module '(ice-9 q) '(make-q q-length))}."
srfi-39 ;; parameterize
srfi-55 ;; require-extension
srfi-61 ;; general cond clause
+ srfi-105 ;; curly infix expressions
))
;; This table maps module public interfaces to the list of features.
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
index 62a2c9e4f..d60a6e36a 100644
--- a/module/ice-9/command-line.scm
+++ b/module/ice-9/command-line.scm
@@ -1,6 +1,6 @@
;;; Parsing Guile's command-line
-;;; Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
+;;; Copyright (C) 1994-1998, 2000-2011, 2012 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -325,7 +325,7 @@ If FILE begins with `-' the -s switch is mandatory.
((string=? arg "--listen") ; start a repl server
(parse args
- (cons '(@@ (system repl server) (spawn-server)) out)))
+ (cons '((@@ (system repl server) spawn-server)) out)))
((string-prefix? "--listen=" arg) ; start a repl server
(parse
@@ -336,14 +336,12 @@ If FILE begins with `-' the -s switch is mandatory.
((string->number where) ; --listen=PORT
=> (lambda (port)
(if (and (integer? port) (exact? port) (>= port 0))
- `(@@ (system repl server)
- (spawn-server
- (make-tcp-server-socket #:port ,port)))
+ `((@@ (system repl server) spawn-server)
+ ((@@ (system repl server) make-tcp-server-socket) #:port ,port))
(error "invalid port for --listen"))))
((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
- `(@@ (system repl server)
- (spawn-server
- (make-unix-domain-server-socket #:path ,where))))
+ `((@@ (system repl server) spawn-server)
+ ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where)))
(else
(error "unknown argument to --listen"))))
out)))
diff --git a/module/ice-9/curried-definitions.scm b/module/ice-9/curried-definitions.scm
index d55f1fb6a..8c684a18c 100644
--- a/module/ice-9/curried-definitions.scm
+++ b/module/ice-9/curried-definitions.scm
@@ -16,7 +16,8 @@
(define-module (ice-9 curried-definitions)
#:replace ((cdefine . define)
- (cdefine* . define*)))
+ (cdefine* . define*)
+ define-public))
(define-syntax cdefine
(syntax-rules ()
@@ -39,3 +40,14 @@
(lambda* rest body body* ...)))
((_ . rest)
(define* . rest))))
+
+(define-syntax define-public
+ (syntax-rules ()
+ ((_ (name . args) . body)
+ (begin
+ (cdefine (name . args) . body)
+ (export name)))
+ ((_ name val)
+ (begin
+ (define name val)
+ (export name)))))
diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm
index d038ace5a..eed8cbb0e 100644
--- a/module/ice-9/format.scm
+++ b/module/ice-9/format.scm
@@ -427,15 +427,15 @@
(case modifier
((at)
(format:out-str
- (with-output-to-string
- (lambda ()
- (truncated-print (next-arg)
+ (call-with-output-string
+ (lambda (p)
+ (truncated-print (next-arg) p
#:width width)))))
((colon-at)
(format:out-str
- (with-output-to-string
- (lambda ()
- (truncated-print (next-arg)
+ (call-with-output-string
+ (lambda (p)
+ (truncated-print (next-arg) p
#:width
(max (- width
output-col)
@@ -779,7 +779,7 @@
(define (format:obj->str obj slashify)
(let ((res (if slashify
(object->string obj)
- (with-output-to-string (lambda () (display obj))))))
+ (call-with-output-string (lambda (p) (display obj p))))))
(if (and format:read-proof (string-prefix? "#<" res))
(object->string res)
res)))
diff --git a/module/ice-9/regex.scm b/module/ice-9/regex.scm
index f7b94b72a..08ae2c2f5 100644
--- a/module/ice-9/regex.scm
+++ b/module/ice-9/regex.scm
@@ -172,8 +172,9 @@
(let loop ((start 0)
(value init)
(abuts #f)) ; True if start abuts a previous match.
+ (define bol (if (zero? start) 0 regexp/notbol))
(let ((m (if (> start (string-length string)) #f
- (regexp-exec regexp string start flags))))
+ (regexp-exec regexp string start (logior flags bol)))))
(cond
((not m) value)
((and (= (match:start m) (match:end m)) abuts)
diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm
index 18126863c..e3f6a9071 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -516,6 +516,27 @@
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
+;; Appropriate for use with either 'eqv?' or 'equal?'.
+(define maybe-simplify-to-eq
+ (case-lambda
+ ((src a b)
+ ;; Simplify cases where either A or B is constant.
+ (define (maybe-simplify a b)
+ (and (const? a)
+ (let ((v (const-exp a)))
+ (and (or (memq v '(#f #t () #nil))
+ (symbol? v)
+ (and (integer? v)
+ (exact? v)
+ (<= v most-positive-fixnum)
+ (>= v most-negative-fixnum)))
+ (make-primcall src 'eq? (list a b))))))
+ (or (maybe-simplify a b) (maybe-simplify b a)))
+ (else #f)))
+
+(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq)
+(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq)
+
(hashq-set! *primitive-expand-table*
'@dynamic-wind
(case-lambda
diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm
index d8f764335..c0a27b1a2 100644
--- a/module/srfi/srfi-19.scm
+++ b/module/srfi/srfi-19.scm
@@ -1113,13 +1113,13 @@
(cons #\1 (lambda (date pad-with port)
(display (date->string date "~Y-~m-~d") port)))
(cons #\2 (lambda (date pad-with port)
- (display (date->string date "~k:~M:~S~z") port)))
+ (display (date->string date "~H:~M:~S~z") port)))
(cons #\3 (lambda (date pad-with port)
- (display (date->string date "~k:~M:~S") port)))
+ (display (date->string date "~H:~M:~S") port)))
(cons #\4 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port)))
+ (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port)))
(cons #\5 (lambda (date pad-with port)
- (display (date->string date "~Y-~m-~dT~k:~M:~S") port)))))
+ (display (date->string date "~Y-~m-~dT~H:~M:~S") port)))))
(define (get-formatter char)
diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm
index 4238dc269..cf67e8af5 100644
--- a/module/srfi/srfi-31.scm
+++ b/module/srfi/srfi-31.scm
@@ -1,6 +1,6 @@
;;; srfi-31.scm --- special form for recursive evaluation
-;; Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2004, 2006, 2012 Free Software Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -19,17 +19,15 @@
;;; Original author: Rob Browning <rlb@defaultvalue.org>
(define-module (srfi srfi-31)
- :export-syntax (rec))
+ #:export (rec))
-(define-macro (rec arg-form . body)
- (cond
- ((and (symbol? arg-form) (= 1 (length body)))
- ;; (rec S (cons 1 (delay S)))
- `(letrec ((,arg-form ,(car body)))
- ,arg-form))
- ;; (rec (f x) (+ x 1))
- ((list? arg-form)
- `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
- ,(car arg-form)))
- (else
- (error "syntax error in rec form" `(rec ,arg-form ,@body)))))
+(define-syntax rec
+ (syntax-rules ()
+ "Return the given object, defined in a lexical environment where
+NAME is bound to itself."
+ ((_ (name . formals) body ...) ; procedure
+ (letrec ((name (lambda formals body ...)))
+ name))
+ ((_ name expr) ; arbitrary object
+ (letrec ((name expr))
+ name))))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 0bc11a30f..afcb55a72 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -1,6 +1,6 @@
;;; High-level compiler interface
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -72,7 +72,7 @@
;; before the check, so that we avoid races (possibly due to parallel
;; compilation).
;;
-(define (ensure-writable-dir dir)
+(define (ensure-directory dir)
(catch 'system-error
(lambda ()
(mkdir dir))
@@ -80,13 +80,12 @@
(let ((errno (and (pair? rest) (car rest))))
(cond
((eqv? errno EEXIST)
- (let ((st (stat dir)))
- (if (or (not (eq? (stat:type st) 'directory))
- (not (access? dir W_OK)))
- (error "directory not writable" dir))))
+ ;; Assume it's a writable directory, to avoid TOCTOU errors,
+ ;; as well as UID/EUID mismatches that occur with access(2).
+ #t)
((eqv? errno ENOENT)
- (ensure-writable-dir (dirname dir))
- (ensure-writable-dir dir))
+ (ensure-directory (dirname dir))
+ (ensure-directory dir))
(else
(throw k subr fmt args rest)))))))
@@ -125,7 +124,7 @@
%compile-fallback-path
(canonical->suffix (canonicalize-path file))
(compiled-extension))))
- (and (false-if-exception (ensure-writable-dir (dirname f)))
+ (and (false-if-exception (ensure-directory (dirname f)))
f))))
(define* (compile-file file #:key
@@ -144,7 +143,7 @@
;; Choose the input encoding deterministically.
(set-port-encoding! in (or enc "UTF-8"))
- (ensure-writable-dir (dirname comp))
+ (ensure-directory (dirname comp))
(call-with-output-file/atomic comp
(lambda (port)
((language-printer (ensure-language to))
diff --git a/module/texinfo.scm b/module/texinfo.scm
index 2ffd85393..519db485d 100644
--- a/module/texinfo.scm
+++ b/module/texinfo.scm
@@ -384,8 +384,14 @@ Examples:
;; Like a DTD for texinfo
(define (command-spec command)
- (or (assq command texi-command-specs)
- (parser-error #f "Unknown command" command)))
+ (let ((spec (assq command texi-command-specs)))
+ (cond
+ ((not spec)
+ (parser-error #f "Unknown command" command))
+ ((eq? (cadr spec) 'ALIAS)
+ (command-spec (cddr spec)))
+ (else
+ spec))))
(define (inline-content? content)
(case content
@@ -647,11 +653,10 @@ Examples:
(arguments->attlist port (read-arguments port stop-char) arg-names))
(let* ((spec (command-spec command))
+ (command (car spec))
(type (cadr spec))
(arg-names (cddr spec)))
(case type
- ((ALIAS)
- (complete-start-command arg-names port))
((INLINE-TEXT)
(assert-curr-char '(#\{) "Inline element lacks {" port)
(values command '() type))
@@ -954,7 +959,9 @@ Examples:
(loop port expect-eof? end-para need-break? seed)))
((START) ; Start of an @-command
(let* ((head (token-head token))
- (type (cadr (command-spec head)))
+ (spec (command-spec head))
+ (head (car spec))
+ (type (cadr spec))
(inline? (inline-content? type))
(seed ((if (and inline? (not need-break?))
identity end-para) seed))
@@ -1045,8 +1052,9 @@ Examples:
(lambda (command args content seed) ; fdown
'())
(lambda (command args parent-seed seed) ; fup
- (let ((seed (reverse-collect-str-drop-ws seed))
- (spec (command-spec command)))
+ (let* ((seed (reverse-collect-str-drop-ws seed))
+ (spec (command-spec command))
+ (command (car spec)))
(if (eq? (cadr spec) 'INLINE-TEXT-ARGS)
(cons (list command (cons '% (parse-inline-text-args #f spec seed)))
parent-seed)
@@ -1062,8 +1070,10 @@ Examples:
(let ((parser (make-dom-parser)))
;; duplicate arguments->attlist to avoid unnecessary splitting
(lambda (command port)
- (let ((args (cdar (parser '*ENVIRON-ARGS* port '())))
- (arg-names (cddr (command-spec command))))
+ (let* ((args (cdar (parser '*ENVIRON-ARGS* port '())))
+ (spec (command-spec command))
+ (command (car spec))
+ (arg-names (cddr spec)))
(cond
((not arg-names)
(if (null? args) '()
diff --git a/module/web/client.scm b/module/web/client.scm
index b0356680d..cf7ea5325 100644
--- a/module/web/client.scm
+++ b/module/web/client.scm
@@ -1,6 +1,6 @@
;;; Web client
-;; Copyright (C) 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2011, 2012 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -42,19 +42,37 @@
http-get))
(define (open-socket-for-uri uri)
- (let* ((ai (car (getaddrinfo (uri-host uri)
- (cond
- ((uri-port uri) => number->string)
- (else (symbol->string (uri-scheme uri)))))))
- (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
- (addrinfo:protocol ai))))
- (set-port-encoding! s "ISO-8859-1")
- (connect s (addrinfo:addr ai))
- ;; Buffer input and output on this port.
- (setvbuf s _IOFBF)
- ;; Enlarge the receive buffer.
- (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
- s))
+ "Return an open input/output port for a connection to URI."
+ (define addresses
+ (let ((port (uri-port uri)))
+ (getaddrinfo (uri-host uri)
+ (cond (port => number->string)
+ (else (symbol->string (uri-scheme uri))))
+ (if port
+ AI_NUMERICSERV
+ 0))))
+
+ (let loop ((addresses addresses))
+ (let* ((ai (car addresses))
+ (s (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+ (addrinfo:protocol ai))))
+ (set-port-encoding! s "ISO-8859-1")
+
+ (catch 'system-error
+ (lambda ()
+ (connect s (addrinfo:addr ai))
+
+ ;; Buffer input and output on this port.
+ (setvbuf s _IOFBF)
+ ;; Enlarge the receive buffer.
+ (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024))
+ s)
+ (lambda args
+ ;; Connection failed, so try one of the other addresses.
+ (close s)
+ (if (null? addresses)
+ (apply throw args)
+ (loop (cdr addresses))))))))
(define (decode-string bv encoding)
(if (string-ci=? encoding "utf-8")
diff --git a/module/web/uri.scm b/module/web/uri.scm
index 109118b12..78614a520 100644
--- a/module/web/uri.scm
+++ b/module/web/uri.scm
@@ -364,7 +364,9 @@ Percent-encoding first writes out the given character to a bytevector
within the given @var{encoding}, then encodes each byte as
@code{%@var{HH}}, where @var{HH} is the hexadecimal representation of
the byte."
- (if (string-index str unescaped-chars)
+ (define (needs-escaped? ch)
+ (not (char-set-contains? unescaped-chars ch)))
+ (if (string-index str needs-escaped?)
(call-with-output-string*
(lambda (port)
(string-for-each
@@ -377,6 +379,8 @@ the byte."
(if (< i len)
(let ((byte (bytevector-u8-ref bv i)))
(display #\% port)
+ (when (< byte 16)
+ (display #\0 port))
(display (number->string byte 16) port)
(lp (1+ i))))))))
str)))