From 1a6ff60da8d824230e186a8c8bef8c21b23ae377 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 16 May 2012 00:04:07 +0200 Subject: [PATCH 01/17] coverage: Add test for applicable structs. * test-suite/tests/coverage.test ("procedure-execution-count")["applicable struct"]: New test. --- test-suite/tests/coverage.test | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test index 4ac404344..b29de0f20 100644 --- a/test-suite/tests/coverage.test +++ b/test-suite/tests/coverage.test @@ -1,6 +1,6 @@ ;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2010, 2011, 2012 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 @@ -216,6 +216,16 @@ (= 3 result) (not (procedure-execution-count data proc)))))) + (pass-if "applicable struct" + (let* (( (make-struct 0 'pw)) + (proc (lambda args (length args))) + (b (make-struct 0 proc))) + (let-values (((data result) + (with-code-coverage %test-vm b))) + (and (coverage-data? data) + (= 0 result) + (= (procedure-execution-count data proc) 1))))) + (pass-if "called from C" ;; The `scm_call_N' functions use the VM returned by `the-vm'. This ;; test makes sure that they get to use %TEST-VM. From 478848cb706b23bcc4c2afe9a4ad33c595bc33f6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 29 May 2012 23:39:05 +0200 Subject: [PATCH 02/17] Access `pt->ilseq_handler' directly when needed. * libguile/print.c (PORT_CONVERSION_HANDLER): New macro. (print_extended_symbol, iprin1, write_character, scm_write_char): Use it instead of `scm_i_get_conversion_strategy'. * libguile/strports.c (scm_mkstrport): Assign `pt->ilseq_handler' directly instead of via `scm_i_set_conversion_strategy_x'. --- libguile/print.c | 13 ++++++++----- libguile/strports.c | 7 ++++--- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/libguile/print.c b/libguile/print.c index c2dcd2812..2fc536b02 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -61,6 +61,9 @@ /* Character printers. */ +#define PORT_CONVERSION_HANDLER(port) \ + SCM_PTAB_ENTRY (port)->ilseq_handler + static size_t display_string (const void *, int, size_t, SCM, scm_t_string_failed_conversion_handler); @@ -393,7 +396,7 @@ print_extended_symbol (SCM sym, SCM port) scm_t_string_failed_conversion_handler strategy; len = scm_i_symbol_length (sym); - strategy = scm_i_get_conversion_strategy (port); + strategy = PORT_CONVERSION_HANDLER (port); scm_lfwrite ("#{", 2, port); @@ -500,7 +503,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) else { if (!display_character (SCM_CHAR (exp), port, - scm_i_get_conversion_strategy (port))) + PORT_CONVERSION_HANDLER (port))) scm_encoding_error (__func__, errno, "cannot convert to output locale", port, exp); @@ -586,7 +589,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) printed = display_string (scm_i_string_data (exp), scm_i_is_narrow_string (exp), len, port, - scm_i_get_conversion_strategy (port)); + PORT_CONVERSION_HANDLER (port)); if (SCM_UNLIKELY (printed < len)) scm_encoding_error (__func__, errno, "cannot convert to output locale", @@ -1116,7 +1119,7 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p) int printed = 0; scm_t_string_failed_conversion_handler strategy; - strategy = scm_i_get_conversion_strategy (port); + strategy = PORT_CONVERSION_HANDLER (port); if (string_escapes_p) { @@ -1469,7 +1472,7 @@ SCM_DEFINE (scm_write_char, "write-char", 1, 1, 0, port = SCM_COERCE_OUTPORT (port); if (!display_character (SCM_CHAR (chr), port, - scm_i_get_conversion_strategy (port))) + PORT_CONVERSION_HANDLER (port))) scm_encoding_error (__func__, errno, "cannot convert to output locale", port, chr); diff --git a/libguile/strports.c b/libguile/strports.c index b7fec4703..649c2477e 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2005, 2006, + * 2009, 2010, 2011, 2012 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 @@ -336,7 +337,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end) st_flush (z); - scm_i_set_conversion_strategy_x (z, SCM_FAILED_CONVERSION_ERROR); + pt->ilseq_handler = SCM_FAILED_CONVERSION_ERROR; return z; } From b22e94db7c91d7661204e33f3bc2bfead002c9b7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 29 May 2012 23:39:05 +0200 Subject: [PATCH 03/17] Add the `%default-port-conversion-strategy' fluid. Fixes . * libguile/ports.c (scm_conversion_strategy): Remove. (default_conversion_strategy_var, sym_error, sym_substitute, sym_escape): New variables. (scm_i_get_conversion_strategy, scm_i_set_conversion_strategy_x): Remove. (scm_i_default_port_conversion_handler, scm_i_set_default_port_conversion_handler): New functions. (scm_port_conversion_strategy): Use `scm_i_default_port_conversion_handler' when PORT is #f. (scm_set_port_conversion_strategy_x): Use SYM_ERROR, SYM_SUBSTITUTE, and SYM_ESCAPE. Use `scm_i_set_default_port_conversion_handler' when PORT is #f. (scm_init_ports): Initialize DEFAULT_CONVERSION_STRATEGY_VAR. * libguile/ports.h: Update declarations accordingly. * libguile/foreign.c: Change `scm_i_get_conversion_strategy (SCM_BOOL_F)' to `scm_i_default_port_conversion_handler ()'. * libguile/strings.c: Likewise. * test-suite/tests/ports.test ("%default-port-conversion-strategy"): New test prefix. * test-suite/tests/foreign.test ("pointer<->string")["%default-port-conversion-strategy is error", "%default-port-conversion-strategy is soft"]: New tests. * test-suite/test-suite/lib.scm (exception:encoding-error): Allow the regexp to match `scm_to_stringn' error messages. * doc/ref/api-io.texi (Ports): Document `%default-port-conversion-strategy'. --- doc/ref/api-io.texi | 15 +++ libguile/foreign.c | 4 +- libguile/ports.c | 167 ++++++++++++++++++---------------- libguile/ports.h | 9 +- libguile/strings.c | 6 +- test-suite/test-suite/lib.scm | 2 +- test-suite/tests/foreign.test | 17 ++++ test-suite/tests/ports.test | 28 ++++++ 8 files changed, 159 insertions(+), 89 deletions(-) diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 24c2706df..de3684c31 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -166,6 +166,21 @@ returned. New ports will have this default behavior when they are created. @end deffn +@deffn {Scheme Variable} %default-port-conversion-strategy +The fluid that defines the conversion strategy for newly created ports, +and for other conversion routines such as @code{scm_to_stringn}, +@code{scm_from_stringn}, @code{string->pointer}, and +@code{pointer->string}. + +Its value must be one of the symbols described above, with the same +semantics: @code{'error}, @code{'substitute}, or @code{'escape}. + +When Guile starts, its value is @code{'substitute}. + +Note that @code{(set-port-conversion-strategy! #f @var{sym})} is +equivalent to @code{(fluid-set! %default-port-conversion-strategy +@var{sym})}. +@end deffn @node Reading diff --git a/libguile/foreign.c b/libguile/foreign.c index f1d960717..355934962 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -375,7 +375,7 @@ SCM_DEFINE (scm_string_to_pointer, "string->pointer", 1, 1, 0, ret = scm_from_pointer (scm_to_stringn (string, NULL, enc, - scm_i_get_conversion_strategy (SCM_BOOL_F)), + scm_i_default_port_conversion_handler ()), free); scm_dynwind_end (); @@ -420,7 +420,7 @@ SCM_DEFINE (scm_pointer_to_string, "pointer->string", 1, 2, 0, scm_dynwind_free (enc); ret = scm_from_stringn (SCM_POINTER_VALUE (pointer), len, enc, - scm_i_get_conversion_strategy (SCM_BOOL_F)); + scm_i_default_port_conversion_handler ()); scm_dynwind_end (); diff --git a/libguile/ports.c b/libguile/ports.c index 3ef92b902..ccf658756 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -628,7 +628,7 @@ scm_new_port_table_entry (scm_t_bits tag) entry->input_cd = (iconv_t) -1; entry->output_cd = (iconv_t) -1; - entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F); + entry->ilseq_handler = scm_i_default_port_conversion_handler (); SCM_SET_CELL_TYPE (z, tag); SCM_SETPTAB_ENTRY (z, entry); @@ -2309,62 +2309,81 @@ SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0, #undef FUNC_NAME -/* This determines how conversions handle unconvertible characters. */ -SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy"); +/* A fluid specifying the default conversion handler for newly created + ports. Its value should be one of the symbols below. */ +SCM_VARIABLE (default_conversion_strategy_var, + "%default-port-conversion-strategy"); + +/* Whether the above fluid is initialized. */ static int scm_conversion_strategy_init = 0; +/* The possible conversion strategies. */ +SCM_SYMBOL (sym_error, "error"); +SCM_SYMBOL (sym_substitute, "substitute"); +SCM_SYMBOL (sym_escape, "escape"); + +/* Return the default failed encoding conversion policy for new created + ports. */ scm_t_string_failed_conversion_handler -scm_i_get_conversion_strategy (SCM port) +scm_i_default_port_conversion_handler (void) { - SCM encoding; - - if (scm_is_false (port)) - { - if (!scm_conversion_strategy_init - || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy))) - return SCM_FAILED_CONVERSION_QUESTION_MARK; - else - { - encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy)); - if (scm_is_false (encoding)) - return SCM_FAILED_CONVERSION_QUESTION_MARK; - else - return (scm_t_string_failed_conversion_handler) scm_to_int (encoding); - } - } + scm_t_string_failed_conversion_handler handler; + + if (!scm_conversion_strategy_init + || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var))) + handler = SCM_FAILED_CONVERSION_QUESTION_MARK; else { - scm_t_port *pt; - pt = SCM_PTAB_ENTRY (port); - return pt->ilseq_handler; + SCM fluid, value; + + fluid = SCM_VARIABLE_REF (default_conversion_strategy_var); + value = scm_fluid_ref (fluid); + + if (scm_is_eq (sym_substitute, value)) + handler = SCM_FAILED_CONVERSION_QUESTION_MARK; + else if (scm_is_eq (sym_escape, value)) + handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; + else + /* Default to 'error also when the fluid's value is not one of + the valid symbols. */ + handler = SCM_FAILED_CONVERSION_ERROR; } - + + return handler; } +/* Use HANDLER as the default conversion strategy for future ports. */ void -scm_i_set_conversion_strategy_x (SCM port, - scm_t_string_failed_conversion_handler handler) +scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler + handler) { SCM strategy; - scm_t_port *pt; - - strategy = scm_from_int ((int) handler); - - if (scm_is_false (port)) + + if (!scm_conversion_strategy_init + || !scm_is_fluid (SCM_VARIABLE_REF (default_conversion_strategy_var))) + scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized", + SCM_EOL); + + switch (handler) { - /* Set the default encoding for future ports. */ - if (!scm_conversion_strategy_init - || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy))) - scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized", - SCM_EOL); - scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy); - } - else - { - /* Set the character encoding for this port. */ - pt = SCM_PTAB_ENTRY (port); - pt->ilseq_handler = handler; + case SCM_FAILED_CONVERSION_ERROR: + strategy = sym_error; + break; + + case SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE: + strategy = sym_escape; + break; + + case SCM_FAILED_CONVERSION_QUESTION_MARK: + strategy = sym_substitute; + break; + + default: + abort (); } + + scm_fluid_set_x (SCM_VARIABLE_REF (default_conversion_strategy_var), + strategy); } SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", @@ -2384,14 +2403,18 @@ SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", { scm_t_string_failed_conversion_handler h; - SCM_VALIDATE_OPPORT (1, port); - - if (!scm_is_false (port)) + if (scm_is_false (port)) + h = scm_i_default_port_conversion_handler (); + else { + scm_t_port *pt; + SCM_VALIDATE_OPPORT (1, port); + pt = SCM_PTAB_ENTRY (port); + + h = pt->ilseq_handler; } - h = scm_i_get_conversion_strategy (port); if (h == SCM_FAILED_CONVERSION_ERROR) return scm_from_latin1_symbol ("error"); else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK) @@ -2426,40 +2449,25 @@ SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", "this thread.\n") #define FUNC_NAME s_scm_set_port_conversion_strategy_x { - SCM err; - SCM qm; - SCM esc; + scm_t_string_failed_conversion_handler handler; - if (!scm_is_false (port)) + if (scm_is_eq (sym, sym_error)) + handler = SCM_FAILED_CONVERSION_ERROR; + else if (scm_is_eq (sym, sym_substitute)) + handler = SCM_FAILED_CONVERSION_QUESTION_MARK; + else if (scm_is_eq (sym, sym_escape)) + handler = SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE; + else + SCM_MISC_ERROR ("unknown conversion strategy ~s", scm_list_1 (sym)); + + if (scm_is_false (port)) + scm_i_set_default_port_conversion_handler (handler); + else { SCM_VALIDATE_OPPORT (1, port); + SCM_PTAB_ENTRY (port)->ilseq_handler = handler; } - err = scm_from_latin1_symbol ("error"); - if (scm_is_true (scm_eqv_p (sym, err))) - { - scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR); - return SCM_UNSPECIFIED; - } - - qm = scm_from_latin1_symbol ("substitute"); - if (scm_is_true (scm_eqv_p (sym, qm))) - { - scm_i_set_conversion_strategy_x (port, - SCM_FAILED_CONVERSION_QUESTION_MARK); - return SCM_UNSPECIFIED; - } - - esc = scm_from_latin1_symbol ("escape"); - if (scm_is_true (scm_eqv_p (sym, esc))) - { - scm_i_set_conversion_strategy_x (port, - SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE); - return SCM_UNSPECIFIED; - } - - SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym)); - return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -2577,11 +2585,10 @@ scm_init_ports () scm_make_fluid_with_default (SCM_BOOL_F)); scm_port_encoding_init = 1; - SCM_VARIABLE_SET (scm_conversion_strategy, - scm_make_fluid_with_default - (scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK))); + SCM_VARIABLE_SET (default_conversion_strategy_var, + scm_make_fluid_with_default (sym_substitute)); scm_conversion_strategy_init = 1; - + /* These bindings are used when boot-9 turns `current-input-port' et al into parameters. They are then removed from the guile module. */ scm_c_define ("%current-input-port-fluid", cur_inport_fluid); diff --git a/libguile/ports.h b/libguile/ports.h index d1e1fd698..d4d59b70e 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -308,9 +308,12 @@ SCM_INTERNAL void scm_i_set_default_port_encoding (const char *); SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str); SCM_API SCM scm_port_encoding (SCM port); SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding); -SCM_INTERNAL scm_t_string_failed_conversion_handler scm_i_get_conversion_strategy (SCM port); -SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port, - scm_t_string_failed_conversion_handler h); +SCM_INTERNAL scm_t_string_failed_conversion_handler +scm_i_default_port_conversion_handler (void); +/* Use HANDLER as the default conversion strategy for future ports. */ +SCM_INTERNAL void +scm_i_set_default_port_conversion_handler (scm_t_string_failed_conversion_handler); + SCM_API SCM scm_port_conversion_strategy (SCM port); SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior); SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *); diff --git a/libguile/strings.c b/libguile/strings.c index 07356fcaf..414951ee1 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1577,7 +1577,7 @@ SCM scm_from_locale_stringn (const char *str, size_t len) { return scm_from_stringn (str, len, locale_charset (), - scm_i_get_conversion_strategy (SCM_BOOL_F)); + scm_i_default_port_conversion_handler ()); } SCM @@ -1802,9 +1802,9 @@ scm_to_locale_string (SCM str) char * scm_to_locale_stringn (SCM str, size_t *lenp) { - return scm_to_stringn (str, lenp, + return scm_to_stringn (str, lenp, locale_charset (), - scm_i_get_conversion_strategy (SCM_BOOL_F)); + scm_i_default_port_conversion_handler ()); } char * diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm index 5785378ad..385cdfae3 100644 --- a/test-suite/test-suite/lib.scm +++ b/test-suite/test-suite/lib.scm @@ -283,7 +283,7 @@ (define exception:system-error (cons 'system-error ".*")) (define exception:encoding-error - (cons 'encoding-error "(cannot convert to output locale|input (locale conversion|decoding) error)")) + (cons 'encoding-error "(cannot convert.* to output locale|input (locale conversion|decoding) error)")) (define exception:miscellaneous-error (cons 'misc-error "^.*")) (define exception:read-error diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 6eafe954a..14fad09e4 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -25,6 +25,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (ice-9 format) #:use-module (test-suite lib)) @@ -160,6 +161,22 @@ (with-test-prefix "pointer<->string" + (pass-if-exception "%default-port-conversion-strategy is error" + exception:encoding-error + (let ((s "χαοσ")) + (with-fluids ((%default-port-conversion-strategy 'error)) + (string->pointer s "ISO-8859-1")))) + + (pass-if "%default-port-conversion-strategy is soft" + (let ((s "teĥniko")) + (equal? (map (lambda (strategy) + (with-fluids ((%default-port-conversion-strategy strategy)) + (pointer->string (string->pointer s "ISO-8859-1")))) + '(substitute escape)) + (list "te?niko" + (format #f "te\\u~4,'0xniko" + (char->integer #\ĥ)))))) + (pass-if "bijection" (let ((s "hello, world")) (string=? s (pointer->string (string->pointer s))))) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 2aec1f0b2..2b161b5ad 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -57,6 +57,34 @@ (close-port port) string)) + + +(with-test-prefix "%default-port-conversion-strategy" + + (pass-if "initial value" + (eq? 'substitute (fluid-ref %default-port-conversion-strategy))) + + (pass-if "file port" + (let ((strategies '(error substitute escape))) + (equal? (map (lambda (s) + (with-fluids ((%default-port-conversion-strategy s)) + (call-with-output-file "/dev/null" + (lambda (p) + (port-conversion-strategy p))))) + strategies) + strategies))) + + (pass-if "(set-port-conversion-strategy! #f sym)" + (begin + (set-port-conversion-strategy! #f 'error) + (and (eq? (fluid-ref %default-port-conversion-strategy) 'error) + (begin + (set-port-conversion-strategy! #f 'substitute) + (eq? (fluid-ref %default-port-conversion-strategy) + 'substitute))))) + +) + ;;;; Normal file ports. From 9f6e3f5a997f484548bd03e7e7573c38a95c8d09 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 29 May 2012 23:39:05 +0200 Subject: [PATCH 04/17] Have string ports honor `%default-port-conversion-strategy'. * libguile/strports.c (scm_mkstrport): Remove initialization of `pt->ilseq_handler'. * module/ice-9/pretty-print.scm (truncated-print)[ellipsis]: Set %DEFAULT-PORT-CONVERSION-STRATEGY to 'error. * test-suite/tests/ports.test ("string ports")["%default-port-conversion-strategy is honored"]: New test. ["wrong encoding"]: Rename to... ["wrong encoding, error"]: ... this. Explicitly set %DEFAULT-PORT-CONVERSION-STRATEGY to 'error. Return #f when no exception is raised. --- libguile/strports.c | 1 - module/ice-9/pretty-print.scm | 7 ++++--- test-suite/tests/ports.test | 22 +++++++++++++++++++--- 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index 649c2477e..ca3a2cf76 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -337,7 +337,6 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end) st_flush (z); - pt->ilseq_handler = SCM_FAILED_CONVERSION_ERROR; return z; } diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index bf45eed42..5c23cb009 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -320,9 +320,10 @@ sub-expression, via the @var{breadth-first?} keyword argument." (let ((e "…")) (catch 'encoding-error (lambda () - (with-output-to-string - (lambda () - (display e)))) + (with-fluids ((%default-port-conversion-strategy 'error)) + (with-output-to-string + (lambda () + (display e))))) (lambda (key . args) "...")))) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 2b161b5ad..7728e2587 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -424,6 +424,20 @@ encodings) encodings))) + (pass-if "%default-port-conversion-strategy is honored" + (let ((strategies '(error substitute escape))) + (equal? (map (lambda (s) + (with-fluids ((%default-port-conversion-strategy s)) + (call-with-output-string + (lambda (p) + (and (eq? s (port-conversion-strategy p)) + (begin + (set-port-conversion-strategy! p s) + (display (port-conversion-strategy p) + p))))))) + strategies) + (map symbol->string strategies)))) + (pass-if "suitable encoding [latin-1]" (let ((str "hello, world")) (with-fluids ((%default-port-encoding "ISO-8859-1")) @@ -440,15 +454,17 @@ (lambda () (display str))))))) - (pass-if "wrong encoding" + (pass-if "wrong encoding, error" (let ((str "ĉu bone?")) (catch 'encoding-error (lambda () ;; Latin-1 cannot represent ‘ĉ’. - (with-fluids ((%default-port-encoding "ISO-8859-1")) + (with-fluids ((%default-port-encoding "ISO-8859-1") + (%default-port-conversion-strategy 'error)) (with-output-to-string (lambda () - (display str))))) + (display str)))) + #f) ; so the test really fails here (lambda (key subr message errno port chr) (and (eq? chr #\ĉ) (string? (strerror errno))))))) From d3a1a74cb8764cf1f60e3d0eb0b5369cb05cf6b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2012 14:29:25 +0200 Subject: [PATCH 05/17] Fix port test that assumed string ports use the `error' conversion strategy. This is a followup to 9f6e3f5a997f484548bd03e7e7573c38a95c8d09 ("Have string ports honor `%default-port-conversion-strategy'."). * test-suite/tests/r6rs-ports.test ("7.2.11 Binary Output")["put-bytevector with wrong-encoding string port"]: Set %DEFAULT-PORT-CONVERSION-STRATEGY to 'error. Return #f when no exception is raised. ("8.2.6 Input and output ports")["transcoded-port [error handling mode = raise]"]: Return #f when no exception is raised. --- test-suite/tests/r6rs-ports.test | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/test-suite/tests/r6rs-ports.test b/test-suite/tests/r6rs-ports.test index f3e8c2c5d..46da67f59 100644 --- a/test-suite/tests/r6rs-ports.test +++ b/test-suite/tests/r6rs-ports.test @@ -1,6 +1,6 @@ ;;;; r6rs-ports.test --- R6RS I/O port tests. -*- coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -306,10 +306,12 @@ (bv (string->utf16 str))) (catch 'decoding-error (lambda () - (with-fluids ((%default-port-encoding "UTF-32")) + (with-fluids ((%default-port-encoding "UTF-32") + (%default-port-conversion-strategy 'error)) (call-with-output-string (lambda (port) - (put-bytevector port bv))))) + (put-bytevector port bv))) + #f)) ; fail if we reach this point (lambda (key subr message errno port) (string? (strerror errno))))))) @@ -662,7 +664,8 @@ (tp (transcoded-port b t))) (guard (c ((i/o-decoding-error? c) (eq? (i/o-error-port c) tp))) - (get-line tp)))) + (get-line tp) + #f))) ; fail if we reach this point (pass-if "transcoded-port [error handling mode = replace]" (let* ((t (make-transcoder (utf-8-codec) (native-eol-style) From 27ea5c3f31cd353b71e4691211082e8a8e36e730 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 31 May 2012 15:53:06 +0200 Subject: [PATCH 06/17] Make `substitute' conversion strategy test portable. * test-suite/tests/foreign.test ("pointer<->string")["%default-port-conversion-strategy is soft"]: Split into the following tests. ["%default-port-conversion-strategy is escape", "%default-port-conversion-strategy is substitute"]: New tests. In the latter, add the escape form returned on FreeBSD 8.2 and Darwin 10.8.0. --- test-suite/tests/foreign.test | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 14fad09e4..60d8630fc 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -167,15 +167,22 @@ (with-fluids ((%default-port-conversion-strategy 'error)) (string->pointer s "ISO-8859-1")))) - (pass-if "%default-port-conversion-strategy is soft" + (pass-if "%default-port-conversion-strategy is escape" (let ((s "teĥniko")) - (equal? (map (lambda (strategy) - (with-fluids ((%default-port-conversion-strategy strategy)) - (pointer->string (string->pointer s "ISO-8859-1")))) - '(substitute escape)) - (list "te?niko" - (format #f "te\\u~4,'0xniko" - (char->integer #\ĥ)))))) + (equal? (with-fluids ((%default-port-conversion-strategy 'escape)) + (pointer->string (string->pointer s "ISO-8859-1"))) + (format #f "te\\u~4,'0xniko" + (char->integer #\ĥ))))) + + (pass-if "%default-port-conversion-strategy is substitute" + (let ((s "teĥniko") + (member (negate (negate member)))) + (member (with-fluids ((%default-port-conversion-strategy 'substitute)) + (pointer->string (string->pointer s "ISO-8859-1"))) + '("te?niko" + + ;; This form is found on FreeBSD 8.2 and Darwin 10.8.0. + "te^hniko")))) (pass-if "bijection" (let ((s "hello, world")) From 0a3ac81a1c1017d3c71e9eac8f0dd3407563632b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 8 Jun 2012 12:42:08 +0200 Subject: [PATCH 07/17] Update (ice-9 match) from Chibi-Scheme. Fixes . * module/ice-9/match.upstream.scm: Update. --- module/ice-9/match.scm | 4 ++-- module/ice-9/match.upstream.scm | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/module/ice-9/match.scm b/module/ice-9/match.scm index 4b078c69f..7fd191a11 100644 --- a/module/ice-9/match.scm +++ b/module/ice-9/match.scm @@ -1,6 +1,6 @@ ;;; -*- mode: scheme; coding: utf-8; -*- ;;; -;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;; Copyright (C) 2010, 2011, 2012 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 @@ -52,7 +52,7 @@ ;; `match' doesn't support clauses of the form `(pat => exp)'. ;; Unmodified public domain code by Alex Shinn retrieved from -;; the Chibi-Scheme repository, commit 876:528cdab3f818. +;; the Chibi-Scheme repository, commit 1206:acd808700e91. ;; ;; Note: Make sure to update `match.test.upstream' when updating this ;; file. diff --git a/module/ice-9/match.upstream.scm b/module/ice-9/match.upstream.scm index 978655667..29f9dbe2e 100644 --- a/module/ice-9/match.upstream.scm +++ b/module/ice-9/match.upstream.scm @@ -210,6 +210,7 @@ ;; performance can be found at ;; http://synthcode.com/scheme/match-cond-expand.scm ;; +;; 2012/05/23 - fixing combinatorial explosion of code in certain or patterns ;; 2011/09/25 - fixing bug when directly matching an identifier repeated in ;; the pattern (thanks to Stefan Israelsson Tampe) ;; 2011/01/27 - fixing bug when matching tail patterns against improper lists @@ -479,7 +480,8 @@ (match-one v p . x)) ((_ v (p . q) g+s sk fk i) ;; match one and try the remaining on failure - (match-one v p g+s sk (match-gen-or-step v q g+s sk fk i) i)) + (let ((fk2 (lambda () (match-gen-or-step v q g+s sk fk i)))) + (match-one v p g+s sk (fk2) i))) )) ;; We match a pattern (p ...) by matching the pattern p in a loop on From e80494083aa3e9dc40a7ae5da12f0e90db550889 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 8 Jun 2012 12:44:07 +0200 Subject: [PATCH 08/17] Fix invalid use of `SCM' as a Boolean. * libguile/deprecated.c (scm_sym2var): Check `scm_is_true (definep)'. --- libguile/deprecated.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/deprecated.c b/libguile/deprecated.c index 61fa8e271..af0752c61 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2653,13 +2653,13 @@ scm_i_deprecated_asrtgo (scm_t_bits condition) * the scm_pre_modules_obarray (a `eq' hash table). */ -SCM +SCM scm_sym2var (SCM sym, SCM proc, SCM definep) #define FUNC_NAME "scm_sym2var" { SCM var; - if (definep) + if (scm_is_true (definep)) scm_c_issue_deprecation_warning ("scm_sym2var is deprecated. Use scm_define or scm_module_define\n" "to define variables. In some rare cases you may need\n" From 6b5e918e4f3cf011713e699c6af1c4e364bfae36 Mon Sep 17 00:00:00 2001 From: Sjoerd van Leent Date: Fri, 8 Jun 2012 21:21:08 -0400 Subject: [PATCH 09/17] Fix unbound variables and unbound values * module/language/ecmascript/base.scm: fix two wrong variable names and a wrong number of arguments in a function call. --- module/language/ecmascript/base.scm | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/module/language/ecmascript/base.scm b/module/language/ecmascript/base.scm index b244bec01..6f5c65ba5 100644 --- a/module/language/ecmascript/base.scm +++ b/module/language/ecmascript/base.scm @@ -92,7 +92,7 @@ (pdel o (string->symbol p))) (define-method (has-property? (o ) p) - (if (hashq-get-handle (js-props o) v) + (if (hashq-get-handle (js-props o) p) #t (let ((proto (js-prototype o))) (if proto @@ -176,9 +176,9 @@ ((boolean? x) (if x 1 0)) ((null? x) 0) ((eq? x *undefined*) +nan.0) - ((is-a? x ) (object->number x)) + ((is-a? x ) (object->number x #t)) ((string? x) (string->number x)) - (else (throw 'TypeError o '->number)))) + (else (throw 'TypeError x '->number)))) (define (->integer x) (let ((n (->number x))) From f3b312a19d70293d7a3407fc4ef479183edd7cca Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 20 Jun 2012 01:11:44 +0200 Subject: [PATCH 10/17] Fix cross-compilation of GOOPS-using code. Fixes . Reported by Bogdan A. Marinescu . * module/oop/goops/dispatch.scm (compute-dispatch-procedure)[comp]: Wrap `compile' call in (with-target %host-type ...). --- module/oop/goops/dispatch.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) diff --git a/module/oop/goops/dispatch.scm b/module/oop/goops/dispatch.scm index b12ab15fa..de5359f3c 100644 --- a/module/oop/goops/dispatch.scm +++ b/module/oop/goops/dispatch.scm @@ -25,6 +25,7 @@ #:use-module (oop goops) #:use-module (oop goops util) #:use-module (oop goops compile) + #:use-module (system base target) #:export (memoize-method!) #:no-backtrace) @@ -178,11 +179,15 @@ '()) (acons gf gf-sym '())))) (define (comp exp vals) - (let ((p ((@ (system base compile) compile) exp - #:env *dispatch-module* - #:opts '(#:partial-eval? #f #:cse? #f)))) - (apply p vals))) - + ;; When cross-compiling Guile itself, the native Guile must generate + ;; code for the host. + (with-target %host-type + (lambda () + (let ((p ((@ (system base compile) compile) exp + #:env *dispatch-module* + #:opts '(#:partial-eval? #f #:cse? #f)))) + (apply p vals))))) + ;; kick it. (scan)) From 2cb363622d03b18402d6ee15c8c87d8fee9bfc32 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 20 Jun 2012 15:44:29 +0200 Subject: [PATCH 11/17] Update `THANKS'. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index bdf11ee28..1b61a8190 100644 --- a/THANKS +++ b/THANKS @@ -101,6 +101,7 @@ For fixes or providing information which led to a fix: Daniel Llorens del Río Jeff Long Marco Maggi + Bogdan A. Marinescu Gregory Marton Kjetil S. Matheussen Antoine Mathys From ecb48dccbac6b8fdd969f50a23351ef7f4b91ce5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 20 Jun 2012 15:49:42 +0200 Subject: [PATCH 12/17] Make SRFI-6 string ports Unicode-capable. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Partly addresses . Reported by Klaus Stehle . * module/srfi/srfi-6.scm (open-input-string, open-output-string): New procedures. * test-suite/tests/srfi-6.test ("open-input-string")["read-char, Unicode"]: New test. ("open-output-string")["λ"]: New test. --- module/srfi/srfi-6.scm | 18 ++++++++++++++---- test-suite/tests/srfi-6.test | 26 +++++++++++++++++++++----- 2 files changed, 35 insertions(+), 9 deletions(-) diff --git a/module/srfi/srfi-6.scm b/module/srfi/srfi-6.scm index 098b586cc..7b8bcb114 100644 --- a/module/srfi/srfi-6.scm +++ b/module/srfi/srfi-6.scm @@ -1,6 +1,6 @@ ;;; srfi-6.scm --- Basic String Ports -;; Copyright (C) 2001, 2002, 2003, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 2003, 2006, 2012 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 @@ -23,10 +23,20 @@ ;;; Code: (define-module (srfi srfi-6) - #:re-export (open-input-string open-output-string get-output-string)) + #:replace (open-input-string open-output-string) + #:re-export (get-output-string)) -;; Currently, guile provides these functions by default, so no action -;; is needed, and this file is just a placeholder. +;; SRFI-6 says nothing about encodings, and assumes that any character +;; or string can be written to a string port. Thus, make all SRFI-6 +;; string ports Unicode capable. See . + +(define (open-input-string s) + (with-fluids ((%default-port-encoding "UTF-8")) + ((@ (guile) open-input-string) s))) + +(define (open-output-string) + (with-fluids ((%default-port-encoding "UTF-8")) + ((@ (guile) open-output-string)))) (cond-expand-provide (current-module) '(srfi-6)) diff --git a/test-suite/tests/srfi-6.test b/test-suite/tests/srfi-6.test index 68fc70dff..bd9167cca 100644 --- a/test-suite/tests/srfi-6.test +++ b/test-suite/tests/srfi-6.test @@ -1,6 +1,6 @@ ;;;; srfi-6.test --- test suite for SRFI-6 -*- scheme -*- ;;;; -;;;; Copyright (C) 2003, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2003, 2006, 2012 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 @@ -37,13 +37,21 @@ (char=? #\y (read-char port)) (char=? #\z (read-char port)) (eof-object? (read-char port))))) - + + (pass-if "read-char, Unicode" + ;; String ports should always be Unicode-capable. + ;; See . + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (let ((port (open-input-string "λμ"))) + (and (char=? #\λ (read-char port)) + (char=? #\μ (read-char port)))))) + (with-test-prefix "unread-char" (pass-if "one char" (let ((port (open-input-string ""))) - (unread-char #\x port) - (and (char=? #\x (read-char port)) + (unread-char #\x port) + (and (char=? #\x (read-char port)) (eof-object? (read-char port))))) (pass-if "after eof" @@ -75,7 +83,15 @@ (let ((port (open-output-string))) (display "xyz" port) (string=? "xyz" (get-output-string port)))) - + + (pass-if "λ" + ;; Writing to an output string should always work. + ;; See . + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (let ((port (open-output-string))) + (display "λ" port) + (string=? "λ" (get-output-string port))))) + (pass-if "seek" (let ((port (open-output-string))) (display "abcdef" port) From 03fcf93bff9f02a3d12ab86be4e67b996310aad4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 20 Jun 2012 22:56:11 +0200 Subject: [PATCH 13/17] Fix possible deadlock upon `encoding-error' in `open-input-string'. Partly addresses . * libguile/strports.c (scm_mkstrport): Call `scm_port_non_buffer', set Z's cell type and stream, and release `scm_i_port_table_mutex' early. Reacquire `scm_i_port_table_mutex' once BUF, C_BUF, and STR_LEN are initialized. * test-suite/tests/ports.test ("string ports")["encoding failure leads to exception"]: New test. --- libguile/strports.c | 30 +++++++++++++++++++++++------- test-suite/tests/ports.test | 16 ++++++++++++++++ 2 files changed, 39 insertions(+), 7 deletions(-) diff --git a/libguile/strports.c b/libguile/strports.c index ca3a2cf76..14cc93f81 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -288,7 +288,18 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) scm_i_dynwind_pthread_mutex_lock (&scm_i_port_table_mutex); z = scm_new_port_table_entry (scm_tc16_strport); - pt = SCM_PTAB_ENTRY(z); + SCM_SET_CELL_TYPE (z, scm_tc16_strport); + pt = SCM_PTAB_ENTRY (z); + + /* Make PT initially empty, and release the port-table mutex + immediately. This is so that if one of the function calls below + raises an exception, a pre-unwind catch handler can still create + new ports; for instance, `display-backtrace' needs to be able to + allocate a new string port. See . */ + scm_port_non_buffer (pt); + SCM_SETSTREAM (z, SCM_UNPACK (scm_null_bytevector)); + + scm_dynwind_end (); if (scm_is_false (str)) { @@ -296,10 +307,6 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) str_len = INITIAL_BUFFER_SIZE; buf = scm_c_make_bytevector (str_len); c_buf = (char *) SCM_BYTEVECTOR_CONTENTS (buf); - - /* Reset `read_buf_size'. It will contain the actual number of - bytes written to PT. */ - pt->read_buf_size = 0; c_pos = 0; } else @@ -318,12 +325,21 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) free (copy); c_pos = scm_to_unsigned_integer (pos, 0, str_len); - pt->read_buf_size = str_len; } + /* Now, finish up the port. */ + scm_i_pthread_mutex_lock (&scm_i_port_table_mutex); + SCM_SETSTREAM (z, SCM_UNPACK (buf)); SCM_SET_CELL_TYPE (z, scm_tc16_strport | modes); + if (scm_is_false (str)) + /* Reset `read_buf_size'. It will contain the actual number of + bytes written to PT. */ + pt->read_buf_size = 0; + else + pt->read_buf_size = str_len; + pt->write_buf = pt->read_buf = (unsigned char *) c_buf; pt->read_pos = pt->write_pos = pt->read_buf + c_pos; pt->write_buf_size = str_len; @@ -331,7 +347,7 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) pt->rw_random = 1; - scm_dynwind_end (); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); /* Ensure WRITE_POS is writable. */ if ((modes & SCM_WRTNG) && pt->write_pos == pt->write_end) diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 7728e2587..613d2693f 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -413,6 +413,22 @@ (pass-if "output check" (string=? text result))) + (pass-if "encoding failure leads to exception" + ;; Prior to 2.0.6, this would trigger a deadlock in `scm_mkstrport'. + ;; See the discussion at , for details. + (catch 'encoding-error + (lambda () + (with-fluids ((%default-port-encoding "ISO-8859-1")) + (let ((p (open-input-string "λ"))) ; raise an exception + #f))) + (lambda (key . rest) + #t) + (lambda (key . rest) + ;; At this point, the port-table mutex used to be still held, + ;; hence the deadlock. This situation would occur when trying + ;; to print a backtrace, for instance. + (input-port? (open-input-string "foo"))))) + (pass-if "%default-port-encoding is honored" (let ((encodings '("UTF-8" "UTF-16" "ISO-8859-1" "ISO-8859-3"))) (equal? (map (lambda (e) From 378daa5fa51f1d193f7236c2691acba59e9af539 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Mon, 11 Jun 2012 12:25:24 +0200 Subject: [PATCH 14/17] scandir: select? takes basenames, operates on (sub)dirs also * module/ice-9/ftw.scm (scandir): Run the select? procedure on all items, including subdirs and the `.' and `..' entries. Pass it the basename of the file in question instead of the full name. * test-suite/tests/ftw.test ("scandir"): Adapt expectation for the .test selector. Add test for a selector that rejects everything. --- module/ice-9/ftw.scm | 19 +++++++++++-------- test-suite/tests/ftw.test | 7 +++++-- 2 files changed, 16 insertions(+), 10 deletions(-) diff --git a/module/ice-9/ftw.scm b/module/ice-9/ftw.scm index 96422b5e4..6c9db27ee 100644 --- a/module/ice-9/ftw.scm +++ b/module/ice-9/ftw.scm @@ -538,26 +538,29 @@ of file names is sorted according to ENTRY (file-system-fold enter? leaf down up skip error #f name stat) (lambda (files) diff --git a/test-suite/tests/ftw.test b/test-suite/tests/ftw.test index 805c779bf..33537d04b 100644 --- a/test-suite/tests/ftw.test +++ b/test-suite/tests/ftw.test @@ -310,14 +310,17 @@ (pass-if "test-suite" (let ((select? (cut string-suffix? ".test" <>))) (match (scandir (string-append %test-dir "/tests") select?) - (("." ".." "00-initial-env.test" (? select?) ...) + (("00-initial-env.test" (? select?) ...) #t)))) (pass-if "flat file" (not (scandir (string-append %test-dir "/Makefile.am")))) (pass-if "EACCES" - (not (scandir "/.does-not-exist.")))) + (not (scandir "/.does-not-exist."))) + + (pass-if "no select" + (null? (scandir %test-dir (lambda (_) #f))))) ;;; Local Variables: ;;; eval: (put 'with-file-tree 'scheme-indent-function 2) From 4d1ae112792cb8faaa1f42b5c7332e9de05001ee Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Jun 2012 12:25:34 +0200 Subject: [PATCH 15/17] cse: expressions evaluated for effect do not provide predicates * module/language/tree-il/cse.scm (cse): When trying to fold conditionals, only look at entries in the database that were added in test context. * test-suite/tests/cse.test ("cse"): Add a test case. --- module/language/tree-il/cse.scm | 4 ++-- test-suite/tests/cse.test | 17 ++++++++++++++++- 2 files changed, 18 insertions(+), 3 deletions(-) diff --git a/module/language/tree-il/cse.scm b/module/language/tree-il/cse.scm index ceef15f70..b8e722967 100644 --- a/module/language/tree-il/cse.scm +++ b/module/language/tree-il/cse.scm @@ -276,11 +276,11 @@ #f))) (_ (cond - ((find-dominating-expression exp effects #f db) + ((find-dominating-expression exp effects 'test db) ;; We have an EXP fact, so we infer #t. (log 'inferring exp #t) (make-const (tree-il-src exp) #t)) - ((find-dominating-expression (negate exp 'test) effects #f db) + ((find-dominating-expression (negate exp 'test) effects 'test db) ;; We have a (not EXP) fact, so we infer #f. (log 'inferring exp #f) (make-const (tree-il-src exp) #f)) diff --git a/test-suite/tests/cse.test b/test-suite/tests/cse.test index ee3128511..d01d31874 100644 --- a/test-suite/tests/cse.test +++ b/test-suite/tests/cse.test @@ -271,4 +271,19 @@ (let ((x (car y))) (cons x (car y))) (let (x) (_) ((apply (primitive car) (toplevel y))) - (apply (primitive cons) (lexical x _) (lexical x _))))) + (apply (primitive cons) (lexical x _) (lexical x _)))) + + ;; Dominating expressions only provide predicates when evaluated in + ;; test context. + (pass-if-cse + (let ((t (car x))) + (if (car x) + 'one + 'two)) + ;; Actually this one should reduce in other ways, but this is the + ;; current reduction: + (begin + (apply (primitive car) (toplevel x)) + (if (apply (primitive car) (toplevel x)) + (const one) + (const two))))) From 5cfa385db721222069aa5a74421cbac6e6cee26a Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Jun 2012 12:29:08 +0200 Subject: [PATCH 16/17] update version-etc copyright year * module/ice-9/command-line.scm (version-etc): Update copyright year to 2012. --- module/ice-9/command-line.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 8aed74ec6..62a2c9e4f 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -66,7 +66,7 @@ There is NO WARRANTY, to the extent permitted by law.")) (define* (version-etc package version #:key (port (current-output-port)) ;; FIXME: authors - (copyright-year 2011) + (copyright-year 2012) (copyright-holder "Free Software Foundation, Inc.") (copyright (format #f "Copyright (C) ~a ~a" copyright-year copyright-holder)) From 2874f66017b7bfae256e85af84689d00ecc418ab Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 22 Jun 2012 12:30:39 +0200 Subject: [PATCH 17/17] add char->integer, number->string etc to interesting primitives * module/language/tree-il/primitives.scm (*interesting-primitive-names*): (*effect-free-primitives*): Add string->number, number->string, integer->char, and char->integer to allow for constant folding and better effects analysis. --- module/language/tree-il/primitives.scm | 3 +++ 1 file changed, 3 insertions(+) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index dba31bdc8..a1c5adc71 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -54,6 +54,8 @@ char=? char>? + integer->char char->integer number->string string->number + acons cons cons* list vector @@ -154,6 +156,7 @@ pair? null? list? symbol? vector? struct? string? number? char? complex? real? rational? inf? nan? integer? exact? inexact? even? odd? char=? char>? + integer->char char->integer number->string string->number struct-vtable string-length ;; These all should get expanded out by expand-primitives!.