From: Andy Wingo Date: Thu, 22 Jan 2015 12:24:30 +0000 (+0100) Subject: Merge commit '8cf2a7ba7432d68b9a055d29f18117be70375af9' X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/a5b5cb422e66f77cac34ded42631db6a067323cc?hp=a51111dd255189bd00eb28547491ee4a9bfa9ca1 Merge commit '8cf2a7ba7432d68b9a055d29f18117be70375af9' --- diff --git a/doc/ref/guile-invoke.texi b/doc/ref/guile-invoke.texi index d233ce653..bc33ce080 100644 --- a/doc/ref/guile-invoke.texi +++ b/doc/ref/guile-invoke.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2011, 2013, 2014 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -327,7 +327,9 @@ variable. By default, the history file is @file{$HOME/.guile_history}. @vindex GUILE_INSTALL_LOCALE This is a flag that can be used to tell Guile whether or not to install the current locale at startup, via a call to @code{(setlocale LC_ALL -"")}. @xref{Locales}, for more information on locales. +"")}@footnote{The @code{GUILE_INSTALL_LOCALE} environment variable was +ignored in Guile versions prior to 2.0.9.}. @xref{Locales}, for more +information on locales. You may explicitly indicate that you do not want to install the locale by setting @env{GUILE_INSTALL_LOCALE} to @code{0}, or diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 9182bd8db..356941f2d 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -567,7 +567,11 @@ This procedure has a variety of uses: waiting for the ability to provide input, accept output, or the existence of exceptional conditions on a collection of ports or file descriptors, or waiting for a timeout to occur. -It also returns if interrupted by a signal. + +When an error occurs, of if it is interrupted by a signal, this +procedure throws a @code{system-error} exception +(@pxref{Conventions, @code{system-error}}). In case of an +interruption, the associated error number is @var{EINTR}. @var{reads}, @var{writes} and @var{excepts} can be lists or vectors, with each member a port or a file descriptor. diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 4ebf76d69..c890d7dd1 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -38,6 +38,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-23:: Error reporting * SRFI-26:: Specializing parameters * SRFI-27:: Sources of Random Bits +* SRFI-28:: Basic format strings. * SRFI-30:: Nested multi-line block comments * SRFI-31:: A special form `rec' for recursive evaluation * SRFI-34:: Exception handling. @@ -3269,6 +3270,42 @@ reasonably small value (related to the width of the mantissa of an efficient number format). @end defun +@node SRFI-28 +@subsection SRFI-28 - Basic Format Strings +@cindex SRFI-28 + +SRFI-28 provides a basic @code{format} procedure that provides only +the @code{~a}, @code{~s}, @code{~%}, and @code{~~} format specifiers. +You can import this procedure by using: + +@lisp +(use-modules (srfi srfi-28)) +@end lisp + +@deffn {Scheme Procedure} format message arg @dots{} +Returns a formatted message, using @var{message} as the format string, +which can contain the following format specifiers: + +@table @code +@item ~a +Insert the textual representation of the next @var{arg}, as if printed +by @code{display}. + +@item ~s +Insert the textual representation of the next @var{arg}, as if printed +by @code{write}. + +@item ~% +Insert a newline. + +@item ~~ +Insert a tilde. +@end table + +This procedure is the same as calling @code{simple-format} (@pxref{Writing}) +with @code{#f} as the destination. +@end deffn + @node SRFI-30 @subsection SRFI-30 - Nested Multi-line Comments @cindex SRFI-30 diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 4f18be6ca..41d5b6c85 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -554,9 +554,14 @@ SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0, { size_t c_len, i; scm_t_uint8 *c_bv, c_fill; + int value; SCM_VALIDATE_BYTEVECTOR (1, bv); - c_fill = scm_to_int8 (fill); + + value = scm_to_int (fill); + if (SCM_UNLIKELY ((value < -128) || (value > 255))) + scm_out_of_range (FUNC_NAME, fill); + c_fill = (scm_t_uint8) value; c_len = SCM_BYTEVECTOR_LENGTH (bv); c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv); diff --git a/libguile/filesys.c b/libguile/filesys.c index 204d74eed..95d1a9dff 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -774,8 +774,13 @@ SCM_DEFINE (scm_select, "select", 3, 2, 0, "This procedure has a variety of uses: waiting for the ability\n" "to provide input, accept output, or the existence of\n" "exceptional conditions on a collection of ports or file\n" - "descriptors, or waiting for a timeout to occur.\n" - "It also returns if interrupted by a signal.\n\n" + "descriptors, or waiting for a timeout to occur.\n\n" + + "When an error occurs, of if it is interrupted by a signal, this\n" + "procedure throws a @code{system-error} exception\n" + "(@pxref{Conventions, @code{system-error}}). In case of an\n" + "interruption, the associated error number is @var{EINTR}.\n\n" + "@var{reads}, @var{writes} and @var{excepts} can be lists or\n" "vectors, with each member a port or a file descriptor.\n" "The value returned is a list of three corresponding\n" diff --git a/module/Makefile.am b/module/Makefile.am index 7b3a4a8b9..e0a0344d0 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -303,6 +303,7 @@ SRFI_SOURCES = \ srfi/srfi-19.scm \ srfi/srfi-26.scm \ srfi/srfi-27.scm \ + srfi/srfi-28.scm \ srfi/srfi-31.scm \ srfi/srfi-34.scm \ srfi/srfi-35.scm \ diff --git a/module/srfi/srfi-28.scm b/module/srfi/srfi-28.scm new file mode 100644 index 000000000..7fc73eb7e --- /dev/null +++ b/module/srfi/srfi-28.scm @@ -0,0 +1,34 @@ +;;; srfi-28.scm --- Basic Format Strings + +;; Copyright (C) 2014 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 +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +;;; Commentary: + +;; This module provides a wrapper for simple-format that always outputs +;; to a string. +;; +;; This module is documented in the Guile Reference Manual. + +;;; Code: + +(define-module (srfi srfi-28) + #:replace (format)) + +(define (format message . args) + (apply simple-format #f message args)) + +(cond-expand-provide (current-module) '(srfi-28)) diff --git a/module/system/base/lalr.upstream.scm b/module/system/base/lalr.upstream.scm index 217c43980..d2c087257 100755 --- a/module/system/base/lalr.upstream.scm +++ b/module/system/base/lalr.upstream.scm @@ -1,6 +1,7 @@ ;;; ;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme ;;; +;; Copyright 2014 Jan Nieuwenhuizen ;; Copyright 1993, 2010 Dominique Boucher ;; ;; This program is free software: you can redistribute it and/or @@ -17,7 +18,7 @@ ;; along with this program. If not, see . -(define *lalr-scm-version* "2.4.1") +(define *lalr-scm-version* "2.5.0") (cond-expand @@ -33,7 +34,8 @@ (def-macro (lalr-error msg obj) `(error ,msg ,obj)) (define pprint pretty-print) - (define lalr-keyword? keyword?)) + (define lalr-keyword? keyword?) + (define (note-source-location lvalue tok) lvalue)) ;; -- (bigloo @@ -44,7 +46,8 @@ (define lalr-keyword? keyword?) (def-macro (BITS-PER-WORD) 29) (def-macro (logical-or x . y) `(bit-or ,x ,@y)) - (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj))) + (def-macro (lalr-error msg obj) `(error "lalr-parser" ,msg ,obj)) + (define (note-source-location lvalue tok) lvalue)) ;; -- Chicken (chicken @@ -56,7 +59,8 @@ (define lalr-keyword? symbol?) (def-macro (BITS-PER-WORD) 30) (def-macro (logical-or x . y) `(bitwise-ior ,x ,@y)) - (def-macro (lalr-error msg obj) `(error ,msg ,obj))) + (def-macro (lalr-error msg obj) `(error ,msg ,obj)) + (define (note-source-location lvalue tok) lvalue)) ;; -- STKlos (stklos @@ -67,7 +71,8 @@ (define lalr-keyword? keyword?) (define-macro (BITS-PER-WORD) 30) (define-macro (logical-or x . y) `(bit-or ,x ,@y)) - (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj))) + (define-macro (lalr-error msg obj) `(error 'lalr-parser ,msg ,obj)) + (define (note-source-location lvalue tok) lvalue)) ;; -- Guile (guile @@ -78,7 +83,14 @@ (define lalr-keyword? symbol?) (define-macro (BITS-PER-WORD) 30) (define-macro (logical-or x . y) `(logior ,x ,@y)) - (define-macro (lalr-error msg obj) `(error ,msg ,obj))) + (define-macro (lalr-error msg obj) `(error ,msg ,obj)) + (define (note-source-location lvalue tok) + (if (and (supports-source-properties? lvalue) + (not (source-property lvalue 'loc)) + (lexical-token? tok)) + (set-source-property! lvalue 'loc (lexical-token-source tok))) + lvalue)) + ;; -- Kawa (kawa @@ -87,7 +99,8 @@ (define logical-or logior) (define (lalr-keyword? obj) (keyword? obj)) (define (pprint obj) (pretty-print obj)) - (define (lalr-error msg obj) (error msg obj))) + (define (lalr-error msg obj) (error msg obj)) + (define (note-source-location lvalue tok) lvalue)) ;; -- SISC (sisc @@ -98,8 +111,8 @@ (define lalr-keyword? symbol?) (define-macro BITS-PER-WORD (lambda () 32)) (define-macro logical-or (lambda (x . y) `(logor ,x ,@y))) - (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj))) - + (define-macro (lalr-error msg obj) `(error "~a ~S:" ,msg ,obj)) + (define (note-source-location lvalue tok) lvalue)) (else (error "Unsupported Scheme system"))) @@ -235,6 +248,11 @@ (define driver-name 'lr-driver) + (define (glr-driver?) + (eq? driver-name 'glr-driver)) + (define (lr-driver?) + (eq? driver-name 'lr-driver)) + (define (gen-tables! tokens gram ) (initialize-all) (rewrite-grammar @@ -1097,14 +1115,14 @@ (add-conflict-message "%% Reduce/Reduce conflict (reduce " (- new-action) ", reduce " (- current-action) ") on '" (get-symbol (+ symbol nvars)) "' in state " state) - (if (eq? driver-name 'glr-driver) + (if (glr-driver?) (set-cdr! (cdr actions) (cons new-action (cddr actions))) (set-car! (cdr actions) (max current-action new-action)))) ;; --- shift/reduce conflict ;; can we resolve the conflict using precedences? (case (resolve-conflict symbol (- current-action)) ;; -- shift - ((shift) (if (eq? driver-name 'glr-driver) + ((shift) (if (glr-driver?) (set-cdr! (cdr actions) (cons new-action (cddr actions))) (set-car! (cdr actions) new-action))) ;; -- reduce @@ -1113,11 +1131,12 @@ (else (add-conflict-message "%% Shift/Reduce conflict (shift " new-action ", reduce " (- current-action) ") on '" (get-symbol (+ symbol nvars)) "' in state " state) - (if (eq? driver-name 'glr-driver) + (if (glr-driver?) (set-cdr! (cdr actions) (cons new-action (cddr actions))) (set-car! (cdr actions) new-action)))))))) - (vector-set! action-table state (cons (list symbol new-action) state-actions))))) + (vector-set! action-table state (cons (list symbol new-action) state-actions))) + )) (define (add-action-for-all-terminals state action) (do ((i 1 (+ i 1))) @@ -1131,7 +1150,9 @@ (let ((red (vector-ref reduction-table i))) (if (and red (>= (red-nreds red) 1)) (if (and (= (red-nreds red) 1) (vector-ref consistent i)) - (add-action-for-all-terminals i (- (car (red-rules red)))) + (if (glr-driver?) + (add-action-for-all-terminals i (- (car (red-rules red)))) + (add-action i 'default (- (car (red-rules red))))) (let ((k (vector-ref lookaheads (+ i 1)))) (let loop ((j (vector-ref lookaheads i))) (if (< j k) @@ -1591,22 +1612,27 @@ `(let* (,@(if act (let loop ((i 1) (l rhs)) (if (pair? l) - (let ((rest (cdr l))) - (cons - `(,(string->symbol - (string-append - "$" - (number->string - (+ (- n i) 1)))) - ,(if (eq? driver-name 'lr-driver) - `(vector-ref ___stack (- ___sp ,(- (* i 2) 1))) - `(list-ref ___sp ,(+ (* (- i 1) 2) 1)))) - (loop (+ i 1) rest))) + (let ((rest (cdr l)) + (ns (number->string (+ (- n i) 1)))) + (cons + `(tok ,(if (eq? driver-name 'lr-driver) + `(vector-ref ___stack (- ___sp ,(- (* i 2) 1))) + `(list-ref ___sp ,(+ (* (- i 1) 2) 1)))) + (cons + `(,(string->symbol (string-append "$" ns)) + (if (lexical-token? tok) (lexical-token-value tok) tok)) + (cons + `(,(string->symbol (string-append "@" ns)) + (if (lexical-token? tok) (lexical-token-source tok) tok)) + (loop (+ i 1) rest))))) '())) '())) ,(if (= nt 0) '$1 - `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp))))))))) + `(___push ,n ,nt ,(cdr p) ,@(if (eq? driver-name 'lr-driver) '() '(___sp)) + ,(if (eq? driver-name 'lr-driver) + `(vector-ref ___stack (- ___sp ,(length rhs))) + `(list-ref ___sp ,(length rhs)))))))))) gram/actions)))) @@ -1822,14 +1848,14 @@ (if (>= ___sp (vector-length ___stack)) (___growstack))) - (define (___push delta new-category lvalue) + (define (___push delta new-category lvalue tok) (set! ___sp (- ___sp (* delta 2))) (let* ((state (vector-ref ___stack ___sp)) (new-state (cdr (assoc new-category (vector-ref ___gtable state))))) (set! ___sp (+ ___sp 2)) (___checkstack) (vector-set! ___stack ___sp new-state) - (vector-set! ___stack (- ___sp 1) lvalue))) + (vector-set! ___stack (- ___sp 1) (note-source-location lvalue tok)))) (define (___reduce st) ((vector-ref ___rtable st) ___stack ___sp ___gtable ___push ___pushback)) @@ -1879,17 +1905,11 @@ (lexical-token-category tok) tok)) - (define (___value tok) - (if (lexical-token? tok) - (lexical-token-value tok) - tok)) - (define (___run) (let loop () (if ___input (let* ((state (vector-ref ___stack ___sp)) (i (___category ___input)) - (attr (___value ___input)) (act (___action i (vector-ref ___atable state)))) (cond ((not (symbol? i)) @@ -1918,7 +1938,7 @@ ;; Shift current token on top of the stack ((>= act 0) - (___shift act attr) + (___shift act ___input) (set! ___input (if (eq? i '*eoi*) '*eoi* #f)) (loop)) @@ -2003,11 +2023,11 @@ (set! *parses* (cons parse *parses*))) - (define (push delta new-category lvalue stack) + (define (push delta new-category lvalue stack tok) (let* ((stack (drop stack (* delta 2))) (state (car stack)) (new-state (cdr (assv new-category (vector-ref ___gtable state))))) - (cons new-state (cons lvalue stack)))) + (cons new-state (cons (note-source-location lvalue tok) stack)))) (define (reduce state stack) ((vector-ref ___rtable state) stack ___gtable push)) @@ -2025,8 +2045,7 @@ (define (run) (let loop-tokens () (consume) - (let ((symbol (token-category *input*)) - (attr (token-attribute *input*))) + (let ((symbol (token-category *input*))) (for-all-processes (lambda (process) (let loop ((stacks (list process)) (active-stacks '())) @@ -2044,7 +2063,7 @@ (add-parse (car (take-right stack 2))) (actions-loop other-actions active-stacks)) ((>= action 0) - (let ((new-stack (shift action attr stack))) + (let ((new-stack (shift action *input* stack))) (add-process new-stack)) (actions-loop other-actions active-stacks)) (else diff --git a/module/system/base/target.scm b/module/system/base/target.scm index e5456749b..d60a8e0af 100644 --- a/module/system/base/target.scm +++ b/module/system/base/target.scm @@ -63,10 +63,10 @@ (cond ((string-match "^i[0-9]86$" cpu) (endianness little)) ((member cpu '("x86_64" "ia64" - "powerpcle" "powerpc64le" "mipsel" "mips64el")) + "powerpcle" "powerpc64le" "mipsel" "mips64el" "sh4")) (endianness little)) ((member cpu '("sparc" "sparc64" "powerpc" "powerpc64" "spu" - "mips" "mips64")) + "mips" "mips64" "m68k" "s390x")) (endianness big)) ((string-match "^arm.*el" cpu) (endianness little)) @@ -102,7 +102,8 @@ ((string-match "64$" cpu) 8) ((string-match "64_?[lbe][lbe]$" cpu) 8) - ((member cpu '("sparc" "powerpc" "mips" "mipsel")) 4) + ((member cpu '("sparc" "powerpc" "mips" "mipsel" "m68k" "sh4")) 4) + ((member cpu '("s390x")) 8) ((string-match "^arm.*" cpu) 4) (else (error "unknown CPU word size" cpu))))) diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 91367db08..4cc5b67e0 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -46,6 +46,21 @@ (not (bytevector=? (make-bytevector 20 7) (make-bytevector 20 0))))) + ;; This failed prior to Guile 2.0.12. + ;; See . + (pass-if-equal "bytevector-fill! with fill 255" + #vu8(255 255 255 255) + (let ((bv (make-bytevector 4))) + (bytevector-fill! bv 255) + bv)) + + ;; This is a Guile-specific extension. + (pass-if-equal "bytevector-fill! with fill -128" + #vu8(128 128 128 128) + (let ((bv (make-bytevector 4))) + (bytevector-fill! bv -128) + bv)) + (pass-if "bytevector-copy! overlapping" ;; See . (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))