mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge commit '8cf2a7ba74'

Browse source
This commit is contained in:
Andy Wingo 2015-01-22 13:24:30 +01:00
commit a5b5cb422e
10 changed files with 172 additions and 49 deletions
Download patch file Download diff file Expand all files Collapse all files

6
doc/ref/guile-invoke.texi
View file

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

6
doc/ref/posix.texi
View file

@ -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.

37
doc/ref/srfi-modules.texi
View file

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

7
libguile/bytevectors.c
View file

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

9
libguile/filesys.c
View file

@ -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"

1
module/Makefile.am
View file

@ -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 \

34
module/srfi/srfi-28.scm Normal file
View file

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

99
module/system/base/lalr.upstream.scm
View file

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

7
module/system/base/target.scm
View file

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

15
test-suite/tests/bytevectors.test
View file

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