[Guile-commits] GNU Guile branch, boehm-demers-weiser-gc, updated. release_1-9-2-283-g0e0d97c

[Ludovic Courtès]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=0e0d97c477b160f193b289b4aabfa73bbaf52e9b

The branch, boehm-demers-weiser-gc has been updated
       via  0e0d97c477b160f193b289b4aabfa73bbaf52e9b (commit)
       via  f538a0709aa89fe8cc3a25996d447f35ef05fab1 (commit)
      from  d7e7a02a6251c8ed4f76933d9d30baeee3f599c0 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 0e0d97c477b160f193b289b4aabfa73bbaf52e9b
Author: Ludovic Courtès <address@hidden>
Date:   Thu Sep 3 00:59:57 2009 +0200

    Fix invalid syntax in `dynamic-input-large.sch' (gc-benchmarks).
    
    * gc-benchmarks/larceny/dynamic-input-large.sch: Remove invalid "\;"
      escape.

commit f538a0709aa89fe8cc3a25996d447f35ef05fab1
Author: Ludovic Courtès <address@hidden>
Date:   Thu Sep 3 00:57:24 2009 +0200

    Add test case for `scm_take_u8vector ()'.
    
    This is a followup to commit d7e7a02a6251c8ed4f76933d9d30baeee3f599c0
    ("Fix leaky behavior of `scm_take_TAGvector ()'.") and a reminder that
    the uniform vector implementation can't do away with the cell->buffer
    indirection.
    
    * test-suite/standalone/Makefile.am (test_scm_take_u8vector_SOURCES,
      test_scm_take_u8vector_CFLAGS, test_scm_take_u8vector_LDADD): New.
      (check_PROGRAMS, TESTS): Add `test-scm-take-u8vector'.
    
    * test-suite/standalone/test-scm-take-u8vector.c: New file.

-----------------------------------------------------------------------

Summary of changes:
 gc-benchmarks/larceny/dynamic-input-large.sch      |    2 +-
 test-suite/standalone/.gitignore                   |    1 +
 test-suite/standalone/Makefile.am                  |    7 +++++
 ...ke-locale-symbol.c => test-scm-take-u8vector.c} |   29 ++++++++++---------
 4 files changed, 24 insertions(+), 15 deletions(-)
 copy test-suite/standalone/{test-scm-take-locale-symbol.c => 
test-scm-take-u8vector.c} (61%)

diff --git a/gc-benchmarks/larceny/dynamic-input-large.sch 
b/gc-benchmarks/larceny/dynamic-input-large.sch
index 068ea3e..7bc52ef 100644
--- a/gc-benchmarks/larceny/dynamic-input-large.sch
+++ b/gc-benchmarks/larceny/dynamic-input-large.sch
@@ -1190,7 +1190,7 @@
 (let () (begin (set! make-fasl (lambda (.infilename|1 . .rest|1) (let 
((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda () (let ((.outfilename|6 
(if (not (null? .rest|1)) (let ((.x|8|11 .rest|1)) (begin (.check! (pair? 
.x|8|11) 0 .x|8|11) (car:pair .x|8|11))) (rewrite-file-type .infilename|1 
*lop-file-type* *fasl-file-type*)))) (begin (process-file .infilename|1 
.outfilename|6 dump-fasl-segment-to-port (lambda (.x|7) .x|7)) 
(unspecified))))) (if (eq? (nbuild-parameter 'target-machine) 'standard-c) 
(error "Make-fasl not supported on this target architecture.") (.doit|2)))))) 
'make-fasl))
 (let () (begin (set! disassemble (lambda (.item|1 . .rest|1) (let 
((.output-port|4 (if (null? .rest|1) (current-output-port) (let ((.x|5|8 
.rest|1)) (begin (.check! (pair? .x|5|8) 0 .x|5|8) (car:pair .x|5|8)))))) 
(begin (disassemble-item .item|1 #f .output-port|4) (unspecified))))) 
'disassemble))
 (let () (begin (set! disassemble-item (lambda (.item|1 .segment-no|1 .port|1) 
(let ((.disassemble-item|2 0)) (begin (set! .disassemble-item|2 (lambda 
(.item|3 .segment-no|3 .port|3) (let ((.print-segment|5 (unspecified)) 
(.print-constvector|5 (unspecified)) (.print|5 (unspecified))) (begin (set! 
.print-segment|5 (lambda (.segment|6) (begin (.print|5 "Segment # " 
.segment-no|3) (print-instructions (disassemble-codevector (let ((.x|7|10 
.segment|6)) (begin (.check! (pair? .x|7|10) 0 .x|7|10) (car:pair .x|7|10)))) 
.port|3) (.print-constvector|5 (let ((.x|11|14 .segment|6)) (begin (.check! 
(pair? .x|11|14) 1 .x|11|14) (cdr:pair .x|11|14)))) (.print|5 
"========================================")))) (set! .print-constvector|5 
(lambda (.cv|15) (let () (let ((.loop|17|19|22 (unspecified))) (begin (set! 
.loop|17|19|22 (lambda (.i|23) (if (= .i|23 (let ((.v|25|28 .cv|15)) (begin 
(.check! (vector? .v|25|28) 42 .v|25|28) (vector-length:vec .v|25|28)))) (if #f 
#f (unspecified)) (begin (begin #t (.print|5 
"------------------------------------------") (.print|5 "Constant vector 
element # " .i|23) (let ((.temp|30|33 (let ((.x|90|93 (let ((.v|94|97 .cv|15) 
(.i|94|97 .i|23)) (begin (.check! (fixnum? .i|94|97) 40 .v|94|97 .i|94|97) 
(.check! (vector? .v|94|97) 40 .v|94|97 .i|94|97) (.check! (<:fix:fix .i|94|97 
(vector-length:vec .v|94|97)) 40 .v|94|97 .i|94|97) (.check! (>=:fix:fix 
.i|94|97 0) 40 .v|94|97 .i|94|97) (vector-ref:trusted .v|94|97 .i|94|97))))) 
(begin (.check! (pair? .x|90|93) 0 .x|90|93) (car:pair .x|90|93))))) (if (memv 
.temp|30|33 '(codevector)) (begin (.print|5 "Code vector") (print-instructions 
(disassemble-codevector (let ((.x|36|39 (let ((.x|40|43 (let ((.v|44|47 .cv|15) 
(.i|44|47 .i|23)) (begin (.check! (fixnum? .i|44|47) 40 .v|44|47 .i|44|47) 
(.check! (vector? .v|44|47) 40 .v|44|47 .i|44|47) (.check! (<:fix:fix .i|44|47 
(vector-length:vec .v|44|47)) 40 .v|44|47 .i|44|47) (.check! (>=:fix:fix 
.i|44|47 0) 40 .v|44|47 .i|44|47) (vector-ref:trusted .v|44|47 .i|44|47))))) 
(begin (.check! (pair? .x|40|43) 1 .x|40|43) (cdr:pair .x|40|43))))) (begin 
(.check! (pair? .x|36|39) 0 .x|36|39) (car:pair .x|36|39)))) .port|3)) (if 
(memv .temp|30|33 '(constantvector)) (begin (.print|5 "Constant vector") 
(.print-constvector|5 (let ((.x|50|53 (let ((.x|54|57 (let ((.v|58|61 .cv|15) 
(.i|58|61 .i|23)) (begin (.check! (fixnum? .i|58|61) 40 .v|58|61 .i|58|61) 
(.check! (vector? .v|58|61) 40 .v|58|61 .i|58|61) (.check! (<:fix:fix .i|58|61 
(vector-length:vec .v|58|61)) 40 .v|58|61 .i|58|61) (.check! (>=:fix:fix 
.i|58|61 0) 40 .v|58|61 .i|58|61) (vector-ref:trusted .v|58|61 .i|58|61))))) 
(begin (.check! (pair? .x|54|57) 1 .x|54|57) (cdr:pair .x|54|57))))) (begin 
(.check! (pair? .x|50|53) 0 .x|50|53) (car:pair .x|50|53))))) (if (memv 
.temp|30|33 '(global)) (.print|5 "Global: " (let ((.x|64|67 (let ((.x|68|71 
(let ((.v|72|75 .cv|15) (.i|72|75 .i|23)) (begin (.check! (fixnum? .i|72|75) 40 
.v|72|75 .i|72|75) (.check! (vector? .v|72|75) 40 .v|72|75 .i|72|75) (.check! 
(<:fix:fix .i|72|75 (vector-length:vec .v|72|75)) 40 .v|72|75 .i|72|75) 
(.check! (>=:fix:fix .i|72|75 0) 40 .v|72|75 .i|72|75) (vector-ref:trusted 
.v|72|75 .i|72|75))))) (begin (.check! (pair? .x|68|71) 1 .x|68|71) (cdr:pair 
.x|68|71))))) (begin (.check! (pair? .x|64|67) 0 .x|64|67) (car:pair 
.x|64|67)))) (if (memv .temp|30|33 '(data)) (.print|5 "Data: " (let ((.x|78|81 
(let ((.x|82|85 (let ((.v|86|89 .cv|15) (.i|86|89 .i|23)) (begin (.check! 
(fixnum? .i|86|89) 40 .v|86|89 .i|86|89) (.check! (vector? .v|86|89) 40 
.v|86|89 .i|86|89) (.check! (<:fix:fix .i|86|89 (vector-length:vec .v|86|89)) 
40 .v|86|89 .i|86|89) (.check! (>=:fix:fix .i|86|89 0) 40 .v|86|89 .i|86|89) 
(vector-ref:trusted .v|86|89 .i|86|89))))) (begin (.check! (pair? .x|82|85) 1 
.x|82|85) (cdr:pair .x|82|85))))) (begin (.check! (pair? .x|78|81) 0 .x|78|81) 
(car:pair .x|78|81)))) (unspecified))))))) (.loop|17|19|22 (+ .i|23 1)))))) 
(.loop|17|19|22 0)))))) (set! .print|5 (lambda .rest|98 (begin (let () (let 
((.loop|104|106|109 (unspecified))) (begin (set! .loop|104|106|109 (lambda 
(.y1|99|100|110) (if (null? .y1|99|100|110) (if #f #f (unspecified)) (begin 
(begin #t (let ((.x|114 (let ((.x|115|118 .y1|99|100|110)) (begin (.check! 
(pair? .x|115|118) 0 .x|115|118) (car:pair .x|115|118))))) (display .x|114 
.port|3))) (.loop|104|106|109 (let ((.x|119|122 .y1|99|100|110)) (begin 
(.check! (pair? .x|119|122) 1 .x|119|122) (cdr:pair .x|119|122)))))))) 
(.loop|104|106|109 .rest|98)))) (newline .port|3)))) (if (procedure? .item|3) 
(print-instructions (disassemble-codevector (procedure-ref .item|3 0)) .port|3) 
(if (if (pair? .item|3) (if (bytevector? (let ((.x|126|129 .item|3)) (begin 
(.check! (pair? .x|126|129) 0 .x|126|129) (car:pair .x|126|129)))) (vector? 
(let ((.x|131|134 .item|3)) (begin (.check! (pair? .x|131|134) 1 .x|131|134) 
(cdr:pair .x|131|134)))) #f) #f) (.print-segment|5 .item|3) (error 
"disassemble-item: " .item|3 " is not disassemblable."))))))) 
(.disassemble-item|2 .item|1 .segment-no|1 .port|1))))) 'disassemble-item))
-(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let 
((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 
.output-port|3) (begin (display "\; From " .output-port|3) (display .file|1 
.output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 
(unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) 
(if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t 
(disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ 
.segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read 
.input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) 
(if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin 
(delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 
.x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 
.rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) 
(lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) 
(unspecified))))) 'disassemble-file))
+(let () (begin (set! disassemble-file (lambda (.file|1 . .rest|1) (let 
((.doit|2 (unspecified))) (begin (set! .doit|2 (lambda (.input-port|3 
.output-port|3) (begin (display "; From " .output-port|3) (display .file|1 
.output-port|3) (newline .output-port|3) (let () (let ((.loop|5|8|11 
(unspecified))) (begin (set! .loop|5|8|11 (lambda (.segment-no|12 .segment|12) 
(if (eof-object? .segment|12) (if #f #f (unspecified)) (begin (begin #t 
(disassemble-item .segment|12 .segment-no|12 .output-port|3)) (.loop|5|8|11 (+ 
.segment-no|12 1) (read .input-port|3)))))) (.loop|5|8|11 0 (read 
.input-port|3)))))))) (call-with-input-file .file|1 (lambda (.input-port|15) 
(if (null? .rest|1) (.doit|2 .input-port|15 (current-output-port)) (begin 
(delete-file (let ((.x|16|19 .rest|1)) (begin (.check! (pair? .x|16|19) 0 
.x|16|19) (car:pair .x|16|19)))) (call-with-output-file (let ((.x|20|23 
.rest|1)) (begin (.check! (pair? .x|20|23) 0 .x|20|23) (car:pair .x|20|23))) 
(lambda (.output-port|24) (.doit|2 .input-port|15 .output-port|24))))))) 
(unspecified))))) 'disassemble-file))
 (let () (begin (set! compiler-switches (lambda .rest|1 (let 
((.fast-unsafe-code|3 (unspecified)) (.fast-safe-code|3 (unspecified)) 
(.standard-code|3 (unspecified)) (.slow-code|3 (unspecified))) (begin (set! 
.fast-unsafe-code|3 (lambda () (begin (set-compiler-flags! 'fast-unsafe) 
(set-assembler-flags! 'fast-unsafe)))) (set! .fast-safe-code|3 (lambda () 
(begin (set-compiler-flags! 'fast-safe) (set-assembler-flags! 'fast-safe)))) 
(set! .standard-code|3 (lambda () (begin (set-compiler-flags! 'standard) 
(set-assembler-flags! 'standard)))) (set! .slow-code|3 (lambda () (begin 
(set-compiler-flags! 'no-optimization) (set-assembler-flags! 
'no-optimization)))) (if (null? .rest|1) (begin (display "Debugging:") 
(newline) (display-twobit-flags 'debugging) (display-assembler-flags 
'debugging) (newline) (display "Safety:") (newline) (display-twobit-flags 
'safety) (display-assembler-flags 'safety) (newline) (display "Speed:") 
(newline) (display-twobit-flags 'optimization) (display-assembler-flags 
'optimization) (if #f #f (unspecified))) (if (null? (let ((.x|9|12 .rest|1)) 
(begin (.check! (pair? .x|9|12) 1 .x|9|12) (cdr:pair .x|9|12)))) (begin (let 
((.temp|13|16 (let ((.x|27|30 .rest|1)) (begin (.check! (pair? .x|27|30) 0 
.x|27|30) (car:pair .x|27|30))))) (if (memv .temp|13|16 '(0 slow)) 
(.slow-code|3) (if (memv .temp|13|16 '(1 standard)) (.standard-code|3) (if 
(memv .temp|13|16 '(2 fast-safe)) (.fast-safe-code|3) (if (memv .temp|13|16 '(3 
fast-unsafe)) (.fast-unsafe-code|3) (if (memv .temp|13|16 '(default 
factory-settings)) (begin (.fast-safe-code|3) (include-source-code #t) 
(benchmark-mode #f) (benchmark-block-mode #f) (common-subexpression-elimination 
#f) (representation-inference #f)) (error "Unrecognized flag " (let ((.x|23|26 
.rest|1)) (begin (.check! (pair? .x|23|26) 0 .x|23|26) (car:pair .x|23|26))) " 
to compiler-switches."))))))) (unspecified)) (error "Too many arguments to 
compiler-switches."))))))) 'compiler-switches))
 (let () (begin (set! process-file (lambda (.infilename|1 .outfilename|1 
.writer|1 .processer|1) (let ((.process-file|2 0)) (begin (set! .process-file|2 
(lambda (.infilename|3 .outfilename|3 .writer|3 .processer|3) (let ((.doit|6 
(unspecified))) (begin (set! .doit|6 (lambda () (begin (delete-file 
.outfilename|3) (call-with-output-file .outfilename|3 (lambda (.outport|8) 
(call-with-input-file .infilename|3 (lambda (.inport|9) (let ((.x|12 (read 
.inport|9))) (let () (let ((.loop|15 (unspecified))) (begin (set! .loop|15 
(lambda (.x|16) (if (eof-object? .x|16) #t (begin (.writer|3 (.processer|3 
.x|16) .outport|8) (.loop|15 (read .inport|9)))))) (.loop|15 .x|12)))))))))))) 
(let ((.current-syntactic-environment|17 (syntactic-copy 
global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () 
(.doit|6)) (lambda () (set! global-syntactic-environment 
.current-syntactic-environment|17)))))))) (.process-file|2 .infilename|1 
.outfilename|1 .writer|1 .processer|1))))) 'process-file))
 (let () (begin (set! process-file-block (lambda (.infilename|1 .outfilename|1 
.writer|1 .processer|1) (let ((.process-file-block|2 0)) (begin (set! 
.process-file-block|2 (lambda (.infilename|3 .outfilename|3 .writer|3 
.processer|3) (let ((.doit|6 (unspecified))) (begin (set! .doit|6 (lambda () 
(begin (delete-file .outfilename|3) (call-with-output-file .outfilename|3 
(lambda (.outport|8) (call-with-input-file .infilename|3 (lambda (.inport|9) 
(let () (let ((.loop|10|13|16 (unspecified))) (begin (set! .loop|10|13|16 
(lambda (.x|17 .forms|17) (if (eof-object? .x|17) (.writer|3 (.processer|3 
(reverse .forms|17)) .outport|8) (begin #t (.loop|10|13|16 (read .inport|9) 
(cons .x|17 .forms|17)))))) (.loop|10|13|16 (read .inport|9) '()))))))))))) 
(let ((.current-syntactic-environment|20 (syntactic-copy 
global-syntactic-environment))) (dynamic-wind (lambda () #t) (lambda () 
(.doit|6)) (lambda () (set! global-syntactic-environment 
.current-syntactic-environment|20)))))))) (.process-file-block|2 .infilename|1 
.outfilename|1 .writer|1 .processer|1))))) 'process-file-block))
diff --git a/test-suite/standalone/.gitignore b/test-suite/standalone/.gitignore
index 9dadde6..1943936 100644
--- a/test-suite/standalone/.gitignore
+++ b/test-suite/standalone/.gitignore
@@ -10,3 +10,4 @@
 /test-scm-c-read
 /test-fast-slot-ref
 /test-scm-take-locale-symbol
+/test-scm-take-u8vector
diff --git a/test-suite/standalone/Makefile.am 
b/test-suite/standalone/Makefile.am
index 488eb14..1b0d9d6 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -129,6 +129,13 @@ test_scm_take_locale_symbol_LDADD = 
${top_builddir}/libguile/libguile.la
 check_PROGRAMS += test-scm-take-locale-symbol
 TESTS += test-scm-take-locale-symbol
 
+# test-scm-take-u8vector
+test_scm_take_u8vector_SOURCES = test-scm-take-u8vector.c
+test_scm_take_u8vector_CFLAGS = ${test_cflags}
+test_scm_take_u8vector_LDADD = ${top_builddir}/libguile/libguile.la
+check_PROGRAMS += test-scm-take-u8vector
+TESTS += test-scm-take-u8vector
+
 # test-extensions
 noinst_LTLIBRARIES += libtest-extensions.la
 libtest_extensions_la_SOURCES = test-extensions-lib.c
diff --git a/test-suite/standalone/test-scm-take-locale-symbol.c 
b/test-suite/standalone/test-scm-take-u8vector.c
similarity index 61%
copy from test-suite/standalone/test-scm-take-locale-symbol.c
copy to test-suite/standalone/test-scm-take-u8vector.c
index 808068f..fff3af4 100644
--- a/test-suite/standalone/test-scm-take-locale-symbol.c
+++ b/test-suite/standalone/test-scm-take-u8vector.c
@@ -16,8 +16,9 @@
  * 02110-1301 USA
  */
 
-/* Exercise `scm_take_locale_symbol ()', making sure it returns an interned
-   symbol.  See https://savannah.gnu.org/bugs/index.php?25865 .  */
+/* Make sure `scm_take_u8vector ()' returns a u8vector that actually uses the
+   provided storage.  */
+
 
 #ifdef HAVE_CONFIG_H
 # include <config.h>
@@ -26,31 +27,31 @@
 #include <libguile.h>
 
 #include <stdlib.h>
-#include <string.h>
 
 
 static void *
 do_test (void *result)
 {
-  SCM taken_sym, sym;
+#define LEN 123
+  SCM u8v;
+  scm_t_uint8 *data;
+  scm_t_array_handle handle;
 
-  taken_sym = scm_take_locale_symbol (strdup ("some random symbol"));
-  sym = scm_from_locale_symbol ("some random symbol");
+  data = scm_malloc (LEN);
+  u8v = scm_take_u8vector (data, LEN);
 
-  if (scm_is_true (scm_symbol_p (sym))
-      && scm_is_true (scm_symbol_p (taken_sym))
+  scm_array_get_handle (u8v, &handle);
 
-      /* Relying solely on `scm_symbol_interned_p ()' is insufficient since
-        it doesn't reflect the actual state of the symbol hashtable, hence
-        the additional `scm_is_eq' test.  */
-      && scm_is_true (scm_symbol_interned_p (sym))
-      && scm_is_true (scm_symbol_interned_p (taken_sym))
-      && scm_is_eq (taken_sym, sym))
+  if (scm_array_handle_u8_writable_elements (&handle) == data
+      && scm_array_handle_u8_elements (&handle) == data)
     * (int *) result = EXIT_SUCCESS;
   else
     * (int *) result = EXIT_FAILURE;
 
+  scm_array_handle_release (&handle);
+
   return NULL;
+#undef LEN
 }
 
 int


hooks/post-receive
-- 
GNU Guile