From 6934d9e75fde9c880b39faa19237b041495c8531 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 30 Jun 2011 16:07:17 +0200 Subject: [PATCH 01/37] fix generation of auto-compiled file names on mingw systems * libguile/load.c (canonical_to_suffix, scm_primitive_load_path): * module/ice-9/boot-9.scm (load-in-vicinity): * module/system/base/compile.scm (compiled-file-name): If the canonical path of a file is a DOS-style path with a drive letter, turn it into a path suffix it by removing the colon and prefixing a "/". Inspired by a patch from Jan Nieuwenhuizen. --- libguile/load.c | 20 ++++++++++++++++++-- module/ice-9/boot-9.scm | 14 ++++++++++++-- module/system/base/compile.scm | 14 +++++++++++--- 3 files changed, 41 insertions(+), 7 deletions(-) diff --git a/libguile/load.c b/libguile/load.c index 3b6ba2b38..91309bb1e 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -793,6 +793,22 @@ scm_try_auto_compile (SCM source) NULL, NULL); } +/* See also (system base compile):compiled-file-name. */ +static SCM +canonical_to_suffix (SCM canon) +{ + size_t len = scm_c_string_length (canon); + + if (len > 1 && scm_is_eq (scm_c_string_ref (canon, 0), SCM_MAKE_CHAR ('/'))) + return canon; + else if (len > 2 && scm_is_eq (scm_c_string_ref (canon, 1), SCM_MAKE_CHAR (':'))) + return scm_string_append (scm_list_3 (scm_from_latin1_string ("/"), + scm_c_substring (canon, 0, 1), + scm_c_substring (canon, 2, len))); + else + return canon; +} + SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, (SCM args), "Search @var{%load-path} for the file named @var{filename} and\n" @@ -857,7 +873,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, { SCM fallback = scm_string_append (scm_list_3 (*scm_loc_compile_fallback_path, - full_filename, + canonical_to_suffix (full_filename), scm_car (*scm_loc_load_compiled_extensions))); if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))) { @@ -895,7 +911,7 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 0, 0, 1, { SCM fallback = scm_string_append (scm_list_3 (*scm_loc_compile_fallback_path, - full_filename, + canonical_to_suffix (full_filename), scm_car (*scm_loc_load_compiled_extensions))); if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)) && compiled_is_fresh (full_filename, fallback)) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 24f63f592..1ddb0ff07 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3450,6 +3450,15 @@ module '(ice-9 q) '(make-q q-length))}." '(#:warnings (unbound-variable arity-mismatch format))) (define* (load-in-vicinity dir path #:optional reader) + (define (canonical->suffix canon) + (cond + ((string-prefix? "/" canon) canon) + ((and (> (string-length canon) 2) + (eqv? (string-ref canon 1) #\:)) + ;; Paths like C:... transform to /C... + (string-append "/" (substring canon 0 1) (substring canon 2))) + (else canon))) + ;; Returns the .go file corresponding to `name'. Does not search load ;; paths, only the fallback path. If the .go file is missing or out of ;; date, and auto-compilation is enabled, will try auto-compilation, just @@ -3461,11 +3470,12 @@ module '(ice-9 q) '(make-q q-length))}." ;; partially duplicates functionality from (system base compile). ;; (define (compiled-file-name canon-path) + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. (and %compile-fallback-path (string-append %compile-fallback-path - ;; no need for '/' separator here, canon-path is absolute - canon-path + (canonical->suffix canon-path) (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) (warn "invalid %load-compiled-extensions" diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 1b6e73f32..943999040 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -103,6 +103,16 @@ ;;; ;;; See also boot-9.scm:load. (define (compiled-file-name file) + ;; FIXME: would probably be better just to append SHA1(canon-path) + ;; to the %compile-fallback-path, to avoid deep directory stats. + (define (canonical->suffix canon) + (cond + ((string-prefix? "/" canon) canon) + ((and (> (string-length canon) 2) + (eqv? (string-ref canon 1) #\:)) + ;; Paths like C:... transform to /C... + (string-append "/" (substring canon 0 1) (substring canon 2))) + (else canon))) (define (compiled-extension) (cond ((or (null? %load-compiled-extensions) (string-null? (car %load-compiled-extensions))) @@ -113,9 +123,7 @@ (and %compile-fallback-path (let ((f (string-append %compile-fallback-path - ;; no need for '/' separator here, canonicalize-path - ;; will give us an absolute path - (canonicalize-path file) + (canonical->suffix (canonicalize-path file)) (compiled-extension)))) (and (false-if-exception (ensure-writable-dir (dirname f))) f)))) From ea5c9ddcebe1d798fccfe9bbb1f4504e77fa2908 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 30 Jun 2011 16:36:03 +0200 Subject: [PATCH 02/37] Add `guile-invoke.texi' to the distribution. * doc/ref/Makefile.am (guile_TEXINFOS): Add `guile-invoke.texi'. --- doc/ref/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index 4def24610..423a9dfe7 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -90,6 +90,7 @@ guile_TEXINFOS = preface.texi \ mod-getopt-long.texi \ goops.texi \ goops-tutorial.texi \ + guile-invoke.texi \ effective-version.texi ETAGS_ARGS = $(info_TEXINFOS) $(guile_TEXINFOS) From b8441577f9954053a90981a5c134aa43f341f712 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 30 Jun 2011 22:58:07 +0200 Subject: [PATCH 03/37] Fix `on_thread_exit' for canceled threads. * libguile/threads.c (on_thread_exit): Clear `t->guile_mode' upon entry. This fixes a bug whereby `t->base' would be incorrect for canceled threads, leading to a misdiagnosed VM stack overflow. See for details. (scm_leave_guile_cleanup): Remove because it's unused. --- libguile/threads.c | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index c07c85342..0c6b8b40b 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -696,6 +696,10 @@ on_thread_exit (void *v) /* This handler is executed in non-guile mode. */ scm_i_thread *t = (scm_i_thread *) v, **tp; + /* If we were canceled, we were unable to clear `t->guile_mode', so do + it here. */ + t->guile_mode = 0; + /* If this thread was cancelled while doing a cond wait, it will still have a mutex locked, so we unlock it here. */ if (t->held_mutex) @@ -835,12 +839,6 @@ scm_init_guile () } } -SCM_UNUSED static void -scm_leave_guile_cleanup (void *x) -{ - on_thread_exit (SCM_I_CURRENT_THREAD); -} - struct with_guile_args { GC_fn_type func; From 1f7945a768a8df06ad208ed2846dfe4f92e1515a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 1 Jul 2011 12:20:52 +0200 Subject: [PATCH 04/37] fix '(a #{.} b) * libguile/read.c (scm_read_sexp): Don't confuse `#{.}#' with `.' for the purpose of reading dotted pairs. Thanks to CRLF0710 for the report. * test-suite/tests/reader.test ("#{}#"): Add test. --- libguile/read.c | 11 ++++++++--- test-suite/tests/reader.test | 1 + 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 4d22ead8a..ee50fb4a3 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -376,8 +376,12 @@ scm_read_sexp (scm_t_wchar chr, SCM port) return SCM_EOL; scm_ungetc (c, port); - if (scm_is_eq (scm_sym_dot, - (tmp = scm_read_expression (port)))) + tmp = scm_read_expression (port); + + /* Note that it is possible for scm_read_expression to return + scm_sym_dot, but not as part of a dotted pair: as in #{.}#. So + check that it's a real dot by checking `c'. */ + if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { ans = scm_read_expression (port); if (terminating_char != (c = flush_ws (port, FUNC_NAME))) @@ -401,7 +405,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port) scm_ungetc (c, port); tmp = scm_read_expression (port); - if (scm_is_eq (scm_sym_dot, tmp)) + /* See above note about scm_sym_dot. */ + if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { SCM_SETCDR (tl, tmp = scm_read_expression (port)); diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index f350e73a6..437706b00 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -428,6 +428,7 @@ (with-test-prefix "#{}#" (pass-if (equal? (read-string "#{}#") '#{}#)) + (pass-if (not (equal? (read-string "(a #{.}# b)") '(a . b)))) (pass-if (equal? (read-string "#{a}#") 'a)) (pass-if (equal? (read-string "#{a b}#") '#{a b}#)) (pass-if-exception "#{" exception:eof-in-symbol From e780c14fd0fd2572eaebc2949f6a67fc773c2835 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 15:29:51 +0200 Subject: [PATCH 05/37] i18n: Don't use `!=' to compare SCMs. * libguile/i18n.c (install_locale)[!USE_GNU_LOCALE_API]: Use `SCM_UNBNDP' instead of `!='. --- libguile/i18n.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/i18n.c b/libguile/i18n.c index b22b33222..f9ec723a0 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -400,7 +400,7 @@ install_locale (scm_t_locale locale) account. */ category_mask |= locale->category_mask; - if (locale->base_locale != SCM_UNDEFINED) + if (!SCM_UNBNDP (locale->base_locale)) locale = (scm_t_locale) SCM_SMOB_DATA (locale->base_locale); else locale = NULL; From 1e8f93922922b09c7003a357d86777b2a79e9735 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 16:21:21 +0200 Subject: [PATCH 06/37] Fix unaligned accesses for bytevectors of complex numbers. * libguile/bytevectors.c (bytevector_ref_c32, bytevector_ref_c64, bytevector_set_c32, bytevector_set_c64): Use `memcpy' to avoid unaligned accesses. This fixes SIGBUS on SPARC and possibly other alignment-sensitive platforms. --- libguile/bytevectors.c | 44 ++++++++++++++++++++++++++++++++---------- 1 file changed, 34 insertions(+), 10 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index 5a83967c3..b8af53ad3 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -2096,17 +2096,27 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", static SCM bytevector_ref_c32 (SCM bv, SCM idx) { /* FIXME add some checks */ - const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv); + float real, imag; + const char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); size_t i = scm_to_size_t (idx); - return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]); + + memcpy (&real, &contents[i], sizeof (float)); + memcpy (&imag, &contents[i + sizeof (float)], sizeof (float)); + + return scm_c_make_rectangular (real, imag); } static SCM bytevector_ref_c64 (SCM bv, SCM idx) { /* FIXME add some checks */ - const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv); + double real, imag; + const char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); size_t i = scm_to_size_t (idx); - return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]); + + memcpy (&real, &contents[i], sizeof (double)); + memcpy (&imag, &contents[i + sizeof (double)], sizeof (double)); + + return scm_c_make_rectangular (real, imag); } typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); @@ -2146,19 +2156,33 @@ bv_handle_ref (scm_t_array_handle *h, size_t index) /* FIXME add checks!!! */ static SCM bytevector_set_c32 (SCM bv, SCM idx, SCM val) -{ float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv); +{ + float imag, real; + char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); size_t i = scm_to_size_t (idx); - contents[i/4] = scm_c_real_part (val); - contents[i/4 + 1] = scm_c_imag_part (val); + + real = scm_c_real_part (val); + imag = scm_c_imag_part (val); + + memcpy (&contents[i], &real, sizeof (float)); + memcpy (&contents[i + sizeof (float)], &imag, sizeof (float)); + return SCM_UNSPECIFIED; } static SCM bytevector_set_c64 (SCM bv, SCM idx, SCM val) -{ double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv); +{ + double imag, real; + char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); size_t i = scm_to_size_t (idx); - contents[i/8] = scm_c_real_part (val); - contents[i/8 + 1] = scm_c_imag_part (val); + + real = scm_c_real_part (val); + imag = scm_c_imag_part (val); + + memcpy (&contents[i], &real, sizeof (double)); + memcpy (&contents[i + sizeof (double)], &imag, sizeof (double)); + return SCM_UNSPECIFIED; } From 4bc95fccad7288004515ce78d50611499cbca2db Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 19:09:29 +0200 Subject: [PATCH 07/37] Add type and range checks to the complex generalized vector accessors. * libguile/bytevectors.c (COMPLEX_ACCESSOR_PROLOGUE, COMPLEX_NATIVE_REF, COMPLEX_NATIVE_SET): New macros. (bytevector_ref_c32, bytevector_ref_c64): Defined in terms of `COMPLEX_NATIVE_REF'. (bytevector_set_c32, bytevector_set_c64): Defined in terms of `COMPLEX_NATIVE_SET'. (bytevector_ref_fns): Make `static'. * test-suite/tests/srfi-4.test ("c32 vectors")["generalized-vector-ref", "generalized-vector-set!", "generalized-vector-ref, out-of-range", "generalized-vector-set!, out-of-range"]: New tests. ("c64 vectors")["generalized-vector-ref", "generalized-vector-set!", "generalized-vector-ref, out-of-range", "generalized-vector-set!, out-of-range"]: New tests. --- libguile/bytevectors.c | 114 ++++++++++++++++++++--------------- test-suite/tests/srfi-4.test | 41 ++++++++++++- 2 files changed, 105 insertions(+), 50 deletions(-) diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c index b8af53ad3..7ac1fa34e 100644 --- a/libguile/bytevectors.c +++ b/libguile/bytevectors.c @@ -2092,36 +2092,56 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string", /* Bytevectors as generalized vectors & arrays. */ +#define COMPLEX_ACCESSOR_PROLOGUE(_type) \ + size_t c_len, c_index; \ + char *c_bv; \ + \ + SCM_VALIDATE_BYTEVECTOR (1, bv); \ + c_index = scm_to_size_t (index); \ + \ + c_len = SCM_BYTEVECTOR_LENGTH (bv); \ + c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \ + \ + if (SCM_UNLIKELY (c_index + 2 * sizeof (_type) - 1 >= c_len)) \ + scm_out_of_range (FUNC_NAME, index); + +/* Template for native access to complex numbers of type TYPE. */ +#define COMPLEX_NATIVE_REF(_type) \ + SCM result; \ + \ + COMPLEX_ACCESSOR_PROLOGUE (_type); \ + \ + { \ + _type real, imag; \ + \ + memcpy (&real, &c_bv[c_index], sizeof (_type)); \ + memcpy (&imag, &c_bv[c_index + sizeof (_type)], sizeof (_type)); \ + \ + result = scm_c_make_rectangular (real, imag); \ + } \ + \ + return result; static SCM -bytevector_ref_c32 (SCM bv, SCM idx) -{ /* FIXME add some checks */ - float real, imag; - const char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - - memcpy (&real, &contents[i], sizeof (float)); - memcpy (&imag, &contents[i + sizeof (float)], sizeof (float)); - - return scm_c_make_rectangular (real, imag); +bytevector_ref_c32 (SCM bv, SCM index) +#define FUNC_NAME "bytevector_ref_c32" +{ + COMPLEX_NATIVE_REF (float); } +#undef FUNC_NAME static SCM -bytevector_ref_c64 (SCM bv, SCM idx) -{ /* FIXME add some checks */ - double real, imag; - const char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - - memcpy (&real, &contents[i], sizeof (double)); - memcpy (&imag, &contents[i + sizeof (double)], sizeof (double)); - - return scm_c_make_rectangular (real, imag); +bytevector_ref_c64 (SCM bv, SCM index) +#define FUNC_NAME "bytevector_ref_c64" +{ + COMPLEX_NATIVE_REF (double); } +#undef FUNC_NAME typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); -const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = +static const scm_t_bytevector_ref_fn +bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = { NULL, /* SCM */ NULL, /* CHAR */ @@ -2153,38 +2173,36 @@ bv_handle_ref (scm_t_array_handle *h, size_t index) return ref_fn (h->array, byte_index); } -/* FIXME add checks!!! */ -static SCM -bytevector_set_c32 (SCM bv, SCM idx, SCM val) -{ - float imag, real; - char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - - real = scm_c_real_part (val); - imag = scm_c_imag_part (val); - - memcpy (&contents[i], &real, sizeof (float)); - memcpy (&contents[i + sizeof (float)], &imag, sizeof (float)); - +/* Template for native modification of complex numbers of type TYPE. */ +#define COMPLEX_NATIVE_SET(_type) \ + COMPLEX_ACCESSOR_PROLOGUE (_type); \ + \ + { \ + _type real, imag; \ + real = scm_c_real_part (value); \ + imag = scm_c_imag_part (value); \ + \ + memcpy (&c_bv[c_index], &real, sizeof (_type)); \ + memcpy (&c_bv[c_index + sizeof (_type)], &imag, sizeof (_type)); \ + } \ + \ return SCM_UNSPECIFIED; -} static SCM -bytevector_set_c64 (SCM bv, SCM idx, SCM val) +bytevector_set_c32 (SCM bv, SCM index, SCM value) +#define FUNC_NAME "bytevector_set_c32" { - double imag, real; - char *contents = (char *) SCM_BYTEVECTOR_CONTENTS (bv); - size_t i = scm_to_size_t (idx); - - real = scm_c_real_part (val); - imag = scm_c_imag_part (val); - - memcpy (&contents[i], &real, sizeof (double)); - memcpy (&contents[i + sizeof (double)], &imag, sizeof (double)); - - return SCM_UNSPECIFIED; + COMPLEX_NATIVE_SET (float); } +#undef FUNC_NAME + +static SCM +bytevector_set_c64 (SCM bv, SCM index, SCM value) +#define FUNC_NAME "bytevector_set_c64" +{ + COMPLEX_NATIVE_SET (double); +} +#undef FUNC_NAME typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM); diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test index fca065d55..2e7f0d5f5 100644 --- a/test-suite/tests/srfi-4.test +++ b/test-suite/tests/srfi-4.test @@ -436,7 +436,26 @@ (make-c32vector 4 7))) (pass-if "+inf.0, -inf.0, +nan.0 in c32vector" - (c32vector? #c32(+inf.0 -inf.0 +nan.0)))) + (c32vector? #c32(+inf.0 -inf.0 +nan.0))) + + (pass-if "generalized-vector-ref" + (let ((v (c32vector 1+1i))) + (= (c32vector-ref v 0) + (generalized-vector-ref v 0)))) + + (pass-if "generalized-vector-set!" + (let ((x 1+1i) + (v (c32vector 0))) + (generalized-vector-set! v 0 x) + (= x (generalized-vector-ref v 0)))) + + (pass-if-exception "generalized-vector-ref, out-of-range" + exception:out-of-range + (generalized-vector-ref (c32vector 1.0) 1)) + + (pass-if-exception "generalized-vector-set!, out-of-range" + exception:out-of-range + (generalized-vector-set! (c32vector 1.0) 1 2.0))) (with-test-prefix "c64 vectors" @@ -476,5 +495,23 @@ (make-c64vector 4 7))) (pass-if "+inf.0, -inf.0, +nan.0 in c64vector" - (c64vector? #c64(+inf.0 -inf.0 +nan.0)))) + (c64vector? #c64(+inf.0 -inf.0 +nan.0))) + (pass-if "generalized-vector-ref" + (let ((v (c64vector 1+1i))) + (= (c64vector-ref v 0) + (generalized-vector-ref v 0)))) + + (pass-if "generalized-vector-set!" + (let ((x 1+1i) + (v (c64vector 0))) + (generalized-vector-set! v 0 x) + (= x (generalized-vector-ref v 0)))) + + (pass-if-exception "generalized-vector-ref, out-of-range" + exception:out-of-range + (generalized-vector-ref (c64vector 1.0) 1)) + + (pass-if-exception "generalized-vector-set!, out-of-range" + exception:out-of-range + (generalized-vector-set! (c64vector 1.0) 1 2.0))) From 97ec95b72873428f215a8a9892487c3a8435a754 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 19:10:18 +0200 Subject: [PATCH 08/37] Type-check the OWNER argument of `lock-mutex'. * libguile/threads.c (scm_lock_mutex_timed): Type-check OWNER. --- libguile/threads.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/threads.c b/libguile/threads.c index 0c6b8b40b..cbacfcad6 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1460,6 +1460,9 @@ SCM_DEFINE (scm_lock_mutex_timed, "lock-mutex", 1, 2, 0, waittime = &cwaittime; } + if (!SCM_UNBNDP (owner) && !scm_is_false (owner)) + SCM_VALIDATE_THREAD (3, owner); + exception = fat_mutex_lock (m, waittime, owner, &ret); if (!scm_is_false (exception)) scm_ithrow (SCM_CAR (exception), scm_list_1 (SCM_CDR (exception)), 1); From 231c0e0e61fc4bdd69398e89084b7819f0420710 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 22:34:29 +0200 Subject: [PATCH 09/37] Update Gnulib to v0.0-5874-g7170ee0. --- .gitignore | 1 + lib/Makefile.am | 4 +- lib/float.c | 33 ++++++++++++++ lib/float.in.h | 111 ++++++++++++++++++++++++++++++++++++++++++++++ lib/isinf.c | 9 ++-- lib/pathmax.h | 15 +++++++ lib/pipe2.c | 15 ++++++- lib/stat.c | 8 ++++ lib/unistd.in.h | 2 + m4/alloca.m4 | 79 ++++++++++++++++++++++++++++++++- m4/ceil.m4 | 16 ++++--- m4/float_h.m4 | 35 +++++++++++++-- m4/floor.m4 | 8 ++-- m4/gnulib-comp.m4 | 4 ++ m4/isinf.m4 | 4 +- m4/lstat.m4 | 4 +- m4/mmap-anon.m4 | 8 ++-- m4/printf.m4 | 11 +++-- m4/trunc.m4 | 8 ++-- maint.mk | 79 ++++++++++++++++++++------------- 20 files changed, 391 insertions(+), 63 deletions(-) create mode 100644 lib/float.c diff --git a/.gitignore b/.gitignore index 928db2060..b8ff18791 100644 --- a/.gitignore +++ b/.gitignore @@ -142,3 +142,4 @@ INSTALL /test-suite/standalone/test-scm-spawn-thread /test-suite/standalone/test-pthread-create /test-suite/standalone/test-pthread-create-secondary +/lib/fcntl.h diff --git a/lib/Makefile.am b/lib/Makefile.am index 5ae7948be..fe37ae832 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -420,7 +420,9 @@ float.h: $(top_builddir)/config.status endif MOSTLYCLEANFILES += float.h float.h-t -EXTRA_DIST += float.in.h +EXTRA_DIST += float.c float.in.h + +EXTRA_libgnu_la_SOURCES += float.c ## end gnulib module float diff --git a/lib/float.c b/lib/float.c new file mode 100644 index 000000000..e42e08e0a --- /dev/null +++ b/lib/float.c @@ -0,0 +1,33 @@ +/* Auxiliary definitions for . + Copyright (C) 2011 Free Software Foundation, Inc. + Written by Bruno Haible , 2011. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public License + along with this program. If not, see . */ + +#include + +/* Specification. */ +#include + +#if (defined _ARCH_PPC || defined _POWER) && defined _AIX && (LDBL_MANT_DIG == 106) && defined __GNUC__ +const union gl_long_double_union gl_LDBL_MAX = + { { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL } }; +#elif defined __i386__ +const union gl_long_double_union gl_LDBL_MAX = + { { 0xFFFFFFFF, 0xFFFFFFFF, 32766 } }; +#else +/* This declaration is solely to ensure that after preprocessing + this file is never empty. */ +typedef int dummy; +#endif diff --git a/lib/float.in.h b/lib/float.in.h index 58a5f736e..95dda79b8 100644 --- a/lib/float.in.h +++ b/lib/float.in.h @@ -29,6 +29,7 @@ #define _@GUARD_PREFIX@_FLOAT_H /* 'long double' properties. */ + #if defined __i386__ && (defined __BEOS__ || defined __OpenBSD__) /* Number of mantissa units, in base FLT_RADIX. */ # undef LDBL_MANT_DIG @@ -59,5 +60,115 @@ # define LDBL_MAX_10_EXP 4932 #endif +/* On FreeBSD/x86 6.4, the 'long double' type really has only 53 bits of + precision in the compiler but 64 bits of precision at runtime. See + . */ +#if defined __i386__ && defined __FreeBSD__ +/* Number of mantissa units, in base FLT_RADIX. */ +# undef LDBL_MANT_DIG +# define LDBL_MANT_DIG 64 +/* Number of decimal digits that is sufficient for representing a number. */ +# undef LDBL_DIG +# define LDBL_DIG 18 +/* x-1 where x is the smallest representable number > 1. */ +# undef LDBL_EPSILON +# define LDBL_EPSILON 1.084202172485504434007452800869941711426e-19L /* 2^-63 */ +/* Minimum e such that FLT_RADIX^(e-1) is a normalized number. */ +# undef LDBL_MIN_EXP +# define LDBL_MIN_EXP (-16381) +/* Maximum e such that FLT_RADIX^(e-1) is a representable finite number. */ +# undef LDBL_MAX_EXP +# define LDBL_MAX_EXP 16384 +/* Minimum positive normalized number. */ +# undef LDBL_MIN +# define LDBL_MIN 3.3621031431120935E-4932L /* = 0x1p-16382L */ +/* Maximum representable finite number. */ +# undef LDBL_MAX +/* LDBL_MAX is represented as { 0xFFFFFFFF, 0xFFFFFFFF, 32766 }. + But the largest literal that GCC allows us to write is + 0x0.fffffffffffff8p16384L = { 0xFFFFF800, 0xFFFFFFFF, 32766 }. + So, define it like this through a reference to an external variable + + const unsigned int LDBL_MAX[3] = { 0xFFFFFFFF, 0xFFFFFFFF, 32766 }; + extern const long double LDBL_MAX; + + Unfortunately, this is not a constant expression. */ +union gl_long_double_union + { + struct { unsigned int lo; unsigned int hi; unsigned int exponent; } xd; + long double ld; + }; +extern const union gl_long_double_union gl_LDBL_MAX; +# define LDBL_MAX (gl_LDBL_MAX.ld) +/* Minimum e such that 10^e is in the range of normalized numbers. */ +# undef LDBL_MIN_10_EXP +# define LDBL_MIN_10_EXP (-4931) +/* Maximum e such that 10^e is in the range of representable finite numbers. */ +# undef LDBL_MAX_10_EXP +# define LDBL_MAX_10_EXP 4932 +#endif + +/* On AIX 7.1 with gcc 4.2, the values of LDBL_MIN_EXP, LDBL_MIN, LDBL_MAX are + wrong. */ +#if (defined _ARCH_PPC || defined _POWER) && defined _AIX && (LDBL_MANT_DIG == 106) && defined __GNUC__ +# undef LDBL_MIN_EXP +# define LDBL_MIN_EXP DBL_MIN_EXP +# undef LDBL_MIN_10_EXP +# define LDBL_MIN_10_EXP DBL_MIN_10_EXP +# undef LDBL_MIN +# define LDBL_MIN 2.22507385850720138309023271733240406422e-308L /* DBL_MIN = 2^-1022 */ +# undef LDBL_MAX +/* LDBL_MAX is represented as { 0x7FEFFFFF, 0xFFFFFFFF, 0x7C8FFFFF, 0xFFFFFFFF }. + It is not easy to define: + #define LDBL_MAX 1.79769313486231580793728971405302307166e308L + is too small, whereas + #define LDBL_MAX 1.79769313486231580793728971405302307167e308L + is too large. Apparently a bug in GCC decimal-to-binary conversion. + Also, I can't get values larger than + #define LDBL63 ((long double) (1ULL << 63)) + #define LDBL882 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63) + #define LDBL945 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63) + #define LDBL1008 (LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63 * LDBL63) + #define LDBL_MAX (LDBL1008 * 65535.0L + LDBL945 * (long double) 9223372036821221375ULL + LDBL882 * (long double) 4611686018427387904ULL) + which is represented as { 0x7FEFFFFF, 0xFFFFFFFF, 0x7C8FFFFF, 0xF8000000 }. + So, define it like this through a reference to an external variable + + const double LDBL_MAX[2] = { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL }; + extern const long double LDBL_MAX; + + or through a pointer cast + + #define LDBL_MAX \ + (*(const long double *) (double[]) { DBL_MAX, DBL_MAX / (double)134217728UL / (double)134217728UL }) + + Unfortunately, this is not a constant expression, and the latter expression + does not work well when GCC is optimizing.. */ +union gl_long_double_union + { + struct { double hi; double lo; } dd; + long double ld; + }; +extern const union gl_long_double_union gl_LDBL_MAX; +# define LDBL_MAX (gl_LDBL_MAX.ld) +#endif + +/* On IRIX 6.5, with cc, the value of LDBL_MANT_DIG is wrong. + On IRIX 6.5, with gcc 4.2, the values of LDBL_MIN_EXP, LDBL_MIN, LDBL_EPSILON + are wrong. */ +#if defined __sgi && (LDBL_MANT_DIG >= 106) +# undef LDBL_MANT_DIG +# define LDBL_MANT_DIG 106 +# if defined __GNUC__ +# undef LDBL_MIN_EXP +# define LDBL_MIN_EXP DBL_MIN_EXP +# undef LDBL_MIN_10_EXP +# define LDBL_MIN_10_EXP DBL_MIN_10_EXP +# undef LDBL_MIN +# define LDBL_MIN 2.22507385850720138309023271733240406422e-308L /* DBL_MIN = 2^-1022 */ +# undef LDBL_EPSILON +# define LDBL_EPSILON 2.46519032881566189191165176650870696773e-32L /* 2^-105 */ +# endif +#endif + #endif /* _@GUARD_PREFIX@_FLOAT_H */ #endif /* _@GUARD_PREFIX@_FLOAT_H */ diff --git a/lib/isinf.c b/lib/isinf.c index 28cfc4d49..0531c6f34 100644 --- a/lib/isinf.c +++ b/lib/isinf.c @@ -21,17 +21,20 @@ #include -int gl_isinff (float x) +int +gl_isinff (float x) { return x < -FLT_MAX || x > FLT_MAX; } -int gl_isinfd (double x) +int +gl_isinfd (double x) { return x < -DBL_MAX || x > DBL_MAX; } -int gl_isinfl (long double x) +int +gl_isinfl (long double x) { return x < -LDBL_MAX || x > LDBL_MAX; } diff --git a/lib/pathmax.h b/lib/pathmax.h index 8056fef22..41f0ba276 100644 --- a/lib/pathmax.h +++ b/lib/pathmax.h @@ -19,6 +19,12 @@ #ifndef _PATHMAX_H # define _PATHMAX_H +/* POSIX:2008 defines PATH_MAX to be the maximum number of bytes in a filename, + including the terminating NUL byte. + + PATH_MAX is not defined on systems which have no limit on filename length, + such as GNU/Hurd. */ + # include # include @@ -45,4 +51,13 @@ # define PATH_MAX _POSIX_PATH_MAX # endif +# ifdef __hpux +/* On HP-UX, PATH_MAX designates the maximum number of bytes in a filename, + *not* including the terminating NUL byte, and is set to 1023. + Additionally, when _XOPEN_SOURCE is defined to 500 or more, PATH_MAX is + not defined at all any more. */ +# undef PATH_MAX +# define PATH_MAX 1024 +# endif + #endif /* _PATHMAX_H */ diff --git a/lib/pipe2.c b/lib/pipe2.c index e1884fadd..bb17264a3 100644 --- a/lib/pipe2.c +++ b/lib/pipe2.c @@ -40,6 +40,13 @@ int pipe2 (int fd[2], int flags) { + /* Mingw _pipe() corrupts fd on failure; also, if we succeed at + creating the pipe but later fail at changing fcntl, we want + to leave fd unchanged: http://austingroupbugs.net/view.php?id=467 */ + int tmp[2]; + tmp[0] = fd[0]; + tmp[1] = fd[1]; + #if HAVE_PIPE2 # undef pipe2 /* Try the system call first, if it exists. (We may be running with a glibc @@ -71,7 +78,11 @@ pipe2 (int fd[2], int flags) /* Native Woe32 API. */ if (_pipe (fd, 4096, flags & ~O_NONBLOCK) < 0) - return -1; + { + fd[0] = tmp[0]; + fd[1] = tmp[1]; + return -1; + } /* O_NONBLOCK handling. On native Windows platforms, O_NONBLOCK is defined by gnulib. Use the @@ -145,6 +156,8 @@ pipe2 (int fd[2], int flags) int saved_errno = errno; close (fd[0]); close (fd[1]); + fd[0] = tmp[0]; + fd[1] = tmp[1]; errno = saved_errno; return -1; } diff --git a/lib/stat.c b/lib/stat.c index aa369d0f2..b203172fe 100644 --- a/lib/stat.c +++ b/lib/stat.c @@ -38,6 +38,7 @@ orig_stat (const char *filename, struct stat *buf) #include #include #include "dosname.h" +#include "verify.h" /* Store information about NAME into ST. Work around bugs with trailing slashes. Mingw has other bugs (such as st_ino always @@ -63,6 +64,12 @@ rpl_stat (char const *name, struct stat *st) } #endif /* REPLACE_FUNC_STAT_FILE */ #if REPLACE_FUNC_STAT_DIR + /* The only known systems where REPLACE_FUNC_STAT_DIR is needed also + have a constant PATH_MAX. */ +# ifndef PATH_MAX +# error "Please port this replacement to your platform" +# endif + if (result == -1 && errno == ENOENT) { /* Due to mingw's oddities, there are some directories (like @@ -77,6 +84,7 @@ rpl_stat (char const *name, struct stat *st) char fixed_name[PATH_MAX + 1] = {0}; size_t len = strlen (name); bool check_dir = false; + verify (PATH_MAX <= 4096); if (PATH_MAX <= len) errno = ENAMETOOLONG; else if (len) diff --git a/lib/unistd.in.h b/lib/unistd.in.h index 2101bced5..f1878e017 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -1062,6 +1062,7 @@ _GL_WARN_ON_USE (pipe2, "pipe2 is unportable - " specification . */ # if @REPLACE_PREAD@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef pread # define pread rpl_pread # endif _GL_FUNCDECL_RPL (pread, ssize_t, @@ -1096,6 +1097,7 @@ _GL_WARN_ON_USE (pread, "pread is unportable - " . */ # if @REPLACE_PWRITE@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef pwrite # define pwrite rpl_pwrite # endif _GL_FUNCDECL_RPL (pwrite, ssize_t, diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 689da75a2..891fc8bc3 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,4 +1,4 @@ -# alloca.m4 serial 11 +# alloca.m4 serial 12 dnl Copyright (C) 2002-2004, 2006-2007, 2009-2011 Free Software Foundation, dnl Inc. dnl This file is free software; the Free Software Foundation @@ -42,3 +42,80 @@ AC_DEFUN([gl_FUNC_ALLOCA], # Prerequisites of lib/alloca.c. # STACK_DIRECTION is already handled by AC_FUNC_ALLOCA. AC_DEFUN([gl_PREREQ_ALLOCA], [:]) + +# This works around a bug in autoconf <= 2.68. +# See . + +m4_version_prereq([2.69], [] ,[ + +# This is taken from the following Autoconf patch: +# http://git.savannah.gnu.org/cgit/autoconf.git/commit/?id=6cd9f12520b0d6f76d3230d7565feba1ecf29497 + +# _AC_LIBOBJ_ALLOCA +# ----------------- +# Set up the LIBOBJ replacement of `alloca'. Well, not exactly +# AC_LIBOBJ since we actually set the output variable `ALLOCA'. +# Nevertheless, for Automake, AC_LIBSOURCES it. +m4_define([_AC_LIBOBJ_ALLOCA], +[# The SVR3 libPW and SVR4 libucb both contain incompatible functions +# that cause trouble. Some versions do not even contain alloca or +# contain a buggy version. If you still want to use their alloca, +# use ar to extract alloca.o from them instead of compiling alloca.c. +AC_LIBSOURCES(alloca.c) +AC_SUBST([ALLOCA], [\${LIBOBJDIR}alloca.$ac_objext])dnl +AC_DEFINE(C_ALLOCA, 1, [Define to 1 if using `alloca.c'.]) + +AC_CACHE_CHECK(whether `alloca.c' needs Cray hooks, ac_cv_os_cray, +[AC_EGREP_CPP(webecray, +[#if defined CRAY && ! defined CRAY2 +webecray +#else +wenotbecray +#endif +], ac_cv_os_cray=yes, ac_cv_os_cray=no)]) +if test $ac_cv_os_cray = yes; then + for ac_func in _getb67 GETB67 getb67; do + AC_CHECK_FUNC($ac_func, + [AC_DEFINE_UNQUOTED(CRAY_STACKSEG_END, $ac_func, + [Define to one of `_getb67', `GETB67', + `getb67' for Cray-2 and Cray-YMP + systems. This function is required for + `alloca.c' support on those systems.]) + break]) + done +fi + +AC_CACHE_CHECK([stack direction for C alloca], + [ac_cv_c_stack_direction], +[AC_RUN_IFELSE([AC_LANG_SOURCE( +[AC_INCLUDES_DEFAULT +int +find_stack_direction (int *addr, int depth) +{ + int dir, dummy = 0; + if (! addr) + addr = &dummy; + *addr = addr < &dummy ? 1 : addr == &dummy ? 0 : -1; + dir = depth ? find_stack_direction (addr, depth - 1) : 0; + return dir + dummy; +} + +int +main (int argc, char **argv) +{ + return find_stack_direction (0, argc + !argv + 20) < 0; +}])], + [ac_cv_c_stack_direction=1], + [ac_cv_c_stack_direction=-1], + [ac_cv_c_stack_direction=0])]) +AH_VERBATIM([STACK_DIRECTION], +[/* If using the C implementation of alloca, define if you know the + direction of stack growth for your system; otherwise it will be + automatically deduced at runtime. + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown */ +@%:@undef STACK_DIRECTION])dnl +AC_DEFINE_UNQUOTED(STACK_DIRECTION, $ac_cv_c_stack_direction) +])# _AC_LIBOBJ_ALLOCA +]) diff --git a/m4/ceil.m4 b/m4/ceil.m4 index 157407745..b9052976f 100644 --- a/m4/ceil.m4 +++ b/m4/ceil.m4 @@ -1,4 +1,4 @@ -# ceil.m4 serial 6 +# ceil.m4 serial 8 dnl Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -28,12 +28,18 @@ AC_DEFUN([gl_FUNC_CEIL], #include ]gl_DOUBLE_MINUS_ZERO_CODE[ ]gl_DOUBLE_SIGNBIT_CODE[ -int main() +static double dummy (double f) { return 0; } +int main (int argc, char *argv[]) { + double (*my_ceil) (double) = argc ? ceil : dummy; + int result = 0; /* Test whether ceil (-0.0) is -0.0. */ - if (signbitd (minus_zerod) && !signbitd (ceil (minus_zerod))) - return 1; - return 0; + if (signbitd (minus_zerod) && !signbitd (my_ceil (minus_zerod))) + result |= 1; + /* Test whether ceil (-0.3) is -0.0. */ + if (signbitd (-0.3) && !signbitd (my_ceil (-0.3))) + result |= 2; + return result; } ]])], [gl_cv_func_ceil_ieee=yes], diff --git a/m4/float_h.m4 b/m4/float_h.m4 index 21a7529fe..261f1ac3a 100644 --- a/m4/float_h.m4 +++ b/m4/float_h.m4 @@ -1,4 +1,4 @@ -# float_h.m4 serial 6 +# float_h.m4 serial 7 dnl Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -9,12 +9,41 @@ AC_DEFUN([gl_FLOAT_H], AC_REQUIRE([AC_PROG_CC]) AC_REQUIRE([AC_CANONICAL_HOST]) FLOAT_H= + REPLACE_FLOAT_LDBL=0 case "$host_os" in - beos* | openbsd* | mirbsd*) + aix* | beos* | openbsd* | mirbsd* | irix*) FLOAT_H=float.h - gl_NEXT_HEADERS([float.h]) + ;; + freebsd*) + case "$host_cpu" in +changequote(,)dnl + i[34567]86 ) +changequote([,])dnl + FLOAT_H=float.h + ;; + x86_64 ) + # On x86_64 systems, the C compiler may still be generating + # 32-bit code. + AC_EGREP_CPP([yes], + [#if defined __LP64__ || defined __x86_64__ || defined __amd64__ + yes + #endif], + [], + [FLOAT_H=float.h]) + ;; + esac ;; esac + case "$host_os" in + aix* | freebsd*) + if test -n "$FLOAT_H"; then + REPLACE_FLOAT_LDBL=1 + fi + ;; + esac + if test -n "$FLOAT_H"; then + gl_NEXT_HEADERS([float.h]) + fi AC_SUBST([FLOAT_H]) AM_CONDITIONAL([GL_GENERATE_FLOAT_H], [test -n "$FLOAT_H"]) ]) diff --git a/m4/floor.m4 b/m4/floor.m4 index 62d19fed7..5de0da277 100644 --- a/m4/floor.m4 +++ b/m4/floor.m4 @@ -1,4 +1,4 @@ -# floor.m4 serial 6 +# floor.m4 serial 7 dnl Copyright (C) 2007, 2009-2011 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -28,10 +28,12 @@ AC_DEFUN([gl_FUNC_FLOOR], #include ]gl_DOUBLE_MINUS_ZERO_CODE[ ]gl_DOUBLE_SIGNBIT_CODE[ -int main() +static double dummy (double f) { return 0; } +int main (int argc, char *argv[]) { + double (*my_floor) (double) = argc ? floor : dummy; /* Test whether floor (-0.0) is -0.0. */ - if (signbitd (minus_zerod) && !signbitd (floor (minus_zerod))) + if (signbitd (minus_zerod) && !signbitd (my_floor (minus_zerod))) return 1; return 0; } diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index f532ac6d7..881d69ef7 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -257,6 +257,9 @@ fi gl_MODULE_INDICATOR([fflush]) gl_STDIO_MODULE_INDICATOR([fflush]) gl_FLOAT_H +if test $REPLACE_FLOAT_LDBL = 1; then + AC_LIBOBJ([float]) +fi gl_FUNC_FLOCK if test $HAVE_FLOCK = 0; then AC_LIBOBJ([flock]) @@ -778,6 +781,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/fd-hook.h lib/fflush.c lib/float+.h + lib/float.c lib/float.in.h lib/flock.c lib/floor.c diff --git a/m4/isinf.m4 b/m4/isinf.m4 index f6056e610..145e37e66 100644 --- a/m4/isinf.m4 +++ b/m4/isinf.m4 @@ -1,4 +1,4 @@ -# isinf.m4 serial 4 +# isinf.m4 serial 5 dnl Copyright (C) 2007-2011 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -11,7 +11,7 @@ AC_DEFUN([gl_ISINF], AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) AC_CHECK_DECLS([isinf], , , [#include ]) if test "$ac_cv_have_decl_isinf" = yes; then - gl_CHECK_MATH_LIB([ISINF_LIBM], [x = isinf (x);]) + gl_CHECK_MATH_LIB([ISINF_LIBM], [x = isinf (x) + isinf ((float) x);]) if test "$ISINF_LIBM" != missing; then dnl Test whether isinf() on 'long double' works. gl_ISINFL_WORKS diff --git a/m4/lstat.m4 b/m4/lstat.m4 index 72c76c6cf..fe161d401 100644 --- a/m4/lstat.m4 +++ b/m4/lstat.m4 @@ -1,4 +1,4 @@ -# serial 22 +# serial 23 # Copyright (C) 1997-2001, 2003-2011 Free Software Foundation, Inc. # @@ -15,7 +15,7 @@ AC_DEFUN([gl_FUNC_LSTAT], dnl "#define lstat stat", and lstat.c is a no-op. AC_CHECK_FUNCS_ONCE([lstat]) if test $ac_cv_func_lstat = yes; then - AC_REQUIRE([AC_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK]) + AC_REQUIRE([gl_FUNC_LSTAT_FOLLOWS_SLASHED_SYMLINK]) if test $gl_cv_func_lstat_dereferences_slashed_symlink = no; then REPLACE_LSTAT=1 fi diff --git a/m4/mmap-anon.m4 b/m4/mmap-anon.m4 index 7ba7fd26b..952536feb 100644 --- a/m4/mmap-anon.m4 +++ b/m4/mmap-anon.m4 @@ -27,18 +27,18 @@ AC_DEFUN([gl_FUNC_MMAP_ANON], gl_have_mmap_anonymous=no if test $gl_have_mmap = yes; then AC_MSG_CHECKING([for MAP_ANONYMOUS]) - AC_EGREP_CPP([I cant identify this map.], [ + AC_EGREP_CPP([I cant identify this map], [ #include #ifdef MAP_ANONYMOUS - I cant identify this map. + I cant identify this map #endif ], [gl_have_mmap_anonymous=yes]) if test $gl_have_mmap_anonymous != yes; then - AC_EGREP_CPP([I cant identify this map.], [ + AC_EGREP_CPP([I cant identify this map], [ #include #ifdef MAP_ANON - I cant identify this map. + I cant identify this map #endif ], [AC_DEFINE([MAP_ANONYMOUS], [MAP_ANON], diff --git a/m4/printf.m4 b/m4/printf.m4 index 9c2ed1ef2..ead5eceae 100644 --- a/m4/printf.m4 +++ b/m4/printf.m4 @@ -1,4 +1,4 @@ -# printf.m4 serial 42 +# printf.m4 serial 43 dnl Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -892,7 +892,8 @@ dnl On mingw, precisions larger than 512 are treated like 512, in integer, dnl floating-point or pointer output. On Solaris 10/x86, precisions larger dnl than 510 in floating-point output crash the program. On Solaris 10/SPARC, dnl precisions larger than 510 in floating-point output yield wrong results. -dnl On BeOS, precisions larger than 1044 crash the program. +dnl On AIX 7.1, precisions larger than 998 in floating-point output yield +dnl wrong results. On BeOS, precisions larger than 1044 crash the program. dnl Result is gl_cv_func_printf_precision. AC_DEFUN([gl_PRINTF_PRECISION], @@ -921,6 +922,9 @@ int main () if (sprintf (buf, "%.511f %d", 1.0, 33, 44) < 511 + 5 || buf[0] != '1') result |= 4; + if (sprintf (buf, "%.999f %d", 1.0, 33, 44) < 999 + 5 + || buf[0] != '1') + result |= 4; return result; }]])], [gl_cv_func_printf_precision=yes], @@ -1465,7 +1469,8 @@ dnl Solaris 11 2010-11 . . # # # . . # . . . # . . . dnl Solaris 10 . . # # # . . # . . . # # . . . . . . . dnl Solaris 2.6 ... 9 # . # # # # . # . . . # # . . . # . . . dnl Solaris 2.5.1 # . # # # # . # . . . # . . # # # # # # -dnl AIX 5.2, 7.1 . . # # # . . . . . . # . . . . . . . . +dnl AIX 7.1 . . # # # . . . . . . # # . . . . . . . +dnl AIX 5.2 . . # # # . . . . . . # . . . . . . . . dnl AIX 4.3.2, 5.1 # . # # # # . . . . . # . . . . # . . . dnl HP-UX 11.31 . . . . # . . . . . . # . . . . # # . . dnl HP-UX 11.{00,11,23} # . . . # # . . . . . # . . . . # # . # diff --git a/m4/trunc.m4 b/m4/trunc.m4 index 953f5b131..62311015b 100644 --- a/m4/trunc.m4 +++ b/m4/trunc.m4 @@ -1,4 +1,4 @@ -# trunc.m4 serial 6 +# trunc.m4 serial 7 dnl Copyright (C) 2007, 2010-2011 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -56,10 +56,12 @@ AC_DEFUN([gl_FUNC_TRUNC], #include ]gl_DOUBLE_MINUS_ZERO_CODE[ ]gl_DOUBLE_SIGNBIT_CODE[ -int main() +static double dummy (double f) { return 0; } +int main (int argc, char *argv[]) { + double (*my_trunc) (double) = argc ? trunc : dummy; /* Test whether trunc (-0.0) is -0.0. */ - if (signbitd (minus_zerod) && !signbitd (trunc (minus_zerod))) + if (signbitd (minus_zerod) && !signbitd (my_trunc (minus_zerod))) return 1; return 0; } diff --git a/maint.mk b/maint.mk index 6f6b8be39..e6e03a897 100644 --- a/maint.mk +++ b/maint.mk @@ -405,11 +405,11 @@ sc_prohibit_HAVE_MBRTOWC: $(_sc_search_regexp) # To use this "command" macro, you must first define two shell variables: -# h: the header, enclosed in <> or "" +# h: the header name, with no enclosing <> or "" # re: a regular expression that matches IFF something provided by $h is used. define _sc_header_without_use dummy=; : so we do not need a semicolon before each use; \ - h_esc=`echo "$$h"|sed 's/\./\\\\./g'`; \ + h_esc=`echo '[<"]'"$$h"'[">]'|sed 's/\./\\\\./g'`; \ if $(VC_LIST_EXCEPT) | grep -l '\.c$$' > /dev/null; then \ files=$$(grep -l '^# *include '"$$h_esc" \ $$($(VC_LIST_EXCEPT) | grep '\.c$$')) && \ @@ -422,42 +422,42 @@ endef # Prohibit the inclusion of assert.h without an actual use of assert. sc_prohibit_assert_without_use: - @h='' re='\ sc_prohibit_hash_without_use: - @h='"hash.h"' \ + @h='hash.h' \ re='$(_hash_fn)|$(_hash_struct)'\ $(_sc_header_without_use) sc_prohibit_cloexec_without_use: - @h='"cloexec.h"' re='\<(set_cloexec_flag|dup_cloexec) *\(' \ + @h='cloexec.h' re='\<(set_cloexec_flag|dup_cloexec) *\(' \ $(_sc_header_without_use) sc_prohibit_posixver_without_use: - @h='"posixver.h"' re='\' \ @@ -1106,6 +1112,7 @@ sc_copyright_check: # the other init.sh-using tests also get it right. _hv_file ?= $(srcdir)/tests/help-version _hv_regex_weak ?= ^ *\. .*/init\.sh" +# Fix syntax-highlighters " _hv_regex_strong ?= ^ *\. "\$${srcdir=\.}/init\.sh" sc_cross_check_PATH_usage_in_tests: @if test -f $(_hv_file); then \ @@ -1133,6 +1140,14 @@ sc_Wundef_boolean: halt='Use 0 or 1 for macro values' \ $(_sc_search_regexp) +# Even if you use pathmax.h to guarantee that PATH_MAX is defined, it might +# not be constant, or might overflow a stack. In general, use PATH_MAX as +# a limit, not an array or alloca size. +sc_prohibit_path_max_allocation: + @prohibit='(\balloca *\([^)]*|\[[^]]*)PATH_MAX' \ + halt='Avoid stack allocations of size PATH_MAX' \ + $(_sc_search_regexp) + sc_vulnerable_makefile_CVE-2009-4029: @prohibit='perm -777 -exec chmod a\+rwx|chmod 777 \$$\(distdir\)' \ in_files=$$(find $(srcdir) -name Makefile.in) \ From 4f39f31ea58f08dfe22df8192e8ff02943a9ed5d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 22:43:01 +0200 Subject: [PATCH 10/37] Revert "Fix lock ordering in `fat_mutex_lock' to match that of `do_thread_exit'." This reverts commit ccb80964cd7cd112e300c34d32f67125a6d6da9a, which introduced a race condition, with a small window during which a mutex could be held by a thread without being part of its `mutexes' list, thereby violating the invariant tested at line 667. --- libguile/threads.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/threads.c b/libguile/threads.c index cbacfcad6..752354008 100644 --- a/libguile/threads.c +++ b/libguile/threads.c @@ -1370,7 +1370,9 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) { scm_i_thread *t = SCM_I_THREAD_DATA (new_owner); - scm_i_pthread_mutex_unlock (&m->lock); + /* FIXME: The order in which `t->admin_mutex' and + `m->lock' are taken differs from that in + `on_thread_exit', potentially leading to deadlocks. */ scm_i_pthread_mutex_lock (&t->admin_mutex); /* Only keep a weak reference to MUTEX so that it's not @@ -1381,7 +1383,6 @@ fat_mutex_lock (SCM mutex, scm_t_timespec *timeout, SCM owner, int *ret) t->mutexes = scm_weak_car_pair (mutex, t->mutexes); scm_i_pthread_mutex_unlock (&t->admin_mutex); - scm_i_pthread_mutex_lock (&m->lock); } *ret = 1; break; From f39779b1be487985d32bb6ad372e9fa29572f813 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 22:49:50 +0200 Subject: [PATCH 11/37] Update `NEWS'. --- NEWS | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/NEWS b/NEWS index 2ca0272a1..f5760cf38 100644 --- a/NEWS +++ b/NEWS @@ -162,11 +162,16 @@ ports)' documentation from the R6RS documentation. Thanks Andreas! ** Fix call-with-input-file & relatives for multiple values ** Fix `hash' for inf and nan ** Fix libguile internal type errors caught by typing-strictness==2 -** Fix compile error in mingw fstat socket detection +** Fix compile error in MinGW fstat socket detection +** Fix generation of auto-compiled file names on MinGW ** Fix multithreaded access to internal hash tables ** Emit a 1-based line number in error messages ** Fix define-module ordering ** Fix several POSIX functions to use the locale encoding +** Add type and range checks to the complex generalized vector accessors +** Fix unaligned accesses for bytevectors of complex numbers +** Fix '(a #{.} b) +** Fix erroneous VM stack overflow for canceled threads Changes in 2.0.1 (since 2.0.0): From c467c36374b7bdbdfe4c0dfccaa2fb4ebfb4d3a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 1 Jul 2011 23:54:10 +0200 Subject: [PATCH 12/37] Bump version number for 2.0.2. * GUILE-VERSION (GUILE_MICRO_VERSION): Increment. (LIBGUILE_INTERFACE_CURRENT): Increment to account for new C function `scm_peek_byte_or_eof'. (LIBGUILE_INTERFACE_AGE): Increment. --- GUILE-VERSION | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/GUILE-VERSION b/GUILE-VERSION index cbbe90948..804ce6c9d 100644 --- a/GUILE-VERSION +++ b/GUILE-VERSION @@ -3,7 +3,7 @@ # Note: `GUILE_VERSION' is defined in `configure.ac' using `git-version-gen'. GUILE_MAJOR_VERSION=2 GUILE_MINOR_VERSION=0 -GUILE_MICRO_VERSION=1 +GUILE_MICRO_VERSION=2 GUILE_EFFECTIVE_VERSION=2.0 @@ -18,7 +18,7 @@ GUILE_EFFECTIVE_VERSION=2.0 # See libtool info pages for more information on how and when to # change these. -LIBGUILE_INTERFACE_CURRENT=23 +LIBGUILE_INTERFACE_CURRENT=24 LIBGUILE_INTERFACE_REVISION=0 -LIBGUILE_INTERFACE_AGE=1 +LIBGUILE_INTERFACE_AGE=2 LIBGUILE_INTERFACE="${LIBGUILE_INTERFACE_CURRENT}:${LIBGUILE_INTERFACE_REVISION}:${LIBGUILE_INTERFACE_AGE}" From 37a5970c19ca7ad2b5de2f667748c840c199f878 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 4 Jul 2011 23:56:16 +0200 Subject: [PATCH 13/37] VM: Keep jump table address in a register. * libguile/vm-engine.c (VM_NAME)[HAVE_LABELS_AS_VALUES]: Rename `jump_table' to `jump_table_pointer'. Add `jump_table' as a local variable, initialize it. * libguile/vm-engine.h (JT_REG): New macro. --- libguile/vm-engine.c | 18 +++++++++++++----- libguile/vm-engine.h | 8 ++++++++ 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c index 22bd39c0e..c90458df6 100644 --- a/libguile/vm-engine.c +++ b/libguile/vm-engine.c @@ -61,23 +61,31 @@ VM_NAME (SCM vm, SCM program, SCM *argv, int nargs) SCM finish_args; /* used both for returns: both in error and normal situations */ #ifdef HAVE_LABELS_AS_VALUES - static void **jump_table = NULL; + static const void **jump_table_pointer = NULL; #endif - + #ifdef HAVE_LABELS_AS_VALUES - if (SCM_UNLIKELY (!jump_table)) + register const void **jump_table JT_REG; + + if (SCM_UNLIKELY (!jump_table_pointer)) { int i; - jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*)); + jump_table_pointer = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof (void*)); for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) - jump_table[i] = &&vm_error_bad_instruction; + jump_table_pointer[i] = &&vm_error_bad_instruction; #define VM_INSTRUCTION_TO_LABEL 1 +#define jump_table jump_table_pointer #include #include #include #include +#undef jump_table #undef VM_INSTRUCTION_TO_LABEL } + + /* Attempt to keep JUMP_TABLE_POINTER in a register. This saves one + load instruction at each instruction dispatch. */ + jump_table = jump_table_pointer; #endif /* Initialization */ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h index 48ab09a12..000397de2 100644 --- a/libguile/vm-engine.h +++ b/libguile/vm-engine.h @@ -57,6 +57,11 @@ /* too few registers! because of register allocation errors with various gcs, just punt on explicit assignments on i386, hoping that the "register" declaration will be sufficient. */ +#elif defined __x86_64__ +/* GCC 4.6 chooses %rbp for IP_REG and %rbx for SP_REG, which works + well. Tell it to keep the jump table in a r12, which is + callee-saved. */ +#define JT_REG asm ("r12") #endif #if defined(PPC) || defined(_POWER) || defined(_IBMR2) #define IP_REG asm("26") @@ -89,6 +94,9 @@ #ifndef FP_REG #define FP_REG #endif +#ifndef JT_REG +#define JT_REG +#endif /* From 0adcd1bd939cb94691b15e585623b768041c058c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 6 Jul 2011 16:01:22 +0200 Subject: [PATCH 14/37] configure: Build a `tar.xz' in addition to `tar.gz'. * configure.ac: Explicitly require Automake 1.11. Add Automake option `dist-xz'. --- configure.ac | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index cf31cfebc..b629f5c3d 100644 --- a/configure.ac +++ b/configure.ac @@ -35,7 +35,8 @@ AC_CONFIG_AUX_DIR([build-aux]) AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_SRCDIR(GUILE-VERSION) -AM_INIT_AUTOMAKE([gnu no-define -Wall -Wno-override]) +dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11. +AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override dist-xz]) m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)]) AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT) From 21b6df302fbc372a4b359f73a7441752cd6c1306 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 6 Jul 2011 18:21:07 +0200 Subject: [PATCH 15/37] doc: Fix `merge-generics' example. * doc/ref/goops.texi (Merging Generics): Change (my-module) example to use (oop goops) and use the right syntax for #:duplicates. Reported by David Pirotte . --- doc/ref/goops.texi | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/ref/goops.texi b/doc/ref/goops.texi index 362a6e371..10192eb3b 100644 --- a/doc/ref/goops.texi +++ b/doc/ref/goops.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 2008, 2009 +@c Copyright (C) 2008, 2009, 2011 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -822,9 +822,10 @@ Here is an example: #:export (x y z ...)) (define-module (my-module) + #:use-module (oop goops) #:use-module (math 2D-vectors) #:use-module (math 3D-vectors) - #:duplicates merge-generics) + #:duplicates (merge-generics)) @end lisp The generic function @code{x} in @code{(my-module)} will now incorporate From c1e3e9aafff8ef669fd3573f7c92d2f5ff7c2d66 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Wed, 6 Jul 2011 14:01:03 +0200 Subject: [PATCH 16/37] more precision for ,time * module/system/repl/command.scm (time): Use the high-precision timers instead of stime(2). Changes the output format of `,time' too; perhaps there is a better way. --- module/system/repl/command.scm | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm index 109b533f8..a2f2a6f84 100644 --- a/module/system/repl/command.scm +++ b/module/system/repl/command.scm @@ -485,21 +485,19 @@ Disassemble a file." "time EXP Time execution." (let* ((gc-start (gc-run-time)) - (tms-start (times)) + (real-start (get-internal-real-time)) + (run-start (get-internal-run-time)) (result (repl-eval repl (repl-parse repl form))) - (tms-end (times)) + (run-end (get-internal-run-time)) + (real-end (get-internal-real-time)) (gc-end (gc-run-time))) - (define (get proc start end) - (exact->inexact (/ (- (proc end) (proc start)) internal-time-units-per-second))) + (define (diff start end) + (/ (- end start) 1.0 internal-time-units-per-second)) (repl-print repl result) - (display "clock utime stime cutime cstime gctime\n") - (format #t "~5,2F ~5,2F ~5,2F ~6,2F ~6,2F ~6,2F\n" - (get tms:clock tms-start tms-end) - (get tms:utime tms-start tms-end) - (get tms:stime tms-start tms-end) - (get tms:cutime tms-start tms-end) - (get tms:cstime tms-start tms-end) - (get identity gc-start gc-end)) + (format #t ";; ~,6Fs real time, ~,6Fs run time. ~,6Fs spent in GC.\n" + (diff real-start real-end) + (diff run-start run-end) + (diff gc-start gc-end)) result)) (define-meta-command (profile repl (form) . opts) From a8c10aa131eb5dd104f134d2ed66afe225fea8e6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jul 2011 12:17:08 +0200 Subject: [PATCH 17/37] goops.scm cleanups * module/oop/goops.scm (make-generic, make-extended-generic): (ensure-generic, make-accessor, ensure-accessor): Use optional arguments for #:name. `make-extended-generic' also accepts empty extension lists. --- module/oop/goops.scm | 85 +++++++++++++++++++++----------------------- 1 file changed, 40 insertions(+), 45 deletions(-) diff --git a/module/oop/goops.scm b/module/oop/goops.scm index 1f9fd5074..0845d29e9 100644 --- a/module/oop/goops.scm +++ b/module/oop/goops.scm @@ -336,13 +336,11 @@ names)) (goops-error "no prefixes supplied")))) -(define (make-generic . name) - (let ((name (and (pair? name) (car name)))) - (make #:name name))) +(define* (make-generic #:optional name) + (make #:name name)) -(define (make-extended-generic gfs . name) - (let* ((name (and (pair? name) (car name))) - (gfs (if (pair? gfs) gfs (list gfs))) +(define* (make-extended-generic gfs #:optional name) + (let* ((gfs (if (list? gfs) gfs (list gfs))) (gws? (any (lambda (gf) (is-a? gf )) gfs))) (let ((ans (if gws? (let* ((sname (and name (make-setter-name name))) @@ -379,18 +377,17 @@ (delq! eg (slot-ref gf 'extended-by)))) gfs)) -(define (ensure-generic old-definition . name) - (let ((name (and (pair? name) (car name)))) - (cond ((is-a? old-definition ) old-definition) - ((procedure-with-setter? old-definition) - (make - #:name name - #:default (procedure old-definition) - #:setter (setter old-definition))) - ((procedure? old-definition) - (if (generic-capability? old-definition) old-definition - (make #:name name #:default old-definition))) - (else (make #:name name))))) +(define* (ensure-generic old-definition #:optional name) + (cond ((is-a? old-definition ) old-definition) + ((procedure-with-setter? old-definition) + (make + #:name name + #:default (procedure old-definition) + #:setter (setter old-definition))) + ((procedure? old-definition) + (if (generic-capability? old-definition) old-definition + (make #:name name #:default old-definition))) + (else (make #:name name)))) ;; same semantics as (define-syntax define-accessor @@ -404,34 +401,32 @@ (define (make-setter-name name) (string->symbol (string-append "setter:" (symbol->string name)))) -(define (make-accessor . name) - (let ((name (and (pair? name) (car name)))) - (make - #:name name - #:setter (make - #:name (and name (make-setter-name name)))))) +(define* (make-accessor #:optional name) + (make + #:name name + #:setter (make + #:name (and name (make-setter-name name))))) -(define (ensure-accessor proc . name) - (let ((name (and (pair? name) (car name)))) - (cond ((and (is-a? proc ) - (is-a? (setter proc) )) - proc) - ((is-a? proc ) - (upgrade-accessor proc (setter proc))) - ((is-a? proc ) - (upgrade-accessor proc (make-generic name))) - ((procedure-with-setter? proc) - (make - #:name name - #:default (procedure proc) - #:setter (ensure-generic (setter proc) name))) - ((procedure? proc) - (ensure-accessor (if (generic-capability? proc) - (make #:name name #:default proc) - (ensure-generic proc name)) - name)) - (else - (make-accessor name))))) +(define* (ensure-accessor proc #:optional name) + (cond ((and (is-a? proc ) + (is-a? (setter proc) )) + proc) + ((is-a? proc ) + (upgrade-accessor proc (setter proc))) + ((is-a? proc ) + (upgrade-accessor proc (make-generic name))) + ((procedure-with-setter? proc) + (make + #:name name + #:default (procedure proc) + #:setter (ensure-generic (setter proc) name))) + ((procedure? proc) + (ensure-accessor (if (generic-capability? proc) + (make #:name name #:default proc) + (ensure-generic proc name)) + name)) + (else + (make-accessor name)))) (define (upgrade-accessor generic setter) (let ((methods (slot-ref generic 'methods)) From 319dd08936ec2d14272f68c16f778c411ed4b505 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jul 2011 12:21:48 +0200 Subject: [PATCH 18/37] fix invocation of duplicate handlers for merge-generics * libguile/modules.c (resolve_duplicate_binding): Fix unbound -> #f conversion for the imported bindings. Pass the existing entry in the import obarray as the resolved var (7th arg), and properly pass #f as the value (8th arg) if there is no such binding. Fixes merge-generics; before, the type test (indicating no previous value) was not being triggered. This bug has been present since 2007 at least, though it was not in 1.8. * test-suite/tests/modules.test ("duplicate bindings"): Add a test that the var and val are both #f. These types are used by GOOPS. --- libguile/modules.c | 73 +++++++++++++++++++++-------------- test-suite/tests/modules.test | 4 ++ 2 files changed, 47 insertions(+), 30 deletions(-) diff --git a/libguile/modules.c b/libguile/modules.c index ca8875dab..6c3f2629e 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -294,39 +294,46 @@ resolve_duplicate_binding (SCM module, SCM sym, SCM iface1, SCM var1, SCM iface2, SCM var2) { + SCM args[8]; + SCM handlers; SCM result = SCM_BOOL_F; - if (!scm_is_eq (var1, var2)) + if (scm_is_eq (var1, var2)) + return var1; + + args[0] = module; + args[1] = sym; + args[2] = iface1; + args[3] = SCM_VARIABLE_REF (var1); + if (SCM_UNBNDP (args[3])) + args[3] = SCM_BOOL_F; + args[4] = iface2; + args[5] = SCM_VARIABLE_REF (var2); + if (SCM_UNBNDP (args[5])) + args[5] = SCM_BOOL_F; + args[6] = scm_hashq_ref (SCM_MODULE_IMPORT_OBARRAY (module), sym, SCM_BOOL_F); + args[7] = SCM_BOOL_F; + + handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); + if (scm_is_false (handlers)) + handlers = default_duplicate_binding_handlers (); + + for (; scm_is_pair (handlers); handlers = SCM_CDR (handlers)) { - SCM val1, val2; - SCM handlers, h, handler_args; + if (scm_is_true (args[6])) + { + args[7] = SCM_VARIABLE_REF (args[6]); + if (SCM_UNBNDP (args[7])) + args[7] = SCM_BOOL_F; + } + + result = scm_call_n (SCM_CAR (handlers), args, 8); - val1 = SCM_VARIABLE_REF (var1); - val2 = SCM_VARIABLE_REF (var2); - - val1 = scm_is_eq (val1, SCM_UNSPECIFIED) ? SCM_BOOL_F : val1; - val2 = scm_is_eq (val2, SCM_UNSPECIFIED) ? SCM_BOOL_F : val2; - - handlers = SCM_MODULE_DUPLICATE_HANDLERS (module); - if (scm_is_false (handlers)) - handlers = default_duplicate_binding_handlers (); - - handler_args = scm_list_n (module, sym, - iface1, val1, iface2, val2, - var1, val1, - SCM_UNDEFINED); - - for (h = handlers; - scm_is_pair (h) && scm_is_false (result); - h = SCM_CDR (h)) - { - result = scm_apply (SCM_CAR (h), handler_args, SCM_EOL); - } + if (scm_is_true (result)) + return result; } - else - result = var1; - return result; + return SCM_BOOL_F; } /* No lock is needed for access to this variable, as there are no @@ -368,9 +375,15 @@ module_imported_variable (SCM module, SCM sym) { /* SYM is a duplicate binding (imported more than once) so we need to resolve it. */ - found_var = resolve_duplicate_binding (module, sym, - found_iface, found_var, - iface, var); + found_var = resolve_duplicate_binding (module, sym, + found_iface, found_var, + iface, var); + + /* Note that it could be that FOUND_VAR doesn't belong + either to FOUND_IFACE or to IFACE, if it was created + by merge-generics. The right thing to do there would + be to treat the import obarray as the iface, but the + import obarray isn't actually a module. Oh well. */ if (scm_is_eq (found_var, var)) found_iface = iface; } diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test index 5f34d9e70..79e3c98e9 100644 --- a/test-suite/tests/modules.test +++ b/test-suite/tests/modules.test @@ -290,6 +290,10 @@ (import2 (make-module)) (handler-invoked? #f) (handler (lambda (module name int1 val1 int2 val2 var val) + ;; We expect both VAR and VAL to be #f, as there + ;; is no previous binding for 'imported in M. + (if var (error "unexpected var" var)) + (if val (error "unexpected val" val)) (set! handler-invoked? #t) ;; Keep the first binding. (or var (module-local-variable int1 name))))) From ae88d9bcf622baa6745a91fafb9be2fb331ad6c0 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 7 Jul 2011 12:45:30 +0200 Subject: [PATCH 19/37] fix CPL of and * libguile/goops.c (fix_cpl): Fix bug in placement of debug assertion. (create_standard_classes): Put before in 's direct supers, so that the slot allocation is a superset of , which results in the `setter' being allocated in the same place. Likewise fix to place before , not just . --- libguile/goops.c | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/libguile/goops.c b/libguile/goops.c index dfe26c30d..c2eb88ffe 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2280,15 +2280,21 @@ SCM_DEFINE (scm_sys_method_more_specific_p, "%method-more-specific?", 3, 0, 0, * ******************************************************************************/ +/* Munge the CPL of C in place such that BEFORE appears before AFTER, + assuming that currently the reverse is true. Recalculate slots and + associated getters-n-setters. */ static void fix_cpl (SCM c, SCM before, SCM after) { SCM cpl = SCM_SLOT (c, scm_si_cpl); SCM ls = scm_c_memq (after, cpl); - SCM tail = scm_delq1_x (before, SCM_CDR (ls)); + SCM tail; + if (scm_is_false (ls)) /* if this condition occurs, fix_cpl should not be applied this way */ abort (); + + tail = scm_delq1_x (before, SCM_CDR (ls)); SCM_SETCAR (ls, before); SCM_SETCDR (ls, scm_cons (after, tail)); { @@ -2414,8 +2420,8 @@ create_standard_classes (void) make_stdcls (&scm_class_extended_generic_with_setter, "", scm_class_applicable_struct_class, - scm_list_2 (scm_class_generic_with_setter, - scm_class_extended_generic), + scm_list_2 (scm_class_extended_generic, + scm_class_generic_with_setter), SCM_EOL); SCM_SET_CLASS_FLAGS (scm_class_extended_generic_with_setter, SCM_CLASSF_PURE_GENERIC); @@ -2424,8 +2430,9 @@ create_standard_classes (void) scm_list_2 (scm_class_accessor, scm_class_extended_generic_with_setter), SCM_EOL); + /* is misplaced. */ fix_cpl (scm_class_extended_accessor, - scm_class_extended_generic, scm_class_generic); + scm_class_extended_generic, scm_class_generic_with_setter); SCM_SET_CLASS_FLAGS (scm_class_extended_accessor, SCM_CLASSF_PURE_GENERIC); /* Primitive types classes */ From 2a8b3b80502e7f5ac9da462c15525858409b1909 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 Jul 2011 09:24:14 +0200 Subject: [PATCH 20/37] Add document describing the release process. * doc/release.org: New file. --- doc/release.org | 164 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 164 insertions(+) create mode 100644 doc/release.org diff --git a/doc/release.org b/doc/release.org new file mode 100644 index 000000000..0d18be383 --- /dev/null +++ b/doc/release.org @@ -0,0 +1,164 @@ +#+TITLE: Release Process for GNU Guile 2.0 +#+AUTHOR: Ludovic Courtès +#+EMAIL: ludo@gnu.org + +This document describes the typical release process for Guile 2.0. + +* Preparing & uploading the tarball + +** Update Gnulib + +The commit log's first line should be "Update Gnulib to X", where X is +the output of `git describe' in the Gnulib repo. + +This allows us to keep track of the source code we use, in case a bug or +security vulnerability gets fixed in Gnulib sometime later. + +Ideally update Gnulib several days prior to the release, so that +portability or build issues can be uncovered in time. + +** Make sure it works, portably, and with different configurations + +*** Check [[http://hydra.nixos.org/jobset/gnu/guile-2-0][Hydra]] + +This contains builds and cross-builds on different platforms, with +different `configure' switches, different CPPFLAGS, and different +versions of the compiler. + +As of this writing, there are unfixed failures. For instance Darwin's +compiler randomly crashes, preventing build completion; the FreeBSD 7.x +box experiences Guile crashes while running the test suite, which were +not fixed because not reproduced elsewhere. Even for these platforms, +make sure "things don't get worse", at least. + +*** Check [[http://autobuild.josefsson.org/guile/][Autobuild]] + +This contains build reports from other people, typically on lesser used +platforms, so it's worth checking. + +*** Use the [[http://gcc.gnu.org/wiki/CompileFarm][GCC Compile Farm]] + +Use the GCC Compile Farm to check on lesser used architectures or +operating systems. In particular, the Farm has ARM, SPARC64, PowerPC, +and MIPS GNU/Linux boxes (remember that this is not superfluous: Debian +builds on 11 architectures). It also has FreeBSD and NetBSD boxes. + +*** Use porter boxes + +If you're still in a good mood, you may also want to check on porter +boxes for other OSes. The GNU/Hurd people have [[http://www.gnu.org/software/hurd/public_hurd_boxen.html][porter boxes]], so does +the [[http://www.opencsw.org/standards/build_farm][OpenCSW Solaris Team]]. + +** Update `GUILE-VERSION' + +For stable releases, make sure to update the SONAME appropriately. To +that end, review the commit logs for libguile in search of any C ABI +changes (new functions added, existing functions deprecated, etc.) +Change `LIBGUILE_INTERFACE_*' accordingly. Re-read the Libtool manual +if in doubt. + +`libguile/libguile.map' should also be updated as new public symbols are +added. Ideally, new symbols should get under a new version +symbol---e.g., `GUILE_2.0.3' for symbols introduced in Guile 2.0.3. +However, this has not been done for Guile <= 2.0.2. + +** Tag v2.0.x + +Create a signed Git tag, like this: + + $ git tag -s u MY-KEY -m "GNU Guile 2.0.X." v2.0.X + +The tag *must* be `v2.0.X'. For the sake of consistency, always use +"GNU Guile 2.0.X." as the tag comment. + +** Push the tag and changes + + $ git push && git push --tags + +Normally nobody committed in the meantime. ;-) + +** Run "make dist" + +This should trigger an `autoreconf', as `build-aux/git-version-gen' +notices the new tag. After "make dist", double-check that `./configure +--version' reports the new version number. + +The reason for running "make dist" instead of "make distcheck" is that +it's much faster and any distribution issues should have been caught by +Hydra already. + +** Upload + + $ ./build-aux/gnupload --to ftp.gnu.org:guile guile-2.0.X.tar.gz + +You'll get an email soon after when the upload is complete. + +Your GPG public key must be registered for this to work (info +"(maintain) Automated Upload Registration"). + +Make sure to publish your public key on public OpenPGP servers +(keys.gnupg.net, pgp.mit.edu, etc.), so that people can actually use it +to check the authenticity and integrity of the tarball. + +** Download + +Make sure the file was uploaded and is available for download as +expected: + + $ mkdir t && cd t && wget ftp.gnu.org/gnu/guile/guile-2.0.X.tar.gz + $ diff guile-2.0.X.tar.gz ../guile-2.0.X.tar.gz + +You're almost done! + +* Announcements + +First, re-read the GNU Maintainers Guide on this topic (info "(maintain) +Announcements"). + +** Update web pages + + - Replace any references to the previous version number and replace it + with the new one. + - Update news.html. + +** Update the on-line copy of the manual + + - Use `build-aux/gendocs', add to the manual/ directory of the web + site. + +** Prepare the email announcement + + $ build-aux/announce-gen --release-type=stable --package-name=guile \ + --previous-version=2.0.1 --current-version=2.0.2 \ + --gpg-key-id=MY-KEY --url-directory=ftp://ftp.gnu.org/gnu/guile \ + --bootstrap-tools=autoconf,automake,libtool,gnulib \ + --gnulib-version=$( cd ~/src/gnulib ; git describe ) + +The subject must be "GNU Guile 2.0.X released". The text should remain +formal and impersonal (it is sent on behalf of the Guile and GNU +projects.) It must include a description of what Guile is (not everyone +reading info-gnu may know about it.) Use the text of previous +announcements as a template. + +Below the initial boilerplate that describes Guile should come the +output of `announce-gen', and then the `NEWS' file excerpt in its +entirety (don't call it a change log since that's not what it is.) + +** Send the email announcement + + - guile-user@gnu.org, guile-devel@gnu.org, guile-sources@gnu.org + - info-gnu@gnu.org (for stable releases only!) + - comp.lang.scheme + +** Post a news on [[http://sv.gnu.org/p/guile/][Savannah]] + +The news will end up on planet.gnu.org. The text can be shorter and +more informal, with a link to the email announcement for details. + + + +Copyright © 2011 Free Software Foundation, Inc. + + Copying and distribution of this file, with or without modification, + are permitted in any medium without royalty provided the copyright + notice and this notice are preserved. From 1fe9920adc80fa7ff59020b13479e5bedeed4401 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 Jul 2011 09:26:32 +0200 Subject: [PATCH 21/37] Disable TLS on NetBSD up to 5.x included. * acinclude.m4 (GUILE_THREAD_LOCAL_STORAGE): Disable TLS on `x86_64-unknown-netbsd5.1' too. --- acinclude.m4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/acinclude.m4 b/acinclude.m4 index c930444a3..ba17e939a 100644 --- a/acinclude.m4 +++ b/acinclude.m4 @@ -374,13 +374,14 @@ AC_DEFUN([GUILE_THREAD_LOCAL_STORAGE], [ dnl dnl Known broken systems includes: dnl - x86_64-unknown-netbsd5.0. + dnl - x86_64-unknown-netbsd5.1 dnl - sparc-sun-solaris2.8 dnl dnl On `x86_64-unknown-freebsd8.0', thread-local storage appears to dnl be reclaimed at the wrong time, leading to a segfault when dnl running `threads.test'. So disable it. case "$enable_shared--$host_os" in - [yes--netbsd[0-5].[0-9].|yes--solaris2.8|yes--freebsd[0-8]*]) + [yes--netbsd[0-5].[0-9]*|yes--solaris2.8|yes--freebsd[0-8]*]) ac_cv_have_thread_storage_class="no" ;; *) From 3565df4546d97da4be573610a73f333d45a6287a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 Jul 2011 23:08:42 +0200 Subject: [PATCH 22/37] Define `O_NOTRANS' on GNU/Hurd. * libguile/filesys.c (scm_init_filesys): Define `O_NOTRANS' when available. --- libguile/filesys.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index ceec87776..5e547a493 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1856,7 +1856,10 @@ scm_init_filesys () #endif #ifdef O_LARGEFILE scm_c_define ("O_LARGEFILE", scm_from_int (O_LARGEFILE)); -#endif +#endif +#ifdef O_NOTRANS + scm_c_define ("O_NOTRANS", scm_from_int (O_NOTRANS)); +#endif #ifdef F_DUPFD scm_c_define ("F_DUPFD", scm_from_int (F_DUPFD)); From 126a32243146d9ad238a3a5adb8d6af5a87ad2aa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 12 Jul 2011 23:57:57 +0200 Subject: [PATCH 23/37] Fix `open' mode bits on GNU/Hurd. * libguile/filesys.c (scm_open): Fix check for read-write flags for systems such as GNU/Hurd, where O_RDWR == (O_WRONLY | O_RDONLY) and O_RDONLY != 0. --- libguile/filesys.c | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/libguile/filesys.c b/libguile/filesys.c index 5e547a493..f60032818 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -261,8 +261,10 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, fd = scm_to_int (scm_open_fdes (path, flags, mode)); iflags = SCM_NUM2INT (2, flags); - if (iflags & O_RDWR) + + if ((iflags & O_RDWR) == O_RDWR) { + /* Opened read-write. */ if (iflags & O_APPEND) port_mode = "a+"; else if (iflags & O_CREAT) @@ -270,14 +272,17 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, else port_mode = "r+"; } - else { - if (iflags & O_APPEND) - port_mode = "a"; - else if (iflags & O_WRONLY) - port_mode = "w"; - else - port_mode = "r"; - } + else + { + /* Opened read-only or write-only. */ + if (iflags & O_APPEND) + port_mode = "a"; + else if (iflags & O_WRONLY) + port_mode = "w"; + else + port_mode = "r"; + } + newpt = scm_fdes_to_port (fd, port_mode, path); return newpt; } From 680c8c5a99e6abe040752c3471cd42a9516842b6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 15 Jul 2011 12:49:46 +0200 Subject: [PATCH 24/37] add (web client) * module/web/client.scm: New module, a simple synchronous web client. * module/Makefile.am (WEB_SOURCES): Add to the build. --- module/Makefile.am | 1 + module/web/client.scm | 115 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 116 insertions(+) create mode 100644 module/web/client.scm diff --git a/module/Makefile.am b/module/Makefile.am index b21b73c77..2357e1946 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -356,6 +356,7 @@ LIB_SOURCES = \ texinfo/serialize.scm WEB_SOURCES = \ + web/client.scm \ web/http.scm \ web/request.scm \ web/response.scm \ diff --git a/module/web/client.scm b/module/web/client.scm new file mode 100644 index 000000000..321c7dba0 --- /dev/null +++ b/module/web/client.scm @@ -0,0 +1,115 @@ +;;; Web client + +;; Copyright (C) 2011 Free Software Foundation, Inc. + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +;; 02110-1301 USA + +;;; Commentary: +;;; +;;; (web client) is a simple HTTP URL fetcher for Guile. +;;; +;;; In its current incarnation, (web client) is synchronous. If you +;;; want to fetch a number of URLs at once, probably the best thing to +;;; do is to write an event-driven URL fetcher, similar in structure to +;;; the web server. +;;; +;;; Another option, good but not as performant, would be to use threads, +;;; possibly via par-map or futures. +;;; +;;; Code: + +(define-module (web client) + #:use-module (rnrs bytevectors) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 rdelim) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (open-socket-for-uri + http-get)) + +(define (open-socket-for-uri uri) + (let* ((ai (car (getaddrinfo (uri-host uri) + (cond + ((uri-port uri) => number->string) + (else (symbol->string (uri-scheme uri))))))) + (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (addrinfo:protocol ai)))) + (connect s (addrinfo:addr ai)) + ;; Buffer input and output on this port. + (setvbuf s _IOFBF) + ;; Enlarge the receive buffer. + (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) + s)) + +(define (decode-string bv encoding) + (if (string-ci=? encoding "utf-8") + (utf8->string bv) + (let ((p (open-bytevector-input-port bv))) + (set-port-encoding! p encoding) + (let ((res (read-delimited "" p))) + (close-port p) + res)))) + +(define (text-type? type) + (let ((type (symbol->string type))) + (or (string-prefix? "text/" type) + (string-suffix? "/xml" type) + (string-suffix? "+xml" type)))) + +;; Logically the inverse of (web server)'s `sanitize-response'. +;; +(define (decode-response-body response body) + ;; `body' is either #f or a bytevector. + (cond + ((not body) body) + ((bytevector? body) + (let ((rlen (response-content-length response)) + (blen (bytevector-length body))) + (cond + ((and rlen (not (= rlen blen))) + (error "bad content-length" rlen blen)) + ((response-content-type response) + => (lambda (type) + (cond + ((text-type? (car type)) + (decode-string body (or (assq-ref (cdr type) 'charset) + "iso-8859-1"))) + (else body)))) + (else body)))) + (else + (error "unexpected body type" body)))) + +(define* (http-get uri #:key (port (open-socket-for-uri uri)) + (version '(1 . 1)) (keep-alive? #f) (extra-headers '()) + (decode-body? #t)) + (let ((req (build-request uri #:version version + #:headers (if keep-alive? + extra-headers + (cons '(connection close) + extra-headers))))) + (write-request req port) + (force-output port) + (if (not keep-alive?) + (shutdown port 1)) + (let* ((res (read-response port)) + (body (read-response-body res))) + (if (not keep-alive?) + (close-port port)) + (values res + (if decode-body? + (decode-response-body res body) + body))))) From 037a68032165a2f1e4c0311baa9f69e2a05c3326 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 15 Jul 2011 13:08:45 +0200 Subject: [PATCH 25/37] ensure presence of Host header in HTTP/1.1 requests * module/web/request.scm (build-request): Make sure that HTTP/1.1 requests have the Host header set, per RFC 2616 section 9. * test-suite/tests/web-request.test ("example-1"): Add test. --- module/web/request.scm | 40 +++++++++++++++++++------------ test-suite/tests/web-request.test | 4 ++++ 2 files changed, 29 insertions(+), 15 deletions(-) diff --git a/module/web/request.scm b/module/web/request.scm index 84119205f..c9204a4bf 100644 --- a/module/web/request.scm +++ b/module/web/request.scm @@ -151,21 +151,31 @@ (validate-headers? #t)) "Construct an HTTP request object. If @var{validate-headers?} is true, the headers are each run through their respective validators." - (cond - ((not (and (pair? version) - (non-negative-integer? (car version)) - (non-negative-integer? (cdr version)))) - (bad-request "Bad version: ~a" version)) - ((not (uri? uri)) - (bad-request "Bad uri: ~a" uri)) - ((and (not port) (memq method '(POST PUT))) - (bad-request "Missing port for message ~a" method)) - ((not (list? meta)) - (bad-request "Bad metadata alist" meta)) - (else - (if validate-headers? - (validate-headers headers)))) - (make-request method uri version headers meta port)) + (let ((needs-host? (and (equal? version '(1 . 1)) + (not (assq-ref headers 'host))))) + (cond + ((not (and (pair? version) + (non-negative-integer? (car version)) + (non-negative-integer? (cdr version)))) + (bad-request "Bad version: ~a" version)) + ((not (uri? uri)) + (bad-request "Bad uri: ~a" uri)) + ((and (not port) (memq method '(POST PUT))) + (bad-request "Missing port for message ~a" method)) + ((not (list? meta)) + (bad-request "Bad metadata alist" meta)) + ((and needs-host? (not (uri-host uri))) + (bad-request "HTTP/1.1 request without Host header and no host in URI: ~a" + uri)) + (else + (if validate-headers? + (validate-headers headers)))) + (make-request method uri version + (if needs-host? + (acons 'host (cons (uri-host uri) (uri-port uri)) + headers) + headers) + meta port))) (define* (read-request port #:optional (meta '())) "Read an HTTP request from @var{port}, optionally attaching the given diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test index e1eec2f74..b1182d2ff 100644 --- a/test-suite/tests/web-request.test +++ b/test-suite/tests/web-request.test @@ -47,6 +47,10 @@ Accept-Language: en-gb, en;q=0.9\r (set! r (read-request (open-input-string example-1))) (request? r))) + (pass-if (equal? + (request-host (build-request (string->uri "http://www.gnu.org/"))) + "www.gnu.org")) + (pass-if (equal? (request-method r) 'GET)) (pass-if (equal? (request-uri r) (build-uri 'http #:path "/qux"))) From ecfb148137e62fc4ca9d1b7319c5aa688cec997f Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 18 Jul 2011 10:37:46 +0200 Subject: [PATCH 26/37] fix web-request.test * test-suite/tests/web-request.test ("example-1"): Fix expected format of `host' header. --- test-suite/tests/web-request.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/web-request.test b/test-suite/tests/web-request.test index b1182d2ff..8cf1c2e87 100644 --- a/test-suite/tests/web-request.test +++ b/test-suite/tests/web-request.test @@ -49,7 +49,7 @@ Accept-Language: en-gb, en;q=0.9\r (pass-if (equal? (request-host (build-request (string->uri "http://www.gnu.org/"))) - "www.gnu.org")) + '("www.gnu.org" . #f))) (pass-if (equal? (request-method r) 'GET)) From 072624134b9d8b2aa37f619dc5f828d667c72737 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 Jul 2011 09:42:20 +0200 Subject: [PATCH 27/37] open-socket-for-url returns port in latin1 encoding * module/web/client.scm (open-socket-for-uri): Set port encoding to latin1, to see if this fixes Nalin Garut's problems. --- module/web/client.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/module/web/client.scm b/module/web/client.scm index 321c7dba0..6a04497cf 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -48,6 +48,7 @@ (else (symbol->string (uri-scheme uri))))))) (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) (addrinfo:protocol ai)))) + (set-port-encoding! s "ISO-8859-1") (connect s (addrinfo:addr ai)) ;; Buffer input and output on this port. (setvbuf s _IOFBF) From 9957641b603f79b070fc2be0bf511235fa764229 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Thu, 21 Jul 2011 10:36:13 +0200 Subject: [PATCH 28/37] add a site dir to %load-compiled-path * libguile/Makefile.am (libpath.h): Define SCM_SITE_CCACHE_DIR. Defined as site-ccache/ instead of site/ccache/ to indicate that we don't expect further subdirectories, and also to avoid confusion about whether extensions/ is a site-specific or not. * libguile/load.c (scm_init_load_path): Add SCM_SITE_CCACHE_DIR to the default load-compiled path. --- libguile/Makefile.am | 1 + libguile/load.c | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/libguile/Makefile.am b/libguile/Makefile.am index e69a1551e..1817100fd 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -647,6 +647,7 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status @echo '#define SCM_LIB_DIR "$(libdir)"' >> libpath.tmp @echo '#define SCM_EXTENSIONS_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/extensions"' >> libpath.tmp @echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp + @echo '#define SCM_SITE_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/site-ccache"' >> libpath.tmp @echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp @echo '#define SCM_BUILD_INFO { \' >> libpath.tmp @echo ' { "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp diff --git a/libguile/load.c b/libguile/load.c index 91309bb1e..de6bf7c60 100644 --- a/libguile/load.c +++ b/libguile/load.c @@ -270,7 +270,10 @@ scm_init_load_path () else if (env) cpath = scm_parse_path (scm_from_locale_string (env), cpath); else - cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath); + { + cpath = scm_list_2 (scm_from_locale_string (SCM_CCACHE_DIR), + scm_from_locale_string (SCM_SITE_CCACHE_DIR)); + } #endif /* SCM_LIBRARY_DIR */ From 5d48015adf47dad962b77bf464b352e7fd2aead6 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2011 13:52:51 +0200 Subject: [PATCH 29/37] a prettier `guild list' * module/scripts/list.scm (strip-extensions): Don't list programs without extensions. (main): Be prettier. Parse out a %summary from modules, for a brief synopsis. --- module/scripts/list.scm | 37 +++++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/module/scripts/list.scm b/module/scripts/list.scm index c4891b6a8..6ffc01629 100644 --- a/module/scripts/list.scm +++ b/module/scripts/list.scm @@ -26,6 +26,7 @@ ;;; Code: (define-module (scripts list) + #:use-module (ice-9 format) #:use-module ((srfi srfi-1) #:select (fold append-map)) #:export (list-scripts)) @@ -50,6 +51,10 @@ (or-map (lambda (ext) (and (string-suffix? ext path) + ;; We really can't be adding e.g. ChangeLog-2008 to the set + ;; of runnable scripts, just because "" is a valid + ;; extension, by default. So hack around that here. + (not (string-null? ext)) (substring path 0 (- (string-length path) (string-length ext))))) (append %load-compiled-extensions %load-extensions))) @@ -74,10 +79,30 @@ %load-path) stringsymbol name))) + (mod (resolve-module modname #:ensure #f)) + (summary (and mod (and=> (module-variable mod '%summary) + variable-ref)))) + (if summary + (format #t " ~A ~32t~a\n" name summary) + (format #t " ~A\n" name)))) + (find-submodules '(scripts))) + + (display "\ + +If COMMAND is \"list\" or omitted, display available scripts, otherwise +COMMAND is run with ARGS. +")) From d322dc92ec8170320c68abc024eb683a0bf8ab00 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2011 13:54:28 +0200 Subject: [PATCH 30/37] remove scripts PROGRAM * module/scripts/PROGRAM.scm: Remove this useless template, which was cluttering `guild list'. We'll perhaps cull the list a bit more in 2.2. * module/Makefile.am: Adapt. --- module/Makefile.am | 1 - module/scripts/PROGRAM.scm | 40 -------------------------------------- 2 files changed, 41 deletions(-) delete mode 100644 module/scripts/PROGRAM.scm diff --git a/module/Makefile.am b/module/Makefile.am index 2357e1946..33d70bd95 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -146,7 +146,6 @@ BRAINFUCK_LANG_SOURCES = \ language/brainfuck/spec.scm SCRIPTS_SOURCES = \ - scripts/PROGRAM.scm \ scripts/autofrisk.scm \ scripts/compile.scm \ scripts/disassemble.scm \ diff --git a/module/scripts/PROGRAM.scm b/module/scripts/PROGRAM.scm deleted file mode 100644 index 56e5cf334..000000000 --- a/module/scripts/PROGRAM.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; PROGRAM --- Does something - -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. -;; -;; This program is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public License -;; as published by the Free Software Foundation; either version 3, or -;; (at your option) any later version. -;; -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. -;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this software; see the file COPYING.LESSER. If -;; not, write to the Free Software Foundation, Inc., 51 Franklin -;; Street, Fifth Floor, Boston, MA 02110-1301 USA - -;;; Author: J.R.Hacker - -;;; Commentary: - -;; Usage: PROGRAM [ARGS] -;; -;; PROGRAM does something. -;; -;; TODO: Write it! - -;;; Code: - -(define-module (scripts PROGRAM) - :export (PROGRAM)) - -(define (PROGRAM . args) - #t) - -(define main PROGRAM) - -;;; PROGRAM ends here From a1a2ed534278b968767727485f84e5957c039c23 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2011 17:50:37 +0200 Subject: [PATCH 31/37] more work on "guild list" * module/scripts/: Add %summary entries, and in many cases, %include-in-guild-list entries to inhibit a script from appearing in "guild list". Update list.scm to respect this new variable. --- module/scripts/api-diff.scm | 5 +++- module/scripts/autofrisk.scm | 5 +++- module/scripts/compile.scm | 2 ++ module/scripts/disassemble.scm | 4 ++- module/scripts/display-commentary.scm | 4 ++- module/scripts/doc-snarf.scm | 4 ++- module/scripts/frisk.scm | 5 +++- module/scripts/generate-autoload.scm | 5 +++- module/scripts/lint.scm | 3 ++ module/scripts/list.scm | 29 ++++++++++++------- module/scripts/punify.scm | 3 ++ module/scripts/read-rfc822.scm | 5 +++- module/scripts/read-scheme-source.scm | 5 +++- module/scripts/read-text-outline.scm | 5 +++- module/scripts/scan-api.scm | 5 +++- .../scripts/snarf-check-and-output-texi.scm | 5 +++- module/scripts/snarf-guile-m4-docs.scm | 5 +++- module/scripts/summarize-guile-TODO.scm | 5 +++- module/scripts/use2dot.scm | 4 ++- 19 files changed, 83 insertions(+), 25 deletions(-) diff --git a/module/scripts/api-diff.scm b/module/scripts/api-diff.scm index b842b03ff..b2527b9e9 100644 --- a/module/scripts/api-diff.scm +++ b/module/scripts/api-diff.scm @@ -1,6 +1,6 @@ ;;; api-diff --- diff guile-api.alist files -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -46,6 +46,9 @@ :autoload (srfi srfi-13) (string-tokenize) :export (api-diff)) +(define %include-in-guild-list #f) +(define %summary "Show differences between two scan-api files.") + (define (read-alist-file file) (with-input-from-file file (lambda () (read)))) diff --git a/module/scripts/autofrisk.scm b/module/scripts/autofrisk.scm index 943c90227..9bce06e2a 100644 --- a/module/scripts/autofrisk.scm +++ b/module/scripts/autofrisk.scm @@ -1,6 +1,6 @@ ;;; autofrisk --- Generate module checks for use with auto* tools -;; Copyright (C) 2002, 2006, 2009 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2009, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -62,6 +62,9 @@ :use-module (scripts frisk) :export (autofrisk)) +(define %include-in-guild-list #f) +(define %summary "Generate snippets for use in configure.ac files.") + (define *recognized-keys* '(files-glob non-critical-external non-critical-internal diff --git a/module/scripts/compile.scm b/module/scripts/compile.scm index f9d6cca99..0651c6804 100644 --- a/module/scripts/compile.scm +++ b/module/scripts/compile.scm @@ -37,6 +37,8 @@ #:use-module (ice-9 format) #:export (compile)) +(define %summary "Compile a file.") + (define (fail . messages) (format (current-error-port) "error: ~{~a~}~%" messages) diff --git a/module/scripts/disassemble.scm b/module/scripts/disassemble.scm index 8907f6d08..7dab2dde9 100644 --- a/module/scripts/disassemble.scm +++ b/module/scripts/disassemble.scm @@ -1,6 +1,6 @@ ;;; Disassemble --- Disassemble .go files into something human-readable -;; Copyright 2005, 2008, 2009 Free Software Foundation, Inc. +;; Copyright 2005, 2008, 2009, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -32,6 +32,8 @@ #:renamer (symbol-prefix-proc 'asm:)) #:export (disassemble)) +(define %summary "Disassemble a compiled .go file.") + (define (disassemble . files) (for-each (lambda (file) (asm:disassemble (load-objcode file))) diff --git a/module/scripts/display-commentary.scm b/module/scripts/display-commentary.scm index 5bd249ce9..81d7907af 100644 --- a/module/scripts/display-commentary.scm +++ b/module/scripts/display-commentary.scm @@ -1,6 +1,6 @@ ;;; display-commentary --- As advertized -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -33,6 +33,8 @@ :use-module (ice-9 documentation) :export (display-commentary)) +(define %summary "Display the Commentary section from a file or module.") + (define (display-commentary-one file) (format #t "~A commentary:\n~A" file (file-commentary file))) diff --git a/module/scripts/doc-snarf.scm b/module/scripts/doc-snarf.scm index b7fbc996e..fa3dfb312 100644 --- a/module/scripts/doc-snarf.scm +++ b/module/scripts/doc-snarf.scm @@ -1,6 +1,6 @@ ;;; doc-snarf --- Extract documentation from source files -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -83,6 +83,8 @@ This procedure foos, or bars, depending on the argument @var{braz}. :use-module (ice-9 rdelim) :export (doc-snarf)) +(define %summary "Snarf out documentation from a file.") + (define command-synopsis '((version (single-char #\v) (value #f)) (help (single-char #\h) (value #f)) diff --git a/module/scripts/frisk.scm b/module/scripts/frisk.scm index c452ede25..a8f79232d 100644 --- a/module/scripts/frisk.scm +++ b/module/scripts/frisk.scm @@ -1,6 +1,6 @@ ;;; frisk --- Grok the module interfaces of a body of files -;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -103,6 +103,9 @@ mod-up-ls mod-down-ls mod-int? edge-type edge-up edge-down)) +(define %include-in-guild-list #f) +(define %summary "Show dependency information for a module.") + (define *default-module* '(guile-user)) (define (grok-proc default-module note-use!) diff --git a/module/scripts/generate-autoload.scm b/module/scripts/generate-autoload.scm index 781931015..90f524b06 100644 --- a/module/scripts/generate-autoload.scm +++ b/module/scripts/generate-autoload.scm @@ -1,6 +1,6 @@ ;;; generate-autoload --- Display define-module form with autoload info -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -59,6 +59,9 @@ (define-module (scripts generate-autoload) :export (generate-autoload)) +(define %include-in-guild-list #f) +(define %summary "Generate #:autoload clauses for a module.") + (define (autoload-info file) (let ((p (open-input-file file))) (let loop ((form (read p)) (module-name #f) (exports '())) diff --git a/module/scripts/lint.scm b/module/scripts/lint.scm index aa74fb6a7..cea425ea9 100644 --- a/module/scripts/lint.scm +++ b/module/scripts/lint.scm @@ -105,6 +105,9 @@ #:use-module (ice-9 format) #:export (lint)) +(define %include-in-guild-list #f) +(define %summary "Check for bugs and style errors in a Scheme file.") + (define (lint filename) (let ((module-name (scan-file-for-module-name filename)) (free-vars (uniq (scan-file-for-free-variables filename)))) diff --git a/module/scripts/list.scm b/module/scripts/list.scm index 6ffc01629..55dbef264 100644 --- a/module/scripts/list.scm +++ b/module/scripts/list.scm @@ -30,6 +30,9 @@ #:use-module ((srfi srfi-1) #:select (fold append-map)) #:export (list-scripts)) +(define %include-in-guild-list #f) +(define %summary "List available guild commands.") + (define (directory-files dir) (if (and (file-exists? dir) (file-is-directory? dir)) @@ -90,16 +93,22 @@ Usage: guild COMMAND [ARGS] Commands: ") - (for-each - (lambda (name) - (let* ((modname `(scripts ,(string->symbol name))) - (mod (resolve-module modname #:ensure #f)) - (summary (and mod (and=> (module-variable mod '%summary) - variable-ref)))) - (if summary - (format #t " ~A ~32t~a\n" name summary) - (format #t " ~A\n" name)))) - (find-submodules '(scripts))) + (let ((all? (or (equal? args '("--all")) + (equal? args '("-a"))))) + (for-each + (lambda (name) + (let* ((modname `(scripts ,(string->symbol name))) + (mod (resolve-module modname #:ensure #f)) + (summary (and mod (and=> (module-variable mod '%summary) + variable-ref)))) + (if (and mod + (or all? + (let ((v (module-variable mod '%include-in-guild-list))) + (if v (variable-ref v) #t)))) + (if summary + (format #t " ~A ~23t~a\n" name summary) + (format #t " ~A\n" name))))) + (find-submodules '(scripts)))) (display "\ diff --git a/module/scripts/punify.scm b/module/scripts/punify.scm index 1627722d3..6b33ac5ee 100644 --- a/module/scripts/punify.scm +++ b/module/scripts/punify.scm @@ -41,6 +41,9 @@ (define-module (scripts punify) :export (punify)) +(define %include-in-guild-list #f) +(define %summary "Strip comments and whitespace from a Scheme file.") + (define (write-punily form) (cond ((and (list? form) (not (null? form))) (let ((first (car form))) diff --git a/module/scripts/read-rfc822.scm b/module/scripts/read-rfc822.scm index c0a54f28c..08f3fb9a1 100644 --- a/module/scripts/read-rfc822.scm +++ b/module/scripts/read-rfc822.scm @@ -1,6 +1,6 @@ ;;; read-rfc822 --- Validate RFC822 file by displaying it to stdout -;; Copyright (C) 2002, 2004, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2004, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -49,6 +49,9 @@ :autoload (srfi srfi-13) (string-join) :export (read-rfc822 read-rfc822-silently)) +(define %include-in-guild-list #f) +(define %summary "Validate an RFC822-style file.") + (define from-line-rx (make-regexp "^From ")) (define header-name-rx (make-regexp "^([^:]+):[ \t]*")) (define header-cont-rx (make-regexp "^[ \t]+")) diff --git a/module/scripts/read-scheme-source.scm b/module/scripts/read-scheme-source.scm index b48a88f9b..1bca6a4c4 100644 --- a/module/scripts/read-scheme-source.scm +++ b/module/scripts/read-scheme-source.scm @@ -1,6 +1,6 @@ ;;; read-scheme-source --- Read a file, recognizing scheme forms and comments -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -91,6 +91,9 @@ quoted? clump)) +(define %include-in-guild-list #f) +(define %summary "Print a parsed representation of a Scheme file.") + ;; Try to figure out what FORM is and its various attributes. ;; Call proc NOTE! with key (a symbol) and value. ;; diff --git a/module/scripts/read-text-outline.scm b/module/scripts/read-text-outline.scm index 64221fbe1..d0933bb0b 100644 --- a/module/scripts/read-text-outline.scm +++ b/module/scripts/read-text-outline.scm @@ -1,6 +1,6 @@ ;;; read-text-outline --- Read a text outline and display it as a sexp -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -118,6 +118,9 @@ :autoload (ice-9 rdelim) (read-line) :autoload (ice-9 getopt-long) (getopt-long)) +(define %include-in-guild-list #f) +(define %summary "Convert textual outlines to s-expressions.") + (define (?? symbol) (let ((name (symbol->string symbol))) (string=? "?" (substring name (1- (string-length name)))))) diff --git a/module/scripts/scan-api.scm b/module/scripts/scan-api.scm index 9236f8742..86d07fc3e 100644 --- a/module/scripts/scan-api.scm +++ b/module/scripts/scan-api.scm @@ -1,6 +1,6 @@ ;;; scan-api --- Scan and group interpreter and libguile interface elements -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -65,6 +65,9 @@ :use-module (ice-9 regex) :export (scan-api)) +(define %include-in-guild-list #f) +(define %summary "Generate an API description for a Guile extension.") + (define put set-object-property!) (define get object-property) diff --git a/module/scripts/snarf-check-and-output-texi.scm b/module/scripts/snarf-check-and-output-texi.scm index f92c833ed..6ca07a1f4 100644 --- a/module/scripts/snarf-check-and-output-texi.scm +++ b/module/scripts/snarf-check-and-output-texi.scm @@ -1,6 +1,6 @@ ;;; snarf-check-and-output-texi --- called by the doc snarfer. -;; Copyright (C) 2001, 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -26,6 +26,9 @@ :use-module (ice-9 match) :export (snarf-check-and-output-texi)) +(define %include-in-guild-list #f) +(define %summary "Transform snarfed .doc files into texinfo documentation.") + ;;; why aren't these in some module? (define-macro (when cond . body) diff --git a/module/scripts/snarf-guile-m4-docs.scm b/module/scripts/snarf-guile-m4-docs.scm index 05c305ebd..4e59f536d 100644 --- a/module/scripts/snarf-guile-m4-docs.scm +++ b/module/scripts/snarf-guile-m4-docs.scm @@ -1,6 +1,6 @@ ;;; snarf-guile-m4-docs --- Parse guile.m4 comments for texi documentation -;; Copyright (C) 2002, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -35,6 +35,9 @@ :use-module (ice-9 rdelim) :export (snarf-guile-m4-docs)) +(define %include-in-guild-list #f) +(define %summary "Snarf out texinfo documentation from .m4 files.") + (define (display-texi lines) (display "@deffn {Autoconf Macro}") (for-each (lambda (line) diff --git a/module/scripts/summarize-guile-TODO.scm b/module/scripts/summarize-guile-TODO.scm index ee4f88c1f..8b119e0ec 100644 --- a/module/scripts/summarize-guile-TODO.scm +++ b/module/scripts/summarize-guile-TODO.scm @@ -1,6 +1,6 @@ ;;; summarize-guile-TODO --- Display Guile TODO list in various ways -;; Copyright (C) 2002, 2006, 2010 Free Software Foundation, Inc. +;; Copyright (C) 2002, 2006, 2010, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -73,6 +73,9 @@ :autoload (ice-9 common-list) (remove-if-not) :export (summarize-guile-TODO)) +(define %include-in-guild-list #f) +(define %summary "A quaint relic of the past.") + (define put set-object-property!) (define get object-property) diff --git a/module/scripts/use2dot.scm b/module/scripts/use2dot.scm index ab97afbc7..975a9c4a4 100644 --- a/module/scripts/use2dot.scm +++ b/module/scripts/use2dot.scm @@ -1,6 +1,6 @@ ;;; use2dot --- Display module dependencies as a DOT specification -;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2006, 2011 Free Software Foundation, Inc. ;; ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public License @@ -53,6 +53,8 @@ :select (make-frisker edge-type edge-up edge-down)) :export (use2dot)) +(define %summary "Print a module's dependencies in graphviz format.") + (define *default-module* '(guile-user)) (define (q s) ; quote From f4a76a315ad8f1f6f4dbdfbd2f030c6b299cb5a4 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2011 18:24:16 +0200 Subject: [PATCH 32/37] add (scripts help) * meta/guild.in (display-version): Use (ice-9 command-line)'s version-etc. (main): Dispatch --help to guild help. * module/scripts/help.scm: New file, a copy of list.scm, but with a better name. * module/Makefile.am: Add help.scm to the list. * module/scripts/list.scm: Change to be an alias to "help". (list-scripts): Restore this API. --- meta/guild.in | 52 +++++++------------ module/Makefile.am | 1 + module/scripts/help.scm | 109 ++++++++++++++++++++++++++++++++++++++++ module/scripts/list.scm | 43 +++------------- 4 files changed, 137 insertions(+), 68 deletions(-) create mode 100644 module/scripts/help.scm diff --git a/meta/guild.in b/meta/guild.in index bb9c37e05..be4e5b5a3 100755 --- a/meta/guild.in +++ b/meta/guild.in @@ -25,6 +25,7 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" (define-module (guild) #:use-module (ice-9 getopt-long) + #:use-module (ice-9 command-line) #:autoload (ice-9 format) (format)) ;; Hack to provide scripts with the bug-report address. @@ -37,23 +38,11 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" '((help (single-char #\h)) (version (single-char #\v)))) -(define (display-help) - (display "\ -Usage: guild --version - guild --help - guild PROGRAM [ARGS] - -If PROGRAM is \"list\" or omitted, display available scripts, otherwise -PROGRAM is run with ARGS. -")) - (define (display-version) - (format #t "guild (GNU Guile ~A) ~A -Copyright (C) 2010 Free Software Foundation, Inc. -License LGPLv3+: GNU LGPL version 3 or later -This is free software: you are free to change and redistribute it. -There is NO WARRANTY, to the extent permitted by law. -" (version) (effective-version))) + (version-etc "GNU Guile" + (effective-version) + #:command-name "guild" + #:license *LGPLv3+*)) (define (find-script s) (resolve-module (list 'scripts (string->symbol s)) #:ensure #f)) @@ -62,27 +51,24 @@ There is NO WARRANTY, to the extent permitted by law. (if (defined? 'setlocale) (setlocale LC_ALL "")) - (let ((options (getopt-long args *option-grammar* - #:stop-at-first-non-option #t))) + (let* ((options (getopt-long args *option-grammar* + #:stop-at-first-non-option #t)) + (args (option-ref options '() '()))) (cond ((option-ref options 'help #f) - (display-help) + (apply (module-ref (resolve-module '(scripts help)) 'main) args) (exit 0)) ((option-ref options 'version #f) (display-version) (exit 0)) + ((find-script (if (null? args) "help" (car args))) + => (lambda (mod) + (exit (apply (module-ref mod 'main) (if (null? args) + '() + (cdr args)))))) (else - (let ((args (option-ref options '() '()))) - (cond ((find-script (if (null? args) - "list" - (car args))) - => (lambda (mod) - (exit (apply (module-ref mod 'main) (if (null? args) - '() - (cdr args)))))) - (else - (format (current-error-port) - "guild: unknown script ~s~%" (car args)) - (format (current-error-port) - "Try `guild --help' for more information.~%") - (exit 1)))))))) + (format (current-error-port) + "guild: unknown script ~s~%" (car args)) + (format (current-error-port) + "Try `guild help' for more information.~%") + (exit 1))))) diff --git a/module/Makefile.am b/module/Makefile.am index 33d70bd95..0787f2004 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -153,6 +153,7 @@ SCRIPTS_SOURCES = \ scripts/doc-snarf.scm \ scripts/frisk.scm \ scripts/generate-autoload.scm \ + scripts/help.scm \ scripts/lint.scm \ scripts/list.scm \ scripts/punify.scm \ diff --git a/module/scripts/help.scm b/module/scripts/help.scm new file mode 100644 index 000000000..9bb6ace9c --- /dev/null +++ b/module/scripts/help.scm @@ -0,0 +1,109 @@ +;;; Help --- Show help on guild commands + +;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free +;;;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;;; Boston, MA 02110-1301 USA + +;;; Commentary: + +;; Usage: help +;; +;; Show help for Guild scripts. + +;;; Code: + +(define-module (scripts help) + #:use-module (ice-9 format) + #:use-module ((srfi srfi-1) #:select (fold append-map))) + +(define %summary "Show a brief help message.") + + +(define (directory-files dir) + (if (and (file-exists? dir) (file-is-directory? dir)) + (let ((dir-stream (opendir dir))) + (let loop ((new (readdir dir-stream)) + (acc '())) + (if (eof-object? new) + (begin + (closedir dir-stream) + acc) + (loop (readdir dir-stream) + (if (or (string=? "." new) ; ignore + (string=? ".." new)) ; ignore + acc + (cons new acc)))))) + '())) + +(define (strip-extensions path) + (or-map (lambda (ext) + (and + (string-suffix? ext path) + ;; We really can't be adding e.g. ChangeLog-2008 to the set + ;; of runnable scripts, just because "" is a valid + ;; extension, by default. So hack around that here. + (not (string-null? ext)) + (substring path 0 + (- (string-length path) (string-length ext))))) + (append %load-compiled-extensions %load-extensions))) + +(define (unique l) + (cond ((null? l) l) + ((null? (cdr l)) l) + ((equal? (car l) (cadr l)) (unique (cdr l))) + (else (cons (car l) (unique (cdr l)))))) + +(define (find-submodules head) + (let ((shead (map symbol->string head))) + (unique + (sort + (append-map (lambda (path) + (fold (lambda (x rest) + (let ((stripped (strip-extensions x))) + (if stripped (cons stripped rest) rest))) + '() + (directory-files + (fold (lambda (x y) (in-vicinity y x)) path shead)))) + %load-path) + stringsymbol name))) + (mod (resolve-module modname #:ensure #f)) + (summary (and mod (and=> (module-variable mod '%summary) + variable-ref)))) + (if (and mod + (or all? + (let ((v (module-variable mod '%include-in-guild-list))) + (if v (variable-ref v) #t)))) + (if summary + (format #t " ~A ~23t~a\n" name summary) + (format #t " ~A\n" name))))) + (find-submodules '(scripts))))) diff --git a/module/scripts/list.scm b/module/scripts/list.scm index 55dbef264..0f1d715dd 100644 --- a/module/scripts/list.scm +++ b/module/scripts/list.scm @@ -26,12 +26,10 @@ ;;; Code: (define-module (scripts list) - #:use-module (ice-9 format) - #:use-module ((srfi srfi-1) #:select (fold append-map)) #:export (list-scripts)) (define %include-in-guild-list #f) -(define %summary "List available guild commands.") +(define %summary "An alias for \"help\".") (define (directory-files dir) @@ -82,36 +80,11 @@ %load-path) stringsymbol name))) - (mod (resolve-module modname #:ensure #f)) - (summary (and mod (and=> (module-variable mod '%summary) - variable-ref)))) - (if (and mod - (or all? - (let ((v (module-variable mod '%include-in-guild-list))) - (if v (variable-ref v) #t)))) - (if summary - (format #t " ~A ~23t~a\n" name summary) - (format #t " ~A\n" name))))) - (find-submodules '(scripts)))) - - (display "\ - -If COMMAND is \"list\" or omitted, display available scripts, otherwise -COMMAND is run with ARGS. -")) + (apply (@@ (scripts help) main) args)) From 4f0ea6e3cef32d54c1a276945b8885433a137b7c Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 23 Jul 2011 18:50:22 +0200 Subject: [PATCH 33/37] add support for guild help FOO * module/scripts/help.scm (main): Add support for guild help FOO. --- module/scripts/help.scm | 70 +++++++++++++++++++++++++++++++---------- 1 file changed, 53 insertions(+), 17 deletions(-) diff --git a/module/scripts/help.scm b/module/scripts/help.scm index 9bb6ace9c..665ba9f71 100644 --- a/module/scripts/help.scm +++ b/module/scripts/help.scm @@ -27,6 +27,7 @@ (define-module (scripts help) #:use-module (ice-9 format) + #:use-module (ice-9 documentation) #:use-module ((srfi srfi-1) #:select (fold append-map))) (define %summary "Show a brief help message.") @@ -80,7 +81,7 @@ %load-path) stringsymbol name))) - (mod (resolve-module modname #:ensure #f)) - (summary (and mod (and=> (module-variable mod '%summary) - variable-ref)))) - (if (and mod - (or all? - (let ((v (module-variable mod '%include-in-guild-list))) - (if v (variable-ref v) #t)))) - (if summary - (format #t " ~A ~23t~a\n" name summary) - (format #t " ~A\n" name))))) - (find-submodules '(scripts))))) + (for-each + (lambda (name) + (let* ((modname `(scripts ,(string->symbol name))) + (mod (resolve-module modname #:ensure #f)) + (summary (and mod (and=> (module-variable mod '%summary) + variable-ref)))) + (if (and mod + (or all? + (let ((v (module-variable mod '%include-in-guild-list))) + (if v (variable-ref v) #t)))) + (if summary + (format #t " ~A ~23t~a\n" name summary) + (format #t " ~A\n" name))))) + (find-submodules '(scripts))) + (display " +For help on a specific command, try \"guild help COMMAND\". +")) + +(define (module-commentary mod) + (file-commentary + (%search-load-path (module-filename mod)))) + +(define (main . args) + (cond + ((null? args) + (list-commands #f)) + ((or (equal? args '("--all")) (equal? args '("-a"))) + (list-commands #t)) + ((not (string-prefix? "-" (car args))) + ;; help for particular command + (let* ((name (car args)) + (mod (resolve-module `(scripts ,(string->symbol name)) + #:ensure #f))) + (if mod + (let ((commentary (module-commentary mod))) + (if commentary + (display commentary) + (format #t "No documentation found for command \"~a\".\n" + name))) + (begin + (format #t "No command named \"~a\".\n" name) + (exit 1))))) + (else + (display "Usage: guild help + guild help --all + guild help COMMAND + +Show a help on guild commands. With --all, show arcane incantations as +well. With COMMAND, show more detailed help for a particular command. +") + (exit 1)))) From 3cf634fa7c7cf02238ef434e4a3c42d9abc64674 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 23 Jul 2011 22:42:09 +0200 Subject: [PATCH 34/37] Export `main' from (scripts help). * module/scripts/help.scm: Export `main'. --- module/scripts/help.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/module/scripts/help.scm b/module/scripts/help.scm index 665ba9f71..e015ad532 100644 --- a/module/scripts/help.scm +++ b/module/scripts/help.scm @@ -28,7 +28,8 @@ (define-module (scripts help) #:use-module (ice-9 format) #:use-module (ice-9 documentation) - #:use-module ((srfi srfi-1) #:select (fold append-map))) + #:use-module ((srfi srfi-1) #:select (fold append-map)) + #:export (main)) (define %summary "Show a brief help message.") From 8698e810078e3224e08a67540fd42ad51b46fdf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 23 Jul 2011 19:25:28 +0200 Subject: [PATCH 35/37] doc: Remove redundant footnote about the former name of `guild'. * doc/ref/scheme-using.texi (Using Guile Tools): Remove redundant footnote introduced in e108c961fed2ffdedddcd10bad9c6aae44491b1e. Mention the version where the new name was introduced. --- doc/ref/scheme-using.texi | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 119e7f8a7..ccf5e1e07 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -704,17 +704,15 @@ information. Guile also comes with a growing number of command-line utilities: a compiler, a disassembler, some module inspectors, and in the future, a system to install Guile packages from the internet. These tools may be -invoked using the @code{guild} program@footnote{Until Guile version -2.0.1, this program was known as @code{guile-tools}. The -@code{guile-tools} executable is still installed as of 2.0.x but may be -removed in a future stable series.}. +invoked using the @code{guild} program. @example $ guild compile -o foo.go foo.scm wrote `foo.go' @end example -This program used to be called @code{guile-tools}, and for backward +This program used to be called @code{guile-tools} up to +Guile version 2.0.1, and for backward compatibility it still may be called as such. However we changed the name to @code{guild}, not only because it is pleasantly shorter and easier to read, but also because this tool will serve to bind Guile From 0d2e3fc1e7095c7b64845b29ff01e2077329f127 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 23 Jul 2011 22:43:08 +0200 Subject: [PATCH 36/37] Change `guild --help' and `--version' output to be more GNUish. * meta/guild.in (display-version): Display the version, not the effective version. * module/scripts/help.scm (list-commands)[help]: Add proper footer, as per the GCS. --- meta/guild.in | 4 ++-- module/scripts/help.scm | 14 ++++++++------ 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/meta/guild.in b/meta/guild.in index be4e5b5a3..17edf6019 100755 --- a/meta/guild.in +++ b/meta/guild.in @@ -39,8 +39,8 @@ exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" (version (single-char #\v)))) (define (display-version) - (version-etc "GNU Guile" - (effective-version) + (version-etc "@PACKAGE_NAME@" + (version) #:command-name "guild" #:license *LGPLv3+*)) diff --git a/module/scripts/help.scm b/module/scripts/help.scm index e015ad532..107d39485 100644 --- a/module/scripts/help.scm +++ b/module/scripts/help.scm @@ -85,10 +85,7 @@ (define (list-commands all?) (display "\ Usage: guild COMMAND [ARGS] - - guild runs command-line scripts provided by GNU Guile and related - programs. See \"Using Guile Tools\" in the Guile manual, for more - information. +Run command-line scripts provided by GNU Guile and related programs. Commands: ") @@ -107,9 +104,14 @@ Commands: (format #t " ~A ~23t~a\n" name summary) (format #t " ~A\n" name))))) (find-submodules '(scripts))) - (display " + (format #t " For help on a specific command, try \"guild help COMMAND\". -")) + +Report guild bugs to ~a +GNU Guile home page: +General help using GNU software: +For complete documentation, run: info guile 'Using Guile Tools' +" %guile-bug-report-address)) (define (module-commentary mod) (file-commentary From f4b7d918eff9770f09893b023fd834f5c0bc33d1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 23 Jul 2011 22:23:59 +0200 Subject: [PATCH 37/37] guild: Close over `$bindir/guile'. * configure.ac: Substitute `guile_program_name'. * meta/guild.in: Use `@bindir@/@guile_program_name@' by default. * meta/uninstalled-env.in: Define $GUILE. --- configure.ac | 4 ++++ meta/guild.in | 4 +++- meta/uninstalled-env.in | 4 ++++ 3 files changed, 11 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index b629f5c3d..dc4ef5681 100644 --- a/configure.ac +++ b/configure.ac @@ -1636,6 +1636,10 @@ pkgdatadir="$datadir/$PACKAGE_TARNAME" sitedir="$pkgdatadir/site/$GUILE_EFFECTIVE_VERSION" AC_SUBST([sitedir]) +dnl Name of the `guile' program. +guile_program_name="`echo guile | "$SED" "$program_transform_name"`" +AC_SUBST([guile_program_name]) + # Additional SCM_I_GSC definitions are above. AC_SUBST([SCM_I_GSC_GUILE_DEBUG]) AC_SUBST([SCM_I_GSC_ENABLE_DEPRECATED]) diff --git a/meta/guild.in b/meta/guild.in index 17edf6019..183323f75 100755 --- a/meta/guild.in +++ b/meta/guild.in @@ -1,6 +1,8 @@ #!/bin/sh # -*- scheme -*- -exec guile $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" +prefix="@prefix@" +exec_prefix="@exec_prefix@" +exec ${GUILE:-@bindir@/@guile_program_name@} $GUILE_FLAGS -e '(@@ (guild) main)' -s "$0" "$@" !# ;;;; guild --- running scripts bundled with Guile diff --git a/meta/uninstalled-env.in b/meta/uninstalled-env.in index 4faad641b..2276b4aed 100644 --- a/meta/uninstalled-env.in +++ b/meta/uninstalled-env.in @@ -136,4 +136,8 @@ if test "x${top_srcdir}" != "x${top_builddir}"; then fi export PATH +# Define $GUILE, used by `guild'. +GUILE="${top_builddir}/meta/guile" +export GUILE + exec "$@"