diff options
| author | Ross Burton <ross.burton@intel.com> | 2012-12-04 11:13:50 +0100 |
|---|---|---|
| committer | Koen Kooi <koen@dominion.thruhere.net> | 2012-12-04 11:25:34 +0100 |
| commit | b6c6adb440262fe1c72d228f01535d78cba8417b (patch) | |
| tree | b90db4d89cbd2e702bbe02f95229f9768da83cfe /meta-oe/recipes-support | |
| parent | 3b4c181ee6f802c3dbcdd9e86c810c7bcffc324c (diff) | |
| download | meta-openembedded-b6c6adb440262fe1c72d228f01535d78cba8417b.tar.gz | |
guile: remove from meta-oe, there is newer version in oe-core
Signed-off-by: Martin Jansa <Martin.Jansa@gmail.com>
Diffstat (limited to 'meta-oe/recipes-support')
8 files changed, 0 insertions, 1870 deletions
diff --git a/meta-oe/recipes-support/guile/guile-1.8.7/18.diff b/meta-oe/recipes-support/guile/guile-1.8.7/18.diff deleted file mode 100644 index 9c9eefb09b..0000000000 --- a/meta-oe/recipes-support/guile/guile-1.8.7/18.diff +++ /dev/null | |||
| @@ -1,1743 +0,0 @@ | |||
| 1 | diff --git a/LICENSE b/LICENSE | ||
| 2 | index 213e34a..dda451e 100644 | ||
| 3 | --- a/LICENSE | ||
| 4 | +++ b/LICENSE | ||
| 5 | @@ -1,2 +1,2 @@ | ||
| 6 | Guile is covered under the terms of the GNU Lesser General Public | ||
| 7 | -License, version 2.1. See COPYING.LESSER. | ||
| 8 | +License, version 2.1 or later. See COPYING.LESSER. | ||
| 9 | diff --git a/NEWS b/NEWS | ||
| 10 | index 0dcc411..564484f 100644 | ||
| 11 | --- a/NEWS | ||
| 12 | +++ b/NEWS | ||
| 13 | @@ -5,6 +5,19 @@ See the end for copying conditions. | ||
| 14 | Please send Guile bug reports to bug-guile@gnu.org. | ||
| 15 | |||
| 16 | |||
| 17 | +Changes in 1.8.8 (since 1.8.7) | ||
| 18 | + | ||
| 19 | +* Bugs fixed | ||
| 20 | + | ||
| 21 | +** Fix possible buffer overruns when parsing numbers | ||
| 22 | +** Avoid clash with system setjmp/longjmp on IA64 | ||
| 23 | +** Don't dynamically link an extension that is already registered | ||
| 24 | +** Fix `wrong type arg' exceptions with IPv6 addresses | ||
| 25 | +** Fix typos in `(srfi srfi-19)' | ||
| 26 | +** Have `(srfi srfi-35)' provide named struct vtables | ||
| 27 | +** Fix some Interix build problems | ||
| 28 | + | ||
| 29 | + | ||
| 30 | Changes in 1.8.7 (since 1.8.6) | ||
| 31 | |||
| 32 | * Bugs fixed | ||
| 33 | diff --git a/THANKS b/THANKS | ||
| 34 | index 47d3cfa..48a105a 100644 | ||
| 35 | --- a/THANKS | ||
| 36 | +++ b/THANKS | ||
| 37 | @@ -50,6 +50,7 @@ For fixes or providing information which led to a fix: | ||
| 38 | Roland Haeder | ||
| 39 | Sven Hartrumpf | ||
| 40 | Eric Hanchrow | ||
| 41 | + Judy Hawkins | ||
| 42 | Sam Hocevar | ||
| 43 | Patrick Horgan | ||
| 44 | Ales Hvezda | ||
| 45 | @@ -64,12 +65,15 @@ For fixes or providing information which led to a fix: | ||
| 46 | Matthias Köppe | ||
| 47 | Matt Kraai | ||
| 48 | Daniel Kraft | ||
| 49 | + Jay Krell | ||
| 50 | Jeff Long | ||
| 51 | Marco Maggi | ||
| 52 | Gregory Marton | ||
| 53 | + Kjetil S. Matheussen | ||
| 54 | Antoine Mathys | ||
| 55 | Dan McMahill | ||
| 56 | Roger Mc Murtrie | ||
| 57 | + Scott McPeak | ||
| 58 | Tim Mooney | ||
| 59 | Han-Wen Nienhuys | ||
| 60 | Jan Nieuwenhuizen | ||
| 61 | diff --git a/doc/ref/api-modules.texi b/doc/ref/api-modules.texi | ||
| 62 | index 9aeb08a..f6393db 100644 | ||
| 63 | --- a/doc/ref/api-modules.texi | ||
| 64 | +++ b/doc/ref/api-modules.texi | ||
| 65 | @@ -758,7 +758,7 @@ Record definition with @code{define-record-type} (@pxref{SRFI-9}). | ||
| 66 | Read hash extension @code{#,()} (@pxref{SRFI-10}). | ||
| 67 | |||
| 68 | @item (srfi srfi-11) | ||
| 69 | -Multiple-value handling with @code{let-values} and @code{let-values*} | ||
| 70 | +Multiple-value handling with @code{let-values} and @code{let*-values} | ||
| 71 | (@pxref{SRFI-11}). | ||
| 72 | |||
| 73 | @item (srfi srfi-13) | ||
| 74 | diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi | ||
| 75 | index 7c17b36..3d9cde4 100644 | ||
| 76 | --- a/doc/ref/guile.texi | ||
| 77 | +++ b/doc/ref/guile.texi | ||
| 78 | @@ -13,8 +13,8 @@ This reference manual documents Guile, GNU's Ubiquitous Intelligent | ||
| 79 | Language for Extensions. This is edition @value{MANUAL-EDITION} | ||
| 80 | corresponding to Guile @value{VERSION}. | ||
| 81 | |||
| 82 | -Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005 Free | ||
| 83 | -Software Foundation. | ||
| 84 | +Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, | ||
| 85 | +2007, 2008, 2009, 2010 Free Software Foundation. | ||
| 86 | |||
| 87 | Permission is granted to copy, distribute and/or modify this document | ||
| 88 | under the terms of the GNU Free Documentation License, Version 1.2 or | ||
| 89 | diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi | ||
| 90 | index 1cb273a..0a7e342 100644 | ||
| 91 | --- a/doc/ref/posix.texi | ||
| 92 | +++ b/doc/ref/posix.texi | ||
| 93 | @@ -2310,8 +2310,8 @@ Convert a network address from an integer to a printable string. | ||
| 94 | |||
| 95 | @lisp | ||
| 96 | (inet-ntop AF_INET 2130706433) @result{} "127.0.0.1" | ||
| 97 | -(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{} | ||
| 98 | -ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff | ||
| 99 | +(inet-ntop AF_INET6 (- (expt 2 128) 1)) | ||
| 100 | + @result{} "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff" | ||
| 101 | @end lisp | ||
| 102 | @end deffn | ||
| 103 | |||
| 104 | @@ -2882,8 +2882,8 @@ same as @code{make-socket-address} would take to make such an object | ||
| 105 | (@pxref{Network Socket Address}). The return value is unspecified. | ||
| 106 | |||
| 107 | @example | ||
| 108 | -(connect sock AF_INET INADDR_LOCALHOST 23) | ||
| 109 | -(connect sock (make-socket-address AF_INET INADDR_LOCALHOST 23)) | ||
| 110 | +(connect sock AF_INET INADDR_LOOPBACK 23) | ||
| 111 | +(connect sock (make-socket-address AF_INET INADDR_LOOPBACK 23)) | ||
| 112 | @end example | ||
| 113 | @end deffn | ||
| 114 | |||
| 115 | diff --git a/ice-9/debugging/ice-9-debugger-extensions.scm b/ice-9/debugging/ice-9-debugger-extensions.scm | ||
| 116 | index a8b8c97..fe04fc0 100644 | ||
| 117 | --- a/ice-9/debugging/ice-9-debugger-extensions.scm | ||
| 118 | +++ b/ice-9/debugging/ice-9-debugger-extensions.scm | ||
| 119 | @@ -39,7 +39,8 @@ | ||
| 120 | (else | ||
| 121 | (define-module (ice-9 debugger)))) | ||
| 122 | |||
| 123 | -(use-modules (ice-9 debugging steps)) | ||
| 124 | +(use-modules (ice-9 debugging steps) | ||
| 125 | + (ice-9 debugging trace)) | ||
| 126 | |||
| 127 | (define (assert-continuable state) | ||
| 128 | ;; Check that debugger is in a state where `continuing' makes sense. | ||
| 129 | diff --git a/libguile/__scm.h b/libguile/__scm.h | ||
| 130 | index b198f9d..e75f1a9 100644 | ||
| 131 | --- a/libguile/__scm.h | ||
| 132 | +++ b/libguile/__scm.h | ||
| 133 | @@ -3,7 +3,7 @@ | ||
| 134 | #ifndef SCM___SCM_H | ||
| 135 | #define SCM___SCM_H | ||
| 136 | |||
| 137 | -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008 Free Software Foundation, Inc. | ||
| 138 | +/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2010 Free Software Foundation, Inc. | ||
| 139 | * | ||
| 140 | * This library is free software; you can redistribute it and/or | ||
| 141 | * modify it under the terms of the GNU Lesser General Public | ||
| 142 | @@ -359,11 +359,9 @@ | ||
| 143 | #define SCM_T_INT32_MIN SCM_I_TYPE_MIN(scm_t_int32,SCM_T_UINT32_MAX) | ||
| 144 | #define SCM_T_INT32_MAX SCM_I_TYPE_MAX(scm_t_int32,SCM_T_UINT32_MAX) | ||
| 145 | |||
| 146 | -#if SCM_HAVE_T_INT64 | ||
| 147 | #define SCM_T_UINT64_MAX SCM_I_UTYPE_MAX(scm_t_uint64) | ||
| 148 | #define SCM_T_INT64_MIN SCM_I_TYPE_MIN(scm_t_int64,SCM_T_UINT64_MAX) | ||
| 149 | #define SCM_T_INT64_MAX SCM_I_TYPE_MAX(scm_t_int64,SCM_T_UINT64_MAX) | ||
| 150 | -#endif | ||
| 151 | |||
| 152 | #if SCM_SIZEOF_LONG_LONG | ||
| 153 | #define SCM_I_ULLONG_MAX SCM_I_UTYPE_MAX(unsigned long long) | ||
| 154 | @@ -409,19 +407,28 @@ | ||
| 155 | typedef struct { | ||
| 156 | ucontext_t ctx; | ||
| 157 | int fresh; | ||
| 158 | - } jmp_buf; | ||
| 159 | -# define setjmp(JB) \ | ||
| 160 | + } scm_i_jmp_buf; | ||
| 161 | +# define SCM_I_SETJMP(JB) \ | ||
| 162 | ( (JB).fresh = 1, \ | ||
| 163 | getcontext (&((JB).ctx)), \ | ||
| 164 | ((JB).fresh ? ((JB).fresh = 0, 0) : 1) ) | ||
| 165 | -# define longjmp(JB,VAL) scm_ia64_longjmp (&(JB), VAL) | ||
| 166 | - void scm_ia64_longjmp (jmp_buf *, int); | ||
| 167 | +# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL) | ||
| 168 | + void scm_ia64_longjmp (scm_i_jmp_buf *, int); | ||
| 169 | # else /* ndef __ia64__ */ | ||
| 170 | # include <setjmp.h> | ||
| 171 | # endif /* ndef __ia64__ */ | ||
| 172 | # endif /* ndef _CRAY1 */ | ||
| 173 | #endif /* ndef vms */ | ||
| 174 | |||
| 175 | +/* For any platform where SCM_I_SETJMP hasn't been defined in some | ||
| 176 | + special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and | ||
| 177 | + scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */ | ||
| 178 | +#ifndef SCM_I_SETJMP | ||
| 179 | +#define scm_i_jmp_buf jmp_buf | ||
| 180 | +#define SCM_I_SETJMP setjmp | ||
| 181 | +#define SCM_I_LONGJMP longjmp | ||
| 182 | +#endif | ||
| 183 | + | ||
| 184 | /* James Clark came up with this neat one instruction fix for | ||
| 185 | * continuations on the SPARC. It flushes the register windows so | ||
| 186 | * that all the state of the process is contained in the stack. | ||
| 187 | diff --git a/libguile/continuations.c b/libguile/continuations.c | ||
| 188 | index 69d2569..84a7fed 100644 | ||
| 189 | --- a/libguile/continuations.c | ||
| 190 | +++ b/libguile/continuations.c | ||
| 191 | @@ -127,7 +127,7 @@ scm_make_continuation (int *first) | ||
| 192 | continuation->offset = continuation->stack - src; | ||
| 193 | memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size); | ||
| 194 | |||
| 195 | - *first = !setjmp (continuation->jmpbuf); | ||
| 196 | + *first = !SCM_I_SETJMP (continuation->jmpbuf); | ||
| 197 | if (*first) | ||
| 198 | { | ||
| 199 | #ifdef __ia64__ | ||
| 200 | @@ -224,12 +224,12 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, | ||
| 201 | scm_i_set_last_debug_frame (continuation->dframe); | ||
| 202 | |||
| 203 | continuation->throw_value = val; | ||
| 204 | - longjmp (continuation->jmpbuf, 1); | ||
| 205 | + SCM_I_LONGJMP (continuation->jmpbuf, 1); | ||
| 206 | } | ||
| 207 | |||
| 208 | #ifdef __ia64__ | ||
| 209 | void | ||
| 210 | -scm_ia64_longjmp (jmp_buf *JB, int VAL) | ||
| 211 | +scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL) | ||
| 212 | { | ||
| 213 | scm_i_thread *t = SCM_I_CURRENT_THREAD; | ||
| 214 | |||
| 215 | diff --git a/libguile/continuations.h b/libguile/continuations.h | ||
| 216 | index f6fb96a..c61ab2d 100644 | ||
| 217 | --- a/libguile/continuations.h | ||
| 218 | +++ b/libguile/continuations.h | ||
| 219 | @@ -43,7 +43,7 @@ SCM_API scm_t_bits scm_tc16_continuation; | ||
| 220 | typedef struct | ||
| 221 | { | ||
| 222 | SCM throw_value; | ||
| 223 | - jmp_buf jmpbuf; | ||
| 224 | + scm_i_jmp_buf jmpbuf; | ||
| 225 | SCM dynenv; | ||
| 226 | #ifdef __ia64__ | ||
| 227 | void *backing_store; | ||
| 228 | diff --git a/libguile/extensions.c b/libguile/extensions.c | ||
| 229 | index 1090b8b..29cb58c 100644 | ||
| 230 | --- a/libguile/extensions.c | ||
| 231 | +++ b/libguile/extensions.c | ||
| 232 | @@ -76,6 +76,7 @@ load_extension (SCM lib, SCM init) | ||
| 233 | { | ||
| 234 | extension_t *ext; | ||
| 235 | char *clib, *cinit; | ||
| 236 | + int found = 0; | ||
| 237 | |||
| 238 | scm_dynwind_begin (0); | ||
| 239 | |||
| 240 | @@ -89,10 +90,14 @@ load_extension (SCM lib, SCM init) | ||
| 241 | && !strcmp (ext->init, cinit)) | ||
| 242 | { | ||
| 243 | ext->func (ext->data); | ||
| 244 | + found = 1; | ||
| 245 | break; | ||
| 246 | } | ||
| 247 | |||
| 248 | scm_dynwind_end (); | ||
| 249 | + | ||
| 250 | + if (found) | ||
| 251 | + return; | ||
| 252 | } | ||
| 253 | |||
| 254 | /* Dynamically link the library. */ | ||
| 255 | diff --git a/libguile/filesys.c b/libguile/filesys.c | ||
| 256 | index 70dfe15..c8acb13 100644 | ||
| 257 | --- a/libguile/filesys.c | ||
| 258 | +++ b/libguile/filesys.c | ||
| 259 | @@ -23,6 +23,9 @@ | ||
| 260 | #ifdef __hpux | ||
| 261 | #define _POSIX_C_SOURCE 199506L /* for readdir_r */ | ||
| 262 | #endif | ||
| 263 | +#if defined(__INTERIX) && !defined(_REENTRANT) | ||
| 264 | +# define _REENTRANT /* ask Interix for readdir_r prototype */ | ||
| 265 | +#endif | ||
| 266 | |||
| 267 | #ifdef HAVE_CONFIG_H | ||
| 268 | # include <config.h> | ||
| 269 | diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c | ||
| 270 | index 85ebfae..e5de31d 100644 | ||
| 271 | --- a/libguile/gen-scmconfig.c | ||
| 272 | +++ b/libguile/gen-scmconfig.c | ||
| 273 | @@ -315,28 +315,10 @@ main (int argc, char *argv[]) | ||
| 274 | return 1; | ||
| 275 | |||
| 276 | pf ("\n"); | ||
| 277 | - pf ("/* 64-bit integer -- if available SCM_HAVE_T_INT64 will be 1 and\n" | ||
| 278 | - " scm_t_int64 will be a suitable type, otherwise SCM_HAVE_T_INT64\n" | ||
| 279 | - " will be 0. */\n"); | ||
| 280 | - if (SCM_I_GSC_T_INT64) | ||
| 281 | - { | ||
| 282 | - pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n"); | ||
| 283 | - pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64); | ||
| 284 | - } | ||
| 285 | - else | ||
| 286 | - pf ("#define SCM_HAVE_T_INT64 0 /* 0 or 1 */\n"); | ||
| 287 | - | ||
| 288 | - pf ("\n"); | ||
| 289 | - pf ("/* 64-bit unsigned integer -- if available SCM_HAVE_T_UINT64 will\n" | ||
| 290 | - " be 1 and scm_t_uint64 will be a suitable type, otherwise\n" | ||
| 291 | - " SCM_HAVE_T_UINT64 will be 0. */\n"); | ||
| 292 | - if (SCM_I_GSC_T_UINT64) | ||
| 293 | - { | ||
| 294 | - pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n"); | ||
| 295 | - pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64); | ||
| 296 | - } | ||
| 297 | - else | ||
| 298 | - pf ("#define SCM_HAVE_T_UINT64 0 /* 0 or 1 */\n"); | ||
| 299 | + pf ("#define SCM_HAVE_T_INT64 1 /* 0 or 1 */\n"); | ||
| 300 | + pf ("typedef %s scm_t_int64;\n", SCM_I_GSC_T_INT64); | ||
| 301 | + pf ("#define SCM_HAVE_T_UINT64 1 /* 0 or 1 */\n"); | ||
| 302 | + pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64); | ||
| 303 | |||
| 304 | pf ("\n"); | ||
| 305 | pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n" | ||
| 306 | diff --git a/libguile/hashtab.c b/libguile/hashtab.c | ||
| 307 | index ea7fc69..1f1569c 100644 | ||
| 308 | --- a/libguile/hashtab.c | ||
| 309 | +++ b/libguile/hashtab.c | ||
| 310 | @@ -1,4 +1,4 @@ | ||
| 311 | -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. | ||
| 312 | +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc. | ||
| 313 | * | ||
| 314 | * This library is free software; you can redistribute it and/or | ||
| 315 | * modify it under the terms of the GNU Lesser General Public | ||
| 316 | @@ -911,74 +911,6 @@ SCM_DEFINE (scm_hashx_remove_x, "hashx-remove!", 4, 0, 0, | ||
| 317 | |||
| 318 | /* Hash table iterators */ | ||
| 319 | |||
| 320 | -static const char s_scm_hash_fold[]; | ||
| 321 | - | ||
| 322 | -SCM | ||
| 323 | -scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) | ||
| 324 | -{ | ||
| 325 | - long i, n; | ||
| 326 | - SCM buckets, result = init; | ||
| 327 | - | ||
| 328 | - if (SCM_HASHTABLE_P (table)) | ||
| 329 | - buckets = SCM_HASHTABLE_VECTOR (table); | ||
| 330 | - else | ||
| 331 | - buckets = table; | ||
| 332 | - | ||
| 333 | - n = SCM_SIMPLE_VECTOR_LENGTH (buckets); | ||
| 334 | - for (i = 0; i < n; ++i) | ||
| 335 | - { | ||
| 336 | - SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; | ||
| 337 | - while (!scm_is_null (ls)) | ||
| 338 | - { | ||
| 339 | - if (!scm_is_pair (ls)) | ||
| 340 | - scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); | ||
| 341 | - handle = SCM_CAR (ls); | ||
| 342 | - if (!scm_is_pair (handle)) | ||
| 343 | - scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); | ||
| 344 | - result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); | ||
| 345 | - ls = SCM_CDR (ls); | ||
| 346 | - } | ||
| 347 | - } | ||
| 348 | - | ||
| 349 | - return result; | ||
| 350 | -} | ||
| 351 | - | ||
| 352 | -/* The following redundant code is here in order to be able to support | ||
| 353 | - hash-for-each-handle. An alternative would have been to replace | ||
| 354 | - this code and scm_internal_hash_fold above with a single | ||
| 355 | - scm_internal_hash_fold_handles, but we don't want to promote such | ||
| 356 | - an API. */ | ||
| 357 | - | ||
| 358 | -static const char s_scm_hash_for_each[]; | ||
| 359 | - | ||
| 360 | -void | ||
| 361 | -scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table) | ||
| 362 | -{ | ||
| 363 | - long i, n; | ||
| 364 | - SCM buckets; | ||
| 365 | - | ||
| 366 | - if (SCM_HASHTABLE_P (table)) | ||
| 367 | - buckets = SCM_HASHTABLE_VECTOR (table); | ||
| 368 | - else | ||
| 369 | - buckets = table; | ||
| 370 | - | ||
| 371 | - n = SCM_SIMPLE_VECTOR_LENGTH (buckets); | ||
| 372 | - for (i = 0; i < n; ++i) | ||
| 373 | - { | ||
| 374 | - SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; | ||
| 375 | - while (!scm_is_null (ls)) | ||
| 376 | - { | ||
| 377 | - if (!scm_is_pair (ls)) | ||
| 378 | - scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); | ||
| 379 | - handle = SCM_CAR (ls); | ||
| 380 | - if (!scm_is_pair (handle)) | ||
| 381 | - scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); | ||
| 382 | - fn (closure, handle); | ||
| 383 | - ls = SCM_CDR (ls); | ||
| 384 | - } | ||
| 385 | - } | ||
| 386 | -} | ||
| 387 | - | ||
| 388 | SCM_DEFINE (scm_hash_fold, "hash-fold", 3, 0, 0, | ||
| 389 | (SCM proc, SCM init, SCM table), | ||
| 390 | "An iterator over hash-table elements.\n" | ||
| 391 | @@ -1067,6 +999,72 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0, | ||
| 392 | |||
| 393 | |||
| 394 | |||
| 395 | +SCM | ||
| 396 | +scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) | ||
| 397 | +{ | ||
| 398 | + long i, n; | ||
| 399 | + SCM buckets, result = init; | ||
| 400 | + | ||
| 401 | + if (SCM_HASHTABLE_P (table)) | ||
| 402 | + buckets = SCM_HASHTABLE_VECTOR (table); | ||
| 403 | + else | ||
| 404 | + buckets = table; | ||
| 405 | + | ||
| 406 | + n = SCM_SIMPLE_VECTOR_LENGTH (buckets); | ||
| 407 | + for (i = 0; i < n; ++i) | ||
| 408 | + { | ||
| 409 | + SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; | ||
| 410 | + while (!scm_is_null (ls)) | ||
| 411 | + { | ||
| 412 | + if (!scm_is_pair (ls)) | ||
| 413 | + scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); | ||
| 414 | + handle = SCM_CAR (ls); | ||
| 415 | + if (!scm_is_pair (handle)) | ||
| 416 | + scm_wrong_type_arg (s_scm_hash_fold, SCM_ARG3, buckets); | ||
| 417 | + result = fn (closure, SCM_CAR (handle), SCM_CDR (handle), result); | ||
| 418 | + ls = SCM_CDR (ls); | ||
| 419 | + } | ||
| 420 | + } | ||
| 421 | + | ||
| 422 | + return result; | ||
| 423 | +} | ||
| 424 | + | ||
| 425 | +/* The following redundant code is here in order to be able to support | ||
| 426 | + hash-for-each-handle. An alternative would have been to replace | ||
| 427 | + this code and scm_internal_hash_fold above with a single | ||
| 428 | + scm_internal_hash_fold_handles, but we don't want to promote such | ||
| 429 | + an API. */ | ||
| 430 | + | ||
| 431 | +void | ||
| 432 | +scm_internal_hash_for_each_handle (SCM (*fn) (), void *closure, SCM table) | ||
| 433 | +{ | ||
| 434 | + long i, n; | ||
| 435 | + SCM buckets; | ||
| 436 | + | ||
| 437 | + if (SCM_HASHTABLE_P (table)) | ||
| 438 | + buckets = SCM_HASHTABLE_VECTOR (table); | ||
| 439 | + else | ||
| 440 | + buckets = table; | ||
| 441 | + | ||
| 442 | + n = SCM_SIMPLE_VECTOR_LENGTH (buckets); | ||
| 443 | + for (i = 0; i < n; ++i) | ||
| 444 | + { | ||
| 445 | + SCM ls = SCM_SIMPLE_VECTOR_REF (buckets, i), handle; | ||
| 446 | + while (!scm_is_null (ls)) | ||
| 447 | + { | ||
| 448 | + if (!scm_is_pair (ls)) | ||
| 449 | + scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); | ||
| 450 | + handle = SCM_CAR (ls); | ||
| 451 | + if (!scm_is_pair (handle)) | ||
| 452 | + scm_wrong_type_arg (s_scm_hash_for_each, SCM_ARG3, buckets); | ||
| 453 | + fn (closure, handle); | ||
| 454 | + ls = SCM_CDR (ls); | ||
| 455 | + } | ||
| 456 | + } | ||
| 457 | +} | ||
| 458 | + | ||
| 459 | + | ||
| 460 | + | ||
| 461 | |||
| 462 | void | ||
| 463 | scm_hashtab_prehistory () | ||
| 464 | diff --git a/libguile/iselect.h b/libguile/iselect.h | ||
| 465 | index 5a4b30d..b23a641 100644 | ||
| 466 | --- a/libguile/iselect.h | ||
| 467 | +++ b/libguile/iselect.h | ||
| 468 | @@ -38,7 +38,12 @@ | ||
| 469 | #ifdef FD_SET | ||
| 470 | |||
| 471 | #define SELECT_TYPE fd_set | ||
| 472 | +#if defined(__INTERIX) && FD_SETSIZE == 4096 | ||
| 473 | +/* Interix defines FD_SETSIZE 4096 but select rejects that. */ | ||
| 474 | +#define SELECT_SET_SIZE 1024 | ||
| 475 | +#else | ||
| 476 | #define SELECT_SET_SIZE FD_SETSIZE | ||
| 477 | +#endif | ||
| 478 | |||
| 479 | #else /* no FD_SET */ | ||
| 480 | |||
| 481 | diff --git a/libguile/numbers.c b/libguile/numbers.c | ||
| 482 | index 2e1635f..4f5ab31 100644 | ||
| 483 | --- a/libguile/numbers.c | ||
| 484 | +++ b/libguile/numbers.c | ||
| 485 | @@ -1,4 +1,4 @@ | ||
| 486 | -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 487 | +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. | ||
| 488 | * | ||
| 489 | * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories | ||
| 490 | * and Bellcore. See scm_divide. | ||
| 491 | @@ -620,7 +620,14 @@ guile_ieee_init (void) | ||
| 492 | #elif HAVE_DINFINITY | ||
| 493 | /* OSF */ | ||
| 494 | extern unsigned int DINFINITY[2]; | ||
| 495 | - guile_Inf = (*((double *) (DINFINITY))); | ||
| 496 | + union | ||
| 497 | + { | ||
| 498 | + double d; | ||
| 499 | + int i[2]; | ||
| 500 | + } alias; | ||
| 501 | + alias.i[0] = DINFINITY[0]; | ||
| 502 | + alias.i[1] = DINFINITY[1]; | ||
| 503 | + guile_Inf = alias.d; | ||
| 504 | #else | ||
| 505 | double tmp = 1e+10; | ||
| 506 | guile_Inf = tmp; | ||
| 507 | @@ -651,7 +658,14 @@ guile_ieee_init (void) | ||
| 508 | { | ||
| 509 | /* OSF */ | ||
| 510 | extern unsigned int DQNAN[2]; | ||
| 511 | - guile_NaN = (*((double *)(DQNAN))); | ||
| 512 | + union | ||
| 513 | + { | ||
| 514 | + double d; | ||
| 515 | + int i[2]; | ||
| 516 | + } alias; | ||
| 517 | + alias.i[0] = DQNAN[0]; | ||
| 518 | + alias.i[1] = DQNAN[1]; | ||
| 519 | + guile_NaN = alias.d; | ||
| 520 | } | ||
| 521 | #else | ||
| 522 | guile_NaN = guile_Inf / guile_Inf; | ||
| 523 | @@ -2663,17 +2677,26 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, | ||
| 524 | case 'l': case 'L': | ||
| 525 | case 's': case 'S': | ||
| 526 | idx++; | ||
| 527 | + if (idx == len) | ||
| 528 | + return SCM_BOOL_F; | ||
| 529 | + | ||
| 530 | start = idx; | ||
| 531 | c = mem[idx]; | ||
| 532 | if (c == '-') | ||
| 533 | { | ||
| 534 | idx++; | ||
| 535 | + if (idx == len) | ||
| 536 | + return SCM_BOOL_F; | ||
| 537 | + | ||
| 538 | sign = -1; | ||
| 539 | c = mem[idx]; | ||
| 540 | } | ||
| 541 | else if (c == '+') | ||
| 542 | { | ||
| 543 | idx++; | ||
| 544 | + if (idx == len) | ||
| 545 | + return SCM_BOOL_F; | ||
| 546 | + | ||
| 547 | sign = 1; | ||
| 548 | c = mem[idx]; | ||
| 549 | } | ||
| 550 | @@ -2789,8 +2812,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, | ||
| 551 | SCM divisor; | ||
| 552 | |||
| 553 | idx++; | ||
| 554 | + if (idx == len) | ||
| 555 | + return SCM_BOOL_F; | ||
| 556 | |||
| 557 | - divisor = mem2uinteger (mem, len, &idx, radix, &x); | ||
| 558 | + divisor = mem2uinteger (mem, len, &idx, radix, &x); | ||
| 559 | if (scm_is_false (divisor)) | ||
| 560 | return SCM_BOOL_F; | ||
| 561 | |||
| 562 | @@ -2911,11 +2936,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx, | ||
| 563 | if (c == '+') | ||
| 564 | { | ||
| 565 | idx++; | ||
| 566 | + if (idx == len) | ||
| 567 | + return SCM_BOOL_F; | ||
| 568 | sign = 1; | ||
| 569 | } | ||
| 570 | else if (c == '-') | ||
| 571 | { | ||
| 572 | idx++; | ||
| 573 | + if (idx == len) | ||
| 574 | + return SCM_BOOL_F; | ||
| 575 | sign = -1; | ||
| 576 | } | ||
| 577 | else | ||
| 578 | @@ -5869,8 +5898,6 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max) | ||
| 579 | #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg) | ||
| 580 | #include "libguile/conv-uinteger.i.c" | ||
| 581 | |||
| 582 | -#if SCM_HAVE_T_INT64 | ||
| 583 | - | ||
| 584 | #define TYPE scm_t_int64 | ||
| 585 | #define TYPE_MIN SCM_T_INT64_MIN | ||
| 586 | #define TYPE_MAX SCM_T_INT64_MAX | ||
| 587 | @@ -5887,8 +5914,6 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max) | ||
| 588 | #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg) | ||
| 589 | #include "libguile/conv-uinteger.i.c" | ||
| 590 | |||
| 591 | -#endif | ||
| 592 | - | ||
| 593 | void | ||
| 594 | scm_to_mpz (SCM val, mpz_t rop) | ||
| 595 | { | ||
| 596 | diff --git a/libguile/numbers.h b/libguile/numbers.h | ||
| 597 | index 2c2fdcf..35263a4 100644 | ||
| 598 | --- a/libguile/numbers.h | ||
| 599 | +++ b/libguile/numbers.h | ||
| 600 | @@ -3,7 +3,7 @@ | ||
| 601 | #ifndef SCM_NUMBERS_H | ||
| 602 | #define SCM_NUMBERS_H | ||
| 603 | |||
| 604 | -/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006 Free Software Foundation, Inc. | ||
| 605 | +/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2010 Free Software Foundation, Inc. | ||
| 606 | * | ||
| 607 | * This library is free software; you can redistribute it and/or | ||
| 608 | * modify it under the terms of the GNU Lesser General Public | ||
| 609 | @@ -321,16 +321,12 @@ SCM_API SCM scm_from_int32 (scm_t_int32 x); | ||
| 610 | SCM_API scm_t_uint32 scm_to_uint32 (SCM x); | ||
| 611 | SCM_API SCM scm_from_uint32 (scm_t_uint32 x); | ||
| 612 | |||
| 613 | -#if SCM_HAVE_T_INT64 | ||
| 614 | - | ||
| 615 | SCM_API scm_t_int64 scm_to_int64 (SCM x); | ||
| 616 | SCM_API SCM scm_from_int64 (scm_t_int64 x); | ||
| 617 | |||
| 618 | SCM_API scm_t_uint64 scm_to_uint64 (SCM x); | ||
| 619 | SCM_API SCM scm_from_uint64 (scm_t_uint64 x); | ||
| 620 | |||
| 621 | -#endif | ||
| 622 | - | ||
| 623 | SCM_API void scm_to_mpz (SCM x, mpz_t rop); | ||
| 624 | SCM_API SCM scm_from_mpz (mpz_t rop); | ||
| 625 | |||
| 626 | diff --git a/libguile/random.c b/libguile/random.c | ||
| 627 | index 8d2ff03..693ed4a 100644 | ||
| 628 | --- a/libguile/random.c | ||
| 629 | +++ b/libguile/random.c | ||
| 630 | @@ -1,4 +1,4 @@ | ||
| 631 | -/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006 Free Software Foundation, Inc. | ||
| 632 | +/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006, 2010 Free Software Foundation, Inc. | ||
| 633 | * This library is free software; you can redistribute it and/or | ||
| 634 | * modify it under the terms of the GNU Lesser General Public | ||
| 635 | * License as published by the Free Software Foundation; either | ||
| 636 | @@ -75,8 +75,6 @@ scm_t_rng scm_the_rng; | ||
| 637 | #define M_PI 3.14159265359 | ||
| 638 | #endif | ||
| 639 | |||
| 640 | -#if SCM_HAVE_T_UINT64 | ||
| 641 | - | ||
| 642 | unsigned long | ||
| 643 | scm_i_uniform32 (scm_t_i_rstate *state) | ||
| 644 | { | ||
| 645 | @@ -87,38 +85,6 @@ scm_i_uniform32 (scm_t_i_rstate *state) | ||
| 646 | return w; | ||
| 647 | } | ||
| 648 | |||
| 649 | -#else | ||
| 650 | - | ||
| 651 | -/* ww This is a portable version of the same RNG without 64 bit | ||
| 652 | - * * aa arithmetic. | ||
| 653 | - * ---- | ||
| 654 | - * xx It is only intended to provide identical behaviour on | ||
| 655 | - * xx platforms without 8 byte longs or long longs until | ||
| 656 | - * xx someone has implemented the routine in assembler code. | ||
| 657 | - * xxcc | ||
| 658 | - * ---- | ||
| 659 | - * ccww | ||
| 660 | - */ | ||
| 661 | - | ||
| 662 | -#define L(x) ((x) & 0xffff) | ||
| 663 | -#define H(x) ((x) >> 16) | ||
| 664 | - | ||
| 665 | -unsigned long | ||
| 666 | -scm_i_uniform32 (scm_t_i_rstate *state) | ||
| 667 | -{ | ||
| 668 | - scm_t_uint32 x1 = L (A) * L (state->w); | ||
| 669 | - scm_t_uint32 x2 = L (A) * H (state->w); | ||
| 670 | - scm_t_uint32 x3 = H (A) * L (state->w); | ||
| 671 | - scm_t_uint32 w = L (x1) + L (state->c); | ||
| 672 | - scm_t_uint32 m = H (x1) + L (x2) + L (x3) + H (state->c) + H (w); | ||
| 673 | - scm_t_uint32 x4 = H (A) * H (state->w); | ||
| 674 | - state->w = w = (L (m) << 16) + L (w); | ||
| 675 | - state->c = H (x2) + H (x3) + x4 + H (m); | ||
| 676 | - return w; | ||
| 677 | -} | ||
| 678 | - | ||
| 679 | -#endif | ||
| 680 | - | ||
| 681 | void | ||
| 682 | scm_i_init_rstate (scm_t_i_rstate *state, const char *seed, int n) | ||
| 683 | { | ||
| 684 | @@ -212,21 +178,49 @@ scm_c_exp1 (scm_t_rstate *state) | ||
| 685 | |||
| 686 | unsigned char scm_masktab[256]; | ||
| 687 | |||
| 688 | -unsigned long | ||
| 689 | -scm_c_random (scm_t_rstate *state, unsigned long m) | ||
| 690 | +static inline scm_t_uint32 | ||
| 691 | +scm_i_mask32 (scm_t_uint32 m) | ||
| 692 | { | ||
| 693 | - unsigned int r, mask; | ||
| 694 | - mask = (m < 0x100 | ||
| 695 | + return (m < 0x100 | ||
| 696 | ? scm_masktab[m] | ||
| 697 | : (m < 0x10000 | ||
| 698 | ? scm_masktab[m >> 8] << 8 | 0xff | ||
| 699 | : (m < 0x1000000 | ||
| 700 | ? scm_masktab[m >> 16] << 16 | 0xffff | ||
| 701 | : scm_masktab[m >> 24] << 24 | 0xffffff))); | ||
| 702 | +} | ||
| 703 | + | ||
| 704 | +static scm_t_uint32 | ||
| 705 | +scm_c_random32 (scm_t_rstate *state, scm_t_uint32 m) | ||
| 706 | +{ | ||
| 707 | + scm_t_uint32 r, mask = scm_i_mask32 (m); | ||
| 708 | while ((r = scm_the_rng.random_bits (state) & mask) >= m); | ||
| 709 | return r; | ||
| 710 | } | ||
| 711 | |||
| 712 | +/* Returns 32 random bits. */ | ||
| 713 | +unsigned long | ||
| 714 | +scm_c_random (scm_t_rstate *state, unsigned long m) | ||
| 715 | +{ | ||
| 716 | + return scm_c_random32 (state, (scm_t_uint32)m); | ||
| 717 | +} | ||
| 718 | + | ||
| 719 | +scm_t_uint64 | ||
| 720 | +scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m) | ||
| 721 | +{ | ||
| 722 | + scm_t_uint64 r; | ||
| 723 | + scm_t_uint32 mask; | ||
| 724 | + | ||
| 725 | + if (m <= SCM_T_UINT32_MAX) | ||
| 726 | + return scm_c_random32 (state, (scm_t_uint32) m); | ||
| 727 | + | ||
| 728 | + mask = scm_i_mask32 (m >> 32); | ||
| 729 | + while ((r = ((scm_t_uint64) (scm_the_rng.random_bits (state) & mask) << 32) | ||
| 730 | + | scm_the_rng.random_bits (state)) >= m) | ||
| 731 | + ; | ||
| 732 | + return r; | ||
| 733 | +} | ||
| 734 | + | ||
| 735 | /* | ||
| 736 | SCM scm_c_random_bignum (scm_t_rstate *state, SCM m) | ||
| 737 | |||
| 738 | @@ -247,24 +241,24 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) | ||
| 739 | { | ||
| 740 | SCM result = scm_i_mkbig (); | ||
| 741 | const size_t m_bits = mpz_sizeinbase (SCM_I_BIG_MPZ (m), 2); | ||
| 742 | - /* how many bits would only partially fill the last unsigned long? */ | ||
| 743 | - const size_t end_bits = m_bits % (sizeof (unsigned long) * SCM_CHAR_BIT); | ||
| 744 | - unsigned long *random_chunks = NULL; | ||
| 745 | - const unsigned long num_full_chunks = | ||
| 746 | - m_bits / (sizeof (unsigned long) * SCM_CHAR_BIT); | ||
| 747 | - const unsigned long num_chunks = num_full_chunks + ((end_bits) ? 1 : 0); | ||
| 748 | + /* how many bits would only partially fill the last u32? */ | ||
| 749 | + const size_t end_bits = m_bits % (sizeof (scm_t_uint32) * SCM_CHAR_BIT); | ||
| 750 | + scm_t_uint32 *random_chunks = NULL; | ||
| 751 | + const scm_t_uint32 num_full_chunks = | ||
| 752 | + m_bits / (sizeof (scm_t_uint32) * SCM_CHAR_BIT); | ||
| 753 | + const scm_t_uint32 num_chunks = num_full_chunks + ((end_bits) ? 1 : 0); | ||
| 754 | |||
| 755 | /* we know the result will be this big */ | ||
| 756 | mpz_realloc2 (SCM_I_BIG_MPZ (result), m_bits); | ||
| 757 | |||
| 758 | random_chunks = | ||
| 759 | - (unsigned long *) scm_gc_calloc (num_chunks * sizeof (unsigned long), | ||
| 760 | + (scm_t_uint32 *) scm_gc_calloc (num_chunks * sizeof (scm_t_uint32), | ||
| 761 | "random bignum chunks"); | ||
| 762 | |||
| 763 | do | ||
| 764 | { | ||
| 765 | - unsigned long *current_chunk = random_chunks + (num_chunks - 1); | ||
| 766 | - unsigned long chunks_left = num_chunks; | ||
| 767 | + scm_t_uint32 *current_chunk = random_chunks + (num_chunks - 1); | ||
| 768 | + scm_t_uint32 chunks_left = num_chunks; | ||
| 769 | |||
| 770 | mpz_set_ui (SCM_I_BIG_MPZ (result), 0); | ||
| 771 | |||
| 772 | @@ -273,23 +267,23 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) | ||
| 773 | /* generate a mask with ones in the end_bits position, i.e. if | ||
| 774 | end_bits is 3, then we'd have a mask of ...0000000111 */ | ||
| 775 | const unsigned long rndbits = scm_the_rng.random_bits (state); | ||
| 776 | - int rshift = (sizeof (unsigned long) * SCM_CHAR_BIT) - end_bits; | ||
| 777 | - unsigned long mask = ((unsigned long) ULONG_MAX) >> rshift; | ||
| 778 | - unsigned long highest_bits = rndbits & mask; | ||
| 779 | + int rshift = (sizeof (scm_t_uint32) * SCM_CHAR_BIT) - end_bits; | ||
| 780 | + scm_t_uint32 mask = 0xffffffff >> rshift; | ||
| 781 | + scm_t_uint32 highest_bits = ((scm_t_uint32) rndbits) & mask; | ||
| 782 | *current_chunk-- = highest_bits; | ||
| 783 | chunks_left--; | ||
| 784 | } | ||
| 785 | |||
| 786 | while (chunks_left) | ||
| 787 | { | ||
| 788 | - /* now fill in the remaining unsigned long sized chunks */ | ||
| 789 | + /* now fill in the remaining scm_t_uint32 sized chunks */ | ||
| 790 | *current_chunk-- = scm_the_rng.random_bits (state); | ||
| 791 | chunks_left--; | ||
| 792 | } | ||
| 793 | mpz_import (SCM_I_BIG_MPZ (result), | ||
| 794 | num_chunks, | ||
| 795 | -1, | ||
| 796 | - sizeof (unsigned long), | ||
| 797 | + sizeof (scm_t_uint32), | ||
| 798 | 0, | ||
| 799 | 0, | ||
| 800 | random_chunks); | ||
| 801 | @@ -297,7 +291,7 @@ scm_c_random_bignum (scm_t_rstate *state, SCM m) | ||
| 802 | all bits in order not to get a distorted distribution) */ | ||
| 803 | } while (mpz_cmp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (m)) >= 0); | ||
| 804 | scm_gc_free (random_chunks, | ||
| 805 | - num_chunks * sizeof (unsigned long), | ||
| 806 | + num_chunks * sizeof (scm_t_uint32), | ||
| 807 | "random bignum chunks"); | ||
| 808 | return scm_i_normbig (result); | ||
| 809 | } | ||
| 810 | @@ -348,9 +342,17 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, | ||
| 811 | SCM_VALIDATE_RSTATE (2, state); | ||
| 812 | if (SCM_I_INUMP (n)) | ||
| 813 | { | ||
| 814 | - unsigned long m = SCM_I_INUM (n); | ||
| 815 | - SCM_ASSERT_RANGE (1, n, m > 0); | ||
| 816 | - return scm_from_ulong (scm_c_random (SCM_RSTATE (state), m)); | ||
| 817 | + unsigned long m = (unsigned long) SCM_I_INUM (n); | ||
| 818 | + SCM_ASSERT_RANGE (1, n, SCM_I_INUM (n) > 0); | ||
| 819 | +#if SCM_SIZEOF_UNSIGNED_LONG <= 4 | ||
| 820 | + return scm_from_uint32 (scm_c_random (SCM_RSTATE (state), | ||
| 821 | + (scm_t_uint32) m)); | ||
| 822 | +#elif SCM_SIZEOF_UNSIGNED_LONG <= 8 | ||
| 823 | + return scm_from_uint64 (scm_c_random64 (SCM_RSTATE (state), | ||
| 824 | + (scm_t_uint64) m)); | ||
| 825 | +#else | ||
| 826 | +#error "Cannot deal with this platform's unsigned long size" | ||
| 827 | +#endif | ||
| 828 | } | ||
| 829 | SCM_VALIDATE_NIM (1, n); | ||
| 830 | if (SCM_REALP (n)) | ||
| 831 | diff --git a/libguile/random.h b/libguile/random.h | ||
| 832 | index 6ec43ff..0690b59 100644 | ||
| 833 | --- a/libguile/random.h | ||
| 834 | +++ b/libguile/random.h | ||
| 835 | @@ -3,7 +3,7 @@ | ||
| 836 | #ifndef SCM_RANDOM_H | ||
| 837 | #define SCM_RANDOM_H | ||
| 838 | |||
| 839 | -/* Copyright (C) 1999,2000,2001, 2006 Free Software Foundation, Inc. | ||
| 840 | +/* Copyright (C) 1999,2000,2001, 2006, 2010 Free Software Foundation, Inc. | ||
| 841 | * | ||
| 842 | * This library is free software; you can redistribute it and/or | ||
| 843 | * modify it under the terms of the GNU Lesser General Public | ||
| 844 | @@ -45,6 +45,7 @@ typedef struct scm_t_rstate { | ||
| 845 | |||
| 846 | typedef struct scm_t_rng { | ||
| 847 | size_t rstate_size; /* size of random state */ | ||
| 848 | + /* Though this returns an unsigned long, it's only 32 bits of randomness. */ | ||
| 849 | unsigned long (*random_bits) (scm_t_rstate *state); /* gives 32 random bits */ | ||
| 850 | void (*init_rstate) (scm_t_rstate *state, const char *seed, int n); | ||
| 851 | scm_t_rstate *(*copy_rstate) (scm_t_rstate *state); | ||
| 852 | @@ -62,6 +63,7 @@ typedef struct scm_t_i_rstate { | ||
| 853 | unsigned long c; | ||
| 854 | } scm_t_i_rstate; | ||
| 855 | |||
| 856 | +/* Though this returns an unsigned long, it's only 32 bits of randomness. */ | ||
| 857 | SCM_API unsigned long scm_i_uniform32 (scm_t_i_rstate *); | ||
| 858 | SCM_API void scm_i_init_rstate (scm_t_i_rstate *, const char *seed, int n); | ||
| 859 | SCM_API scm_t_i_rstate *scm_i_copy_rstate (scm_t_i_rstate *); | ||
| 860 | @@ -76,7 +78,10 @@ SCM_API scm_t_rstate *scm_c_default_rstate (void); | ||
| 861 | SCM_API double scm_c_uniform01 (scm_t_rstate *); | ||
| 862 | SCM_API double scm_c_normal01 (scm_t_rstate *); | ||
| 863 | SCM_API double scm_c_exp1 (scm_t_rstate *); | ||
| 864 | +/* Though this returns an unsigned long, it's only 32 bits of randomness. */ | ||
| 865 | SCM_API unsigned long scm_c_random (scm_t_rstate *, unsigned long m); | ||
| 866 | +/* This one returns 64 bits of randomness. */ | ||
| 867 | +SCM_API scm_t_uint64 scm_c_random64 (scm_t_rstate *state, scm_t_uint64 m); | ||
| 868 | SCM_API SCM scm_c_random_bignum (scm_t_rstate *, SCM m); | ||
| 869 | |||
| 870 | |||
| 871 | diff --git a/libguile/socket.c b/libguile/socket.c | ||
| 872 | index f34b6d4..cb954f4 100644 | ||
| 873 | --- a/libguile/socket.c | ||
| 874 | +++ b/libguile/socket.c | ||
| 875 | @@ -347,7 +347,7 @@ scm_to_ipv6 (scm_t_uint8 dst[16], SCM src) | ||
| 876 | scm_remember_upto_here_1 (src); | ||
| 877 | } | ||
| 878 | else | ||
| 879 | - scm_wrong_type_arg (NULL, 0, src); | ||
| 880 | + scm_wrong_type_arg_msg ("scm_to_ipv6", 0, src, "integer"); | ||
| 881 | } | ||
| 882 | |||
| 883 | #ifdef HAVE_INET_PTON | ||
| 884 | @@ -397,8 +397,8 @@ SCM_DEFINE (scm_inet_ntop, "inet-ntop", 2, 0, 0, | ||
| 885 | "@var{family} can be @code{AF_INET} or @code{AF_INET6}. E.g.,\n\n" | ||
| 886 | "@lisp\n" | ||
| 887 | "(inet-ntop AF_INET 2130706433) @result{} \"127.0.0.1\"\n" | ||
| 888 | - "(inet-ntop AF_INET6 (- (expt 2 128) 1)) @result{}\n" | ||
| 889 | - "ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\n" | ||
| 890 | + "(inet-ntop AF_INET6 (- (expt 2 128) 1))\n" | ||
| 891 | + " @result{} \"ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff\"\n" | ||
| 892 | "@end lisp") | ||
| 893 | #define FUNC_NAME s_scm_inet_ntop | ||
| 894 | { | ||
| 895 | @@ -1167,7 +1167,8 @@ scm_to_sockaddr (SCM address, size_t *address_size) | ||
| 896 | { | ||
| 897 | struct sockaddr_in6 c_inet6; | ||
| 898 | |||
| 899 | - scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, address); | ||
| 900 | + scm_to_ipv6 (c_inet6.sin6_addr.s6_addr, | ||
| 901 | + SCM_SIMPLE_VECTOR_REF (address, 1)); | ||
| 902 | c_inet6.sin6_port = | ||
| 903 | htons (scm_to_ushort (SCM_SIMPLE_VECTOR_REF (address, 2))); | ||
| 904 | c_inet6.sin6_flowinfo = | ||
| 905 | diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c | ||
| 906 | index b0e052a..f2a9d7f 100644 | ||
| 907 | --- a/libguile/srfi-4.c | ||
| 908 | +++ b/libguile/srfi-4.c | ||
| 909 | @@ -1,6 +1,6 @@ | ||
| 910 | /* srfi-4.c --- Uniform numeric vector datatypes. | ||
| 911 | * | ||
| 912 | - * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. | ||
| 913 | + * Copyright (C) 2001, 2004, 2006, 2010 Free Software Foundation, Inc. | ||
| 914 | * | ||
| 915 | * This library is free software; you can redistribute it and/or | ||
| 916 | * modify it under the terms of the GNU Lesser General Public | ||
| 917 | @@ -84,11 +84,7 @@ static const int uvec_sizes[12] = { | ||
| 918 | 1, 1, | ||
| 919 | 2, 2, | ||
| 920 | 4, 4, | ||
| 921 | -#if SCM_HAVE_T_INT64 | ||
| 922 | 8, 8, | ||
| 923 | -#else | ||
| 924 | - sizeof (SCM), sizeof (SCM), | ||
| 925 | -#endif | ||
| 926 | sizeof(float), sizeof(double), | ||
| 927 | 2*sizeof(float), 2*sizeof(double) | ||
| 928 | }; | ||
| 929 | @@ -127,10 +123,8 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) | ||
| 930 | scm_t_int16 *s16; | ||
| 931 | scm_t_uint32 *u32; | ||
| 932 | scm_t_int32 *s32; | ||
| 933 | -#if SCM_HAVE_T_INT64 | ||
| 934 | scm_t_uint64 *u64; | ||
| 935 | scm_t_int64 *s64; | ||
| 936 | -#endif | ||
| 937 | float *f32; | ||
| 938 | double *f64; | ||
| 939 | SCM *fake_64; | ||
| 940 | @@ -148,13 +142,8 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) | ||
| 941 | case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break; | ||
| 942 | case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break; | ||
| 943 | case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break; | ||
| 944 | -#if SCM_HAVE_T_INT64 | ||
| 945 | case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break; | ||
| 946 | case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break; | ||
| 947 | -#else | ||
| 948 | - case SCM_UVEC_U64: | ||
| 949 | - case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break; | ||
| 950 | -#endif | ||
| 951 | case SCM_UVEC_F32: np.f32 = (float *) uptr; break; | ||
| 952 | case SCM_UVEC_F64: np.f64 = (double *) uptr; break; | ||
| 953 | case SCM_UVEC_C32: np.f32 = (float *) uptr; break; | ||
| 954 | @@ -179,14 +168,8 @@ uvec_print (SCM uvec, SCM port, scm_print_state *pstate) | ||
| 955 | case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break; | ||
| 956 | case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break; | ||
| 957 | case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break; | ||
| 958 | -#if SCM_HAVE_T_INT64 | ||
| 959 | case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break; | ||
| 960 | case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break; | ||
| 961 | -#else | ||
| 962 | - case SCM_UVEC_U64: | ||
| 963 | - case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate); | ||
| 964 | - np.fake_64++; break; | ||
| 965 | -#endif | ||
| 966 | case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break; | ||
| 967 | case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break; | ||
| 968 | case SCM_UVEC_C32: | ||
| 969 | @@ -222,20 +205,6 @@ uvec_equalp (SCM a, SCM b) | ||
| 970 | result = SCM_BOOL_F; | ||
| 971 | else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b)) | ||
| 972 | result = SCM_BOOL_F; | ||
| 973 | -#if SCM_HAVE_T_INT64 == 0 | ||
| 974 | - else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64 | ||
| 975 | - || SCM_UVEC_TYPE (a) == SCM_UVEC_S64) | ||
| 976 | - { | ||
| 977 | - SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b); | ||
| 978 | - size_t len = SCM_UVEC_LENGTH (a), i; | ||
| 979 | - for (i = 0; i < len; i++) | ||
| 980 | - if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++))) | ||
| 981 | - { | ||
| 982 | - result = SCM_BOOL_F; | ||
| 983 | - break; | ||
| 984 | - } | ||
| 985 | - } | ||
| 986 | -#endif | ||
| 987 | else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b), | ||
| 988 | SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0) | ||
| 989 | result = SCM_BOOL_F; | ||
| 990 | @@ -244,24 +213,6 @@ uvec_equalp (SCM a, SCM b) | ||
| 991 | return result; | ||
| 992 | } | ||
| 993 | |||
| 994 | -/* Mark hook. Only used when U64 and S64 are implemented as SCMs. */ | ||
| 995 | - | ||
| 996 | -#if SCM_HAVE_T_INT64 == 0 | ||
| 997 | -static SCM | ||
| 998 | -uvec_mark (SCM uvec) | ||
| 999 | -{ | ||
| 1000 | - if (SCM_UVEC_TYPE (uvec) == SCM_UVEC_U64 | ||
| 1001 | - || SCM_UVEC_TYPE (uvec) == SCM_UVEC_S64) | ||
| 1002 | - { | ||
| 1003 | - SCM *ptr = (SCM *)SCM_UVEC_BASE (uvec); | ||
| 1004 | - size_t len = SCM_UVEC_LENGTH (uvec), i; | ||
| 1005 | - for (i = 0; i < len; i++) | ||
| 1006 | - scm_gc_mark (*ptr++); | ||
| 1007 | - } | ||
| 1008 | - return SCM_BOOL_F; | ||
| 1009 | -} | ||
| 1010 | -#endif | ||
| 1011 | - | ||
| 1012 | /* Smob free hook for uniform numeric vectors. */ | ||
| 1013 | static size_t | ||
| 1014 | uvec_free (SCM uvec) | ||
| 1015 | @@ -318,15 +269,6 @@ alloc_uvec (int type, size_t len) | ||
| 1016 | if (len > SCM_I_SIZE_MAX / uvec_sizes[type]) | ||
| 1017 | scm_out_of_range (NULL, scm_from_size_t (len)); | ||
| 1018 | base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]); | ||
| 1019 | -#if SCM_HAVE_T_INT64 == 0 | ||
| 1020 | - if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64) | ||
| 1021 | - { | ||
| 1022 | - SCM *ptr = (SCM *)base; | ||
| 1023 | - size_t i; | ||
| 1024 | - for (i = 0; i < len; i++) | ||
| 1025 | - *ptr++ = SCM_UNSPECIFIED; | ||
| 1026 | - } | ||
| 1027 | -#endif | ||
| 1028 | return take_uvec (type, base, len); | ||
| 1029 | } | ||
| 1030 | |||
| 1031 | @@ -349,17 +291,10 @@ uvec_fast_ref (int type, const void *base, size_t c_idx) | ||
| 1032 | return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]); | ||
| 1033 | else if (type == SCM_UVEC_S32) | ||
| 1034 | return scm_from_int32 (((scm_t_int32*)base)[c_idx]); | ||
| 1035 | -#if SCM_HAVE_T_INT64 | ||
| 1036 | else if (type == SCM_UVEC_U64) | ||
| 1037 | return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]); | ||
| 1038 | else if (type == SCM_UVEC_S64) | ||
| 1039 | return scm_from_int64 (((scm_t_int64*)base)[c_idx]); | ||
| 1040 | -#else | ||
| 1041 | - else if (type == SCM_UVEC_U64) | ||
| 1042 | - return ((SCM *)base)[c_idx]; | ||
| 1043 | - else if (type == SCM_UVEC_S64) | ||
| 1044 | - return ((SCM *)base)[c_idx]; | ||
| 1045 | -#endif | ||
| 1046 | else if (type == SCM_UVEC_F32) | ||
| 1047 | return scm_from_double (((float*)base)[c_idx]); | ||
| 1048 | else if (type == SCM_UVEC_F64) | ||
| 1049 | @@ -374,22 +309,6 @@ uvec_fast_ref (int type, const void *base, size_t c_idx) | ||
| 1050 | return SCM_BOOL_F; | ||
| 1051 | } | ||
| 1052 | |||
| 1053 | -#if SCM_HAVE_T_INT64 == 0 | ||
| 1054 | -static SCM scm_uint64_min, scm_uint64_max; | ||
| 1055 | -static SCM scm_int64_min, scm_int64_max; | ||
| 1056 | - | ||
| 1057 | -static void | ||
| 1058 | -assert_exact_integer_range (SCM val, SCM min, SCM max) | ||
| 1059 | -{ | ||
| 1060 | - if (!scm_is_integer (val) | ||
| 1061 | - || scm_is_false (scm_exact_p (val))) | ||
| 1062 | - scm_wrong_type_arg_msg (NULL, 0, val, "exact integer"); | ||
| 1063 | - if (scm_is_true (scm_less_p (val, min)) | ||
| 1064 | - || scm_is_true (scm_gr_p (val, max))) | ||
| 1065 | - scm_out_of_range (NULL, val); | ||
| 1066 | -} | ||
| 1067 | -#endif | ||
| 1068 | - | ||
| 1069 | static SCM_C_INLINE_KEYWORD void | ||
| 1070 | uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) | ||
| 1071 | { | ||
| 1072 | @@ -405,23 +324,10 @@ uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val) | ||
| 1073 | (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val); | ||
| 1074 | else if (type == SCM_UVEC_S32) | ||
| 1075 | (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val); | ||
| 1076 | -#if SCM_HAVE_T_INT64 | ||
| 1077 | else if (type == SCM_UVEC_U64) | ||
| 1078 | (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val); | ||
| 1079 | else if (type == SCM_UVEC_S64) | ||
| 1080 | (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val); | ||
| 1081 | -#else | ||
| 1082 | - else if (type == SCM_UVEC_U64) | ||
| 1083 | - { | ||
| 1084 | - assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max); | ||
| 1085 | - ((SCM *)base)[c_idx] = val; | ||
| 1086 | - } | ||
| 1087 | - else if (type == SCM_UVEC_S64) | ||
| 1088 | - { | ||
| 1089 | - assert_exact_integer_range (val, scm_int64_min, scm_int64_max); | ||
| 1090 | - ((SCM *)base)[c_idx] = val; | ||
| 1091 | - } | ||
| 1092 | -#endif | ||
| 1093 | else if (type == SCM_UVEC_F32) | ||
| 1094 | (((float*)base)[c_idx]) = scm_to_double (val); | ||
| 1095 | else if (type == SCM_UVEC_F64) | ||
| 1096 | @@ -1027,16 +933,12 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, | ||
| 1097 | |||
| 1098 | #define TYPE SCM_UVEC_U64 | ||
| 1099 | #define TAG u64 | ||
| 1100 | -#if SCM_HAVE_T_UINT64 | ||
| 1101 | #define CTYPE scm_t_uint64 | ||
| 1102 | -#endif | ||
| 1103 | #include "libguile/srfi-4.i.c" | ||
| 1104 | |||
| 1105 | #define TYPE SCM_UVEC_S64 | ||
| 1106 | #define TAG s64 | ||
| 1107 | -#if SCM_HAVE_T_INT64 | ||
| 1108 | #define CTYPE scm_t_int64 | ||
| 1109 | -#endif | ||
| 1110 | #include "libguile/srfi-4.i.c" | ||
| 1111 | |||
| 1112 | #define TYPE SCM_UVEC_F32 | ||
| 1113 | @@ -1094,23 +996,9 @@ scm_init_srfi_4 (void) | ||
| 1114 | { | ||
| 1115 | scm_tc16_uvec = scm_make_smob_type ("uvec", 0); | ||
| 1116 | scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp); | ||
| 1117 | -#if SCM_HAVE_T_INT64 == 0 | ||
| 1118 | - scm_set_smob_mark (scm_tc16_uvec, uvec_mark); | ||
| 1119 | -#endif | ||
| 1120 | scm_set_smob_free (scm_tc16_uvec, uvec_free); | ||
| 1121 | scm_set_smob_print (scm_tc16_uvec, uvec_print); | ||
| 1122 | |||
| 1123 | -#if SCM_HAVE_T_INT64 == 0 | ||
| 1124 | - scm_uint64_min = | ||
| 1125 | - scm_permanent_object (scm_from_int (0)); | ||
| 1126 | - scm_uint64_max = | ||
| 1127 | - scm_permanent_object (scm_c_read_string ("18446744073709551615")); | ||
| 1128 | - scm_int64_min = | ||
| 1129 | - scm_permanent_object (scm_c_read_string ("-9223372036854775808")); | ||
| 1130 | - scm_int64_max = | ||
| 1131 | - scm_permanent_object (scm_c_read_string ("9223372036854775807")); | ||
| 1132 | -#endif | ||
| 1133 | - | ||
| 1134 | #include "libguile/srfi-4.x" | ||
| 1135 | |||
| 1136 | } | ||
| 1137 | diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h | ||
| 1138 | index 7abbac8..2348c5a 100644 | ||
| 1139 | --- a/libguile/srfi-4.h | ||
| 1140 | +++ b/libguile/srfi-4.h | ||
| 1141 | @@ -2,7 +2,7 @@ | ||
| 1142 | #define SCM_SRFI_4_H | ||
| 1143 | /* srfi-4.c --- Homogeneous numeric vector datatypes. | ||
| 1144 | * | ||
| 1145 | - * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc. | ||
| 1146 | + * Copyright (C) 2001, 2004, 2006, 2010 Free Software Foundation, Inc. | ||
| 1147 | * | ||
| 1148 | * This library is free software; you can redistribute it and/or | ||
| 1149 | * modify it under the terms of the GNU Lesser General Public | ||
| 1150 | @@ -186,7 +186,6 @@ SCM_API SCM scm_u64vector_to_list (SCM uvec); | ||
| 1151 | SCM_API SCM scm_list_to_u64vector (SCM l); | ||
| 1152 | SCM_API SCM scm_any_to_u64vector (SCM obj); | ||
| 1153 | |||
| 1154 | -#if SCM_HAVE_T_UINT64 | ||
| 1155 | SCM_API SCM scm_take_u64vector (scm_t_uint64 *data, size_t n); | ||
| 1156 | SCM_API const scm_t_uint64 *scm_array_handle_u64_elements (scm_t_array_handle *h); | ||
| 1157 | SCM_API scm_t_uint64 *scm_array_handle_u64_writable_elements (scm_t_array_handle *h); | ||
| 1158 | @@ -198,7 +197,6 @@ SCM_API scm_t_uint64 *scm_u64vector_writable_elements (SCM uvec, | ||
| 1159 | scm_t_array_handle *h, | ||
| 1160 | size_t *lenp, | ||
| 1161 | ssize_t *incp); | ||
| 1162 | -#endif | ||
| 1163 | |||
| 1164 | SCM_API SCM scm_s64vector_p (SCM obj); | ||
| 1165 | SCM_API SCM scm_make_s64vector (SCM n, SCM fill); | ||
| 1166 | @@ -210,7 +208,6 @@ SCM_API SCM scm_s64vector_to_list (SCM uvec); | ||
| 1167 | SCM_API SCM scm_list_to_s64vector (SCM l); | ||
| 1168 | SCM_API SCM scm_any_to_s64vector (SCM obj); | ||
| 1169 | |||
| 1170 | -#if SCM_HAVE_T_INT64 | ||
| 1171 | SCM_API SCM scm_take_s64vector (scm_t_int64 *data, size_t n); | ||
| 1172 | SCM_API const scm_t_int64 *scm_array_handle_s64_elements (scm_t_array_handle *h); | ||
| 1173 | SCM_API scm_t_int64 *scm_array_handle_s64_writable_elements (scm_t_array_handle *h); | ||
| 1174 | @@ -221,7 +218,6 @@ SCM_API scm_t_int64 *scm_s64vector_writable_elements (SCM uvec, | ||
| 1175 | scm_t_array_handle *h, | ||
| 1176 | size_t *lenp, | ||
| 1177 | ssize_t *incp); | ||
| 1178 | -#endif | ||
| 1179 | |||
| 1180 | SCM_API SCM scm_f32vector_p (SCM obj); | ||
| 1181 | SCM_API SCM scm_make_f32vector (SCM n, SCM fill); | ||
| 1182 | diff --git a/libguile/threads.c b/libguile/threads.c | ||
| 1183 | index 95a905c..f2bb556 100644 | ||
| 1184 | --- a/libguile/threads.c | ||
| 1185 | +++ b/libguile/threads.c | ||
| 1186 | @@ -276,7 +276,7 @@ unblock_from_queue (SCM queue) | ||
| 1187 | var 't' | ||
| 1188 | // save registers. | ||
| 1189 | SCM_FLUSH_REGISTER_WINDOWS; // sparc only | ||
| 1190 | - setjmp (t->regs); // here's most of the magic | ||
| 1191 | + SCM_I_SETJMP (t->regs); // here's most of the magic | ||
| 1192 | |||
| 1193 | ... and returns. | ||
| 1194 | |||
| 1195 | @@ -330,7 +330,7 @@ unblock_from_queue (SCM queue) | ||
| 1196 | t->top = SCM_STACK_PTR (&t); | ||
| 1197 | // save registers. | ||
| 1198 | SCM_FLUSH_REGISTER_WINDOWS; | ||
| 1199 | - setjmp (t->regs); | ||
| 1200 | + SCM_I_SETJMP (t->regs); | ||
| 1201 | res = func(data); | ||
| 1202 | scm_enter_guile (t); | ||
| 1203 | |||
| 1204 | @@ -388,7 +388,7 @@ suspend (void) | ||
| 1205 | t->top = SCM_STACK_PTR (&t); | ||
| 1206 | /* save registers. */ | ||
| 1207 | SCM_FLUSH_REGISTER_WINDOWS; | ||
| 1208 | - setjmp (t->regs); | ||
| 1209 | + SCM_I_SETJMP (t->regs); | ||
| 1210 | return t; | ||
| 1211 | } | ||
| 1212 | |||
| 1213 | diff --git a/libguile/threads.h b/libguile/threads.h | ||
| 1214 | index 2b0e067..e22d9bd 100644 | ||
| 1215 | --- a/libguile/threads.h | ||
| 1216 | +++ b/libguile/threads.h | ||
| 1217 | @@ -107,7 +107,7 @@ typedef struct scm_i_thread { | ||
| 1218 | /* For keeping track of the stack and registers. */ | ||
| 1219 | SCM_STACKITEM *base; | ||
| 1220 | SCM_STACKITEM *top; | ||
| 1221 | - jmp_buf regs; | ||
| 1222 | + scm_i_jmp_buf regs; | ||
| 1223 | #ifdef __ia64__ | ||
| 1224 | void *register_backing_store_base; | ||
| 1225 | scm_t_contregs *pending_rbs_continuation; | ||
| 1226 | diff --git a/libguile/throw.c b/libguile/throw.c | ||
| 1227 | index 92c5a1a..fcfde47 100644 | ||
| 1228 | --- a/libguile/throw.c | ||
| 1229 | +++ b/libguile/throw.c | ||
| 1230 | @@ -53,7 +53,7 @@ static scm_t_bits tc16_jmpbuffer; | ||
| 1231 | #define DEACTIVATEJB(x) \ | ||
| 1232 | (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) | ||
| 1233 | |||
| 1234 | -#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) | ||
| 1235 | +#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ)) | ||
| 1236 | #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v))) | ||
| 1237 | #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) | ||
| 1238 | #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v))) | ||
| 1239 | @@ -75,7 +75,7 @@ make_jmpbuf (void) | ||
| 1240 | { | ||
| 1241 | SCM answer; | ||
| 1242 | SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0); | ||
| 1243 | - SETJBJMPBUF(answer, (jmp_buf *)0); | ||
| 1244 | + SETJBJMPBUF(answer, (scm_i_jmp_buf *)0); | ||
| 1245 | DEACTIVATEJB(answer); | ||
| 1246 | return answer; | ||
| 1247 | } | ||
| 1248 | @@ -85,7 +85,7 @@ make_jmpbuf (void) | ||
| 1249 | |||
| 1250 | struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ | ||
| 1251 | { | ||
| 1252 | - jmp_buf buf; /* must be first */ | ||
| 1253 | + scm_i_jmp_buf buf; /* must be first */ | ||
| 1254 | SCM throw_tag; | ||
| 1255 | SCM retval; | ||
| 1256 | }; | ||
| 1257 | @@ -179,7 +179,7 @@ scm_c_catch (SCM tag, | ||
| 1258 | pre_unwind.lazy_catch_p = 0; | ||
| 1259 | SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind); | ||
| 1260 | |||
| 1261 | - if (setjmp (jbr.buf)) | ||
| 1262 | + if (SCM_I_SETJMP (jbr.buf)) | ||
| 1263 | { | ||
| 1264 | SCM throw_tag; | ||
| 1265 | SCM throw_args; | ||
| 1266 | @@ -821,7 +821,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) | ||
| 1267 | jbr->throw_tag = key; | ||
| 1268 | jbr->retval = args; | ||
| 1269 | scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf)); | ||
| 1270 | - longjmp (*JBJMPBUF (jmpbuf), 1); | ||
| 1271 | + SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1); | ||
| 1272 | } | ||
| 1273 | |||
| 1274 | /* Otherwise, it's some random piece of junk. */ | ||
| 1275 | diff --git a/libguile/vectors.c b/libguile/vectors.c | ||
| 1276 | index eeb8569..074655c 100644 | ||
| 1277 | --- a/libguile/vectors.c | ||
| 1278 | +++ b/libguile/vectors.c | ||
| 1279 | @@ -1,4 +1,4 @@ | ||
| 1280 | -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc. | ||
| 1281 | +/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2010 Free Software Foundation, Inc. | ||
| 1282 | * | ||
| 1283 | * This library is free software; you can redistribute it and/or | ||
| 1284 | * modify it under the terms of the GNU Lesser General Public | ||
| 1285 | @@ -465,7 +465,9 @@ SCM_DEFINE (scm_vector_move_left_x, "vector-move-left!", 5, 0, 0, | ||
| 1286 | |||
| 1287 | i = scm_to_unsigned_integer (start1, 0, len1); | ||
| 1288 | e = scm_to_unsigned_integer (end1, i, len1); | ||
| 1289 | - j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); | ||
| 1290 | + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2); | ||
| 1291 | + j = scm_to_unsigned_integer (start2, 0, len2); | ||
| 1292 | + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); | ||
| 1293 | |||
| 1294 | i *= inc1; | ||
| 1295 | e *= inc1; | ||
| 1296 | @@ -503,7 +505,11 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, | ||
| 1297 | |||
| 1298 | i = scm_to_unsigned_integer (start1, 0, len1); | ||
| 1299 | e = scm_to_unsigned_integer (end1, i, len1); | ||
| 1300 | - j = scm_to_unsigned_integer (start2, 0, len2 - (i-e)); | ||
| 1301 | + SCM_ASSERT_RANGE (SCM_ARG3, end1, (e-i) < len2); | ||
| 1302 | + j = scm_to_unsigned_integer (start2, 0, len2); | ||
| 1303 | + SCM_ASSERT_RANGE (SCM_ARG5, start2, j <= len2 - (e - i)); | ||
| 1304 | + | ||
| 1305 | + j += (e - i); | ||
| 1306 | |||
| 1307 | i *= inc1; | ||
| 1308 | e *= inc1; | ||
| 1309 | diff --git a/scripts/snarf-check-and-output-texi b/scripts/snarf-check-and-output-texi | ||
| 1310 | index ea33e17..8cd42e8 100755 | ||
| 1311 | --- a/scripts/snarf-check-and-output-texi | ||
| 1312 | +++ b/scripts/snarf-check-and-output-texi | ||
| 1313 | @@ -267,6 +267,17 @@ exec ${GUILE-guile} -l $0 -c "(apply $main (cdr (command-line)))" "$@" | ||
| 1314 | (set! *file* file) | ||
| 1315 | (set! *line* line)) | ||
| 1316 | |||
| 1317 | + ;; newer gccs like to throw around more location markers into the | ||
| 1318 | + ;; preprocessed source; these (hash . hash) bits are what they translate to | ||
| 1319 | + ;; in snarfy terms. | ||
| 1320 | + (('location ('string . file) ('int . line) ('hash . 'hash)) | ||
| 1321 | + (set! *file* file) | ||
| 1322 | + (set! *line* line)) | ||
| 1323 | + | ||
| 1324 | + (('location ('hash . 'hash) ('string . file) ('int . line) ('hash . 'hash)) | ||
| 1325 | + (set! *file* file) | ||
| 1326 | + (set! *line* line)) | ||
| 1327 | + | ||
| 1328 | (('arglist rest ...) | ||
| 1329 | (set! *args* (do-arglist rest))) | ||
| 1330 | |||
| 1331 | diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm | ||
| 1332 | index ffce990..482ec4e 100644 | ||
| 1333 | --- a/srfi/srfi-19.scm | ||
| 1334 | +++ b/srfi/srfi-19.scm | ||
| 1335 | @@ -1,6 +1,6 @@ | ||
| 1336 | ;;; srfi-19.scm --- Time/Date Library | ||
| 1337 | |||
| 1338 | -;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | ||
| 1339 | +;; Copyright (C) 2001, 2002, 2003, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 1340 | ;; | ||
| 1341 | ;; This library is free software; you can redistribute it and/or | ||
| 1342 | ;; modify it under the terms of the GNU Lesser General Public | ||
| 1343 | @@ -41,7 +41,8 @@ | ||
| 1344 | (define-module (srfi srfi-19) | ||
| 1345 | :use-module (srfi srfi-6) | ||
| 1346 | :use-module (srfi srfi-8) | ||
| 1347 | - :use-module (srfi srfi-9)) | ||
| 1348 | + :use-module (srfi srfi-9) | ||
| 1349 | + :autoload (ice-9 rdelim) (read-line)) | ||
| 1350 | |||
| 1351 | (begin-deprecated | ||
| 1352 | ;; Prevent `export' from re-exporting core bindings. This behaviour | ||
| 1353 | @@ -339,7 +340,7 @@ | ||
| 1354 | (set-tm:hour result (date-hour date)) | ||
| 1355 | ;; FIXME: SRFI day ranges from 0-31. (not compatible with set-tm:mday). | ||
| 1356 | (set-tm:mday result (date-day date)) | ||
| 1357 | - (set-tm:month result (- (date-month date) 1)) | ||
| 1358 | + (set-tm:mon result (- (date-month date) 1)) | ||
| 1359 | ;; FIXME: need to signal error on range violation. | ||
| 1360 | (set-tm:year result (+ 1900 (date-year date))) | ||
| 1361 | (set-tm:isdst result -1) | ||
| 1362 | @@ -528,33 +529,38 @@ | ||
| 1363 | ;; -- these depend on time-monotonic having the same definition as time-tai! | ||
| 1364 | (define (time-monotonic->time-utc time-in) | ||
| 1365 | (if (not (eq? (time-type time-in) time-monotonic)) | ||
| 1366 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1367 | + (priv:time-error 'time-monotonic->time-utc | ||
| 1368 | + 'incompatible-time-types time-in)) | ||
| 1369 | (let ((ntime (copy-time time-in))) | ||
| 1370 | (set-time-type! ntime time-tai) | ||
| 1371 | (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc))) | ||
| 1372 | |||
| 1373 | (define (time-monotonic->time-utc! time-in) | ||
| 1374 | (if (not (eq? (time-type time-in) time-monotonic)) | ||
| 1375 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1376 | + (priv:time-error 'time-monotonic->time-utc! | ||
| 1377 | + 'incompatible-time-types time-in)) | ||
| 1378 | (set-time-type! time-in time-tai) | ||
| 1379 | - (priv:time-tai->time-utc! ntime ntime 'time-monotonic->time-utc)) | ||
| 1380 | + (priv:time-tai->time-utc! time-in time-in 'time-monotonic->time-utc)) | ||
| 1381 | |||
| 1382 | (define (time-monotonic->time-tai time-in) | ||
| 1383 | (if (not (eq? (time-type time-in) time-monotonic)) | ||
| 1384 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1385 | + (priv:time-error 'time-monotonic->time-tai | ||
| 1386 | + 'incompatible-time-types time-in)) | ||
| 1387 | (let ((ntime (copy-time time-in))) | ||
| 1388 | (set-time-type! ntime time-tai) | ||
| 1389 | ntime)) | ||
| 1390 | |||
| 1391 | (define (time-monotonic->time-tai! time-in) | ||
| 1392 | (if (not (eq? (time-type time-in) time-monotonic)) | ||
| 1393 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1394 | + (priv:time-error 'time-monotonic->time-tai! | ||
| 1395 | + 'incompatible-time-types time-in)) | ||
| 1396 | (set-time-type! time-in time-tai) | ||
| 1397 | time-in) | ||
| 1398 | |||
| 1399 | (define (time-utc->time-monotonic time-in) | ||
| 1400 | (if (not (eq? (time-type time-in) time-utc)) | ||
| 1401 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1402 | + (priv:time-error 'time-utc->time-monotonic | ||
| 1403 | + 'incompatible-time-types time-in)) | ||
| 1404 | (let ((ntime (priv:time-utc->time-tai! time-in (make-time-unnormalized #f #f #f) | ||
| 1405 | 'time-utc->time-monotonic))) | ||
| 1406 | (set-time-type! ntime time-monotonic) | ||
| 1407 | @@ -562,7 +568,8 @@ | ||
| 1408 | |||
| 1409 | (define (time-utc->time-monotonic! time-in) | ||
| 1410 | (if (not (eq? (time-type time-in) time-utc)) | ||
| 1411 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1412 | + (priv:time-error 'time-utc->time-monotonic! | ||
| 1413 | + 'incompatible-time-types time-in)) | ||
| 1414 | (let ((ntime (priv:time-utc->time-tai! time-in time-in | ||
| 1415 | 'time-utc->time-monotonic!))) | ||
| 1416 | (set-time-type! ntime time-monotonic) | ||
| 1417 | @@ -570,14 +577,16 @@ | ||
| 1418 | |||
| 1419 | (define (time-tai->time-monotonic time-in) | ||
| 1420 | (if (not (eq? (time-type time-in) time-tai)) | ||
| 1421 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1422 | + (priv:time-error 'time-tai->time-monotonic | ||
| 1423 | + 'incompatible-time-types time-in)) | ||
| 1424 | (let ((ntime (copy-time time-in))) | ||
| 1425 | (set-time-type! ntime time-monotonic) | ||
| 1426 | ntime)) | ||
| 1427 | |||
| 1428 | (define (time-tai->time-monotonic! time-in) | ||
| 1429 | (if (not (eq? (time-type time-in) time-tai)) | ||
| 1430 | - (priv:time-error caller 'incompatible-time-types time-in)) | ||
| 1431 | + (priv:time-error 'time-tai->time-monotonic! | ||
| 1432 | + 'incompatible-time-types time-in)) | ||
| 1433 | (set-time-type! time-in time-monotonic) | ||
| 1434 | time-in) | ||
| 1435 | |||
| 1436 | @@ -780,7 +789,7 @@ | ||
| 1437 | (define (priv:year-day day month year) | ||
| 1438 | (let ((days-pr (assoc month priv:month-assoc))) | ||
| 1439 | (if (not days-pr) | ||
| 1440 | - (priv:error 'date-year-day 'invalid-month-specification month)) | ||
| 1441 | + (priv:time-error 'date-year-day 'invalid-month-specification month)) | ||
| 1442 | (if (and (priv:leap-year? year) (> month 2)) | ||
| 1443 | (+ day (cdr days-pr) 1) | ||
| 1444 | (+ day (cdr days-pr))))) | ||
| 1445 | @@ -1263,7 +1272,7 @@ | ||
| 1446 | ((#\8) 8) | ||
| 1447 | ((#\9) 9) | ||
| 1448 | (else (priv:time-error 'bad-date-template-string | ||
| 1449 | - (list "Non-integer character" ch i))))) | ||
| 1450 | + (list "Non-integer character" ch))))) | ||
| 1451 | |||
| 1452 | ;; read an integer upto n characters long on port; upto -> #f is any length | ||
| 1453 | (define (priv:integer-reader upto port) | ||
| 1454 | diff --git a/srfi/srfi-35.scm b/srfi/srfi-35.scm | ||
| 1455 | index 2035466..ee20a10 100644 | ||
| 1456 | --- a/srfi/srfi-35.scm | ||
| 1457 | +++ b/srfi/srfi-35.scm | ||
| 1458 | @@ -57,6 +57,19 @@ | ||
| 1459 | (number->string (object-address ct) | ||
| 1460 | 16)))))) | ||
| 1461 | |||
| 1462 | +(define (%make-condition-type layout id parent all-fields) | ||
| 1463 | + (let ((struct (make-struct %condition-type-vtable 0 | ||
| 1464 | + (make-struct-layout layout) ;; layout | ||
| 1465 | + print-condition ;; printer | ||
| 1466 | + id parent all-fields))) | ||
| 1467 | + | ||
| 1468 | + ;; Hack to associate STRUCT with a name, providing a better name for | ||
| 1469 | + ;; GOOPS classes as returned by `class-of' et al. | ||
| 1470 | + (set-struct-vtable-name! struct (cond ((symbol? id) id) | ||
| 1471 | + ((string? id) (string->symbol id)) | ||
| 1472 | + (else (string->symbol "")))) | ||
| 1473 | + struct)) | ||
| 1474 | + | ||
| 1475 | (define (condition-type? obj) | ||
| 1476 | "Return true if OBJ is a condition type." | ||
| 1477 | (and (struct? obj) | ||
| 1478 | @@ -104,10 +117,8 @@ supertypes." | ||
| 1479 | field-names parent-fields))) | ||
| 1480 | (let* ((all-fields (append parent-fields field-names)) | ||
| 1481 | (layout (struct-layout-for-condition all-fields))) | ||
| 1482 | - (make-struct %condition-type-vtable 0 | ||
| 1483 | - (make-struct-layout layout) ;; layout | ||
| 1484 | - print-condition ;; printer | ||
| 1485 | - id parent all-fields)) | ||
| 1486 | + (%make-condition-type layout | ||
| 1487 | + id parent all-fields)) | ||
| 1488 | (error "invalid condition type field names" | ||
| 1489 | field-names))) | ||
| 1490 | (error "parent is not a condition type" parent)) | ||
| 1491 | @@ -126,13 +137,10 @@ supertypes." | ||
| 1492 | (let* ((all-fields (append-map condition-type-all-fields | ||
| 1493 | parents)) | ||
| 1494 | (layout (struct-layout-for-condition all-fields))) | ||
| 1495 | - (make-struct %condition-type-vtable 0 | ||
| 1496 | - (make-struct-layout layout) ;; layout | ||
| 1497 | - print-condition ;; printer | ||
| 1498 | - id | ||
| 1499 | - parents ;; list of parents! | ||
| 1500 | - all-fields | ||
| 1501 | - all-fields))))) | ||
| 1502 | + (%make-condition-type layout | ||
| 1503 | + id | ||
| 1504 | + parents ;; list of parents! | ||
| 1505 | + all-fields))))) | ||
| 1506 | |||
| 1507 | |||
| 1508 | ;;; | ||
| 1509 | diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am | ||
| 1510 | index e7cfd82..058ce93 100644 | ||
| 1511 | --- a/test-suite/standalone/Makefile.am | ||
| 1512 | +++ b/test-suite/standalone/Makefile.am | ||
| 1513 | @@ -28,7 +28,9 @@ check_SCRIPTS = | ||
| 1514 | BUILT_SOURCES = | ||
| 1515 | EXTRA_DIST = | ||
| 1516 | |||
| 1517 | -TESTS_ENVIRONMENT = "${top_builddir}/pre-inst-guile-env" | ||
| 1518 | +TESTS_ENVIRONMENT = \ | ||
| 1519 | + builddir="$(builddir)" \ | ||
| 1520 | + "${top_builddir}/pre-inst-guile-env" | ||
| 1521 | |||
| 1522 | test_cflags = \ | ||
| 1523 | -I$(top_srcdir)/test-suite/standalone \ | ||
| 1524 | diff --git a/test-suite/standalone/test-asmobs b/test-suite/standalone/test-asmobs | ||
| 1525 | index 2ea75d9..9689ab9 100755 | ||
| 1526 | --- a/test-suite/standalone/test-asmobs | ||
| 1527 | +++ b/test-suite/standalone/test-asmobs | ||
| 1528 | @@ -2,7 +2,8 @@ | ||
| 1529 | exec guile -q -s "$0" "$@" | ||
| 1530 | !# | ||
| 1531 | |||
| 1532 | -(load-extension "libtest-asmobs" "libtest_asmobs_init") | ||
| 1533 | +(load-extension (string-append (getenv "builddir") "/libtest-asmobs") | ||
| 1534 | + "libtest_asmobs_init") | ||
| 1535 | |||
| 1536 | (define (test x v) | ||
| 1537 | (if v | ||
| 1538 | diff --git a/test-suite/standalone/test-conversion.c b/test-suite/standalone/test-conversion.c | ||
| 1539 | index 41f99d3..caa835d 100644 | ||
| 1540 | --- a/test-suite/standalone/test-conversion.c | ||
| 1541 | +++ b/test-suite/standalone/test-conversion.c | ||
| 1542 | @@ -1,4 +1,4 @@ | ||
| 1543 | -/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 1544 | +/* Copyright (C) 1999,2000,2001,2003,2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. | ||
| 1545 | * | ||
| 1546 | * This library is free software; you can redistribute it and/or | ||
| 1547 | * modify it under the terms of the GNU Lesser General Public | ||
| 1548 | @@ -702,10 +702,8 @@ DEFSTST (scm_to_int16) | ||
| 1549 | DEFUTST (scm_to_uint16) | ||
| 1550 | DEFSTST (scm_to_int32) | ||
| 1551 | DEFUTST (scm_to_uint32) | ||
| 1552 | -#ifdef SCM_HAVE_T_INT64 | ||
| 1553 | DEFSTST (scm_to_int64) | ||
| 1554 | DEFUTST (scm_to_uint64) | ||
| 1555 | -#endif | ||
| 1556 | |||
| 1557 | #define TEST_8S(v,f,r,re,te) test_8s (v, tst_##f, #f, r, re, te) | ||
| 1558 | #define TEST_8U(v,f,r,re,te) test_8u (v, tst_##f, #f, r, re, te) | ||
| 1559 | @@ -745,11 +743,9 @@ test_int_sizes () | ||
| 1560 | TEST_7S (scm_from_int32, SCM_T_INT32_MAX+1LL, "-2147483648"); | ||
| 1561 | TEST_7U (scm_from_uint32, SCM_T_UINT32_MAX, "4294967295"); | ||
| 1562 | |||
| 1563 | -#if SCM_HAVE_T_INT64 | ||
| 1564 | TEST_7S (scm_from_int64, SCM_T_INT64_MIN, "-9223372036854775808"); | ||
| 1565 | TEST_7S (scm_from_int64, SCM_T_INT64_MAX, "9223372036854775807"); | ||
| 1566 | TEST_7U (scm_from_uint64, SCM_T_UINT64_MAX, "18446744073709551615"); | ||
| 1567 | -#endif | ||
| 1568 | |||
| 1569 | TEST_8S ("91", scm_to_schar, 91, 0, 0); | ||
| 1570 | TEST_8U ("91", scm_to_uchar, 91, 0, 0); | ||
| 1571 | @@ -794,7 +790,6 @@ test_int_sizes () | ||
| 1572 | TEST_8U ("-1", scm_to_uint32, 0, 1, 0); | ||
| 1573 | TEST_8U ("#f", scm_to_uint32, 0, 0, 1); | ||
| 1574 | |||
| 1575 | -#if SCM_HAVE_T_INT64 | ||
| 1576 | TEST_8S ("-9223372036854775808", scm_to_int64, SCM_T_INT64_MIN, 0, 0); | ||
| 1577 | TEST_8S ("9223372036854775807", scm_to_int64, SCM_T_INT64_MAX, 0, 0); | ||
| 1578 | TEST_8S ("9223372036854775808", scm_to_int64, 0, 1, 0); | ||
| 1579 | @@ -803,7 +798,6 @@ test_int_sizes () | ||
| 1580 | TEST_8U ("18446744073709551616", scm_to_uint64, 0, 1, 0); | ||
| 1581 | TEST_8U ("-1", scm_to_uint64, 0, 1, 0); | ||
| 1582 | TEST_8U ("#f", scm_to_uint64, 0, 0, 1); | ||
| 1583 | -#endif | ||
| 1584 | |||
| 1585 | } | ||
| 1586 | |||
| 1587 | diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test | ||
| 1588 | index fa53fd2..fb2535a 100644 | ||
| 1589 | --- a/test-suite/tests/goops.test | ||
| 1590 | +++ b/test-suite/tests/goops.test | ||
| 1591 | @@ -140,7 +140,12 @@ | ||
| 1592 | (eq? (class-of "foo") <string>)) | ||
| 1593 | |||
| 1594 | (pass-if "port" | ||
| 1595 | - (is-a? (%make-void-port "w") <port>))) | ||
| 1596 | + (is-a? (%make-void-port "w") <port>)) | ||
| 1597 | + | ||
| 1598 | + (pass-if "struct vtable" | ||
| 1599 | + ;; Previously, `class-of' would fail for nameless structs, i.e., structs | ||
| 1600 | + ;; for which `struct-vtable-name' is #f. | ||
| 1601 | + (is-a? (class-of (make-vtable-vtable "prprpr" 0)) <class>))) | ||
| 1602 | |||
| 1603 | |||
| 1604 | (with-test-prefix "defining classes" | ||
| 1605 | diff --git a/test-suite/tests/socket.test b/test-suite/tests/socket.test | ||
| 1606 | index 4bfc415..e73f585 100644 | ||
| 1607 | --- a/test-suite/tests/socket.test | ||
| 1608 | +++ b/test-suite/tests/socket.test | ||
| 1609 | @@ -1,6 +1,6 @@ | ||
| 1610 | ;;;; socket.test --- test socket functions -*- scheme -*- | ||
| 1611 | ;;;; | ||
| 1612 | -;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. | ||
| 1613 | +;;;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc. | ||
| 1614 | ;;;; | ||
| 1615 | ;;;; This library is free software; you can redistribute it and/or | ||
| 1616 | ;;;; modify it under the terms of the GNU Lesser General Public | ||
| 1617 | @@ -174,13 +174,28 @@ | ||
| 1618 | ;;; AF_UNIX sockets and `make-socket-address' | ||
| 1619 | ;;; | ||
| 1620 | |||
| 1621 | +(define %tmpdir | ||
| 1622 | + ;; Honor `$TMPDIR', which tmpnam(3) doesn't do. | ||
| 1623 | + (or (getenv "TMPDIR") "/tmp")) | ||
| 1624 | + | ||
| 1625 | +(define %curdir | ||
| 1626 | + ;; Remember the current working directory. | ||
| 1627 | + (getcwd)) | ||
| 1628 | + | ||
| 1629 | +;; Temporarily cd to %TMPDIR. The goal is to work around path name | ||
| 1630 | +;; limitations, which can lead to exceptions like: | ||
| 1631 | +;; | ||
| 1632 | +;; (misc-error "scm_to_sockaddr" | ||
| 1633 | +;; "unix address path too long: ~A" | ||
| 1634 | +;; ("/tmp/nix-build-fb7bph4ifh0vr3ihigm702dzffdnapfj-guile-coverage-1.9.5.drv-0/guile-test-socket-1258553296-77619") | ||
| 1635 | +;; #f) | ||
| 1636 | +(chdir %tmpdir) | ||
| 1637 | + | ||
| 1638 | (define (temp-file-path) | ||
| 1639 | - ;; Return a temporary file path that honors `$TMPDIR', which `tmpnam' | ||
| 1640 | - ;; doesn't do. | ||
| 1641 | - (let ((dir (or (getenv "TMPDIR") "/tmp"))) | ||
| 1642 | - (string-append dir "/guile-test-socket-" | ||
| 1643 | - (number->string (current-time)) "-" | ||
| 1644 | - (number->string (random 100000))))) | ||
| 1645 | + ;; Return a temporary file name, assuming the current directory is %TMPDIR. | ||
| 1646 | + (string-append "guile-test-socket-" | ||
| 1647 | + (number->string (current-time)) "-" | ||
| 1648 | + (number->string (random 100000)))) | ||
| 1649 | |||
| 1650 | |||
| 1651 | (if (defined? 'AF_UNIX) | ||
| 1652 | @@ -320,3 +335,91 @@ | ||
| 1653 | |||
| 1654 | #t))) | ||
| 1655 | |||
| 1656 | + | ||
| 1657 | +(if (defined? 'AF_INET6) | ||
| 1658 | + (with-test-prefix "AF_INET6/SOCK_STREAM" | ||
| 1659 | + | ||
| 1660 | + ;; testing `bind', `listen' and `connect' on stream-oriented sockets | ||
| 1661 | + | ||
| 1662 | + (let ((server-socket (socket AF_INET6 SOCK_STREAM 0)) | ||
| 1663 | + (server-bound? #f) | ||
| 1664 | + (server-listening? #f) | ||
| 1665 | + (server-pid #f) | ||
| 1666 | + (ipv6-addr 1) ; ::1 | ||
| 1667 | + (server-port 8889) | ||
| 1668 | + (client-port 9998)) | ||
| 1669 | + | ||
| 1670 | + (pass-if "bind" | ||
| 1671 | + (catch 'system-error | ||
| 1672 | + (lambda () | ||
| 1673 | + (bind server-socket AF_INET6 ipv6-addr server-port) | ||
| 1674 | + (set! server-bound? #t) | ||
| 1675 | + #t) | ||
| 1676 | + (lambda args | ||
| 1677 | + (let ((errno (system-error-errno args))) | ||
| 1678 | + (cond ((= errno EADDRINUSE) (throw 'unresolved)) | ||
| 1679 | + (else (apply throw args))))))) | ||
| 1680 | + | ||
| 1681 | + (pass-if "bind/sockaddr" | ||
| 1682 | + (let* ((sock (socket AF_INET6 SOCK_STREAM 0)) | ||
| 1683 | + (sockaddr (make-socket-address AF_INET6 ipv6-addr client-port))) | ||
| 1684 | + (catch 'system-error | ||
| 1685 | + (lambda () | ||
| 1686 | + (bind sock sockaddr) | ||
| 1687 | + #t) | ||
| 1688 | + (lambda args | ||
| 1689 | + (let ((errno (system-error-errno args))) | ||
| 1690 | + (cond ((= errno EADDRINUSE) (throw 'unresolved)) | ||
| 1691 | + (else (apply throw args)))))))) | ||
| 1692 | + | ||
| 1693 | + (pass-if "listen" | ||
| 1694 | + (if (not server-bound?) | ||
| 1695 | + (throw 'unresolved) | ||
| 1696 | + (begin | ||
| 1697 | + (listen server-socket 123) | ||
| 1698 | + (set! server-listening? #t) | ||
| 1699 | + #t))) | ||
| 1700 | + | ||
| 1701 | + (if server-listening? | ||
| 1702 | + (let ((pid (primitive-fork))) | ||
| 1703 | + ;; Spawn a server process. | ||
| 1704 | + (case pid | ||
| 1705 | + ((-1) (throw 'unresolved)) | ||
| 1706 | + ((0) ;; the kid: serve two connections and exit | ||
| 1707 | + (let serve ((conn | ||
| 1708 | + (false-if-exception (accept server-socket))) | ||
| 1709 | + (count 1)) | ||
| 1710 | + (if (not conn) | ||
| 1711 | + (exit 1) | ||
| 1712 | + (if (> count 0) | ||
| 1713 | + (serve (false-if-exception (accept server-socket)) | ||
| 1714 | + (- count 1))))) | ||
| 1715 | + (exit 0)) | ||
| 1716 | + (else ;; the parent | ||
| 1717 | + (set! server-pid pid) | ||
| 1718 | + #t)))) | ||
| 1719 | + | ||
| 1720 | + (pass-if "connect" | ||
| 1721 | + (if (not server-pid) | ||
| 1722 | + (throw 'unresolved) | ||
| 1723 | + (let ((s (socket AF_INET6 SOCK_STREAM 0))) | ||
| 1724 | + (connect s AF_INET6 ipv6-addr server-port) | ||
| 1725 | + #t))) | ||
| 1726 | + | ||
| 1727 | + (pass-if "connect/sockaddr" | ||
| 1728 | + (if (not server-pid) | ||
| 1729 | + (throw 'unresolved) | ||
| 1730 | + (let ((s (socket AF_INET6 SOCK_STREAM 0))) | ||
| 1731 | + (connect s (make-socket-address AF_INET6 ipv6-addr server-port)) | ||
| 1732 | + #t))) | ||
| 1733 | + | ||
| 1734 | + (pass-if "accept" | ||
| 1735 | + (if (not server-pid) | ||
| 1736 | + (throw 'unresolved) | ||
| 1737 | + (let ((status (cdr (waitpid server-pid)))) | ||
| 1738 | + (eq? 0 (status:exit-val status))))) | ||
| 1739 | + | ||
| 1740 | + #t))) | ||
| 1741 | + | ||
| 1742 | +;; Switch back to the previous directory. | ||
| 1743 | +(false-if-exception (chdir %curdir)) | ||
diff --git a/meta-oe/recipes-support/guile/guile-1.8.7/configure-fix.patch b/meta-oe/recipes-support/guile/guile-1.8.7/configure-fix.patch deleted file mode 100644 index c59798d9e9..0000000000 --- a/meta-oe/recipes-support/guile/guile-1.8.7/configure-fix.patch +++ /dev/null | |||
| @@ -1,10 +0,0 @@ | |||
| 1 | --- /tmp/configure.in 2008-06-04 12:33:55.451086283 +0200 | ||
| 2 | +++ guile-1.8.5/configure.in 2008-06-04 12:34:03.974994278 +0200 | ||
| 3 | @@ -38,7 +38,6 @@ | ||
| 4 | ]), | ||
| 5 | [bug-guile@gnu.org]) | ||
| 6 | AC_CONFIG_AUX_DIR([build-aux]) | ||
| 7 | -AC_CONFIG_MACRO_DIR([m4]) | ||
| 8 | AC_CONFIG_SRCDIR(GUILE-VERSION) | ||
| 9 | |||
| 10 | AM_INIT_AUTOMAKE([gnu no-define check-news]) | ||
diff --git a/meta-oe/recipes-support/guile/guile-native-1.8.7/cpp-linemarkers.patch b/meta-oe/recipes-support/guile/guile-native-1.8.7/cpp-linemarkers.patch deleted file mode 100644 index 3e48932a3c..0000000000 --- a/meta-oe/recipes-support/guile/guile-native-1.8.7/cpp-linemarkers.patch +++ /dev/null | |||
| @@ -1,8 +0,0 @@ | |||
| 1 | --- guile.orig/libguile/guile-snarf-docs.in 2009-07-03 18:19:00.000000000 -0400 | ||
| 2 | +++ guile/libguile/guile-snarf-docs.in 2009-11-19 12:55:32.487266268 -0500 | ||
| 3 | @@ -23,4 +23,4 @@ | ||
| 4 | ## Let the user override the preprocessor autoconf found. | ||
| 5 | test -n "${CPP+set}" || CPP="@CPP@" | ||
| 6 | |||
| 7 | -${CPP} -DSCM_MAGIC_SNARF_DOCS "$@" | ||
| 8 | +${CPP} -P -DSCM_MAGIC_SNARF_DOCS "$@" | ||
diff --git a/meta-oe/recipes-support/guile/guile-native-1.8.7/reloc.patch b/meta-oe/recipes-support/guile/guile-native-1.8.7/reloc.patch deleted file mode 100644 index c061743ab7..0000000000 --- a/meta-oe/recipes-support/guile/guile-native-1.8.7/reloc.patch +++ /dev/null | |||
| @@ -1,22 +0,0 @@ | |||
| 1 | --- guile-1.8.7.orig/guile-tools.in | ||
| 2 | +++ guile-1.8.7/guile-tools.in | ||
| 3 | @@ -42,14 +42,15 @@ Default scripts dir: $default_scriptsdir | ||
| 4 | EOF | ||
| 5 | } | ||
| 6 | |||
| 7 | -prefix="@prefix@" | ||
| 8 | -datarootdir="@datarootdir@" | ||
| 9 | -pkgdatadir="@datadir@/@PACKAGE@" | ||
| 10 | +bindir=`dirname $0` | ||
| 11 | +bindir=`cd $bindir && pwd` | ||
| 12 | +prefix=`dirname $bindir` | ||
| 13 | +datarootdir=${prefix}/share | ||
| 14 | +pkgdatadir=${prefix}/share/guile | ||
| 15 | guileversion="@GUILE_EFFECTIVE_VERSION@" | ||
| 16 | default_scriptsdir=$pkgdatadir/$guileversion/scripts | ||
| 17 | |||
| 18 | # pre-install invocation frob | ||
| 19 | -mydir=`dirname $0` | ||
| 20 | if [ -d "$mydir/scripts" -a -f "$mydir/scripts/Makefile.am" ] ; then | ||
| 21 | default_scriptsdir=`(cd $mydir/scripts ; pwd)` | ||
| 22 | fi | ||
diff --git a/meta-oe/recipes-support/guile/guile-native.inc b/meta-oe/recipes-support/guile/guile-native.inc deleted file mode 100644 index dfa126af04..0000000000 --- a/meta-oe/recipes-support/guile/guile-native.inc +++ /dev/null | |||
| @@ -1,13 +0,0 @@ | |||
| 1 | SECTION = "unknown" | ||
| 2 | DEPENDS = "gettext-native gmp-native" | ||
| 3 | |||
| 4 | LICENSE = "LGPLv2.1" | ||
| 5 | |||
| 6 | inherit autotools native | ||
| 7 | |||
| 8 | S="${WORKDIR}/guile-${PV}" | ||
| 9 | |||
| 10 | do_configure_append() { | ||
| 11 | find ${S} -name Makefile | xargs sed -i s:'-Werror':'':g | ||
| 12 | } | ||
| 13 | |||
diff --git a/meta-oe/recipes-support/guile/guile-native_1.8.7.bb b/meta-oe/recipes-support/guile/guile-native_1.8.7.bb deleted file mode 100644 index 2b2707abe3..0000000000 --- a/meta-oe/recipes-support/guile/guile-native_1.8.7.bb +++ /dev/null | |||
| @@ -1,13 +0,0 @@ | |||
| 1 | require guile-native.inc | ||
| 2 | |||
| 3 | LIC_FILES_CHKSUM = "file://LICENSE;md5=c9ba0d76ca3ef2a1d15a2ac839ef01fa" | ||
| 4 | |||
| 5 | PR = "r1" | ||
| 6 | SRC_URI = "http://ftp.gnu.org/pub/gnu/guile/guile-${PV}.tar.gz \ | ||
| 7 | file://configure-fix.patch \ | ||
| 8 | file://cpp-linemarkers.patch \ | ||
| 9 | file://reloc.patch \ | ||
| 10 | " | ||
| 11 | |||
| 12 | SRC_URI[md5sum] = "991b5b3efcbbc3f7507d05bc42f80a5e" | ||
| 13 | SRC_URI[sha256sum] = "bfee6339d91955a637e7f541d96f5b1d53271b42bb4a37b8867d186a6c66f0b3" | ||
diff --git a/meta-oe/recipes-support/guile/guile.inc b/meta-oe/recipes-support/guile/guile.inc deleted file mode 100644 index 842e8d7ebf..0000000000 --- a/meta-oe/recipes-support/guile/guile.inc +++ /dev/null | |||
| @@ -1,47 +0,0 @@ | |||
| 1 | DESCRIPTION = "Guile is an interpreter for the Scheme programming language, \ | ||
| 2 | packaged as a library which can be incorporated into your programs." | ||
| 3 | HOMEPAGE = "http://www.gnu.org/software/guile/guile.html" | ||
| 4 | SECTION = "devel/scheme" | ||
| 5 | DEPENDS = "guile-native gmp libtool" | ||
| 6 | PACKAGES =+ "${PN}-el" | ||
| 7 | FILES_${PN}-el = "${datadir}/emacs" | ||
| 8 | DESCRIPTION_${PN}-el = "Emacs lisp files for Guile" | ||
| 9 | |||
| 10 | LICENSE = "LGPLv2.1+" | ||
| 11 | |||
| 12 | inherit autotools gettext | ||
| 13 | |||
| 14 | acpaths = "-I ${S}/guile-config" | ||
| 15 | |||
| 16 | EXTRA_OECONF = " \ | ||
| 17 | --without-threads \ | ||
| 18 | --without-included-ltdl \ | ||
| 19 | " | ||
| 20 | |||
| 21 | do_compile() { | ||
| 22 | for i in $(find ${S} -name "Makefile") ; do | ||
| 23 | sed -i -e s:-Werror::g $i | ||
| 24 | done | ||
| 25 | |||
| 26 | (cd libguile; oe_runmake CC="${BUILD_CC}" CFLAGS="${BUILD_CFLAGS}" LDFLAGS="${BUILD_LDFLAGS}" guile_filter_doc_snarfage) | ||
| 27 | oe_runmake preinstguile="`which guile`" | ||
| 28 | |||
| 29 | sed -i -e s:${STAGING_DIR_TARGET}::g \ | ||
| 30 | -e s:/${TARGET_SYS}::g \ | ||
| 31 | -e s:-L/usr/lib::g \ | ||
| 32 | -e s:-isystem/usr/include::g \ | ||
| 33 | -e s:,/usr/lib:,\$\{libdir\}:g \ | ||
| 34 | guile-1.8.pc | ||
| 35 | } | ||
| 36 | |||
| 37 | SYSROOT_PREPROCESS_FUNCS = "guile_cross_config" | ||
| 38 | |||
| 39 | guile_cross_config() { | ||
| 40 | # Create guile-config returning target values instead of native values | ||
| 41 | install -d ${SYSROOT_DESTDIR}${STAGING_BINDIR_CROSS} | ||
| 42 | echo '#!'`which guile`$' \\\n-e main -s\n!#\n(define %guile-build-info '\'\( >guile-config.cross | ||
| 43 | sed -n $'s:-isystem[^ ]* ::;s:-Wl,-rpath-link,[^ ]* ::;s:^[ \t]*{[ \t]*": (:;s:",[ \t]*": . ":;s:" *}, *\\\\:"):;/^ (/p' <libguile/libpath.h >>guile-config.cross | ||
| 44 | echo '))' >>guile-config.cross | ||
| 45 | cat guile-config/guile-config >>guile-config.cross | ||
| 46 | install guile-config.cross ${SYSROOT_DESTDIR}${STAGING_BINDIR_CROSS}/guile-config | ||
| 47 | } | ||
diff --git a/meta-oe/recipes-support/guile/guile_1.8.7.bb b/meta-oe/recipes-support/guile/guile_1.8.7.bb deleted file mode 100644 index d02fe42e57..0000000000 --- a/meta-oe/recipes-support/guile/guile_1.8.7.bb +++ /dev/null | |||
| @@ -1,14 +0,0 @@ | |||
| 1 | require guile.inc | ||
| 2 | |||
| 3 | LIC_FILES_CHKSUM = "file://LICENSE;md5=5711ae313ffd140741e741b88d9d4007" | ||
| 4 | |||
| 5 | PR = "r1" | ||
| 6 | |||
| 7 | SRC_URI = "http://ftp.gnu.org/pub/gnu/guile/guile-${PV}.tar.gz \ | ||
| 8 | file://configure-fix.patch \ | ||
| 9 | file://18.diff \ | ||
| 10 | " | ||
| 11 | |||
| 12 | |||
| 13 | SRC_URI[md5sum] = "991b5b3efcbbc3f7507d05bc42f80a5e" | ||
| 14 | SRC_URI[sha256sum] = "bfee6339d91955a637e7f541d96f5b1d53271b42bb4a37b8867d186a6c66f0b3" | ||
