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 branch 'stable-2.0'

Browse source 
Conflicts:
	module/system/vm/traps.scm
	test-suite/tests/peval.test
This commit is contained in:
Mark H Weaver 2014-01-09 01:32:32 -05:00
commit 1df515a077
19 changed files with 276 additions and 80 deletions
Download patch file Download diff file Expand all files Collapse all files

2
THANKS
View file

@ -2,6 +2,7 @@ Contributors since the last release:
Greg Benison
Tristan Colgate-McFarlane
Aleix Conchillo Flaqué
Ludovic Courtès
Jason Earl
Brian Gough
@ -167,6 +168,7 @@ For fixes or providing information which led to a fix:
Rainer Tammer
Samuel Thibault
Richard Todd
Tom Tromey
Issac Trotts
Greg Troxel
Aaron M. Ucko

27
doc/ref/api-data.texi
View file

@ -1,7 +1,7 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
@c 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
@c 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@node Simple Data Types
@ -318,7 +318,8 @@ Scheme integers can be exact and inexact. For example, a number
written as @code{3.0} with an explicit decimal-point is inexact, but
it is also an integer. The functions @code{integer?} and
@code{scm_is_integer} report true for such a number, but the functions
@code{scm_is_signed_integer} and @code{scm_is_unsigned_integer} only
@code{exact-integer?}, @code{scm_is_exact_integer},
@code{scm_is_signed_integer}, and @code{scm_is_unsigned_integer} only
allow exact integers and thus report false. Likewise, the conversion
functions like @code{scm_to_signed_integer} only accept exact
integers.
@ -333,7 +334,7 @@ will become exact fractions.)
@deffn {Scheme Procedure} integer? x
@deffnx {C Function} scm_integer_p (x)
Return @code{#t} if @var{x} is an exact or inexact integer number, else
@code{#f}.
return @code{#f}.
@lisp
(integer? 487)
@ -346,7 +347,7 @@ Return @code{#t} if @var{x} is an exact or inexact integer number, else
@result{} #f
(integer? +inf.0)
@result{} #t
@result{} #f
@end lisp
@end deffn
@ -354,6 +355,24 @@ Return @code{#t} if @var{x} is an exact or inexact integer number, else
This is equivalent to @code{scm_is_true (scm_integer_p (x))}.
@end deftypefn
@deffn {Scheme Procedure} exact-integer? x
@deffnx {C Function} scm_exact_integer_p (x)
Return @code{#t} if @var{x} is an exact integer number, else
return @code{#f}.
@lisp
(exact-integer? 37)
@result{} #t
(exact-integer? 3.0)
@result{} #f
@end lisp
@end deffn
@deftypefn {C Function} int scm_is_exact_integer (SCM x)
This is equivalent to @code{scm_is_true (scm_exact_integer_p (x))}.
@end deftypefn
@defvr {C Type} scm_t_int8
@defvrx {C Type} scm_t_uint8
@defvrx {C Type} scm_t_int16

15
libguile/load.c
View file

@ -88,7 +88,6 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
{
SCM hook = *scm_loc_load_hook;
SCM ret = SCM_UNSPECIFIED;
char *encoding;
SCM_VALIDATE_STRING (1, filename);
if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook)))
@ -101,18 +100,14 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0,
{
SCM port;
port = scm_open_file (filename, scm_from_locale_string ("r"));
port = scm_open_file_with_encoding (filename,
scm_from_latin1_string ("r"),
SCM_BOOL_T, /* guess_encoding */
scm_from_latin1_string ("UTF-8"));
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
scm_i_dynwind_current_load_port (port);
encoding = scm_i_scan_for_encoding (port);
if (encoding)
scm_i_set_port_encoding_x (port, encoding);
else
/* The file has no encoding declared. We'll presume UTF-8, like
compile-file does. */
scm_i_set_port_encoding_x (port, "UTF-8");
while (1)
{
SCM reader, form;

23
libguile/numbers.c
View file

@ -6519,8 +6519,8 @@ SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
(SCM x),
"Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
"else.")
"Return @code{#t} if @var{x} is an integer number,\n"
"else return @code{#f}.")
#define FUNC_NAME s_scm_integer_p
{
if (SCM_I_INUMP (x) || SCM_BIGP (x))
@ -6535,6 +6535,19 @@ SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_exact_integer_p, "exact-integer?", 1, 0, 0,
(SCM x),
"Return @code{#t} if @var{x} is an exact integer number,\n"
"else return @code{#f}.")
#define FUNC_NAME s_scm_exact_integer_p
{
if (SCM_I_INUMP (x) || SCM_BIGP (x))
return SCM_BOOL_T;
else
return SCM_BOOL_F;
}
#undef FUNC_NAME
SCM scm_i_num_eq_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
@ -9623,6 +9636,12 @@ scm_is_integer (SCM val)
return scm_is_true (scm_integer_p (val));
}
int
scm_is_exact_integer (SCM val)
{
return scm_is_true (scm_exact_integer_p (val));
}
int
scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
{

2
libguile/numbers.h
View file

@ -242,6 +242,7 @@ SCM_API SCM scm_complex_p (SCM x);
SCM_API SCM scm_real_p (SCM x);
SCM_API SCM scm_rational_p (SCM z);
SCM_API SCM scm_integer_p (SCM x);
SCM_API SCM scm_exact_integer_p (SCM x);
SCM_API SCM scm_inexact_p (SCM x);
SCM_API int scm_is_inexact (SCM x);
SCM_API SCM scm_num_eq_p (SCM x, SCM y);
@ -330,6 +331,7 @@ SCM_INTERNAL void scm_i_print_complex (double real, double imag, SCM port);
/* conversion functions for integers */
SCM_API int scm_is_integer (SCM val);
SCM_API int scm_is_exact_integer (SCM val);
SCM_API int scm_is_signed_integer (SCM val,
scm_t_intmax min, scm_t_intmax max);
SCM_API int scm_is_unsigned_integer (SCM val,

2
libguile/private-options.h
View file

@ -69,6 +69,6 @@ SCM_INTERNAL scm_t_option scm_read_opts[];
#define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val
#define SCM_CURLY_INFIX_P scm_read_opts[7].val
#define SCM_N_READ_OPTIONS 7
#define SCM_N_READ_OPTIONS 8
#endif /* PRIVATE_OPTIONS */

3
libguile/read.c
View file

@ -1116,6 +1116,9 @@ read_decimal_integer (SCM port, int c, ssize_t *resp)
while ('0' <= c && c <= '9')
{
if (((SSIZE_MAX - (c-'0')) / 10) <= res)
scm_i_input_error ("read_decimal_integer", port,
"number too large", SCM_EOL);
res = 10*res + c-'0';
got_it = 1;
c = scm_getc_unlocked (port);

2
libguile/socket.c
View file

@ -1331,7 +1331,7 @@ SCM_DEFINE (scm_accept, "accept", 1, 0, 0,
sock = SCM_COERCE_OUTPORT (sock);
SCM_VALIDATE_OPFPORT (1, sock);
fd = SCM_FPORT_FDES (sock);
newfd = accept (fd, (struct sockaddr *) &addr, &addr_size);
SCM_SYSCALL (newfd = accept (fd, (struct sockaddr *) &addr, &addr_size));
if (newfd == -1)
SCM_SYSERROR;
newsock = SCM_SOCK_FD_TO_PORT (newfd);

13
libguile/srfi-13.c
View file

@ -546,10 +546,17 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
target = scm_i_string_start_writing (target);
for (i = 0; i < cend - cstart; i++)
if (ctstart < cstart)
{
scm_i_string_set_x (target, ctstart + i,
scm_i_string_ref (s, cstart + i));
for (i = 0; i < len; i++)
scm_i_string_set_x (target, ctstart + i,
scm_i_string_ref (s, cstart + i));
}
else
{
for (i = len; i--;)
scm_i_string_set_x (target, ctstart + i,
scm_i_string_ref (s, cstart + i));
}
scm_i_string_stop_writing ();
scm_remember_upto_here_1 (target);

45
meta/guile.m4
View file

@ -1,17 +1,17 @@
## Autoconf macros for working with Guile.
##
## Copyright (C) 1998,2001, 2006, 2010, 2012 Free Software Foundation, Inc.
## Copyright (C) 1998,2001, 2006, 2010, 2012, 2013 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
@ -177,12 +177,16 @@ AC_DEFUN([GUILE_SITE_DIR],
# GUILE_PROGS -- set paths to Guile interpreter, config and tool programs
#
# Usage: GUILE_PROGS
# Usage: GUILE_PROGS([VERSION])
#
# This macro looks for programs @code{guile} and @code{guild}, setting
# variables @var{GUILE} and @var{GUILD} to their paths, respectively.
# If @code{guile} is not found, signal an error.
#
# By default, this macro will search for the latest stable version of
# Guile (e.g. 2.0). x.y or x.y.z versions can be specified. If an older
# version is found, the macro will signal an error.
#
# The effective version of the found @code{guile} is set to
# @var{GUILE_EFFECTIVE_VERSION}. This macro ensures that the effective
# version is compatible with the result of a previous invocation of
@ -195,18 +199,43 @@ AC_DEFUN([GUILE_SITE_DIR],
#
AC_DEFUN([GUILE_PROGS],
[AC_PATH_PROG(GUILE,guile)
_guile_required_version="m4_default([$1], [2.0])"
if test "$GUILE" = "" ; then
AC_MSG_ERROR([guile required but not found])
fi
AC_SUBST(GUILE)
_guile_prog_version=`$GUILE -c "(display (effective-version))"`
_guile_effective_version=`$GUILE -c "(display (effective-version))"`
if test -z "$GUILE_EFFECTIVE_VERSION"; then
GUILE_EFFECTIVE_VERSION=$_guile_prog_version
elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_prog_version"; then
AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_prog_version])
GUILE_EFFECTIVE_VERSION=$_guile_effective_version
elif test "$GUILE_EFFECTIVE_VERSION" != "$_guile_effective_version"; then
AC_MSG_ERROR([found development files for Guile $GUILE_EFFECTIVE_VERSION, but $GUILE has effective version $_guile_effective_version])
fi
_guile_major_version=`$GUILE -c "(display (major-version))"`
_guile_minor_version=`$GUILE -c "(display (minor-version))"`
_guile_micro_version=`$GUILE -c "(display (micro-version))"`
_guile_prog_version="$_guile_major_version.$_guile_minor_version.$_guile_micro_version"
AC_MSG_CHECKING([for Guile version >= $_guile_required_version])
_major_version=`echo $_guile_required_version | cut -d . -f 1`
_minor_version=`echo $_guile_required_version | cut -d . -f 2`
_micro_version=`echo $_guile_required_version | cut -d . -f 3`
if test "$_guile_major_version" -ge "$_major_version"; then
if test "$_guile_minor_version" -ge "$_minor_version"; then
if test -n "$_micro_version"; then
if test "$_guile_micro_version" -lt "$_micro_version"; then
AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found])
fi
fi
else
AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found])
fi
else
AC_MSG_ERROR([Guile $_guile_required_version required, but $_guile_prog_version found])
fi
AC_MSG_RESULT([$_guile_prog_version])
AC_PATH_PROG(GUILD,guild)
AC_SUBST(GUILD)

3
module/ice-9/boot-9.scm
View file

@ -3295,6 +3295,9 @@ module '(ice-9 q) '(make-q q-length))}."
;;; {Autoloading modules}
;;;
;;; XXX FIXME autoloads-in-progress and autoloads-done
;;; are not handled in a thread-safe way.
(define autoloads-in-progress '())
;; This function is called from scm_load_scheme_module in

25
module/ice-9/psyntax-pp.scm
View file

@ -2106,14 +2106,17 @@
(lambda (pattern keys)
(letrec*
((cvt* (lambda (p* n ids)
(if (not (pair? p*))
(cvt p* n ids)
(call-with-values
(lambda () (cvt* (cdr p*) n ids))
(lambda (y ids)
(call-with-values
(lambda () (cvt (car p*) n ids))
(lambda (x ids) (values (cons x y) ids))))))))
(let* ((tmp p*) (tmp ($sc-dispatch tmp '(any . any))))
(if tmp
(apply (lambda (x y)
(call-with-values
(lambda () (cvt* y n ids))
(lambda (y ids)
(call-with-values
(lambda () (cvt x n ids))
(lambda (x ids) (values (cons x y) ids))))))
tmp)
(cvt p* n ids)))))
(v-reverse
(lambda (x)
(let loop ((r '()) (x x))
@ -2196,10 +2199,10 @@
(call-with-values
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
(cond ((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
(cond ((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
(build-call

17
module/ice-9/psyntax.scm
View file

@ -2441,15 +2441,16 @@
(lambda (pattern keys)
(define cvt*
(lambda (p* n ids)
(if (not (pair? p*))
(cvt p* n ids)
(call-with-values
(lambda () (cvt* (cdr p*) n ids))
(syntax-case p* ()
((x . y)
(call-with-values
(lambda () (cvt* #'y n ids))
(lambda (y ids)
(call-with-values
(lambda () (cvt (car p*) n ids))
(lambda () (cvt #'x n ids))
(lambda (x ids)
(values (cons x y) ids))))))))
(values (cons x y) ids))))))
(_ (cvt p* n ids)))))
(define (v-reverse x)
(let loop ((r '()) (x x))
@ -2530,10 +2531,10 @@
(lambda () (convert-pattern pat keys))
(lambda (p pvars)
(cond
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
((not (and-map (lambda (x) (not (ellipsis? (car x)))) pvars))
(syntax-violation 'syntax-case "misplaced ellipsis" pat))
((not (distinct-bound-ids? (map car pvars)))
(syntax-violation 'syntax-case "duplicate pattern variable" pat))
(else
(let ((y (gen-var 'tmp)))
;; fat finger binding and references to temp variable y

38
module/language/tree-il/peval.scm
View file

@ -731,24 +731,26 @@ top-level bindings from ENV and return the resulting expression."
(cond
((lookup (lexical-ref-gensym x))
=> (lambda (op)
(let ((y (or (operand-residual-value op)
(visit-operand op counter 'value 10 10)
(operand-source op))))
(cond
((and (lexical-ref? y)
(= (lexical-refcount (lexical-ref-gensym x)) 1))
;; X is a simple alias for Y. Recurse, regardless of
;; the number of aliases we were expecting.
(find-definition y n-aliases))
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
;; We found a definition that is aliased the right
;; number of times. We still recurse in case it is a
;; lexical.
(values (find-definition y 1)
op))
(else
;; We can't account for our aliases.
(values #f #f))))))
(if (var-set? (operand-var op))
(values #f #f)
(let ((y (or (operand-residual-value op)
(visit-operand op counter 'value 10 10)
(operand-source op))))
(cond
((and (lexical-ref? y)
(= (lexical-refcount (lexical-ref-gensym x)) 1))
;; X is a simple alias for Y. Recurse, regardless of
;; the number of aliases we were expecting.
(find-definition y n-aliases))
((= (lexical-refcount (lexical-ref-gensym x)) n-aliases)
;; We found a definition that is aliased the right
;; number of times. We still recurse in case it is a
;; lexical.
(values (find-definition y 1)
op))
(else
;; We can't account for our aliases.
(values #f #f)))))))
(else
;; A formal parameter. Can't say anything about that.
(values #f #f))))

23
module/system/vm/traps.scm
View file

@ -113,16 +113,19 @@
(and pdi (program-debug-info-size pdi))))
(define (frame-matcher proc match-code?)
(if match-code?
(if (program? proc)
(let ((start (program-code proc))
(end (program-last-ip proc)))
(lambda (frame)
(let ((ip (frame-instruction-pointer frame)))
(and (<= start ip) (< ip end)))))
(lambda (frame) #f))
(lambda (frame)
(eq? (frame-procedure frame) proc))))
(let ((proc (if (struct? proc)
(procedure proc)
proc)))
(if match-code?
(if (program? proc)
(let ((start (program-code proc))
(end (program-last-ip proc)))
(lambda (frame)
(let ((ip (frame-instruction-pointer frame)))
(and (<= start ip) (< ip end)))))
(lambda (frame) #f))
(lambda (frame)
(eq? (frame-procedure frame) proc)))))
;; A basic trap, fires when a procedure is called.
;;

28
test-suite/tests/numbers.test
View file

@ -1807,6 +1807,34 @@
(pass-if (not (integer? (lambda () #t))))
(pass-if (not (integer? (current-input-port)))))
;;;
;;; integer?
;;;
(with-test-prefix "exact-integer?"
(pass-if (documented? exact-integer?))
(pass-if (exact-integer? 0))
(pass-if (exact-integer? 7))
(pass-if (exact-integer? -7))
(pass-if (exact-integer? (+ 1 fixnum-max)))
(pass-if (exact-integer? (- 1 fixnum-min)))
(pass-if (and (= 1.0 (round 1.0))
(not (exact-integer? 1.0))))
(pass-if (not (exact-integer? 1.3)))
(pass-if (not (exact-integer? +inf.0)))
(pass-if (not (exact-integer? -inf.0)))
(pass-if (not (exact-integer? +nan.0)))
(pass-if (not (exact-integer? +inf.0-inf.0i)))
(pass-if (not (exact-integer? +nan.0+nan.0i)))
(pass-if (not (exact-integer? 3+4i)))
(pass-if (not (exact-integer? #\a)))
(pass-if (not (exact-integer? "a")))
(pass-if (not (exact-integer? (make-vector 0))))
(pass-if (not (exact-integer? (cons 1 2))))
(pass-if (not (exact-integer? #t)))
(pass-if (not (exact-integer? (lambda () #t))))
(pass-if (not (exact-integer? (current-input-port)))))
;;;
;;; inexact?
;;;

16
test-suite/tests/peval.test
View file

@ -1286,4 +1286,18 @@
(list a b))
(bar 1))
1)
(primcall list (const 1) (const 2))))
(primcall list (const 1) (const 2)))
(pass-if-peval
;; Should not inline tail list to apply if it is mutable.
;; <http://debbugs.gnu.org/15533>
(let ((l '()))
(if (pair? arg)
(set! l arg))
(apply f l))
(let (l) (_) ((const ()))
(seq
(if (primcall pair? (toplevel arg))
(set! (lexical l _) (toplevel arg))
(void))
(primcall apply (toplevel f) (lexical l _))))))

15
test-suite/tests/srfi-13.test
View file

@ -555,8 +555,7 @@
(string=? "o-bar" (string-copy "\u0100\u0101o-bar" 2)))
(pass-if "start and end index"
(string=? "o-ba" (string-copy "foo-bar" 2 6)))
)
(string=? "o-ba" (string-copy "foo-bar" 2 6))))
(with-test-prefix "substring/shared"
@ -578,7 +577,17 @@
(let* ((s "hello")
(t (string-copy "world, oh yeah!")))
(string-copy! t 1 s 1 3)
t))))
t)))
(pass-if-equal "overlapping src and dest, moving right"
"aabce"
(let ((str (string-copy "abcde")))
(string-copy! str 1 str 0 3) str))
(pass-if-equal "overlapping src and dest, moving left"
"bcdde"
(let ((str (string-copy "abcde")))
(string-copy! str 0 str 1 4) str)))
(with-test-prefix "string-take"

57
test-suite/tests/syntax.test
View file

@ -1237,3 +1237,60 @@
(unreachable))))))
(r 'outer))
#t)))
(with-test-prefix "syntax-case"
(pass-if-syntax-error "duplicate pattern variable"
'(syntax-case . "duplicate pattern variable")
(eval '(lambda (e)
(syntax-case e ()
((a b c d e d f) #f)))
(interaction-environment)))
(with-test-prefix "misplaced ellipses"
(pass-if-syntax-error "bare ellipsis"
'(syntax-case . "misplaced ellipsis")
(eval '(lambda (e)
(syntax-case e ()
(... #f)))
(interaction-environment)))
(pass-if-syntax-error "ellipsis singleton"
'(syntax-case . "misplaced ellipsis")
(eval '(lambda (e)
(syntax-case e ()
((...) #f)))
(interaction-environment)))
(pass-if-syntax-error "ellipsis in car"
'(syntax-case . "misplaced ellipsis")
(eval '(lambda (e)
(syntax-case e ()
((... . _) #f)))
(interaction-environment)))
(pass-if-syntax-error "ellipsis in cdr"
'(syntax-case . "misplaced ellipsis")
(eval '(lambda (e)
(syntax-case e ()
((_ . ...) #f)))
(interaction-environment)))
(pass-if-syntax-error "two ellipses in the same list"
'(syntax-case . "misplaced ellipsis")
(eval '(lambda (e)
(syntax-case e ()
((x ... y ...) #f)))
(interaction-environment)))
(pass-if-syntax-error "three ellipses in the same list"
'(syntax-case . "misplaced ellipsis")
(eval '(lambda (e)
(syntax-case e ()
((x ... y ... z ...) #f)))
(interaction-environment)))))
;;; Local Variables:
;;; eval: (put 'pass-if-syntax-error 'scheme-indent-function 1)
;;; End: