Merge commit '8cf2a7ba74'

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

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.

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

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);

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"
+	    "descriptors, or waiting for a timeout to occur.\n\n"
-	    "It also returns if interrupted by a signal.\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"

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 \

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))

module/system/base/lalr.upstream.scm

@@ -1,6 +1,7 @@
 ;;;
 ;;;; An Efficient and Portable LALR(1) Parser Generator for Scheme
 ;;;
+;; Copyright 2014  Jan Nieuwenhuizen <janneke@gnu.org>
 ;; 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 <http://www.gnu.org/licenses/>.
 
 
-(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))
+		(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)))
+					 (let ((rest (cdr l))
+                                               (ns (number->string (+ (- n i) 1))))
                                            (cons
-					    `(,(string->symbol
+                                            `(tok ,(if (eq? driver-name 'lr-driver)
-						(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)))
+                                            (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*))
+      (let ((symbol (token-category *input*)))
-            (attr   (token-attribute *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

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)))))
 

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 <http://bugs.gnu.org/19027>.
+  (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 <http://debbugs.gnu.org/10070>.
     (let ((b (u8-list->bytevector '(1 2 3 4 5 6 7 8))))