diff --git a/LICENSE b/LICENSE index 213e34a..dda451e 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ Guile is covered under the terms of the GNU Lesser General Public -License, version 2.1. See COPYING.LESSER. +License, version 2.1 or later. See COPYING.LESSER. diff --git a/NEWS b/NEWS index 0dcc411..564484f 100644 --- a/NEWS +++ b/NEWS @@ -5,6 +5,19 @@ See the end for copying conditions. Please send Guile bug reports to bug-guile@gnu.org. +Changes in 1.8.8 (since 1.8.7) + +* Bugs fixed + +** Fix possible buffer overruns when parsing numbers +** Avoid clash with system setjmp/longjmp on IA64 +** Don't dynamically link an extension that is already registered +** Fix `wrong type arg' exceptions with IPv6 addresses +** Fix typos in `(srfi srfi-19)' +** Have `(srfi srfi-35)' provide named struct vtables +** Fix some Interix build problems + + Changes in 1.8.7 (since 1.8.6) * Bugs fixed diff --git a/THANKS b/THANKS index 47d3cfa..48a105a 100644 --- a/THANKS +++ b/THANKS @@ -50,6 +50,7 @@ For fixes or providing information which led to a fix: Roland Haeder Sven Hartrumpf Eric Hanchrow + Judy Hawkins Sam Hocevar Patrick Horgan Ales Hvezda @@ -64,12 +65,15 @@ For fixes or providing information which led to a fix: Matthias Köppe Matt Kraai Daniel Kraft + Jay Krell Jeff Long Marco Maggi Gregory Marton + Kjetil S. Matheussen Antoine Mathys Dan McMahill Roger Mc Murtrie + Scott McPeak Tim Mooney Han-Wen Nienhuys Jan Nieuwenhuizen diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi index 9aeb08a..f6393db 100644 --- a/doc/ref/api-modules.texi +++ b/doc/ref/api-modules.texi @@ -758,7 +758,7 @@ Record definition with @code{define-record-type} (@pxref{SRFI-9}). Read hash extension @code{#,()} (@pxref{SRFI-10}). @item (srfi srfi-11) -Multiple-value handling with @code{let-values} and @code{let-values*} +Multiple-value handling with @code{let-values} and @code{let*-values} (@pxref{SRFI-11}). @item (srfi srfi-13) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index 7c17b36..3d9cde4 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -13,8 +13,8 @@ This reference manual documents Guile, GNU's Ubiquitous Intelligent Language for Extensions. This is edition @value{MANUAL-EDITION} corresponding to Guile @value{VERSION}. -Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005 Free -Software Foundation. +Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +2007, 2008, 2009, 2010 Free Software Foundation. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.2 or diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 1cb273a..0a7e342 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2310,8 +2310,8 @@ Convert a network address from an integer to a printable string. @lisp (inet-ntop AF_INET 2130706433) @result{} "127.0.0.1" -(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{} -ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff +(inet-ntop AF_INET6 (- (expt 2 128) 1)) + @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" @end lisp @end deffn @@ -2882,8 +2882,8 @@ same as @code{make-socket-address} would take to make such an object (@pxref{Network Socket Address}). The return value is unspecified. @example -(connect sock AF_INET INADDR_LOCALHOST 23) -(connect sock (make-socket-address AF_INET INADDR_LOCALHOST 23)) +(connect sock AF_INET INADDR_LOOPBACK 23) +(connect sock (make-socket-address AF_INET INADDR_LOOPBACK 23)) @end example @end deffn diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm index a8b8c97..fe04fc0 100644 --- a/ice-9/debugging/ice-9-debugger-extensions.scm +++ b/ice-9/debugging/ice-9-debugger-extensions.scm @@ -39,7 +39,8 @@ (else (define-module (ice-9 debugger)))) -(use-modules (ice-9 debugging steps)) +(use-modules (ice-9 debugging steps) + (ice-9 debugging trace)) (define (assert-continuable state) ;; Check that debugger is in a state where `continuing' makes sense. diff --git a/libguile/__scm.h b/libguile/__scm.h index b198f9d..e75f1a9 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -3,7 +3,7 @@ #ifndef SCM___SCM_H #define SCM___SCM_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2010 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 @@ -359,11 +359,9 @@ #define SCM_T_INT32_MIN SCM_I_TYPE_MIN(scm_t_int32,SCM_T_UINT32_MAX) #define SCM_T_INT32_MAX SCM_I_TYPE_MAX(scm_t_int32,SCM_T_UINT32_MAX) -#if SCM_HAVE_T_INT64 #define SCM_T_UINT64_MAX SCM_I_UTYPE_MAX(scm_t_uint64) #define SCM_T_INT64_MIN SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX) #define SCM_T_INT64_MAX SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX) -#endif #if SCM_SIZEOF_LONG_LONG #define SCM_I_ULLONG_MAX SCM_I_UTYPE_MAX(unsigned long long) @@ -409,19 +407,28 @@ typedef struct { ucontext_t ctx; int fresh; - } jmp_buf; -# define setjmp(JB) \ + } scm_i_jmp_buf; +# define SCM_I_SETJMP(JB) \ ( (JB).fresh = 1, \ getcontext (&((JB).ctx)), \ ((JB).fresh ? ((JB).fresh = 0, 0) : 1) ) -# define longjmp(JB,VAL) scm_ia64_longjmp (&(JB), VAL) - void scm_ia64_longjmp (jmp_buf *, int); +# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL) + void scm_ia64_longjmp (scm_i_jmp_buf *, int); # else /* ndef __ia64__ */ # include # endif /* ndef __ia64__ */ # endif /* ndef _CRAY1 */ #endif /* ndef vms */ +/* For any platform where SCM_I_SETJMP hasn't been defined in some + special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and + scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */ +#ifndef SCM_I_SETJMP +#define scm_i_jmp_buf jmp_buf +#define SCM_I_SETJMP setjmp +#define SCM_I_LONGJMP longjmp +#endif + /* James Clark came up with this neat one instruction fix for * continuations on the SPARC. It flushes the register windows so * that all the state of the process is contained in the stack. diff --git a/libguile/continuations.c b/libguile/continuations.c index 69d2569..84a7fed 100644 --- a/libguile/continuations.c +++ b/libguile/continuations.c @@ -127,7 +127,7 @@ scm_make_continuation (int *first) continuation->offset = continuation->stack - src; memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); - *first = !setjmp (continuation->jmpbuf); + *first = !SCM_I_SETJMP (continuation->jmpbuf); if (*first) { #ifdef __ia64__ @@ -224,12 +224,12 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, scm_i_set_last_debug_frame (continuation->dframe); continuation->throw_value = val; - longjmp (continuation->jmpbuf, 1); + SCM_I_LONGJMP (continuation->jmpbuf, 1); } #ifdef __ia64__ void -scm_ia64_longjmp (jmp_buf *JB, int VAL) +scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL) { scm_i_thread *t = SCM_I_CURRENT_THREAD; diff --git a/libguile/continuations.h b/libguile/continuations.h index f6fb96a..c61ab2d 100644 --- a/libguile/continuations.h +++ b/libguile/continuations.h @@ -43,7 +43,7 @@ SCM_API scm_t_bits scm_tc16_continuation; typedef struct { SCM throw_value; - jmp_buf jmpbuf; + scm_i_jmp_buf jmpbuf; SCM dynenv; #ifdef __ia64__ void *backing_store; diff --git a/libguile/extensions.c b/libguile/extensions.c index 1090b8b..29cb58c 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -76,6 +76,7 @@ load_extension (SCM lib, SCM init) { extension_t *ext; char *clib, *cinit; + int found = 0; scm_dynwind_begin (0); @@ -89,10 +90,14 @@ load_extension (SCM lib, SCM init) && !strcmp (ext->init, cinit)) { ext->func (ext->data); + found = 1; break; } scm_dynwind_end (); + + if (found) + return; } /* Dynamically link the library. */ diff --git a/libguile/filesys.c b/libguile/filesys.c index 70dfe15..c8acb13 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -23,6 +23,9 @@ #ifdef __hpux #define _POSIX_C_SOURCE 199506L /* for readdir_r */ #endif +#if defined(__INTERIX) && !defined(_REENTRANT) +# define _REENTRANT /* ask Interix for readdir_r prototype */ +#endif #ifdef HAVE_CONFIG_H # include diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index 85ebfae..e5de31d 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -315,28 +315,10 @@ main (int argc, char *argv[]) return 1; pf ("\n"); - pf ("/* 64-bit integer -- if available SCM_HAVE_T_INT64 will be 1 and\n" - " scm_t_int64 will be a suitable type, otherwise SCM_HAVE_T_INT64\n" - " will be 0. */\n"); - if (SCM_I_GSC_T_INT64) - { - pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n"); - pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64); - } - else - pf ("#define SCM_HAVE_T_INT64 0 /* 0 or 1 */\n"); - - pf ("\n"); - pf ("/* 64-bit unsigned integer -- if available SCM_HAVE_T_UINT64 will\n" - " be 1 and scm_t_uint64 will be a suitable type, otherwise\n" - " SCM_HAVE_T_UINT64 will be 0. */\n"); - if (SCM_I_GSC_T_UINT64) - { - pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n"); - pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64); - } - else - pf ("#define SCM_HAVE_T_UINT64 0 /* 0 or 1 */\n"); + pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n"); + pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64); + pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n"); + pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64); pf ("\n"); pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n" diff --git a/libguile/hashtab.c b/libguile/hashtab.c index ea7fc69..1f1569c 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 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 @@ -911,74 +911,6 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0, /* Hash table iterators */ -static const char s_scm_hash_fold[]; - -SCM -scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) -{ - long i, n; - SCM buckets, result = init; - - if (SCM_HASHTABLE_P (table)) - buckets = SCM_HASHTABLE_VECTOR (table); - else - buckets = table; - - n = SCM_SIMPLE_VECTOR_LENGTH (buckets); - for (i = 0; i < n; ++i) - { - SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; - while (!scm_is_null (ls)) - { - if (!scm_is_pair (ls)) - scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); - handle = SCM_CAR (ls); - if (!scm_is_pair (handle)) - scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); - result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); - ls = SCM_CDR (ls); - } - } - - return result; -} - -/* The following redundant code is here in order to be able to support - hash-for-each-handle. An alternative would have been to replace - this code and scm_internal_hash_fold above with a single - scm_internal_hash_fold_handles, but we don't want to promote such - an API. */ - -static const char s_scm_hash_for_each[]; - -void -scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table) -{ - long i, n; - SCM buckets; - - if (SCM_HASHTABLE_P (table)) - buckets = SCM_HASHTABLE_VECTOR (table); - else - buckets = table; - - n = SCM_SIMPLE_VECTOR_LENGTH (buckets); - for (i = 0; i < n; ++i) - { - SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; - while (!scm_is_null (ls)) - { - if (!scm_is_pair (ls)) - scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); - handle = SCM_CAR (ls); - if (!scm_is_pair (handle)) - scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); - fn (closure, handle); - ls = SCM_CDR (ls); - } - } -} - SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, (SCM proc, SCM init, SCM table), "An iterator over hash-table elements.\n" @@ -1067,6 +999,72 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, +SCM +scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) +{ + long i, n; + SCM buckets, result = init; + + if (SCM_HASHTABLE_P (table)) + buckets = SCM_HASHTABLE_VECTOR (table); + else + buckets = table; + + n = SCM_SIMPLE_VECTOR_LENGTH (buckets); + for (i = 0; i < n; ++i) + { + SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; + while (!scm_is_null (ls)) + { + if (!scm_is_pair (ls)) + scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); + handle = SCM_CAR (ls); + if (!scm_is_pair (handle)) + scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); + ls = SCM_CDR (ls); + } + } + + return result; +} + +/* The following redundant code is here in order to be able to support + hash-for-each-handle. An alternative would have been to replace + this code and scm_internal_hash_fold above with a single + scm_internal_hash_fold_handles, but we don't want to promote such + an API. */ + +void +scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table) +{ + long i, n; + SCM buckets; + + if (SCM_HASHTABLE_P (table)) + buckets = SCM_HASHTABLE_VECTOR (table); + else + buckets = table; + + n = SCM_SIMPLE_VECTOR_LENGTH (buckets); + for (i = 0; i < n; ++i) + { + SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; + while (!scm_is_null (ls)) + { + if (!scm_is_pair (ls)) + scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); + handle = SCM_CAR (ls); + if (!scm_is_pair (handle)) + scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); + fn (closure, handle); + ls = SCM_CDR (ls); + } + } +} + + + void scm_hashtab_prehistory () diff --git a/libguile/iselect.h b/libguile/iselect.h index 5a4b30d..b23a641 100644 --- a/libguile/iselect.h +++ b/libguile/iselect.h @@ -38,7 +38,12 @@ #ifdef FD_SET #define SELECT_TYPE fd_set +#if defined(__INTERIX) && FD_SETSIZE == 4096 +/* Interix defines FD_SETSIZE 4096 but select rejects that. */ +#define SELECT_SET_SIZE 1024 +#else #define SELECT_SET_SIZE FD_SETSIZE +#endif #else /* no FD_SET */ diff --git a/libguile/numbers.c b/libguile/numbers.c index 2e1635f..4f5ab31 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. * * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories * and Bellcore. See scm_divide. @@ -620,7 +620,14 @@ guile_ieee_init (void) #elif HAVE_DINFINITY /* OSF */ extern unsigned int DINFINITY[2]; - guile_Inf = (*((double *) (DINFINITY))); + union + { + double d; + int i[2]; + } alias; + alias.i[0] = DINFINITY[0]; + alias.i[1] = DINFINITY[1]; + guile_Inf = alias.d; #else double tmp = 1e+10; guile_Inf = tmp; @@ -651,7 +658,14 @@ guile_ieee_init (void) { /* OSF */ extern unsigned int DQNAN[2]; - guile_NaN = (*((double *)(DQNAN))); + union + { + double d; + int i[2]; + } alias; + alias.i[0] = DQNAN[0]; + alias.i[1] = DQNAN[1]; + guile_NaN = alias.d; } #else guile_NaN = guile_Inf / guile_Inf; @@ -2663,17 +2677,26 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, case 'l': case 'L': case 's': case 'S': idx++; + if (idx == len) + return SCM_BOOL_F; + start = idx; c = mem[idx]; if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = -1; c = mem[idx]; } else if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = 1; c = mem[idx]; } @@ -2789,8 +2812,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, SCM divisor; idx++; + if (idx == len) + return SCM_BOOL_F; - divisor = mem2uinteger (mem, len, &idx, radix, &x); + divisor = mem2uinteger (mem, len, &idx, radix, &x); if (scm_is_false (divisor)) return SCM_BOOL_F; @@ -2911,11 +2936,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; sign = 1; } else if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; sign = -1; } else @@ -5869,8 +5898,6 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max) #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg) #include "libguile/conv-uinteger.i.c" -#if SCM_HAVE_T_INT64 - #define TYPE scm_t_int64 #define TYPE_MIN SCM_T_INT64_MIN #define TYPE_MAX SCM_T_INT64_MAX @@ -5887,8 +5914,6 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max) #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg) #include "libguile/conv-uinteger.i.c" -#endif - void scm_to_mpz (SCM val, mpz_t rop) { diff --git a/libguile/numbers.h b/libguile/numbers.h index 2c2fdcf..35263a4 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -3,7 +3,7 @@ #ifndef SCM_NUMBERS_H #define SCM_NUMBERS_H -/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2010 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 @@ -321,16 +321,12 @@ SCM_API SCM scm_from_int32 (scm_t_int32 x); SCM_API scm_t_uint32 scm_to_uint32 (SCM x); SCM_API SCM scm_from_uint32 (scm_t_uint32 x); -#if SCM_HAVE_T_INT64 - SCM_API scm_t_int64 scm_to_int64 (SCM x); SCM_API SCM scm_from_int64 (scm_t_int64 x); SCM_API scm_t_uint64 scm_to_uint64 (SCM x); SCM_API SCM scm_from_uint64 (scm_t_uint64 x); -#endif - SCM_API void scm_to_mpz (SCM x, mpz_t rop); SCM_API SCM scm_from_mpz (mpz_t rop); diff --git a/libguile/random.c b/libguile/random.c index 8d2ff03..693ed4a 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2010 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 @@ -75,8 +75,6 @@ scm_t_rng scm_the_rng; #define M_PI 3.14159265359 #endif -#if SCM_HAVE_T_UINT64 - unsigned long scm_i_uniform32 (scm_t_i_rstate *state) { @@ -87,38 +85,6 @@ scm_i_uniform32 (scm_t_i_rstate *state) return w; } -#else - -/* ww This is a portable version of the same RNG without 64 bit - * * aa arithmetic. - * ---- - * xx It is only intended to provide identical behaviour on - * xx platforms without 8 byte longs or long longs until - * xx someone has implemented the routine in assembler code. - * xxcc - * ---- - * ccww - */ - -#define L(x) ((x) & 0xffff) -#define H(x) ((x) >> 16) - -unsigned long -scm_i_uniform32 (scm_t_i_rstate *state) -{ - scm_t_uint32 x1 = L (A) * L (state->w); - scm_t_uint32 x2 = L (A) * H (state->w); - scm_t_uint32 x3 = H (A) * L (state->w); - scm_t_uint32 w = L (x1) + L (state->c); - scm_t_uint32 m = H (x1) + L (x2) + L (x3) + H (state->c) + H (w); - scm_t_uint32 x4 = H (A) * H (state->w); - state->w = w = (L (m) << 16) + L (w); - state->c = H (x2) + H (x3) + x4 + H (m); - return w; -} - -#endif - void scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n) { @@ -212,21 +178,49 @@ scm_c_exp1 (scm_t_rstate *state) unsigned char scm_masktab[256]; -unsigned long -scm_c_random (scm_t_rstate *state, unsigned long m) +static inline scm_t_uint32 +scm_i_mask32 (scm_t_uint32 m) { - unsigned int r, mask; - mask = (m < 0x100 + return (m < 0x100 ? scm_masktab[m] : (m < 0x10000 ? scm_masktab[m >> 8] << 8 | 0xff : (m < 0x1000000 ? scm_masktab[m >> 16] << 16 | 0xffff : scm_masktab[m >> 24] << 24 | 0xffffff))); +} + +static scm_t_uint32 +scm_c_random32 (scm_t_rstate *state, scm_t_uint32 m) +{ + scm_t_uint32 r, mask = scm_i_mask32 (m); while ((r = scm_the_rng.random_bits (state) & mask) >= m); return r; } +/* Returns 32 random bits. */ +unsigned long +scm_c_random (scm_t_rstate *state, unsigned long m) +{ + return scm_c_random32 (state, (scm_t_uint32)m); +} + +scm_t_uint64 +scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m) +{ + scm_t_uint64 r; + scm_t_uint32 mask; + + if (m <= SCM_T_UINT32_MAX) + return scm_c_random32 (state, (scm_t_uint32) m); + + mask = scm_i_mask32 (m >> 32); + while ((r = ((scm_t_uint64) (scm_the_rng.random_bits (state) & mask) << 32) + | scm_the_rng.random_bits (state)) >= m) + ; + return r; +} + /* SCM scm_c_random_bignum (scm_t_rstate *state, SCM m) @@ -247,24 +241,24 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) { SCM result = scm_i_mkbig (); const size_t m_bits = mpz_sizeinbase (SCM_I_BIG_MPZ (m), 2); - /* how many bits would only partially fill the last unsigned long? */ - const size_t end_bits = m_bits % (sizeof (unsigned long) * SCM_CHAR_BIT); - unsigned long *random_chunks = NULL; - const unsigned long num_full_chunks = - m_bits / (sizeof (unsigned long) * SCM_CHAR_BIT); - const unsigned long num_chunks = num_full_chunks + ((end_bits) ? 1 : 0); + /* how many bits would only partially fill the last u32? */ + const size_t end_bits = m_bits % (sizeof (scm_t_uint32) * SCM_CHAR_BIT); + scm_t_uint32 *random_chunks = NULL; + const scm_t_uint32 num_full_chunks = + m_bits / (sizeof (scm_t_uint32) * SCM_CHAR_BIT); + const scm_t_uint32 num_chunks = num_full_chunks + ((end_bits) ? 1 : 0); /* we know the result will be this big */ mpz_realloc2 (SCM_I_BIG_MPZ (result), m_bits); random_chunks = - (unsigned long *) scm_gc_calloc (num_chunks * sizeof (unsigned long), + (scm_t_uint32 *) scm_gc_calloc (num_chunks * sizeof (scm_t_uint32), "random bignum chunks"); do { - unsigned long *current_chunk = random_chunks + (num_chunks - 1); - unsigned long chunks_left = num_chunks; + scm_t_uint32 *current_chunk = random_chunks + (num_chunks - 1); + scm_t_uint32 chunks_left = num_chunks; mpz_set_ui (SCM_I_BIG_MPZ (result), 0); @@ -273,23 +267,23 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) /* generate a mask with ones in the end_bits position, i.e. if end_bits is 3, then we'd have a mask of ...0000000111 */ const unsigned long rndbits = scm_the_rng.random_bits (state); - int rshift = (sizeof (unsigned long) * SCM_CHAR_BIT) - end_bits; - unsigned long mask = ((unsigned long) ULONG_MAX) >> rshift; - unsigned long highest_bits = rndbits & mask; + int rshift = (sizeof (scm_t_uint32) * SCM_CHAR_BIT) - end_bits; + scm_t_uint32 mask = 0xffffffff >> rshift; + scm_t_uint32 highest_bits = ((scm_t_uint32) rndbits) & mask; *current_chunk-- = highest_bits; chunks_left--; } while (chunks_left) { - /* now fill in the remaining unsigned long sized chunks */ + /* now fill in the remaining scm_t_uint32 sized chunks */ *current_chunk-- = scm_the_rng.random_bits (state); chunks_left--; } mpz_import (SCM_I_BIG_MPZ (result), num_chunks, -1, - sizeof (unsigned long), + sizeof (scm_t_uint32), 0, 0, random_chunks); @@ -297,7 +291,7 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) all bits in order not to get a distorted distribution) */ } while (mpz_cmp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (m)) >= 0); scm_gc_free (random_chunks, - num_chunks * sizeof (unsigned long), + num_chunks * sizeof (scm_t_uint32), "random bignum chunks"); return scm_i_normbig (result); } @@ -348,9 +342,17 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, SCM_VALIDATE_RSTATE (2, state); if (SCM_I_INUMP (n)) { - unsigned long m = SCM_I_INUM (n); - SCM_ASSERT_RANGE (1, n, m > 0); - return scm_from_ulong (scm_c_random (SCM_RSTATE (state), m)); + unsigned long m = (unsigned long) SCM_I_INUM (n); + SCM_ASSERT_RANGE (1, n, SCM_I_INUM (n) > 0); +#if SCM_SIZEOF_UNSIGNED_LONG <= 4 + return scm_from_uint32 (scm_c_random (SCM_RSTATE (state), + (scm_t_uint32) m)); +#elif SCM_SIZEOF_UNSIGNED_LONG <= 8 + return scm_from_uint64 (scm_c_random64 (SCM_RSTATE (state), + (scm_t_uint64) m)); +#else +#error "Cannot deal with this platform's unsigned long size" +#endif } SCM_VALIDATE_NIM (1, n); if (SCM_REALP (n)) diff --git a/libguile/random.h b/libguile/random.h index 6ec43ff..0690b59 100644 --- a/libguile/random.h +++ b/libguile/random.h @@ -3,7 +3,7 @@ #ifndef SCM_RANDOM_H #define SCM_RANDOM_H -/* Copyright (C) 1999,2000,2001, 2006 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001, 2006, 2010 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 @@ -45,6 +45,7 @@ typedef struct scm_t_rstate { typedef struct scm_t_rng { size_t rstate_size; /* size of random state */ + /* Though this returns an unsigned long, it's only 32 bits of randomness. */ unsigned long (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */ void (*init_rstate) (scm_t_rstate *state, const char *seed, int n); scm_t_rstate *(*copy_rstate) (scm_t_rstate *state); @@ -62,6 +63,7 @@ typedef struct scm_t_i_rstate { unsigned long c; } scm_t_i_rstate; +/* Though this returns an unsigned long, it's only 32 bits of randomness. */ SCM_API unsigned long scm_i_uniform32 (scm_t_i_rstate *); SCM_API void scm_i_init_rstate (scm_t_i_rstate *, const char *seed, int n); SCM_API scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *); @@ -76,7 +78,10 @@ SCM_API scm_t_rstate *scm_c_default_rstate (void); SCM_API double scm_c_uniform01 (scm_t_rstate *); SCM_API double scm_c_normal01 (scm_t_rstate *); SCM_API double scm_c_exp1 (scm_t_rstate *); +/* Though this returns an unsigned long, it's only 32 bits of randomness. */ SCM_API unsigned long scm_c_random (scm_t_rstate *, unsigned long m); +/* This one returns 64 bits of randomness. */ +SCM_API scm_t_uint64 scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m); SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m); diff --git a/libguile/socket.c b/libguile/socket.c index f34b6d4..cb954f4 100644 --- a/libguile/socket.c +++ b/libguile/socket.c @@ -347,7 +347,7 @@ scm_to_ipv6 (scm_t_uint8 dst[16], SCM src) scm_remember_upto_here_1 (src); } else - scm_wrong_type_arg (NULL, 0, src); + scm_wrong_type_arg_msg ("scm_to_ipv6", 0, src, "integer"); } #ifdef HAVE_INET_PTON @@ -397,8 +397,8 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n" "@lisp\n" "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n" - "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n" - "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n" + "(inet-ntop AF_INET6 (- (expt 2 128) 1))\n" + " @result{} \"ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\"\n" "@end lisp") #define FUNC_NAME s_scm_inet_ntop { @@ -1167,7 +1167,8 @@ scm_to_sockaddr (SCM address, size_t *address_size) { struct sockaddr_in6 c_inet6; - scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, address); + scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, + SCM_SIMPLE_VECTOR_REF (address, 1)); c_inet6.sin6_port = htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2))); c_inet6.sin6_flowinfo = diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index b0e052a..f2a9d7f 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -1,6 +1,6 @@ /* srfi-4.c --- Uniform numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2010 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 @@ -84,11 +84,7 @@ static const int uvec_sizes[12] = { 1, 1, 2, 2, 4, 4, -#if SCM_HAVE_T_INT64 8, 8, -#else - sizeof (SCM), sizeof (SCM), -#endif sizeof(float), sizeof(double), 2*sizeof(float), 2*sizeof(double) }; @@ -127,10 +123,8 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) scm_t_int16 *s16; scm_t_uint32 *u32; scm_t_int32 *s32; -#if SCM_HAVE_T_INT64 scm_t_uint64 *u64; scm_t_int64 *s64; -#endif float *f32; double *f64; SCM *fake_64; @@ -148,13 +142,8 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break; case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break; case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break; -#if SCM_HAVE_T_INT64 case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break; case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break; -#else - case SCM_UVEC_U64: - case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break; -#endif case SCM_UVEC_F32: np.f32 = (float *) uptr; break; case SCM_UVEC_F64: np.f64 = (double *) uptr; break; case SCM_UVEC_C32: np.f32 = (float *) uptr; break; @@ -179,14 +168,8 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break; case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break; case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break; -#if SCM_HAVE_T_INT64 case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break; case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break; -#else - case SCM_UVEC_U64: - case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate); - np.fake_64++; break; -#endif case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break; case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break; case SCM_UVEC_C32: @@ -222,20 +205,6 @@ uvec_equalp (SCM a, SCM b) result = SCM_BOOL_F; else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b)) result = SCM_BOOL_F; -#if SCM_HAVE_T_INT64 == 0 - else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64 - || SCM_UVEC_TYPE (a) == SCM_UVEC_S64) - { - SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b); - size_t len = SCM_UVEC_LENGTH (a), i; - for (i = 0; i < len; i++) - if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++))) - { - result = SCM_BOOL_F; - break; - } - } -#endif else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b), SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0) result = SCM_BOOL_F; @@ -244,24 +213,6 @@ uvec_equalp (SCM a, SCM b) return result; } -/* Mark hook. Only used when U64 and S64 are implemented as SCMs. */ - -#if SCM_HAVE_T_INT64 == 0 -static SCM -uvec_mark (SCM uvec) -{ - if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64 - || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64) - { - SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec); - size_t len = SCM_UVEC_LENGTH (uvec), i; - for (i = 0; i < len; i++) - scm_gc_mark (*ptr++); - } - return SCM_BOOL_F; -} -#endif - /* Smob free hook for uniform numeric vectors. */ static size_t uvec_free (SCM uvec) @@ -318,15 +269,6 @@ alloc_uvec (int type, size_t len) if (len > SCM_I_SIZE_MAX / uvec_sizes[type]) scm_out_of_range (NULL, scm_from_size_t (len)); base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]); -#if SCM_HAVE_T_INT64 == 0 - if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64) - { - SCM *ptr = (SCM *)base; - size_t i; - for (i = 0; i < len; i++) - *ptr++ = SCM_UNSPECIFIED; - } -#endif return take_uvec (type, base, len); } @@ -349,17 +291,10 @@ uvec_fast_ref (int type, const void *base, size_t c_idx) return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]); else if (type == SCM_UVEC_S32) return scm_from_int32 (((scm_t_int32*)base)[c_idx]); -#if SCM_HAVE_T_INT64 else if (type == SCM_UVEC_U64) return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]); else if (type == SCM_UVEC_S64) return scm_from_int64 (((scm_t_int64*)base)[c_idx]); -#else - else if (type == SCM_UVEC_U64) - return ((SCM *)base)[c_idx]; - else if (type == SCM_UVEC_S64) - return ((SCM *)base)[c_idx]; -#endif else if (type == SCM_UVEC_F32) return scm_from_double (((float*)base)[c_idx]); else if (type == SCM_UVEC_F64) @@ -374,22 +309,6 @@ uvec_fast_ref (int type, const void *base, size_t c_idx) return SCM_BOOL_F; } -#if SCM_HAVE_T_INT64 == 0 -static SCM scm_uint64_min, scm_uint64_max; -static SCM scm_int64_min, scm_int64_max; - -static void -assert_exact_integer_range (SCM val, SCM min, SCM max) -{ - if (!scm_is_integer (val) - || scm_is_false (scm_exact_p (val))) - scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); - if (scm_is_true (scm_less_p (val, min)) - || scm_is_true (scm_gr_p (val, max))) - scm_out_of_range (NULL, val); -} -#endif - static SCM_C_INLINE_KEYWORD void uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) { @@ -405,23 +324,10 @@ uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val); else if (type == SCM_UVEC_S32) (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val); -#if SCM_HAVE_T_INT64 else if (type == SCM_UVEC_U64) (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val); else if (type == SCM_UVEC_S64) (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val); -#else - else if (type == SCM_UVEC_U64) - { - assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max); - ((SCM *)base)[c_idx] = val; - } - else if (type == SCM_UVEC_S64) - { - assert_exact_integer_range (val, scm_int64_min, scm_int64_max); - ((SCM *)base)[c_idx] = val; - } -#endif else if (type == SCM_UVEC_F32) (((float*)base)[c_idx]) = scm_to_double (val); else if (type == SCM_UVEC_F64) @@ -1027,16 +933,12 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, #define TYPE SCM_UVEC_U64 #define TAG u64 -#if SCM_HAVE_T_UINT64 #define CTYPE scm_t_uint64 -#endif #include "libguile/srfi-4.i.c" #define TYPE SCM_UVEC_S64 #define TAG s64 -#if SCM_HAVE_T_INT64 #define CTYPE scm_t_int64 -#endif #include "libguile/srfi-4.i.c" #define TYPE SCM_UVEC_F32 @@ -1094,23 +996,9 @@ scm_init_srfi_4 (void) { scm_tc16_uvec = scm_make_smob_type ("uvec", 0); scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); -#if SCM_HAVE_T_INT64 == 0 - scm_set_smob_mark (scm_tc16_uvec, uvec_mark); -#endif scm_set_smob_free (scm_tc16_uvec, uvec_free); scm_set_smob_print (scm_tc16_uvec, uvec_print); -#if SCM_HAVE_T_INT64 == 0 - scm_uint64_min = - scm_permanent_object (scm_from_int (0)); - scm_uint64_max = - scm_permanent_object (scm_c_read_string ("18446744073709551615")); - scm_int64_min = - scm_permanent_object (scm_c_read_string ("-9223372036854775808")); - scm_int64_max = - scm_permanent_object (scm_c_read_string ("9223372036854775807")); -#endif - #include "libguile/srfi-4.x" } diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 7abbac8..2348c5a 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -2,7 +2,7 @@ #define SCM_SRFI_4_H /* srfi-4.c --- Homogeneous numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. + * Copyright (C) 2001, 2004, 2006, 2010 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 @@ -186,7 +186,6 @@ SCM_API SCM scm_u64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_u64vector (SCM l); SCM_API SCM scm_any_to_u64vector (SCM obj); -#if SCM_HAVE_T_UINT64 SCM_API SCM scm_take_u64vector (scm_t_uint64 *data, size_t n); SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h); SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h); @@ -198,7 +197,6 @@ SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp); -#endif SCM_API SCM scm_s64vector_p (SCM obj); SCM_API SCM scm_make_s64vector (SCM n, SCM fill); @@ -210,7 +208,6 @@ SCM_API SCM scm_s64vector_to_list (SCM uvec); SCM_API SCM scm_list_to_s64vector (SCM l); SCM_API SCM scm_any_to_s64vector (SCM obj); -#if SCM_HAVE_T_INT64 SCM_API SCM scm_take_s64vector (scm_t_int64 *data, size_t n); SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h); SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h); @@ -221,7 +218,6 @@ SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec, scm_t_array_handle *h, size_t *lenp, ssize_t *incp); -#endif SCM_API SCM scm_f32vector_p (SCM obj); SCM_API SCM scm_make_f32vector (SCM n, SCM fill); diff --git a/libguile/threads.c b/libguile/threads.c index 95a905c..f2bb556 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -276,7 +276,7 @@ unblock_from_queue (SCM queue) var 't' // save registers. SCM_FLUSH_REGISTER_WINDOWS; // sparc only - setjmp (t->regs); // here's most of the magic + SCM_I_SETJMP (t->regs); // here's most of the magic ... and returns. @@ -330,7 +330,7 @@ unblock_from_queue (SCM queue) t->top = SCM_STACK_PTR (&t); // save registers. SCM_FLUSH_REGISTER_WINDOWS; - setjmp (t->regs); + SCM_I_SETJMP (t->regs); res = func(data); scm_enter_guile (t); @@ -388,7 +388,7 @@ suspend (void) t->top = SCM_STACK_PTR (&t); /* save registers. */ SCM_FLUSH_REGISTER_WINDOWS; - setjmp (t->regs); + SCM_I_SETJMP (t->regs); return t; } diff --git a/libguile/threads.h b/libguile/threads.h index 2b0e067..e22d9bd 100644 --- a/libguile/threads.h +++ b/libguile/threads.h @@ -107,7 +107,7 @@ typedef struct scm_i_thread { /* For keeping track of the stack and registers. */ SCM_STACKITEM *base; SCM_STACKITEM *top; - jmp_buf regs; + scm_i_jmp_buf regs; #ifdef __ia64__ void *register_backing_store_base; scm_t_contregs *pending_rbs_continuation; diff --git a/libguile/throw.c b/libguile/throw.c index 92c5a1a..fcfde47 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -53,7 +53,7 @@ static scm_t_bits tc16_jmpbuffer; #define DEACTIVATEJB(x) \ (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) -#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) +#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v))) #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v))) @@ -75,7 +75,7 @@ make_jmpbuf (void) { SCM answer; SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0); - SETJBJMPBUF(answer, (jmp_buf *)0); + SETJBJMPBUF(answer, (scm_i_jmp_buf *)0); DEACTIVATEJB(answer); return answer; } @@ -85,7 +85,7 @@ make_jmpbuf (void) struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ { - jmp_buf buf; /* must be first */ + scm_i_jmp_buf buf; /* must be first */ SCM throw_tag; SCM retval; }; @@ -179,7 +179,7 @@ scm_c_catch (SCM tag, pre_unwind.lazy_catch_p = 0; SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind); - if (setjmp (jbr.buf)) + if (SCM_I_SETJMP (jbr.buf)) { SCM throw_tag; SCM throw_args; @@ -821,7 +821,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) jbr->throw_tag = key; jbr->retval = args; scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf)); - longjmp (*JBJMPBUF (jmpbuf), 1); + SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1); } /* Otherwise, it's some random piece of junk. */ diff --git a/libguile/vectors.c b/libguile/vectors.c index eeb8569..074655c 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2010 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 @@ -465,7 +465,9 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, i = scm_to_unsigned_integer (start1, 0, len1); e = scm_to_unsigned_integer (end1, i, len1); - j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2); + j = scm_to_unsigned_integer (start2, 0, len2); + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); i *= inc1; e *= inc1; @@ -503,7 +505,11 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, i = scm_to_unsigned_integer (start1, 0, len1); e = scm_to_unsigned_integer (end1, i, len1); - j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2); + j = scm_to_unsigned_integer (start2, 0, len2); + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); + + j += (e - i); i *= inc1; e *= inc1; diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi index ea33e17..8cd42e8 100755 --- a/scripts/snarf-check-and-output-texi +++ b/scripts/snarf-check-and-output-texi @@ -267,6 +267,17 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" (set! *file* file) (set! *line* line)) + ;; newer gccs like to throw around more location markers into the + ;; preprocessed source; these (hash . hash) bits are what they translate to + ;; in snarfy terms. + (('location ('string . file) ('int . line) ('hash . 'hash)) + (set! *file* file) + (set! *line* line)) + + (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash)) + (set! *file* file) + (set! *line* line)) + (('arglist rest ...) (set! *args* (do-arglist rest))) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index ffce990..482ec4e 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -1,6 +1,6 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 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 @@ -41,7 +41,8 @@ (define-module (srfi srfi-19) :use-module (srfi srfi-6) :use-module (srfi srfi-8) - :use-module (srfi srfi-9)) + :use-module (srfi srfi-9) + :autoload (ice-9 rdelim) (read-line)) (begin-deprecated ;; Prevent `export' from re-exporting core bindings. This behaviour @@ -339,7 +340,7 @@ (set-tm:hour result (date-hour date)) ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). (set-tm:mday result (date-day date)) - (set-tm:month result (- (date-month date) 1)) + (set-tm:mon result (- (date-month date) 1)) ;; FIXME: need to signal error on range violation. (set-tm:year result (+ 1900 (date-year date))) (set-tm:isdst result -1) @@ -528,33 +529,38 @@ ;; -- these depend on time-monotonic having the same definition as time-tai! (define (time-monotonic->time-utc time-in) (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-monotonic->time-utc + 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) (define (time-monotonic->time-utc! time-in) (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-monotonic->time-utc! + 'incompatible-time-types time-in)) (set-time-type! time-in time-tai) - (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)) + (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) (define (time-monotonic->time-tai time-in) (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-monotonic->time-tai + 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-tai) ntime)) (define (time-monotonic->time-tai! time-in) (if (not (eq? (time-type time-in) time-monotonic)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-monotonic->time-tai! + 'incompatible-time-types time-in)) (set-time-type! time-in time-tai) time-in) (define (time-utc->time-monotonic time-in) (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-utc->time-monotonic + 'incompatible-time-types time-in)) (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) 'time-utc->time-monotonic))) (set-time-type! ntime time-monotonic) @@ -562,7 +568,8 @@ (define (time-utc->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-utc)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-utc->time-monotonic! + 'incompatible-time-types time-in)) (let ((ntime (priv:time-utc->time-tai! time-in time-in 'time-utc->time-monotonic!))) (set-time-type! ntime time-monotonic) @@ -570,14 +577,16 @@ (define (time-tai->time-monotonic time-in) (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-tai->time-monotonic + 'incompatible-time-types time-in)) (let ((ntime (copy-time time-in))) (set-time-type! ntime time-monotonic) ntime)) (define (time-tai->time-monotonic! time-in) (if (not (eq? (time-type time-in) time-tai)) - (priv:time-error caller 'incompatible-time-types time-in)) + (priv:time-error 'time-tai->time-monotonic! + 'incompatible-time-types time-in)) (set-time-type! time-in time-monotonic) time-in) @@ -780,7 +789,7 @@ (define (priv:year-day day month year) (let ((days-pr (assoc month priv:month-assoc))) (if (not days-pr) - (priv:error 'date-year-day 'invalid-month-specification month)) + (priv:time-error 'date-year-day 'invalid-month-specification month)) (if (and (priv:leap-year? year) (> month 2)) (+ day (cdr days-pr) 1) (+ day (cdr days-pr))))) @@ -1263,7 +1272,7 @@ ((#\8) 8) ((#\9) 9) (else (priv:time-error 'bad-date-template-string - (list "Non-integer character" ch i))))) + (list "Non-integer character" ch))))) ;; read an integer upto n characters long on port; upto -> #f is any length (define (priv:integer-reader upto port) diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm index 2035466..ee20a10 100644 --- a/srfi/srfi-35.scm +++ b/srfi/srfi-35.scm @@ -57,6 +57,19 @@ (number->string (object-address ct) 16)))))) +(define (%make-condition-type layout id parent all-fields) + (let ((struct (make-struct %condition-type-vtable 0 + (make-struct-layout layout) ;; layout + print-condition ;; printer + id parent all-fields))) + + ;; Hack to associate STRUCT with a name, providing a better name for + ;; GOOPS classes as returned by `class-of' et al. + (set-struct-vtable-name! struct (cond ((symbol? id) id) + ((string? id) (string->symbol id)) + (else (string->symbol "")))) + struct)) + (define (condition-type? obj) "Return true if OBJ is a condition type." (and (struct? obj) @@ -104,10 +117,8 @@ supertypes." field-names parent-fields))) (let* ((all-fields (append parent-fields field-names)) (layout (struct-layout-for-condition all-fields))) - (make-struct %condition-type-vtable 0 - (make-struct-layout layout) ;; layout - print-condition ;; printer - id parent all-fields)) + (%make-condition-type layout + id parent all-fields)) (error "invalid condition type field names" field-names))) (error "parent is not a condition type" parent)) @@ -126,13 +137,10 @@ supertypes." (let* ((all-fields (append-map condition-type-all-fields parents)) (layout (struct-layout-for-condition all-fields))) - (make-struct %condition-type-vtable 0 - (make-struct-layout layout) ;; layout - print-condition ;; printer - id - parents ;; list of parents! - all-fields - all-fields))))) + (%make-condition-type layout + id + parents ;; list of parents! + all-fields))))) ;;; diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index e7cfd82..058ce93 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -28,7 +28,9 @@ check_SCRIPTS = BUILT_SOURCES = EXTRA_DIST = -TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env" +TESTS_ENVIRONMENT = \ + builddir="$(builddir)" \ + "${top_builddir}/pre-inst-guile-env" test_cflags = \ -I$(top_srcdir)/test-suite/standalone \ diff --git a/test-suite/standalone/test-asmobs b/test-suite/standalone/test-asmobs index 2ea75d9..9689ab9 100755 --- a/test-suite/standalone/test-asmobs +++ b/test-suite/standalone/test-asmobs @@ -2,7 +2,8 @@ exec guile -q -s "$0" "$@" !# -(load-extension "libtest-asmobs" "libtest_asmobs_init") +(load-extension (string-append (getenv "builddir") "/libtest-asmobs") + "libtest_asmobs_init") (define (test x v) (if v diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c index 41f99d3..caa835d 100644 --- a/test-suite/standalone/test-conversion.c +++ b/test-suite/standalone/test-conversion.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 2010 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 @@ -702,10 +702,8 @@ DEFSTST (scm_to_int16) DEFUTST (scm_to_uint16) DEFSTST (scm_to_int32) DEFUTST (scm_to_uint32) -#ifdef SCM_HAVE_T_INT64 DEFSTST (scm_to_int64) DEFUTST (scm_to_uint64) -#endif #define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te) #define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te) @@ -745,11 +743,9 @@ test_int_sizes () TEST_7S (scm_from_int32, SCM_T_INT32_MAX+1LL, "-2147483648"); TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX, "4294967295"); -#if SCM_HAVE_T_INT64 TEST_7S (scm_from_int64, SCM_T_INT64_MIN, "-9223372036854775808"); TEST_7S (scm_from_int64, SCM_T_INT64_MAX, "9223372036854775807"); TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615"); -#endif TEST_8S ("91", scm_to_schar, 91, 0, 0); TEST_8U ("91", scm_to_uchar, 91, 0, 0); @@ -794,7 +790,6 @@ test_int_sizes () TEST_8U ("-1", scm_to_uint32, 0, 1, 0); TEST_8U ("#f", scm_to_uint32, 0, 0, 1); -#if SCM_HAVE_T_INT64 TEST_8S ("-9223372036854775808", scm_to_int64, SCM_T_INT64_MIN, 0, 0); TEST_8S ("9223372036854775807", scm_to_int64, SCM_T_INT64_MAX, 0, 0); TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0); @@ -803,7 +798,6 @@ test_int_sizes () TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0); TEST_8U ("-1", scm_to_uint64, 0, 1, 0); TEST_8U ("#f", scm_to_uint64, 0, 0, 1); -#endif } diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test index fa53fd2..fb2535a 100644 --- a/test-suite/tests/goops.test +++ b/test-suite/tests/goops.test @@ -140,7 +140,12 @@ (eq? (class-of "foo") )) (pass-if "port" - (is-a? (%make-void-port "w") ))) + (is-a? (%make-void-port "w") )) + + (pass-if "struct vtable" + ;; Previously, `class-of' would fail for nameless structs, i.e., structs + ;; for which `struct-vtable-name' is #f. + (is-a? (class-of (make-vtable-vtable "prprpr" 0)) ))) (with-test-prefix "defining classes" diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test index 4bfc415..e73f585 100644 --- a/test-suite/tests/socket.test +++ b/test-suite/tests/socket.test @@ -1,6 +1,6 @@ ;;;; socket.test --- test socket functions -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 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 @@ -174,13 +174,28 @@ ;;; AF_UNIX sockets and `make-socket-address' ;;; +(define %tmpdir + ;; Honor `$TMPDIR', which tmpnam(3) doesn't do. + (or (getenv "TMPDIR") "/tmp")) + +(define %curdir + ;; Remember the current working directory. + (getcwd)) + +;; Temporarily cd to %TMPDIR. The goal is to work around path name +;; limitations, which can lead to exceptions like: +;; +;; (misc-error "scm_to_sockaddr" +;; "unix address path too long: ~A" +;; ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619") +;; #f) +(chdir %tmpdir) + (define (temp-file-path) - ;; Return a temporary file path that honors `$TMPDIR', which `tmpnam' - ;; doesn't do. - (let ((dir (or (getenv "TMPDIR") "/tmp"))) - (string-append dir "/guile-test-socket-" - (number->string (current-time)) "-" - (number->string (random 100000))))) + ;; Return a temporary file name, assuming the current directory is %TMPDIR. + (string-append "guile-test-socket-" + (number->string (current-time)) "-" + (number->string (random 100000)))) (if (defined? 'AF_UNIX) @@ -320,3 +335,91 @@ #t))) + +(if (defined? 'AF_INET6) + (with-test-prefix "AF_INET6/SOCK_STREAM" + + ;; testing `bind', `listen' and `connect' on stream-oriented sockets + + (let ((server-socket (socket AF_INET6 SOCK_STREAM 0)) + (server-bound? #f) + (server-listening? #f) + (server-pid #f) + (ipv6-addr 1) ; ::1 + (server-port 8889) + (client-port 9998)) + + (pass-if "bind" + (catch 'system-error + (lambda () + (bind server-socket AF_INET6 ipv6-addr server-port) + (set! server-bound? #t) + #t) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EADDRINUSE) (throw 'unresolved)) + (else (apply throw args))))))) + + (pass-if "bind/sockaddr" + (let* ((sock (socket AF_INET6 SOCK_STREAM 0)) + (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port))) + (catch 'system-error + (lambda () + (bind sock sockaddr) + #t) + (lambda args + (let ((errno (system-error-errno args))) + (cond ((= errno EADDRINUSE) (throw 'unresolved)) + (else (apply throw args)))))))) + + (pass-if "listen" + (if (not server-bound?) + (throw 'unresolved) + (begin + (listen server-socket 123) + (set! server-listening? #t) + #t))) + + (if server-listening? + (let ((pid (primitive-fork))) + ;; Spawn a server process. + (case pid + ((-1) (throw 'unresolved)) + ((0) ;; the kid: serve two connections and exit + (let serve ((conn + (false-if-exception (accept server-socket))) + (count 1)) + (if (not conn) + (exit 1) + (if (> count 0) + (serve (false-if-exception (accept server-socket)) + (- count 1))))) + (exit 0)) + (else ;; the parent + (set! server-pid pid) + #t)))) + + (pass-if "connect" + (if (not server-pid) + (throw 'unresolved) + (let ((s (socket AF_INET6 SOCK_STREAM 0))) + (connect s AF_INET6 ipv6-addr server-port) + #t))) + + (pass-if "connect/sockaddr" + (if (not server-pid) + (throw 'unresolved) + (let ((s (socket AF_INET6 SOCK_STREAM 0))) + (connect s (make-socket-address AF_INET6 ipv6-addr server-port)) + #t))) + + (pass-if "accept" + (if (not server-pid) + (throw 'unresolved) + (let ((status (cdr (waitpid server-pid)))) + (eq? 0 (status:exit-val status))))) + + #t))) + +;; Switch back to the previous directory. +(false-if-exception (chdir %curdir))