diff options
Diffstat (limited to 'module')
-rw-r--r-- | module/ice-9/boot-9.scm | 14 | ||||
-rw-r--r-- | module/ice-9/command-line.scm | 14 | ||||
-rw-r--r-- | module/ice-9/curried-definitions.scm | 14 | ||||
-rw-r--r-- | module/ice-9/format.scm | 14 | ||||
-rw-r--r-- | module/ice-9/regex.scm | 3 | ||||
-rw-r--r-- | module/language/tree-il/primitives.scm | 21 | ||||
-rw-r--r-- | module/srfi/srfi-19.scm | 8 | ||||
-rw-r--r-- | module/srfi/srfi-31.scm | 26 | ||||
-rw-r--r-- | module/system/base/compile.scm | 19 | ||||
-rw-r--r-- | module/texinfo.scm | 28 | ||||
-rw-r--r-- | module/web/client.scm | 46 | ||||
-rw-r--r-- | module/web/uri.scm | 6 |
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))) |