From cc26b9de1d3c21cb4be49cc61c4b5872b8f607c5 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 28 Jul 2012 13:07:38 -0400 Subject: [PATCH 01/52] Add tests for 'exp' and 'expt' that should produce complex NaNs * test-suite/tests/numbers.test (exp, expt): Add tests that should produce complex NaNs, but apparently don't on all systems. --- test-suite/tests/numbers.test | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index a6697c9a3..35fe707ae 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -332,7 +332,16 @@ (eqv-loosely? 1.0 (exp 0+6.28318i))) (pass-if "exp(2-pi*i) = -e^2" - (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i)))) + (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i))) + + (pass-if "exp(+inf.0i) = nan.0+nan.0i" + (complex-nan? (exp +inf.0i))) + (pass-if "exp(+nan.0i) = nan.0+nan.0i" + (complex-nan? (exp +nan.0i))) + (pass-if "exp(inf.0+inf.0i) = nan.0+nan.0i" + (complex-nan? (exp +inf.0+inf.0i))) + (pass-if "exp(inf.0-inf.0i) = nan.0+nan.0i" + (complex-nan? (exp +inf.0-inf.0i)))) ;;; ;;; odd? @@ -4021,6 +4030,7 @@ (pass-if (real-nan? (expt 0 -1.0))) (pass-if (real-nan? (expt 0.0 -1))) (pass-if (real-nan? (expt 0.0 -1.0))) + (pass-if (complex-nan? (expt 0.0 -1.0+1.0i))) (pass-if (eqv? 0 (expt 0 3))) (pass-if (= 0 (expt 0 4.0))) (pass-if (eqv? 0.0 (expt 0.0 5))) From ecbded71bb423a6055c541d6272796aefd1486f9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 31 Jul 2012 22:52:17 -0400 Subject: [PATCH 02/52] Avoid cexp, whose C standard definition is mathematically incorrect * libguile/numbers.c (scm_exp): Do not use cexp. --- libguile/numbers.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 52e227f78..3ea88ea96 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9593,13 +9593,13 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0, { if (SCM_COMPLEXP (z)) { -#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \ - && defined (SCM_COMPLEX_VALUE) - return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z))); -#else + /* Unfortunately we cannot use cexp() here, because both C99 and + C11 specify behavior for cexp() that is mathematically + incorrect. In particular, they specify in annex G.6.3.1 + that cexp(+inf.0+inf.0i) and cexp(+inf.0+nan.0i) return + +inf.0+nan.0i or -inf.0+nan.0i. */ return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)), SCM_COMPLEX_IMAG (z)); -#endif } else if (SCM_NUMBERP (z)) { From 93723f3d1d4ed211a7a0d1ec547dfeb005424490 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 7 Aug 2012 18:13:48 -0400 Subject: [PATCH 03/52] Revert "Avoid cexp, whose C standard definition is mathematically incorrect" This reverts commit ecbded71bb423a6055c541d6272796aefd1486f9. --- libguile/numbers.c | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 3ea88ea96..52e227f78 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -9593,13 +9593,13 @@ SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0, { if (SCM_COMPLEXP (z)) { - /* Unfortunately we cannot use cexp() here, because both C99 and - C11 specify behavior for cexp() that is mathematically - incorrect. In particular, they specify in annex G.6.3.1 - that cexp(+inf.0+inf.0i) and cexp(+inf.0+nan.0i) return - +inf.0+nan.0i or -inf.0+nan.0i. */ +#if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \ + && defined (SCM_COMPLEX_VALUE) + return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z))); +#else return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)), SCM_COMPLEX_IMAG (z)); +#endif } else if (SCM_NUMBERP (z)) { From 639fd0a44265ba9223793eea9b5ae4d3c4da5237 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 7 Aug 2012 18:14:32 -0400 Subject: [PATCH 04/52] Revert "Add tests for 'exp' and 'expt' that should produce complex NaNs" This reverts commit cc26b9de1d3c21cb4be49cc61c4b5872b8f607c5. --- test-suite/tests/numbers.test | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 35fe707ae..a6697c9a3 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -332,16 +332,7 @@ (eqv-loosely? 1.0 (exp 0+6.28318i))) (pass-if "exp(2-pi*i) = -e^2" - (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i))) - - (pass-if "exp(+inf.0i) = nan.0+nan.0i" - (complex-nan? (exp +inf.0i))) - (pass-if "exp(+nan.0i) = nan.0+nan.0i" - (complex-nan? (exp +nan.0i))) - (pass-if "exp(inf.0+inf.0i) = nan.0+nan.0i" - (complex-nan? (exp +inf.0+inf.0i))) - (pass-if "exp(inf.0-inf.0i) = nan.0+nan.0i" - (complex-nan? (exp +inf.0-inf.0i)))) + (eqv-loosely? (- const-e^2) (exp 2.0-3.14159i)))) ;;; ;;; odd? @@ -4030,7 +4021,6 @@ (pass-if (real-nan? (expt 0 -1.0))) (pass-if (real-nan? (expt 0.0 -1))) (pass-if (real-nan? (expt 0.0 -1.0))) - (pass-if (complex-nan? (expt 0.0 -1.0+1.0i))) (pass-if (eqv? 0 (expt 0 3))) (pass-if (= 0 (expt 0 4.0))) (pass-if (eqv? 0.0 (expt 0.0 5))) From ee26a9ebe2d93263473db7d68e74a317eaf053ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Aug 2012 16:41:27 +0200 Subject: [PATCH 05/52] reinstate type check to scm_to_utf8_stringn * libguile/strings.c (scm_to_utf8_stringn): Re-add missing type check, inadvertantly removed in e3d4597469a543d97c4997b128509c2ceb13ca2b. --- libguile/strings.c | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/strings.c b/libguile/strings.c index 414951ee1..5d0db2301 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -1922,7 +1922,10 @@ u32_u8_length_in_bytes (const scm_t_uint32 *str, size_t len) char * scm_to_utf8_stringn (SCM str, size_t *lenp) +#define FUNC_NAME "scm_to_utf8_stringn" { + SCM_VALIDATE_STRING (1, str); + if (scm_i_is_narrow_string (str)) return (char *) latin1_to_u8 ((scm_t_uint8 *) scm_i_string_chars (str), scm_i_string_length (str), @@ -1969,6 +1972,7 @@ scm_to_utf8_stringn (SCM str, size_t *lenp) } } } +#undef FUNC_NAME scm_t_wchar * scm_to_utf32_string (SCM str) From b908768a7ec79f78def344c464186a51f55b69e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 20 Aug 2012 23:38:21 +0200 Subject: [PATCH 06/52] Optimize `scm_lfwrite_substr', used by `scm_simple_format'. Fixes . Reported by nalaginrut . * libguile/print.c (scm_i_display_substring): New function. * libguile/print.h (scm_i_display_substring): New internal declaration. * libguile/ports.c (scm_lfwrite_substr): Use it instead of `scm_display' + `scm_c_substring'. --- libguile/ports.c | 2 +- libguile/print.c | 23 +++++++++++++++++++++++ libguile/print.h | 5 ++++- 3 files changed, 28 insertions(+), 2 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 2f8c79217..301bc448b 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1465,7 +1465,7 @@ scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port) if (end == (size_t) -1) end = scm_i_string_length (str); - scm_display (scm_c_substring (str, start, end), port); + scm_i_display_substring (str, start, end, port); if (pt->rw_random) pt->rw_active = SCM_PORT_WRITE; diff --git a/libguile/print.c b/libguile/print.c index cb3c0b95a..647eed8cb 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1167,6 +1167,29 @@ write_character (scm_t_wchar ch, SCM port, int string_escapes_p) write_character_escaped (ch, string_escapes_p, port); } +/* Display STR to PORT from START inclusive to END exclusive. */ +void +scm_i_display_substring (SCM str, size_t start, size_t end, SCM port) +{ + int narrow_p; + const char *buf; + size_t len, printed; + + buf = scm_i_string_data (str); + len = end - start; + narrow_p = scm_i_is_narrow_string (str); + buf += start * (narrow_p ? sizeof (char) : sizeof (scm_t_wchar)); + + printed = display_string (buf, narrow_p, end - start, port, + PORT_CONVERSION_HANDLER (port)); + + if (SCM_UNLIKELY (printed < len)) + scm_encoding_error (__func__, errno, + "cannot convert to output locale", + port, scm_c_string_ref (str, printed + start)); +} + + /* Print an integer. */ diff --git a/libguile/print.h b/libguile/print.h index 64d1f4bd8..4c60b52f1 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -3,7 +3,8 @@ #ifndef SCM_PRINT_H #define SCM_PRINT_H -/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006, 2008, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 2000, 2001, 2003, 2004, 2006, 2008, + * 2010, 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 @@ -78,6 +79,8 @@ SCM_API SCM scm_print_options (SCM setting); SCM_API SCM scm_make_print_state (void); SCM_API void scm_free_print_state (SCM print_state); SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state); +SCM_INTERNAL void scm_i_display_substring (SCM str, size_t start, size_t end, + SCM port); SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port); SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port); SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port); From 6c9220064d987deee813cfd933d50353d14d4c0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 21 Aug 2012 00:36:50 +0200 Subject: [PATCH 07/52] Micro-optimize (ice-9 format). * module/ice-9/format.scm (format): Use `call-with-output-string' instead of `with-output-to-string'. --- module/ice-9/format.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/module/ice-9/format.scm b/module/ice-9/format.scm index d038ace5a..eed8cbb0e 100644 --- a/module/ice-9/format.scm +++ b/module/ice-9/format.scm @@ -427,15 +427,15 @@ (case modifier ((at) (format:out-str - (with-output-to-string - (lambda () - (truncated-print (next-arg) + (call-with-output-string + (lambda (p) + (truncated-print (next-arg) p #:width width))))) ((colon-at) (format:out-str - (with-output-to-string - (lambda () - (truncated-print (next-arg) + (call-with-output-string + (lambda (p) + (truncated-print (next-arg) p #:width (max (- width output-col) @@ -779,7 +779,7 @@ (define (format:obj->str obj slashify) (let ((res (if slashify (object->string obj) - (with-output-to-string (lambda () (display obj)))))) + (call-with-output-string (lambda (p) (display obj p)))))) (if (and format:read-proof (string-prefix? "#<" res)) (object->string res) res))) From dc7a9cefbf5434b6e7e503fe83faa07b24a1a6cd Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sat, 25 Aug 2012 11:52:44 +0200 Subject: [PATCH 08/52] more robust texinfo alias handling * module/texinfo.scm (command-spec): Resolve aliases here. (complete-start-command, make-command-parser): (make-dom-parser, parse-environment-args): Reload command after resolving spec, so we get the alias target. --- module/texinfo.scm | 28 +++++++++++++++++++--------- 1 file changed, 19 insertions(+), 9 deletions(-) diff --git a/module/texinfo.scm b/module/texinfo.scm index 2ffd85393..519db485d 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -384,8 +384,14 @@ Examples: ;; Like a DTD for texinfo (define (command-spec command) - (or (assq command texi-command-specs) - (parser-error #f "Unknown command" command))) + (let ((spec (assq command texi-command-specs))) + (cond + ((not spec) + (parser-error #f "Unknown command" command)) + ((eq? (cadr spec) 'ALIAS) + (command-spec (cddr spec))) + (else + spec)))) (define (inline-content? content) (case content @@ -647,11 +653,10 @@ Examples: (arguments->attlist port (read-arguments port stop-char) arg-names)) (let* ((spec (command-spec command)) + (command (car spec)) (type (cadr spec)) (arg-names (cddr spec))) (case type - ((ALIAS) - (complete-start-command arg-names port)) ((INLINE-TEXT) (assert-curr-char '(#\{) "Inline element lacks {" port) (values command '() type)) @@ -954,7 +959,9 @@ Examples: (loop port expect-eof? end-para need-break? seed))) ((START) ; Start of an @-command (let* ((head (token-head token)) - (type (cadr (command-spec head))) + (spec (command-spec head)) + (head (car spec)) + (type (cadr spec)) (inline? (inline-content? type)) (seed ((if (and inline? (not need-break?)) identity end-para) seed)) @@ -1045,8 +1052,9 @@ Examples: (lambda (command args content seed) ; fdown '()) (lambda (command args parent-seed seed) ; fup - (let ((seed (reverse-collect-str-drop-ws seed)) - (spec (command-spec command))) + (let* ((seed (reverse-collect-str-drop-ws seed)) + (spec (command-spec command)) + (command (car spec))) (if (eq? (cadr spec) 'INLINE-TEXT-ARGS) (cons (list command (cons '% (parse-inline-text-args #f spec seed))) parent-seed) @@ -1062,8 +1070,10 @@ Examples: (let ((parser (make-dom-parser))) ;; duplicate arguments->attlist to avoid unnecessary splitting (lambda (command port) - (let ((args (cdar (parser '*ENVIRON-ARGS* port '()))) - (arg-names (cddr (command-spec command)))) + (let* ((args (cdar (parser '*ENVIRON-ARGS* port '()))) + (spec (command-spec command)) + (command (car spec)) + (arg-names (cddr spec))) (cond ((not arg-names) (if (null? args) '() From b401fe71692a4473a51c39d7964ce554bf2ced37 Mon Sep 17 00:00:00 2001 From: Ian Price Date: Mon, 20 Aug 2012 23:03:38 +0100 Subject: [PATCH 09/52] Fix uri-encoding for octets 0-15 * module/web/uri.scm (uri-encode): All encoded octets should be of the form % HEXDIGIT HEXDIGIT. * test-suite/tests/web-uri.test ("encode"): Add test. --- module/web/uri.scm | 2 ++ test-suite/tests/web-uri.test | 3 ++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/module/web/uri.scm b/module/web/uri.scm index 109118b12..3816d0200 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -377,6 +377,8 @@ the byte." (if (< i len) (let ((byte (bytevector-u8-ref bv i))) (display #\% port) + (when (< byte 16) + (display #\0 port)) (display (number->string byte 16) port) (lp (1+ i)))))))) str))) diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index 4621a19f9..a9ded46bd 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -258,4 +258,5 @@ (equal? "foo bar" (uri-decode "foo+bar")))) (with-test-prefix "encode" - (pass-if (equal? "foo%20bar" (uri-encode "foo bar")))) + (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))) + (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar")))) From 866210bf247ea57bed5421ce8887a84e53347acb Mon Sep 17 00:00:00 2001 From: Ian Price Date: Mon, 20 Aug 2012 23:12:23 +0100 Subject: [PATCH 10/52] Fix uri-encoding for strings with no unreserved chars * module/web/uri.scm (uri-encode): Change test to check for unreserved chars instead of reserved chars. * test-suite/tests/web-uri.test ("encode"): Add test. --- module/web/uri.scm | 4 +++- test-suite/tests/web-uri.test | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/module/web/uri.scm b/module/web/uri.scm index 3816d0200..78614a520 100644 --- a/module/web/uri.scm +++ b/module/web/uri.scm @@ -364,7 +364,9 @@ Percent-encoding first writes out the given character to a bytevector within the given @var{encoding}, then encodes each byte as @code{%@var{HH}}, where @var{HH} is the hexadecimal representation of the byte." - (if (string-index str unescaped-chars) + (define (needs-escaped? ch) + (not (char-set-contains? unescaped-chars ch))) + (if (string-index str needs-escaped?) (call-with-output-string* (lambda (port) (string-for-each diff --git a/test-suite/tests/web-uri.test b/test-suite/tests/web-uri.test index a9ded46bd..3f6e7e3ab 100644 --- a/test-suite/tests/web-uri.test +++ b/test-suite/tests/web-uri.test @@ -259,4 +259,5 @@ (with-test-prefix "encode" (pass-if (equal? "foo%20bar" (uri-encode "foo bar"))) - (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar")))) + (pass-if (equal? "foo%0a%00bar" (uri-encode "foo\n\x00bar"))) + (pass-if (equal? "%3c%3e%5c%5e" (uri-encode "<>\\^")))) From fd99e505d794049bb1a06aa1e9de8a0f9cff6689 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 26 Aug 2012 23:42:09 +0200 Subject: [PATCH 11/52] Update `texinfo.test' to match latest change. * test-suite/tests/texinfo.test ("test-texinfo->stexinfo")["@url{arg}"]: Update test as a follow-up to dc7a9cefbf5434b6e7e503fe83faa07b24a1a6cd ("more robust texinfo alias handling"). --- test-suite/tests/texinfo.test | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test-suite/tests/texinfo.test b/test-suite/tests/texinfo.test index 98c44b91b..8a4b593fd 100644 --- a/test-suite/tests/texinfo.test +++ b/test-suite/tests/texinfo.test @@ -208,9 +208,8 @@ (test-body "@code{arg}" '((para (code "arg")))) - ;; FIXME: Why no enclosing para here? Probably a bug. (test-body "@url{arg}" - '((uref (% (url "arg"))))) + '((para (uref (% (url "arg")))))) (test-body "@code{ }" '((para (code)))) (test-body "@code{ @code{} }" From 7aa394b53c289c1f05dacaef8a9167fbaecc00fa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 27 Aug 2012 00:09:30 +0200 Subject: [PATCH 12/52] doc: Fix description of regexp/locale encoding interaction. * doc/ref/api-regex.texi (Regexp Functions): Update paragraph that mentions locale encoding and strings-as-bytes. * test-suite/tests/regexp.test ("nonascii locales")["match structures refer to char offsets, non-ASCII pattern"]: New test. --- doc/ref/api-regex.texi | 13 +++++++------ test-suite/tests/regexp.test | 15 ++++++++++++--- 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/doc/ref/api-regex.texi b/doc/ref/api-regex.texi index 11a31fca0..082fb874d 100644 --- a/doc/ref/api-regex.texi +++ b/doc/ref/api-regex.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2007, 2009, 2010, 2012 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -54,11 +54,12 @@ Zero bytes (@code{#\nul}) cannot be used in regex patterns or input strings, since the underlying C functions treat that as the end of string. If there's a zero byte an error is thrown. -Patterns and input strings are treated as being in the locale -character set if @code{setlocale} has been called (@pxref{Locales}), -and in a multibyte locale this includes treating multi-byte sequences -as a single character. (Guile strings are currently merely bytes, -though this may change in the future, @xref{Conversion to/from C}.) +Internally, patterns and input strings are converted to the current +locale's encoding, and then passed to the C library's regular expression +routines (@pxref{Regular Expressions,,, libc, The GNU C Library +Reference Manual}). The returned match structures always point to +characters in the strings, not to individual bytes, even in the case of +multi-byte encodings. @deffn {Scheme Procedure} string-match pattern str [start] Compile the string @var{pattern} into a regular expression and compare diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index 8217a4156..ef5946501 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -1,8 +1,9 @@ ;;;; regexp.test --- test Guile's regexps -*- coding: utf-8; mode: scheme -*- ;;;; Jim Blandy --- September 1999 ;;;; -;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. -;;;; +;;;; Copyright (C) 1999, 2004, 2006, 2007, 2008, 2009, 2010, +;;;; 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 @@ -280,4 +281,12 @@ (with-locale "en_US.utf8" ;; bug #31650 (equal? (match:substring (string-match ".*" "calçot") 0) - "calçot")))) + "calçot"))) + + (pass-if "match structures refer to char offsets, non-ASCII pattern" + (with-locale "en_US.utf8" + ;; bug #31650 + (equal? (match:substring (string-match "λ: The Ultimate (.*)" + "λ: The Ultimate GOTO") + 1) + "GOTO")))) From d6bd18261895a9b7cb9570c95b779c615e261728 Mon Sep 17 00:00:00 2001 From: Ian Price Date: Tue, 21 Aug 2012 12:13:25 +0100 Subject: [PATCH 13/52] ISO 8601 time format specifies zero padding for hours, not blank padding. * doc/ref/srfi-modules.texi ("SRFI-19 Date to string"): Fix iso 8601 format strings. * module/srfi/srfi-19.scm (directives): Fix iso 8601 format strings. --- doc/ref/srfi-modules.texi | 8 ++++---- module/srfi/srfi-19.scm | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 7e7d658b1..ba701a264 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -3003,10 +3003,10 @@ with locale decimal point, eg.@: @samp{5.2} @item @nicode{~z} @tab time zone, RFC-822 style @item @nicode{~Z} @tab time zone symbol (not currently implemented) @item @nicode{~1} @tab ISO-8601 date, @samp{~Y-~m-~d} -@item @nicode{~2} @tab ISO-8601 time+zone, @samp{~k:~M:~S~z} -@item @nicode{~3} @tab ISO-8601 time, @samp{~k:~M:~S} -@item @nicode{~4} @tab ISO-8601 date/time+zone, @samp{~Y-~m-~dT~k:~M:~S~z} -@item @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~k:~M:~S} +@item @nicode{~2} @tab ISO-8601 time+zone, @samp{~H:~M:~S~z} +@item @nicode{~3} @tab ISO-8601 time, @samp{~H:~M:~S} +@item @nicode{~4} @tab ISO-8601 date/time+zone, @samp{~Y-~m-~dT~H:~M:~S~z} +@item @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~H:~M:~S} @end multitable @end defun diff --git a/module/srfi/srfi-19.scm b/module/srfi/srfi-19.scm index d8f764335..c0a27b1a2 100644 --- a/module/srfi/srfi-19.scm +++ b/module/srfi/srfi-19.scm @@ -1113,13 +1113,13 @@ (cons #\1 (lambda (date pad-with port) (display (date->string date "~Y-~m-~d") port))) (cons #\2 (lambda (date pad-with port) - (display (date->string date "~k:~M:~S~z") port))) + (display (date->string date "~H:~M:~S~z") port))) (cons #\3 (lambda (date pad-with port) - (display (date->string date "~k:~M:~S") port))) + (display (date->string date "~H:~M:~S") port))) (cons #\4 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~k:~M:~S~z") port))) + (display (date->string date "~Y-~m-~dT~H:~M:~S~z") port))) (cons #\5 (lambda (date pad-with port) - (display (date->string date "~Y-~m-~dT~k:~M:~S") port))))) + (display (date->string date "~Y-~m-~dT~H:~M:~S") port))))) (define (get-formatter char) From a8872c78a4baa6c98e60924919d9adb7e651a7df Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 3 Sep 2012 22:33:45 +0200 Subject: [PATCH 14/52] build: Use Automake's `color-tests'. * configure.ac: Use Automake's `color-tests'. --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 32a6760a5..52fff6918 100644 --- a/configure.ac +++ b/configure.ac @@ -36,7 +36,7 @@ AC_CONFIG_MACRO_DIR([m4]) AC_CONFIG_SRCDIR(GUILE-VERSION) dnl `AM_SUBST_NOTMAKE' was introduced in Automake 1.11. -AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override dist-xz]) +AM_INIT_AUTOMAKE([1.11 gnu no-define -Wall -Wno-override color-tests dist-xz]) m4_ifdef([AM_SILENT_RULES], [AM_SILENT_RULES([yes])], [AC_SUBST([AM_DEFAULT_VERBOSITY],1)]) AC_COPYRIGHT(GUILE_CONFIGURE_COPYRIGHT) From 8a84f7fb46182c9220da514bc25d85ee799c799f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 3 Sep 2012 22:35:33 +0200 Subject: [PATCH 15/52] doc: Use scm_{to,from}_double instead of old API in example. Fixed . Reported by Kurt W. Gochko . * doc/ref/tour.texi (Writing Guile Extensions): Change example to use scm_{to,from}_double instead of the pre-1.8 API. --- doc/ref/tour.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/tour.texi b/doc/ref/tour.texi index 3e612692d..0924216aa 100644 --- a/doc/ref/tour.texi +++ b/doc/ref/tour.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2010, 2011, +@c 2012 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @raisesections @@ -149,7 +149,7 @@ that makes the @code{j0} function available to Scheme code. SCM j0_wrapper (SCM x) @{ - return scm_make_real (j0 (scm_num2dbl (x, "j0"))); + return scm_from_double (j0 (scm_to_double (x))); @} void From 068adc1980535f187ad9721d67f223c52546c38a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Mon, 3 Sep 2012 22:40:46 +0200 Subject: [PATCH 16/52] build: Fix race between installing `guild' and the `guile-tools' symlink. Fixes . Report and patch by Song.Li . * meta/Makefile.am (install-data-hook): Rename to... (install-exec-hook): ... this. --- meta/Makefile.am | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/meta/Makefile.am b/meta/Makefile.am index a05730d13..bd2078409 100644 --- a/meta/Makefile.am +++ b/meta/Makefile.am @@ -28,7 +28,7 @@ EXTRA_DIST= \ guild.in guile-config.in # What we now call `guild' used to be known as `guile-tools'. -install-data-hook: +install-exec-hook: guild="`echo $(ECHO_N) guild \ | $(SED) -e '$(program_transform_name)'`$(EXEEXT)" ; \ guile_tools="`echo $(ECHO_N) guile-tools \ From 4aaceda29fc70124e64397c1593dc07a3a73a463 Mon Sep 17 00:00:00 2001 From: Ian Price Date: Tue, 4 Sep 2012 13:18:58 +0100 Subject: [PATCH 17/52] `define-public' is no a longer curried definition by default. * module/ice-9/boot-9.scm (define-public): Remove currying functionality. * module/ice-9/curried-definitions.scm (define-public): New export. --- module/ice-9/boot-9.scm | 4 +++- module/ice-9/curried-definitions.scm | 14 +++++++++++++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 5ed543a1c..cf8252a4a 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3321,7 +3321,9 @@ module '(ice-9 q) '(make-q q-length))}." (define-syntax define-public (syntax-rules () ((_ (name . args) . body) - (define-public name (lambda args . body))) + (begin + (define name (lambda args . body)) + (export name))) ((_ name val) (begin (define name val) diff --git a/module/ice-9/curried-definitions.scm b/module/ice-9/curried-definitions.scm index d55f1fb6a..8c684a18c 100644 --- a/module/ice-9/curried-definitions.scm +++ b/module/ice-9/curried-definitions.scm @@ -16,7 +16,8 @@ (define-module (ice-9 curried-definitions) #:replace ((cdefine . define) - (cdefine* . define*))) + (cdefine* . define*) + define-public)) (define-syntax cdefine (syntax-rules () @@ -39,3 +40,14 @@ (lambda* rest body body* ...))) ((_ . rest) (define* . rest)))) + +(define-syntax define-public + (syntax-rules () + ((_ (name . args) . body) + (begin + (cdefine (name . args) . body) + (export name))) + ((_ name val) + (begin + (define name val) + (export name))))) From 985538837806ab8dadfe3c01388355b9f551a303 Mon Sep 17 00:00:00 2001 From: Ian Price Date: Thu, 6 Sep 2012 21:21:47 +0100 Subject: [PATCH 18/52] Document (ice-9 curried definitions) * doc/ref/Makefile.am (guile_TEXINFOS): Add curried.texi to list * doc/ref/curried.texi: New file. * doc/ref/guile.texi (Guile Modules): Add "Curried Definitions" to menu. * doc/ref/scheme-ideas.texi (Lambda Alternatives): Refer to "Curried Definitions" from the `define' section. --- doc/ref/Makefile.am | 1 + doc/ref/curried.texi | 56 +++++++++++++++++++++++++++++++++++++++ doc/ref/guile.texi | 2 ++ doc/ref/scheme-ideas.texi | 5 ++++ 4 files changed, 64 insertions(+) create mode 100644 doc/ref/curried.texi diff --git a/doc/ref/Makefile.am b/doc/ref/Makefile.am index abe9cb9ee..201ab6b3f 100644 --- a/doc/ref/Makefile.am +++ b/doc/ref/Makefile.am @@ -62,6 +62,7 @@ guile_TEXINFOS = preface.texi \ web.texi \ expect.texi \ scsh.texi \ + curried.texi \ sxml-match.texi \ scheme-scripts.texi \ api-overview.texi \ diff --git a/doc/ref/curried.texi b/doc/ref/curried.texi new file mode 100644 index 000000000..25430b4f0 --- /dev/null +++ b/doc/ref/curried.texi @@ -0,0 +1,56 @@ +@c -*-texinfo-*- +@c This is part of the GNU Guile Reference Manual. +@c Copyright (C) 2012 Free Software Foundation, Inc. +@c See the file guile.texi for copying conditions. + +@node Curried Definitions +@section Curried Definitions + +The macros in this section are provided by +@lisp +(use-modules (ice-9 curried-definitions)) +@end lisp +@noindent +and replace those provided by default. + +Prior to Guile 2.0, Guile provided a type of definition known colloquially +as a ``curried definition''. The idea is to extend the syntax of +@code{define} so that you can conveniently define procedures that return +procedures, up to any desired depth. + +For example, +@example +(define ((foo x) y) + (list x y)) +@end example +is a convenience form of +@example +(define foo + (lambda (x) + (lambda (y) + (list x y)))) +@end example + +@deffn {Scheme Syntax} define (@dots{} (name args @dots{}) @dots{}) body @dots{} +@deffnx {Scheme Syntax} define* (@dots{} (name args @dots{}) @dots{}) body @dots{} +@deffnx {Scheme Syntax} define-public (@dots{} (name args @dots{}) @dots{}) body @dots{} + +Create a top level variable @var{name} bound to the procedure with +parameter list @var{args}. If @var{name} is itself a formal parameter +list, then a higher order procedure is created using that +formal-parameter list, and returning a procedure that has parameter list +@var{args}. This nesting may occur to arbitrary depth. + +@code{define*} is similar but the formal parameter lists take additional +options as described in @ref{lambda* and define*}. For example, +@example +(define* ((foo #:keys (bar 'baz) (quux 'zot)) frotz #:rest rest) + (list bar quux frotz rest)) + +((foo #:quux 'foo) 1 2 3 4 5) +@result{} (baz foo 1 (2 3 4 5)) +@end example + +@code{define-public} is similar to @code{define} but it also adds +@var{name} to the list of exported bindings of the current module. +@end deffn diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index c3da0c36d..a1b3fe60c 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -370,6 +370,7 @@ available through both Scheme and C interfaces. * Expect:: Controlling interactive programs with Guile. * sxml-match:: Pattern matching of SXML. * The Scheme shell (scsh):: Using scsh interfaces in Guile. +* Curried Definitions:: Extended @code{define} syntax. @end menu @include slib.texi @@ -387,6 +388,7 @@ available through both Scheme and C interfaces. @include sxml-match.texi @include scsh.texi +@include curried.texi @node Standard Library @chapter Standard Library diff --git a/doc/ref/scheme-ideas.texi b/doc/ref/scheme-ideas.texi index 53f7b6132..15cf6640d 100644 --- a/doc/ref/scheme-ideas.texi +++ b/doc/ref/scheme-ideas.texi @@ -476,6 +476,11 @@ The corresponding forms of the alternative @code{define} syntax are: @noindent For details on how these forms work, see @xref{Lambda}. +Prior to Guile 2.0, Guile provided an extension to @code{define} syntax +that allowed you to nest the previous extension up to an arbitrary +depth. These are no longer provided by default, and instead have been +moved to @ref{Curried Definitions} + (It could be argued that the alternative @code{define} forms are rather confusing, especially for newcomers to the Scheme language, as they hide both the role of @code{lambda} and the fact that procedures are values From e7350baf1e93d68eb7dc23fc16f711c066cb37ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 11 Sep 2012 23:39:32 +0200 Subject: [PATCH 19/52] Rewrite SRFI-31 in terms of `syntax-rules'. * module/srfi/srfi-31.scm: Use `#:export' instead of `#:export-syntax'. (rec): Rewrite using `syntax-rules'. * test-suite/tests/srfi-31.test ("rec special form"): Change exception type to EXCEPTION:SYNTAX-PATTERN-UNMATCHED. --- module/srfi/srfi-31.scm | 26 ++++++++++++-------------- test-suite/tests/srfi-31.test | 7 ++++--- 2 files changed, 16 insertions(+), 17 deletions(-) diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm index 4238dc269..cf67e8af5 100644 --- a/module/srfi/srfi-31.scm +++ b/module/srfi/srfi-31.scm @@ -1,6 +1,6 @@ ;;; srfi-31.scm --- special form for recursive evaluation -;; Copyright (C) 2004, 2006 Free Software Foundation, Inc. +;; Copyright (C) 2004, 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 @@ -19,17 +19,15 @@ ;;; Original author: Rob Browning (define-module (srfi srfi-31) - :export-syntax (rec)) + #:export (rec)) -(define-macro (rec arg-form . body) - (cond - ((and (symbol? arg-form) (= 1 (length body))) - ;; (rec S (cons 1 (delay S))) - `(letrec ((,arg-form ,(car body))) - ,arg-form)) - ;; (rec (f x) (+ x 1)) - ((list? arg-form) - `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body))) - ,(car arg-form))) - (else - (error "syntax error in rec form" `(rec ,arg-form ,@body))))) +(define-syntax rec + (syntax-rules () + "Return the given object, defined in a lexical environment where +NAME is bound to itself." + ((_ (name . formals) body ...) ; procedure + (letrec ((name (lambda formals body ...))) + name)) + ((_ name expr) ; arbitrary object + (letrec ((name expr)) + name)))) diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test index 8537d49b6..62645d918 100644 --- a/test-suite/tests/srfi-31.test +++ b/test-suite/tests/srfi-31.test @@ -1,6 +1,6 @@ ;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*- ;;;; -;;;; Copyright (C) 2004, 2006, 2010 Free Software Foundation, Inc. +;;;; Copyright (C) 2004, 2006, 2010, 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 @@ -22,9 +22,10 @@ (with-test-prefix "rec special form" - (pass-if-exception "bogus variable" '(misc-error . ".*") + (pass-if-exception "bogus variable" + exception:syntax-pattern-unmatched (eval '(rec #:foo) (current-module))) - + (pass-if "rec expressions" (let ((ones-list (rec ones (cons 1 (delay ones))))) (and (= 1 (car ones-list)) From b6aedd68bcbb07c9c6fd60e10cde314b68b0e1e9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Tue, 11 Sep 2012 23:44:59 +0200 Subject: [PATCH 20/52] Don't stat(2) and access(2) the .go location before using it. * module/system/base/compile.scm (ensure-directory): Rename to... (ensure-directory): ... this. Update callers. When ERRNO is EEXIST, assume DIR is a writable directory instead of calling `stat' and `access?' again. Fixes UID/EUID mismatches for setuid binaries. Reported by rixed@happyleptic.org at . --- module/system/base/compile.scm | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm index 0bc11a30f..afcb55a72 100644 --- a/module/system/base/compile.scm +++ b/module/system/base/compile.scm @@ -1,6 +1,6 @@ ;;; High-level compiler interface -;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc. +;; Copyright (C) 2001, 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 @@ -72,7 +72,7 @@ ;; before the check, so that we avoid races (possibly due to parallel ;; compilation). ;; -(define (ensure-writable-dir dir) +(define (ensure-directory dir) (catch 'system-error (lambda () (mkdir dir)) @@ -80,13 +80,12 @@ (let ((errno (and (pair? rest) (car rest)))) (cond ((eqv? errno EEXIST) - (let ((st (stat dir))) - (if (or (not (eq? (stat:type st) 'directory)) - (not (access? dir W_OK))) - (error "directory not writable" dir)))) + ;; Assume it's a writable directory, to avoid TOCTOU errors, + ;; as well as UID/EUID mismatches that occur with access(2). + #t) ((eqv? errno ENOENT) - (ensure-writable-dir (dirname dir)) - (ensure-writable-dir dir)) + (ensure-directory (dirname dir)) + (ensure-directory dir)) (else (throw k subr fmt args rest))))))) @@ -125,7 +124,7 @@ %compile-fallback-path (canonical->suffix (canonicalize-path file)) (compiled-extension)))) - (and (false-if-exception (ensure-writable-dir (dirname f))) + (and (false-if-exception (ensure-directory (dirname f))) f)))) (define* (compile-file file #:key @@ -144,7 +143,7 @@ ;; Choose the input encoding deterministically. (set-port-encoding! in (or enc "UTF-8")) - (ensure-writable-dir (dirname comp)) + (ensure-directory (dirname comp)) (call-with-output-file/atomic comp (lambda (port) ((language-printer (ensure-language to)) From d6e1c8bfdb727f39352c7304c225c05545067f30 Mon Sep 17 00:00:00 2001 From: "Chris K. Jester-Young" Date: Sun, 16 Sep 2012 02:27:19 -0400 Subject: [PATCH 21/52] In fold-matches, set regexp/notbol unless matching string start. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * module/ice-9/regex.scm (fold-matches): Set regexp/notbol if the starting position is nonzero. * test-suite/tests/regexp.test (fold-matches): Check that when matching /^foo/ against "foofoofoofoo", only one match results. Signed-off-by: Ludovic Courtès --- module/ice-9/regex.scm | 3 ++- test-suite/tests/regexp.test | 9 ++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/module/ice-9/regex.scm b/module/ice-9/regex.scm index f7b94b72a..08ae2c2f5 100644 --- a/module/ice-9/regex.scm +++ b/module/ice-9/regex.scm @@ -172,8 +172,9 @@ (let loop ((start 0) (value init) (abuts #f)) ; True if start abuts a previous match. + (define bol (if (zero? start) 0 regexp/notbol)) (let ((m (if (> start (string-length string)) #f - (regexp-exec regexp string start flags)))) + (regexp-exec regexp string start (logior flags bol))))) (cond ((not m) value) ((and (= (match:start m) (match:end m)) abuts) diff --git a/test-suite/tests/regexp.test b/test-suite/tests/regexp.test index ef5946501..d549df2cb 100644 --- a/test-suite/tests/regexp.test +++ b/test-suite/tests/regexp.test @@ -132,7 +132,14 @@ (lambda (match result) (cons (match:substring match) result)) - (logior regexp/notbol regexp/noteol))))) + (logior regexp/notbol regexp/noteol)))) + + (pass-if "regexp/notbol is set correctly" + (equal? '("foo") + (fold-matches "^foo" "foofoofoofoo" '() + (lambda (match result) + (cons (match:substring match) + result)))))) ;;; From 88644a10d82045f429f66f20a47973e48715de1d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Thu, 4 Oct 2012 07:57:27 -0400 Subject: [PATCH 22/52] Change inappropriate uses of expect-fail X to pass-if not X in chars.test * test-suite/tests/chars.test (basic char handling): Change inappropriate uses of 'expect-fail' to 'pass-if' with 'not' applied to the test. --- test-suite/tests/chars.test | 84 ++++++++++++++++++------------------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/test-suite/tests/chars.test b/test-suite/tests/chars.test index bdc9bdb41..98854f73a 100644 --- a/test-suite/tests/chars.test +++ b/test-suite/tests/chars.test @@ -45,18 +45,18 @@ (pass-if "char=? #\\A #\\A" (char=? #\A #\A)) - (expect-fail "char=? #\\A #\\a" - (char=? #\A #\a)) + (pass-if "char=? #\\A #\\a" + (not (char=? #\A #\a))) - (expect-fail "char=? #\\A #\\B" - (char=? #\A #\B)) + (pass-if "char=? #\\A #\\B" + (not (char=? #\A #\B))) - (expect-fail "char=? #\\B #\\A" - (char=? #\A #\B)) + (pass-if "char=? #\\B #\\A" + (not (char=? #\A #\B))) ;; char? - (expect-fail "char>? #\\A #\\A" - (char>? #\A #\A)) + (pass-if "char>? #\\A #\\A" + (not (char>? #\A #\A))) - (expect-fail "char>? #\\A #\\a" - (char>? #\A #\a)) + (pass-if "char>? #\\A #\\a" + (not (char>? #\A #\a))) - (expect-fail "char>? #\\A #\\B" - (char>? #\A #\B)) + (pass-if "char>? #\\A #\\B" + (not (char>? #\A #\B))) (pass-if "char>? #\\B #\\A" (char>? #\B #\A)) @@ -97,11 +97,11 @@ (pass-if "char>=? #\\A #\\A" (char>=? #\A #\A)) - (expect-fail "char>=? #\\A #\\a" - (char>=? #\A #\a)) + (pass-if "char>=? #\\A #\\a" + (not (char>=? #\A #\a))) - (expect-fail "char>=? #\\A #\\B" - (char>=? #\A #\B)) + (pass-if "char>=? #\\A #\\B" + (not (char>=? #\A #\B))) (pass-if "char>=? #\\B #\\A" (char>=? #\B #\A)) @@ -113,24 +113,24 @@ (pass-if "char-ci=? #\\A #\\a" (char-ci=? #\A #\a)) - (expect-fail "char-ci=? #\\A #\\B" - (char-ci=? #\A #\B)) + (pass-if "char-ci=? #\\A #\\B" + (not (char-ci=? #\A #\B))) - (expect-fail "char-ci=? #\\B #\\A" - (char-ci=? #\A #\B)) + (pass-if "char-ci=? #\\B #\\A" + (not (char-ci=? #\A #\B))) ;; char-ci? - (expect-fail "char-ci>? #\\A #\\A" - (char-ci>? #\A #\A)) + (pass-if "char-ci>? #\\A #\\A" + (not (char-ci>? #\A #\A))) - (expect-fail "char-ci>? #\\A #\\a" - (char-ci>? #\A #\a)) + (pass-if "char-ci>? #\\A #\\a" + (not (char-ci>? #\A #\a))) - (expect-fail "char-ci>? #\\A #\\B" - (char-ci>? #\A #\B)) + (pass-if "char-ci>? #\\A #\\B" + (not (char-ci>? #\A #\B))) (pass-if "char-ci>? #\\B #\\A" (char-ci>? #\B #\A)) @@ -165,8 +165,8 @@ (pass-if "char-ci>=? #\\A #\\a" (char-ci>=? #\A #\a)) - (expect-fail "char-ci>=? #\\A #\\B" - (char-ci>=? #\A #\B)) + (pass-if "char-ci>=? #\\A #\\B" + (not (char-ci>=? #\A #\B))) (pass-if "char-ci>=? #\\B #\\A" (char-ci>=? #\B #\A))) From 226a56a3d454b18b2b57c4489fdb8efbf4cd8332 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 6 Oct 2012 06:04:29 -0400 Subject: [PATCH 23/52] Improve error reporting in 'append!' * libguile/list.c (scm_append_x): Report correct argument number when validating arguments. Validate that the last cdr of each argument is null or nil. Rename formal rest argument from 'lists' to 'args'. * test-suite/tests/list.test (append!): Update tests to expect correct handling of improper lists. --- libguile/list.c | 17 ++++++++++------- test-suite/tests/list.test | 6 +++--- 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/libguile/list.c b/libguile/list.c index 221ee79d0..6c8f8bef2 100644 --- a/libguile/list.c +++ b/libguile/list.c @@ -267,7 +267,7 @@ SCM_DEFINE (scm_append, "append", 0, 0, 1, SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, - (SCM lists), + (SCM args), "A destructive version of @code{append} (@pxref{Pairs and\n" "Lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field\n" "of each list's final pair is changed to point to the head of\n" @@ -276,26 +276,29 @@ SCM_DEFINE (scm_append_x, "append!", 0, 0, 1, #define FUNC_NAME s_scm_append_x { SCM ret, *loc; - SCM_VALIDATE_REST_ARGUMENT (lists); + int argnum = 1; + SCM_VALIDATE_REST_ARGUMENT (args); - if (scm_is_null (lists)) + if (scm_is_null (args)) return SCM_EOL; loc = &ret; for (;;) { - SCM arg = SCM_CAR (lists); + SCM arg = SCM_CAR (args); *loc = arg; - lists = SCM_CDR (lists); - if (scm_is_null (lists)) + args = SCM_CDR (args); + if (scm_is_null (args)) return ret; if (!SCM_NULL_OR_NIL_P (arg)) { - SCM_VALIDATE_CONS (SCM_ARG1, arg); + SCM_VALIDATE_CONS (argnum, arg); loc = SCM_CDRLOC (scm_last_pair (arg)); + SCM_VALIDATE_NULL_OR_NIL (argnum, *loc); } + argnum++; } } #undef FUNC_NAME diff --git a/test-suite/tests/list.test b/test-suite/tests/list.test index dc06f0795..ff31c8605 100644 --- a/test-suite/tests/list.test +++ b/test-suite/tests/list.test @@ -439,15 +439,15 @@ (with-test-prefix "wrong argument" - (expect-fail-exception "improper list and empty list" + (pass-if-exception "improper list and empty list" exception:wrong-type-arg (append! (cons 1 2) '())) - (expect-fail-exception "improper list and list" + (pass-if-exception "improper list and list" exception:wrong-type-arg (append! (cons 1 2) (list 3 4))) - (expect-fail-exception "list, improper list and list" + (pass-if-exception "list, improper list and list" exception:wrong-type-arg (append! (list 1 2) (cons 3 4) (list 5 6))) From 2446f8e126d9a7c145c4868f2a918d2dfb226d4e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 6 Oct 2012 01:24:46 +0200 Subject: [PATCH 24/52] Simplify calls to `equal?' when one argument is a constant. * module/language/tree-il/primitives.scm (*primitive-expand-table*): Add expansion rules for `equal?', when called with one constant and another argument. * test-suite/tests/tree-il.test (pass-if-primitives-resolved): New macro. ("primitives"): New test prefix. --- module/language/tree-il/primitives.scm | 27 +++++++++++++++ test-suite/tests/tree-il.test | 46 ++++++++++++++++++++++++++ 2 files changed, 73 insertions(+) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index a1c5adc71..dc0a1457e 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -490,6 +490,33 @@ (define-primitive-expander f64vector-set! (vec i x) (bytevector-ieee-double-native-set! vec (* i 8) x)) +(hashq-set! *primitive-expand-table* + 'equal? + (case-lambda + ((src a b) + ;; Simplify cases where either A or B is constant. + (define (maybe-simplify a b) + (and (const? a) + (let ((v (const-exp a))) + (cond + ((eq? #f v) + (make-application src (make-primitive-ref #f 'not) + (list b))) + ((eq? '() v) + (make-application src (make-primitive-ref #f 'null?) + (list b))) + ((or (eq? #t v) + (eq? #nil v) + (symbol? v) + (and (integer? v) + (<= v most-positive-fixnum) + (>= v most-negative-fixnum))) + (make-application src (make-primitive-ref #f 'eq?) + (list a b))) + (else #f))))) + (or (maybe-simplify a b) (maybe-simplify b a))) + (else #f))) + (hashq-set! *primitive-expand-table* 'dynamic-wind (case-lambda diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 4ffdce09e..bb7f90863 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -58,6 +58,20 @@ (assert-tree-il->glil with-partial-evaluation in pat test ...)))) +(define-syntax-rule (pass-if-primitives-resolved in expected) + (pass-if (format #f "primitives-resolved in ~s" 'in) + (let* ((module (let ((m (make-module))) + (beautify-user-module! m) + m)) + (orig (parse-tree-il 'in)) + (resolved (expand-primitives! (resolve-primitives! orig module)))) + (or (equal? (unparse-tree-il resolved) 'expected) + (begin + (format (current-error-port) + "primitive test failed: got ~s, expected ~s" + resolved 'expected) + #f))))) + (define-syntax pass-if-tree-il->scheme (syntax-rules () ((_ in pat) @@ -69,6 +83,33 @@ (pat (guard guard-exp) #t) (_ #f)))))) + +(with-test-prefix "primitives" + + (pass-if-primitives-resolved + (apply (primitive equal?) (toplevel x) (const #f)) + (apply (primitive not) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (toplevel x) (const ())) + (apply (primitive null?) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #t) (lexical x y)) + (apply (primitive eq?) (const #t) (lexical x y))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const this-is-a-symbol) (toplevel x)) + (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const 42) (toplevel x)) + (apply (primitive eq?) (const 42) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #nil) (toplevel x)) + (apply (primitive eq?) (const #nil) (toplevel x)))) + (with-test-prefix "tree-il->scheme" (pass-if-tree-il->scheme @@ -1704,3 +1745,8 @@ #:to 'assembly))))) (and (= (length w) 1) (number? (string-contains (car w) "unsupported format option")))))))) + +;; Local Variables: +;; eval: (put 'pass-if-primitives-resolved 'scheme-indent-function 1) +;; eval: (put 'pass-if-tree-il->scheme 'scheme-indent-function 1) +;; End: From ebd363161ef533833fc48c3389075bf4db7ebe17 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sun, 7 Oct 2012 23:57:13 -0400 Subject: [PATCH 25/52] Don't simplify 'equal?' to 'eq?' when constant is an *inexact* small integer. * module/language/tree-il/primitives.scm (*primitive-expand-table*): Refine test for fixnums to verify that the small integer is exact. * test-suite/tests/tree-il.test ("primitives"): Add test. --- module/language/tree-il/primitives.scm | 1 + test-suite/tests/tree-il.test | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index dc0a1457e..0c5b0855a 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -509,6 +509,7 @@ (eq? #nil v) (symbol? v) (and (integer? v) + (exact? v) (<= v most-positive-fixnum) (>= v most-negative-fixnum))) (make-application src (make-primitive-ref #f 'eq?) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index bb7f90863..0a5303703 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -106,6 +106,10 @@ (apply (primitive equal?) (const 42) (toplevel x)) (apply (primitive eq?) (const 42) (toplevel x))) + (pass-if-primitives-resolved + (apply (primitive equal?) (const 42.0) (toplevel x)) + (apply (primitive equal?) (const 42.0) (toplevel x))) + (pass-if-primitives-resolved (apply (primitive equal?) (const #nil) (toplevel x)) (apply (primitive eq?) (const #nil) (toplevel x)))) From bcf87e35e17741c279b755b0804776cdc8ee5828 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 8 Oct 2012 00:37:09 -0400 Subject: [PATCH 26/52] Don't simplify 'equal?' to 'not' or 'null?'. * module/language/tree-il/primitives.scm (*primitive-expand-table*): Don't simplify 'equal?' to 'not' or 'null?', but only to 'eq?'. * test-suite/tests/tree-il.test ("primitives"): Adjust tests. --- module/language/tree-il/primitives.scm | 25 ++++++++----------------- test-suite/tests/tree-il.test | 8 ++++---- 2 files changed, 12 insertions(+), 21 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index 0c5b0855a..c3cd8c67a 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -498,23 +498,14 @@ (define (maybe-simplify a b) (and (const? a) (let ((v (const-exp a))) - (cond - ((eq? #f v) - (make-application src (make-primitive-ref #f 'not) - (list b))) - ((eq? '() v) - (make-application src (make-primitive-ref #f 'null?) - (list b))) - ((or (eq? #t v) - (eq? #nil v) - (symbol? v) - (and (integer? v) - (exact? v) - (<= v most-positive-fixnum) - (>= v most-negative-fixnum))) - (make-application src (make-primitive-ref #f 'eq?) - (list a b))) - (else #f))))) + (and (or (memq v '(#f #t () #nil)) + (symbol? v) + (and (integer? v) + (exact? v) + (<= v most-positive-fixnum) + (>= v most-negative-fixnum))) + (make-application src (make-primitive-ref #f 'eq?) + (list a b)))))) (or (maybe-simplify a b) (maybe-simplify b a))) (else #f))) diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 0a5303703..008eb83fc 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -87,12 +87,12 @@ (with-test-prefix "primitives" (pass-if-primitives-resolved - (apply (primitive equal?) (toplevel x) (const #f)) - (apply (primitive not) (toplevel x))) + (apply (primitive equal?) (const #f) (toplevel x)) + (apply (primitive eq?) (const #f) (toplevel x))) (pass-if-primitives-resolved - (apply (primitive equal?) (toplevel x) (const ())) - (apply (primitive null?) (toplevel x))) + (apply (primitive equal?) (const ()) (toplevel x)) + (apply (primitive eq?) (const ()) (toplevel x))) (pass-if-primitives-resolved (apply (primitive equal?) (const #t) (lexical x y)) From 75a5de18a0e6e34963cf0f5e0e20f528222e06af Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 8 Oct 2012 11:56:10 -0400 Subject: [PATCH 27/52] Simplify calls to 'eqv?' when one argument is an immediate constant. * module/language/tree-il/primitives.scm (maybe-simplify-to-eq): New helper procedure shared by expanders for 'eqv?' and 'equal?'. (*primitive-expand-table*): Add expansion rule for 'eqv?'. * test-suite/tests/tree-il.test ("primitives"): Add tests. --- module/language/tree-il/primitives.scm | 38 ++++++------- test-suite/tests/tree-il.test | 74 ++++++++++++++++++-------- 2 files changed, 73 insertions(+), 39 deletions(-) diff --git a/module/language/tree-il/primitives.scm b/module/language/tree-il/primitives.scm index c3cd8c67a..bac3136e3 100644 --- a/module/language/tree-il/primitives.scm +++ b/module/language/tree-il/primitives.scm @@ -490,24 +490,26 @@ (define-primitive-expander f64vector-set! (vec i x) (bytevector-ieee-double-native-set! vec (* i 8) x)) -(hashq-set! *primitive-expand-table* - 'equal? - (case-lambda - ((src a b) - ;; Simplify cases where either A or B is constant. - (define (maybe-simplify a b) - (and (const? a) - (let ((v (const-exp a))) - (and (or (memq v '(#f #t () #nil)) - (symbol? v) - (and (integer? v) - (exact? v) - (<= v most-positive-fixnum) - (>= v most-negative-fixnum))) - (make-application src (make-primitive-ref #f 'eq?) - (list a b)))))) - (or (maybe-simplify a b) (maybe-simplify b a))) - (else #f))) +;; Appropriate for use with either 'eqv?' or 'equal?'. +(define maybe-simplify-to-eq + (case-lambda + ((src a b) + ;; Simplify cases where either A or B is constant. + (define (maybe-simplify a b) + (and (const? a) + (let ((v (const-exp a))) + (and (or (memq v '(#f #t () #nil)) + (symbol? v) + (and (integer? v) + (exact? v) + (<= most-negative-fixnum v most-positive-fixnum))) + (make-application src (make-primitive-ref #f 'eq?) + (list a b)))))) + (or (maybe-simplify a b) (maybe-simplify b a))) + (else #f))) + +(hashq-set! *primitive-expand-table* 'eqv? maybe-simplify-to-eq) +(hashq-set! *primitive-expand-table* 'equal? maybe-simplify-to-eq) (hashq-set! *primitive-expand-table* 'dynamic-wind diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test index 008eb83fc..1df72e848 100644 --- a/test-suite/tests/tree-il.test +++ b/test-suite/tests/tree-il.test @@ -86,33 +86,65 @@ (with-test-prefix "primitives" - (pass-if-primitives-resolved - (apply (primitive equal?) (const #f) (toplevel x)) - (apply (primitive eq?) (const #f) (toplevel x))) + (with-test-prefix "eqv?" - (pass-if-primitives-resolved - (apply (primitive equal?) (const ()) (toplevel x)) - (apply (primitive eq?) (const ()) (toplevel x))) + (pass-if-primitives-resolved + (apply (primitive eqv?) (const #f) (toplevel x)) + (apply (primitive eq?) (const #f) (toplevel x))) - (pass-if-primitives-resolved - (apply (primitive equal?) (const #t) (lexical x y)) - (apply (primitive eq?) (const #t) (lexical x y))) + (pass-if-primitives-resolved + (apply (primitive eqv?) (const ()) (toplevel x)) + (apply (primitive eq?) (const ()) (toplevel x))) - (pass-if-primitives-resolved - (apply (primitive equal?) (const this-is-a-symbol) (toplevel x)) - (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) + (pass-if-primitives-resolved + (apply (primitive eqv?) (const #t) (lexical x y)) + (apply (primitive eq?) (const #t) (lexical x y))) - (pass-if-primitives-resolved - (apply (primitive equal?) (const 42) (toplevel x)) - (apply (primitive eq?) (const 42) (toplevel x))) + (pass-if-primitives-resolved + (apply (primitive eqv?) (const this-is-a-symbol) (toplevel x)) + (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) - (pass-if-primitives-resolved - (apply (primitive equal?) (const 42.0) (toplevel x)) - (apply (primitive equal?) (const 42.0) (toplevel x))) + (pass-if-primitives-resolved + (apply (primitive eqv?) (const 42) (toplevel x)) + (apply (primitive eq?) (const 42) (toplevel x))) - (pass-if-primitives-resolved - (apply (primitive equal?) (const #nil) (toplevel x)) - (apply (primitive eq?) (const #nil) (toplevel x)))) + (pass-if-primitives-resolved + (apply (primitive eqv?) (const 42.0) (toplevel x)) + (apply (primitive eqv?) (const 42.0) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive eqv?) (const #nil) (toplevel x)) + (apply (primitive eq?) (const #nil) (toplevel x)))) + + (with-test-prefix "equal?" + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #f) (toplevel x)) + (apply (primitive eq?) (const #f) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const ()) (toplevel x)) + (apply (primitive eq?) (const ()) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #t) (lexical x y)) + (apply (primitive eq?) (const #t) (lexical x y))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const this-is-a-symbol) (toplevel x)) + (apply (primitive eq?) (const this-is-a-symbol) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const 42) (toplevel x)) + (apply (primitive eq?) (const 42) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const 42.0) (toplevel x)) + (apply (primitive equal?) (const 42.0) (toplevel x))) + + (pass-if-primitives-resolved + (apply (primitive equal?) (const #nil) (toplevel x)) + (apply (primitive eq?) (const #nil) (toplevel x))))) (with-test-prefix "tree-il->scheme" From 3e3d32dd9b2d71ffb0703dedc4d47387e981c9b5 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 8 Oct 2012 14:08:43 -0400 Subject: [PATCH 28/52] Preserve keyword identifier in 'syntax-rules' and 'define-syntax-rule' * module/ice-9/psyntax-pp.scm (syntax-rule, define-syntax-rule): Preserve the keyword identifier. * module/ice-9/psyntax-pp.scm: Regenerate. --- module/ice-9/psyntax-pp.scm | 24 ++++++++++++------------ module/ice-9/psyntax.scm | 8 ++++---- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index 68d1bf6eb..b148c9ade 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2551,12 +2551,13 @@ (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (cons '#(syntax-object x ((top)) (hygiene guile)) (cons k - (map (lambda (tmp-1 tmp) - (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) + (map (lambda (tmp-2 tmp-1 tmp) + (list (cons tmp tmp-1) (list '#(syntax-object syntax ((top)) (hygiene guile)) - tmp-1))) + tmp-2))) template - pattern)))))) + pattern + keyword)))))) tmp) (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any)))))) (if (if tmp @@ -2576,12 +2577,13 @@ (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (cons '#(syntax-object x ((top)) (hygiene guile)) (cons k - (map (lambda (tmp-1 tmp) - (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) + (map (lambda (tmp-2 tmp-1 tmp) + (list (cons tmp tmp-1) (list '#(syntax-object syntax ((top)) (hygiene guile)) - tmp-1))) + tmp-2))) template - pattern)))))) + pattern + keyword)))))) tmp) (syntax-violation #f @@ -2601,8 +2603,7 @@ name (list '#(syntax-object syntax-rules ((top)) (hygiene guile)) '() - (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) - template)))) + (list (cons name pattern) template)))) tmp) (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any)))) (if (if tmp @@ -2616,8 +2617,7 @@ (list '#(syntax-object syntax-rules ((top)) (hygiene guile)) '() docstring - (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) - template)))) + (list (cons name pattern) template)))) tmp) (syntax-violation #f diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index 6c264a6df..dc32f5a92 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2789,7 +2789,7 @@ #((macro-type . syntax-rules) (patterns pattern ...)) (syntax-case x (k ...) - ((dummy . pattern) #'template) + ((keyword . pattern) #'template) ...))) ((_ (k ...) docstring ((keyword . pattern) template) ...) (string? (syntax->datum #'docstring)) @@ -2799,7 +2799,7 @@ #((macro-type . syntax-rules) (patterns pattern ...)) (syntax-case x (k ...) - ((dummy . pattern) #'template) + ((keyword . pattern) #'template) ...)))))) (define-syntax define-syntax-rule @@ -2808,13 +2808,13 @@ ((_ (name . pattern) template) #'(define-syntax name (syntax-rules () - ((_ . pattern) template)))) + ((name . pattern) template)))) ((_ (name . pattern) docstring template) (string? (syntax->datum #'docstring)) #'(define-syntax name (syntax-rules () docstring - ((_ . pattern) template))))))) + ((name . pattern) template))))))) (define-syntax let* (lambda (x) From 8b22ced1c9dee2743eedb5658172e931a42e8453 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 10 Oct 2012 13:13:19 -0400 Subject: [PATCH 29/52] Revert "Preserve keyword identifier in 'syntax-rules' and 'define-syntax-rule'" This reverts commit 3e3d32dd9b2d71ffb0703dedc4d47387e981c9b5. --- module/ice-9/psyntax-pp.scm | 24 ++++++++++++------------ module/ice-9/psyntax.scm | 8 ++++---- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm index b148c9ade..68d1bf6eb 100644 --- a/module/ice-9/psyntax-pp.scm +++ b/module/ice-9/psyntax-pp.scm @@ -2551,13 +2551,12 @@ (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (cons '#(syntax-object x ((top)) (hygiene guile)) (cons k - (map (lambda (tmp-2 tmp-1 tmp) - (list (cons tmp tmp-1) + (map (lambda (tmp-1 tmp) + (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) (list '#(syntax-object syntax ((top)) (hygiene guile)) - tmp-2))) + tmp-1))) template - pattern - keyword)))))) + pattern)))))) tmp) (let ((tmp ($sc-dispatch tmp-1 '(_ each-any any . #(each ((any . any) any)))))) (if (if tmp @@ -2577,13 +2576,12 @@ (cons '#(syntax-object syntax-case ((top)) (hygiene guile)) (cons '#(syntax-object x ((top)) (hygiene guile)) (cons k - (map (lambda (tmp-2 tmp-1 tmp) - (list (cons tmp tmp-1) + (map (lambda (tmp-1 tmp) + (list (cons '#(syntax-object dummy ((top)) (hygiene guile)) tmp) (list '#(syntax-object syntax ((top)) (hygiene guile)) - tmp-2))) + tmp-1))) template - pattern - keyword)))))) + pattern)))))) tmp) (syntax-violation #f @@ -2603,7 +2601,8 @@ name (list '#(syntax-object syntax-rules ((top)) (hygiene guile)) '() - (list (cons name pattern) template)))) + (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) + template)))) tmp) (let ((tmp ($sc-dispatch tmp-1 '(_ (any . any) any any)))) (if (if tmp @@ -2617,7 +2616,8 @@ (list '#(syntax-object syntax-rules ((top)) (hygiene guile)) '() docstring - (list (cons name pattern) template)))) + (list (cons '#(syntax-object _ ((top)) (hygiene guile)) pattern) + template)))) tmp) (syntax-violation #f diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm index dc32f5a92..6c264a6df 100644 --- a/module/ice-9/psyntax.scm +++ b/module/ice-9/psyntax.scm @@ -2789,7 +2789,7 @@ #((macro-type . syntax-rules) (patterns pattern ...)) (syntax-case x (k ...) - ((keyword . pattern) #'template) + ((dummy . pattern) #'template) ...))) ((_ (k ...) docstring ((keyword . pattern) template) ...) (string? (syntax->datum #'docstring)) @@ -2799,7 +2799,7 @@ #((macro-type . syntax-rules) (patterns pattern ...)) (syntax-case x (k ...) - ((keyword . pattern) #'template) + ((dummy . pattern) #'template) ...)))))) (define-syntax define-syntax-rule @@ -2808,13 +2808,13 @@ ((_ (name . pattern) template) #'(define-syntax name (syntax-rules () - ((name . pattern) template)))) + ((_ . pattern) template)))) ((_ (name . pattern) docstring template) (string? (syntax->datum #'docstring)) #'(define-syntax name (syntax-rules () docstring - ((name . pattern) template))))))) + ((_ . pattern) template))))))) (define-syntax let* (lambda (x) From 5f085775aba737c6e829b3e06abb66a64c83b057 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig Date: Mon, 8 Oct 2012 18:35:00 +0800 Subject: [PATCH 30/52] In string-split, add support for character sets and predicates. * libguile/srfi-13.c (string-split): Add support for splitting on character sets and predicates, like string-index and others. * test-suite/tests/strings.test (string-split): Add tests covering the new argument types. * doc/ref/api-data.texi (string-split): Update. Signed-off-by: Mark H Weaver --- doc/ref/api-data.texi | 22 ++++++-- libguile/srfi-13.c | 97 ++++++++++++++++++++++++----------- libguile/srfi-13.h | 2 +- test-suite/tests/strings.test | 62 +++++++++++++++++++++- 4 files changed, 146 insertions(+), 37 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 39c97909a..6d8de2bd6 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -3152,12 +3152,24 @@ These procedures are useful for similar tasks. Convert the string @var{str} into a list of characters. @end deffn -@deffn {Scheme Procedure} string-split str chr -@deffnx {C Function} scm_string_split (str, chr) +@deffn {Scheme Procedure} string-split str char_pred +@deffnx {C Function} scm_string_split (str, char_pred) Split the string @var{str} into a list of substrings delimited -by appearances of the character @var{chr}. Note that an empty substring -between separator characters will result in an empty string in the -result list. +by appearances of characters that + +@itemize @bullet +@item +equal @var{char_pred}, if it is a character, + +@item +satisfy the predicate @var{char_pred}, if it is a procedure, + +@item +are in the set @var{char_pred}, if it is a character set. +@end itemize + +Note that an empty substring between separator characters will result in +an empty string in the result list. @lisp (string-split "root:x:0:0:root:/root:/bin/bash" #\:) diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index 28345532e..97c5a1d64 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -2993,11 +2993,22 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, #undef FUNC_NAME SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, - (SCM str, SCM chr), + (SCM str, SCM char_pred), "Split the string @var{str} into a list of the substrings delimited\n" - "by appearances of the character @var{chr}. Note that an empty substring\n" - "between separator characters will result in an empty string in the\n" - "result list.\n" + "by appearances of characters that\n" + "\n" + "@itemize @bullet\n" + "@item\n" + "equal @var{char_pred}, if it is a character,\n" + "\n" + "@item\n" + "satisfy the predicate @var{char_pred}, if it is a procedure,\n" + "\n" + "@item\n" + "are in the set @var{char_pred}, if it is a character set.\n" + "@end itemize\n\n" + "Note that an empty substring between separator characters\n" + "will result in an empty string in the result list.\n" "\n" "@lisp\n" "(string-split \"root:x:0:0:root:/root:/bin/bash\" #\\:)\n" @@ -3014,47 +3025,73 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, "@end lisp") #define FUNC_NAME s_scm_string_split { - long idx, last_idx; - int narrow; SCM res = SCM_EOL; SCM_VALIDATE_STRING (1, str); - SCM_VALIDATE_CHAR (2, chr); - /* This is explicit wide/narrow logic (instead of using - scm_i_string_ref) is a speed optimization. */ - idx = scm_i_string_length (str); - narrow = scm_i_is_narrow_string (str); - if (narrow) + if (SCM_CHARP (char_pred)) { - const char *buf = scm_i_string_chars (str); - while (idx >= 0) + long idx, last_idx; + int narrow; + + /* This is explicit wide/narrow logic (instead of using + scm_i_string_ref) is a speed optimization. */ + idx = scm_i_string_length (str); + narrow = scm_i_is_narrow_string (str); + if (narrow) { - last_idx = idx; - while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr)) - idx--; - if (idx >= 0) + const char *buf = scm_i_string_chars (str); + while (idx >= 0) { - res = scm_cons (scm_i_substring (str, idx, last_idx), res); - idx--; + last_idx = idx; + while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(char_pred)) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_i_substring (str, idx, last_idx), res); + idx--; + } + } + } + else + { + const scm_t_wchar *buf = scm_i_string_wide_chars (str); + while (idx >= 0) + { + last_idx = idx; + while (idx > 0 && buf[idx-1] != SCM_CHAR(char_pred)) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_i_substring (str, idx, last_idx), res); + idx--; + } } } } else { - const scm_t_wchar *buf = scm_i_string_wide_chars (str); - while (idx >= 0) + SCM sidx, slast_idx; + + if (!SCM_CHARSETP (char_pred)) + SCM_ASSERT (scm_is_true (scm_procedure_p (char_pred)), + char_pred, SCM_ARG2, FUNC_NAME); + + /* Supporting predicates and character sets involves handling SCM + values so there is less chance to optimize. */ + slast_idx = scm_string_length (str); + for (;;) { - last_idx = idx; - while (idx > 0 && buf[idx-1] != SCM_CHAR(chr)) - idx--; - if (idx >= 0) - { - res = scm_cons (scm_i_substring (str, idx, last_idx), res); - idx--; - } + sidx = scm_string_index_right (str, char_pred, SCM_INUM0, slast_idx); + if (scm_is_false (sidx)) + break; + res = scm_cons (scm_substring (str, scm_oneplus (sidx), slast_idx), res); + slast_idx = sidx; } + + res = scm_cons (scm_substring (str, SCM_INUM0, slast_idx), res); } + scm_remember_upto_here_1 (str); return res; } diff --git a/libguile/srfi-13.h b/libguile/srfi-13.h index f63239a25..325e22272 100644 --- a/libguile/srfi-13.h +++ b/libguile/srfi-13.h @@ -110,7 +110,7 @@ SCM_API SCM scm_xsubstring (SCM s, SCM from, SCM to, SCM start, SCM end); SCM_API SCM scm_string_xcopy_x (SCM target, SCM tstart, SCM s, SCM sfrom, SCM sto, SCM start, SCM end); SCM_API SCM scm_string_replace (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2); SCM_API SCM scm_string_tokenize (SCM s, SCM token_char, SCM start, SCM end); -SCM_API SCM scm_string_split (SCM s, SCM chr); +SCM_API SCM scm_string_split (SCM s, SCM char_pred); SCM_API SCM scm_string_filter (SCM char_pred, SCM s, SCM start, SCM end); SCM_API SCM scm_string_delete (SCM char_pred, SCM s, SCM start, SCM end); diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index d892b7077..679e17326 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -557,7 +557,67 @@ (pass-if "char 255" (equal? '("a" "b") (string-split (string #\a (integer->char 255) #\b) - (integer->char 255))))) + (integer->char 255)))) + + (pass-if "empty string - char" + (equal? '("") + (string-split "" #\:))) + + (pass-if "non-empty - char - no delimiters" + (equal? '("foobarfrob") + (string-split "foobarfrob" #\:))) + + (pass-if "non-empty - char - delimiters" + (equal? '("foo" "bar" "frob") + (string-split "foo:bar:frob" #\:))) + + (pass-if "non-empty - char - leading delimiters" + (equal? '("" "" "foo" "bar" "frob") + (string-split "::foo:bar:frob" #\:))) + + (pass-if "non-empty - char - trailing delimiters" + (equal? '("foo" "bar" "frob" "" "") + (string-split "foo:bar:frob::" #\:))) + + (pass-if "empty string - charset" + (equal? '("") + (string-split "" (char-set #\:)))) + + (pass-if "non-empty - charset - no delimiters" + (equal? '("foobarfrob") + (string-split "foobarfrob" (char-set #\:)))) + + (pass-if "non-empty - charset - delimiters" + (equal? '("foo" "bar" "frob") + (string-split "foo:bar:frob" (char-set #\:)))) + + (pass-if "non-empty - charset - leading delimiters" + (equal? '("" "" "foo" "bar" "frob") + (string-split "::foo:bar:frob" (char-set #\:)))) + + (pass-if "non-empty - charset - trailing delimiters" + (equal? '("foo" "bar" "frob" "" "") + (string-split "foo:bar:frob::" (char-set #\:)))) + + (pass-if "empty string - pred" + (equal? '("") + (string-split "" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - no delimiters" + (equal? '("foobarfrob") + (string-split "foobarfrob" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - delimiters" + (equal? '("foo" "bar" "frob") + (string-split "foo:bar:frob" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - leading delimiters" + (equal? '("" "" "foo" "bar" "frob") + (string-split "::foo:bar:frob" (negate char-alphabetic?)))) + + (pass-if "non-empty - pred - trailing delimiters" + (equal? '("foo" "bar" "frob" "" "") + (string-split "foo:bar:frob::" (negate char-alphabetic?))))) (with-test-prefix "substring-move!" From 6996f07f577416505b2e33e5967f9fcc933559b7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 12 Oct 2012 08:26:34 -0400 Subject: [PATCH 31/52] Thanks Daniel Hartwig. * THANKS (Contributors since the last release): Add Daniel Hartwig. --- THANKS | 1 + 1 file changed, 1 insertion(+) diff --git a/THANKS b/THANKS index a3d15defa..2dbf570eb 100644 --- a/THANKS +++ b/THANKS @@ -6,6 +6,7 @@ Contributors since the last release: Volker Grabsch Julian Graham Michael Gran + Daniel Hartwig No Itisnt Neil Jerram Daniel Kraft From 8ac870dee4397c3b3f0ac24b072e88e87b91e47e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 12 Oct 2012 23:03:39 +0200 Subject: [PATCH 32/52] Implement `hash' for structs. * libguile/hash.c (scm_hasher): Call `scm_i_struct_hash' upon `scm_tcs_struct'. * libguile/struct.c (scm_i_struct_hash): New function. * libguile/struct.h (scm_i_struct_hash): New declaration. * test-suite/tests/structs.test ("hash"): New test prefix. --- libguile/hash.c | 7 +++-- libguile/struct.c | 49 +++++++++++++++++++++++++++++++++++ libguile/struct.h | 2 ++ test-suite/tests/structs.test | 42 ++++++++++++++++++++++++++++++ 4 files changed, 98 insertions(+), 2 deletions(-) diff --git a/libguile/hash.c b/libguile/hash.c index a79f03d95..8b00a0cb1 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -1,5 +1,6 @@ -/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. - * +/* Copyright (C) 1995, 1996, 1997, 2000, 2001, 2003, 2004, 2006, 2008, + * 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 @@ -223,6 +224,8 @@ scm_hasher(SCM obj, unsigned long n, size_t d) significant_bits = (scm_t_uintptr) SCM_POINTER_VALUE (obj) >> 4UL; return (size_t) significant_bits % n; } + case scm_tcs_struct: + return scm_i_struct_hash (obj, n, d); case scm_tc7_wvect: case scm_tc7_vector: { diff --git a/libguile/struct.c b/libguile/struct.c index 5837b7c42..db1687ef8 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -922,6 +922,55 @@ scm_struct_ihashq (SCM obj, unsigned long n, void *closure) return SCM_UNPACK (obj) % n; } +/* Return the hash of struct OBJ, modulo N. Traverse OBJ's fields to + compute the result, unless DEPTH is zero. */ +unsigned long +scm_i_struct_hash (SCM obj, unsigned long n, size_t depth) +#define FUNC_NAME "hash" +{ + SCM layout; + scm_t_bits *data; + size_t struct_size, field_num; + unsigned long hash; + + SCM_VALIDATE_STRUCT (1, obj); + + layout = SCM_STRUCT_LAYOUT (obj); + struct_size = scm_i_symbol_length (layout) / 2; + data = SCM_STRUCT_DATA (obj); + + hash = SCM_UNPACK (SCM_STRUCT_VTABLE (obj)) % n; + if (depth > 0) + for (field_num = 0; field_num < struct_size; field_num++) + { + int protection; + + protection = scm_i_symbol_ref (layout, field_num * 2 + 1); + if (protection != 'h' && protection != 'o') + { + int type; + type = scm_i_symbol_ref (layout, field_num * 2); + switch (type) + { + case 'p': + hash ^= scm_hasher (SCM_PACK (data[field_num]), n, + depth / 2); + break; + case 'u': + hash ^= data[field_num] % n; + break; + default: + /* Ignore 's' fields. */; + } + } + } + + /* FIXME: Tail elements should be taken into account. */ + + return hash % n; +} +#undef FUNC_NAME + SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0, (SCM vtable), "Return the name of the vtable @var{vtable}.") diff --git a/libguile/struct.h b/libguile/struct.h index 3072f24bf..643fd9dc9 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -193,6 +193,8 @@ SCM_API void scm_print_struct (SCM exp, SCM port, scm_print_state *); SCM_INTERNAL SCM scm_i_struct_equalp (SCM s1, SCM s2); SCM_INTERNAL unsigned long scm_struct_ihashq (SCM, unsigned long, void *); +SCM_INTERNAL unsigned long scm_i_struct_hash (SCM s, unsigned long n, + size_t depth); SCM_INTERNAL SCM scm_i_alloc_struct (scm_t_bits *vtable_data, int n_words); SCM_INTERNAL void scm_i_struct_inherit_vtable_magic (SCM vtable, SCM obj); SCM_INTERNAL void scm_init_struct (void); diff --git a/test-suite/tests/structs.test b/test-suite/tests/structs.test index 431a014b8..0e3b2417e 100644 --- a/test-suite/tests/structs.test +++ b/test-suite/tests/structs.test @@ -126,7 +126,49 @@ (not (or (equal? (make-ball red "Bob") (make-ball green "Bob")) (equal? (make-ball red "Bob") (make-ball red "Bill")))))) + +(with-test-prefix "hash" + (pass-if "simple structs" + (let* ((v (make-vtable "pr")) + (s1 (make-struct v 0 "hello")) + (s2 (make-struct v 0 "hello"))) + (= (hash s1 7777) (hash s2 7777)))) + + (pass-if "different structs" + (let* ((v (make-vtable "pr")) + (s1 (make-struct v 0 "hello")) + (s2 (make-struct v 0 "world"))) + (or (not (= (hash s1 7777) (hash s2 7777))) + (throw 'unresolved)))) + + (pass-if "different struct types" + (let* ((v1 (make-vtable "pr")) + (v2 (make-vtable "pr")) + (s1 (make-struct v1 0 "hello")) + (s2 (make-struct v2 0 "hello"))) + (or (not (= (hash s1 7777) (hash s2 7777))) + (throw 'unresolved)))) + + (pass-if "more complex structs" + (let ((s1 (make-ball red (string-copy "Bob"))) + (s2 (make-ball red (string-copy "Bob")))) + (= (hash s1 7777) (hash s2 7777)))) + + (pass-if "struct with weird fields" + (let* ((v (make-vtable "prurph")) + (s1 (make-struct v 0 "hello" 123 "invisible-secret1")) + (s2 (make-struct v 0 "hello" 123 "invisible-secret2"))) + (= (hash s1 7777) (hash s2 7777)))) + + (pass-if "cyclic structs" + (let* ((v (make-vtable "pw")) + (a (make-struct v 0 #f)) + (b (make-struct v 0 a))) + (struct-set! a 0 b) + (and (hash a 7777) (hash b 7777) #t)))) + + ;; ;; make-struct ;; From 2663411bd7d7d6b7be6c674c4e6c35c22e2e3c19 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 12 Oct 2012 23:05:22 +0200 Subject: [PATCH 33/52] web: Change `http-get' to try all the addresses for the given URI. * module/web/client.scm (open-socket-for-uri): Try all the addresses returned by `getaddrinfo' until one succeeds. --- module/web/client.scm | 44 +++++++++++++++++++++++++++++-------------- 1 file changed, 30 insertions(+), 14 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index b0356680d..fcbfb153c 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -1,6 +1,6 @@ ;;; Web client -;; Copyright (C) 2011 Free Software Foundation, Inc. +;; Copyright (C) 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 @@ -42,19 +42,35 @@ 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)))) - (set-port-encoding! s "ISO-8859-1") - (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)) + "Return an open input/output port for a connection to URI." + (define addresses + (getaddrinfo (uri-host uri) + (cond + ((uri-port uri) => number->string) + (else (symbol->string (uri-scheme uri)))))) + + (let loop ((addresses addresses)) + (let* ((ai (car addresses)) + (s (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (addrinfo:protocol ai)))) + (set-port-encoding! s "ISO-8859-1") + + (catch 'system-error + (lambda () + (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) + (lambda args + ;; Connection failed, so try one of the other addresses. + (if (null? addresses) + (apply throw args) + (begin + (close s) + (loop (cdr addresses))))))))) (define (decode-string bv encoding) (if (string-ci=? encoding "utf-8") From d74fcce9b98135042fd713180c587dff0239d6b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Fri, 12 Oct 2012 23:09:44 +0200 Subject: [PATCH 34/52] web: Pass `AI_NUMERICSERV' when given a port number. * module/web/client.scm (open-socket-for-uri)[addresses]: Pass AI_NUMERICSERV as the `getaddrinfo' hint when (uri-port URI) is true. --- module/web/client.scm | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index fcbfb153c..27458a4c6 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -44,10 +44,13 @@ (define (open-socket-for-uri uri) "Return an open input/output port for a connection to URI." (define addresses - (getaddrinfo (uri-host uri) - (cond - ((uri-port uri) => number->string) - (else (symbol->string (uri-scheme uri)))))) + (let ((port (uri-port uri))) + (getaddrinfo (uri-host uri) + (cond (port => number->string) + (else (symbol->string (uri-scheme uri)))) + (if port + AI_NUMERICSERV + 0)))) (let loop ((addresses addresses)) (let* ((ai (car addresses)) From f865ffaab159e52d48b015bea7280b2940753482 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sat, 13 Oct 2012 21:13:10 +0200 Subject: [PATCH 35/52] web: Fix possible file descriptor leak in `open-socket-for-uri'. * module/web/client.scm (open-socket-for-uri): Always close S in the `system-error' handler. --- module/web/client.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/module/web/client.scm b/module/web/client.scm index 27458a4c6..cf7ea5325 100644 --- a/module/web/client.scm +++ b/module/web/client.scm @@ -69,11 +69,10 @@ s) (lambda args ;; Connection failed, so try one of the other addresses. + (close s) (if (null? addresses) (apply throw args) - (begin - (close s) - (loop (cdr addresses))))))))) + (loop (cdr addresses)))))))) (define (decode-string bv encoding) (if (string-ci=? encoding "utf-8") From 495797ceb50a857a033f390b4fc35e2989bd66cd Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 13 Oct 2012 20:28:27 -0400 Subject: [PATCH 36/52] Improve formatting of options help given long option names * module/ice-9/boot-9.scm (define-option-interface): When printing options help, e.g. for (read-options 'help), expand the width of the first column by another tab stop, to accommodate option names of up to 23 characters. --- module/ice-9/boot-9.scm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index cf8252a4a..d679f6eaf 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -2850,8 +2850,11 @@ module '(ice-9 q) '(make-q q-length))}." (lambda (option) (apply (lambda (name value documentation) (display name) - (if (< (string-length (symbol->string name)) 8) - (display #\tab)) + (let ((len (string-length (symbol->string name)))) + (when (< len 16) + (display #\tab) + (when (< len 8) + (display #\tab)))) (display #\tab) (display value) (display #\tab) From b3a2259ce3ffeb6a33093f5d02fa04aba15c633a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 13 Oct 2012 20:41:45 -0400 Subject: [PATCH 37/52] Remove prototype for scm_read_token, which does not exist. * libguile/read.h: Remove prototype for scm_read_token. --- libguile/read.h | 1 - 1 file changed, 1 deletion(-) diff --git a/libguile/read.h b/libguile/read.h index 4bd08fa44..3c47afdd0 100644 --- a/libguile/read.h +++ b/libguile/read.h @@ -54,7 +54,6 @@ SCM_API SCM scm_sym_dot; SCM_API SCM scm_read_options (SCM setting); SCM_API SCM scm_read (SCM port); -SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird); SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc); SCM_INTERNAL char *scm_i_scan_for_encoding (SCM port); SCM_API SCM scm_file_encoding (SCM port); From 591065954c340553214d49512cfb539177b58dcf Mon Sep 17 00:00:00 2001 From: Ian Price Date: Wed, 19 Sep 2012 17:33:29 +0100 Subject: [PATCH 38/52] Fix @@ usage in --listen option * module/ice-9/command-line.scm (compile-shell-switches): Fix usage of @@, which no longer supports arbitrary expressions, only identifiers. --- module/ice-9/command-line.scm | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm index 62a2c9e4f..d60a6e36a 100644 --- a/module/ice-9/command-line.scm +++ b/module/ice-9/command-line.scm @@ -1,6 +1,6 @@ ;;; Parsing Guile's command-line -;;; Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc. +;;; Copyright (C) 1994-1998, 2000-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 @@ -325,7 +325,7 @@ If FILE begins with `-' the -s switch is mandatory. ((string=? arg "--listen") ; start a repl server (parse args - (cons '(@@ (system repl server) (spawn-server)) out))) + (cons '((@@ (system repl server) spawn-server)) out))) ((string-prefix? "--listen=" arg) ; start a repl server (parse @@ -336,14 +336,12 @@ If FILE begins with `-' the -s switch is mandatory. ((string->number where) ; --listen=PORT => (lambda (port) (if (and (integer? port) (exact? port) (>= port 0)) - `(@@ (system repl server) - (spawn-server - (make-tcp-server-socket #:port ,port))) + `((@@ (system repl server) spawn-server) + ((@@ (system repl server) make-tcp-server-socket) #:port ,port)) (error "invalid port for --listen")))) ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET - `(@@ (system repl server) - (spawn-server - (make-unix-domain-server-socket #:path ,where)))) + `((@@ (system repl server) spawn-server) + ((@@ (system repl server) make-unix-domain-server-socket) #:path ,where))) (else (error "unknown argument to --listen")))) out))) From ead2496f73d401b096bb92e66e7434160d65c6e2 Mon Sep 17 00:00:00 2001 From: Ian Price Date: Wed, 19 Sep 2012 17:40:17 +0100 Subject: [PATCH 39/52] Fix typo in scheme-using.texi * doc/ref/scheme-using.texi (System Commands): Fix typo. --- doc/ref/scheme-using.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi index 3d439132b..7eb84de0a 100644 --- a/doc/ref/scheme-using.texi +++ b/doc/ref/scheme-using.texi @@ -457,7 +457,7 @@ show a short error printout. Default values for REPL options may be set using @code{repl-default-option-set!} from @code{(system repl common)}: -@deffn {Scheme Procedure} repl-set-default-option! key value +@deffn {Scheme Procedure} repl-default-option-set! key value Set the default value of a REPL option. This function is particularly useful in a user's init file. @xref{Init File}. @end deffn From 493ceb99e520a307c51fbee3633d89f688e2d3f7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 22 Oct 2012 23:23:45 -0400 Subject: [PATCH 40/52] Move array reader from arrays.c to read.c * libguile/arrays.c (read_decimal_integer): Move to read.c. (scm_i_read_array): Remove. Incorporate the code into the 'scm_read_array' static function in read.c. * libguile/arrays.h (scm_i_read_array): Remove prototype. * libguile/read.c (read_decimal_integer): Move here from read.c. (scm_read_array): Incorporate the code from 'scm_i_read_array'. Call 'scm_read_vector' and 'scm_read_sexp' instead of 'scm_read'. --- libguile/arrays.c | 175 +--------------------------------------------- libguile/arrays.h | 4 +- libguile/read.c | 161 ++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 159 insertions(+), 181 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index a294f33ec..1eb10b981 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,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 @@ -814,178 +815,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) return scm_i_print_array_dimension (&h, 0, 0, port, pstate); } -/* Read an array. This function can also read vectors and uniform - vectors. Also, the conflict between '#f' and '#f32' and '#f64' is - handled here. - - C is the first character read after the '#'. -*/ - -static int -read_decimal_integer (SCM port, int c, ssize_t *resp) -{ - ssize_t sign = 1; - ssize_t res = 0; - int got_it = 0; - - if (c == '-') - { - sign = -1; - c = scm_getc (port); - } - - while ('0' <= c && c <= '9') - { - res = 10*res + c-'0'; - got_it = 1; - c = scm_getc (port); - } - - if (got_it) - *resp = sign * res; - return c; -} - -SCM -scm_i_read_array (SCM port, int c) -{ - ssize_t rank; - scm_t_wchar tag_buf[8]; - int tag_len; - - SCM tag, shape = SCM_BOOL_F, elements; - - /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but - the array code can not deal with zero-length dimensions yet, and - we want to allow zero-length vectors, of course. - */ - if (c == '(') - { - scm_ungetc (c, port); - return scm_vector (scm_read (port)); - } - - /* Disambiguate between '#f' and uniform floating point vectors. - */ - if (c == 'f') - { - c = scm_getc (port); - if (c != '3' && c != '6') - { - if (c != EOF) - scm_ungetc (c, port); - return SCM_BOOL_F; - } - rank = 1; - tag_buf[0] = 'f'; - tag_len = 1; - goto continue_reading_tag; - } - - /* Read rank. - */ - rank = 1; - c = read_decimal_integer (port, c, &rank); - if (rank < 0) - scm_i_input_error (NULL, port, "array rank must be non-negative", - SCM_EOL); - - /* Read tag. - */ - tag_len = 0; - continue_reading_tag: - while (c != EOF && c != '(' && c != '@' && c != ':' - && tag_len < sizeof tag_buf / sizeof tag_buf[0]) - { - tag_buf[tag_len++] = c; - c = scm_getc (port); - } - if (tag_len == 0) - tag = SCM_BOOL_T; - else - { - tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len)); - if (tag_len == sizeof tag_buf / sizeof tag_buf[0]) - scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a", - scm_list_1 (tag)); - } - - /* Read shape. - */ - if (c == '@' || c == ':') - { - shape = SCM_EOL; - - do - { - ssize_t lbnd = 0, len = 0; - SCM s; - - if (c == '@') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &lbnd); - } - - s = scm_from_ssize_t (lbnd); - - if (c == ':') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &len); - if (len < 0) - scm_i_input_error (NULL, port, - "array length must be non-negative", - SCM_EOL); - - s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); - } - - shape = scm_cons (s, shape); - } while (c == '@' || c == ':'); - - shape = scm_reverse_x (shape, SCM_EOL); - } - - /* Read nested lists of elements. - */ - if (c != '(') - scm_i_input_error (NULL, port, - "missing '(' in vector or array literal", - SCM_EOL); - scm_ungetc (c, port); - elements = scm_read (port); - - if (scm_is_false (shape)) - shape = scm_from_ssize_t (rank); - else if (scm_ilength (shape) != rank) - scm_i_input_error - (NULL, port, - "the number of shape specifications must match the array rank", - SCM_EOL); - - /* Handle special print syntax of rank zero arrays; see - scm_i_print_array for a rationale. - */ - if (rank == 0) - { - if (!scm_is_pair (elements)) - scm_i_input_error (NULL, port, - "too few elements in array literal, need 1", - SCM_EOL); - if (!scm_is_null (SCM_CDR (elements))) - scm_i_input_error (NULL, port, - "too many elements in array literal, want 1", - SCM_EOL); - elements = SCM_CAR (elements); - } - - /* Construct array. - */ - return scm_list_to_typed_array (tag, shape, elements); -} - - static SCM array_handle_ref (scm_t_array_handle *h, size_t pos) { diff --git a/libguile/arrays.h b/libguile/arrays.h index 5ea604d6a..6045ab65d 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -3,7 +3,8 @@ #ifndef SCM_ARRAY_H #define SCM_ARRAY_H -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, + * 2010, 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 @@ -73,7 +74,6 @@ typedef struct scm_i_t_array SCM_INTERNAL SCM scm_i_make_array (int ndim); SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate); -SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); SCM_INTERNAL void scm_init_arrays (void); diff --git a/libguile/read.c b/libguile/read.c index 87d73bfbe..7fb1c21bc 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1002,14 +1002,163 @@ scm_read_vector (int chr, SCM port, long line, int column) port, line, column); } -static SCM -scm_read_array (int chr, SCM port, long line, int column) +/* Helper used by scm_read_array */ +static int +read_decimal_integer (SCM port, int c, ssize_t *resp) { - SCM result = scm_i_read_array (port, chr); - if (scm_is_false (result)) - return result; + ssize_t sign = 1; + ssize_t res = 0; + int got_it = 0; + + if (c == '-') + { + sign = -1; + c = scm_getc (port); + } + + while ('0' <= c && c <= '9') + { + res = 10*res + c-'0'; + got_it = 1; + c = scm_getc (port); + } + + if (got_it) + *resp = sign * res; + return c; +} + +/* Read an array. This function can also read vectors and uniform + vectors. Also, the conflict between '#f' and '#f32' and '#f64' is + handled here. + + C is the first character read after the '#'. */ +static SCM +scm_read_array (int c, SCM port, long line, int column) +{ + ssize_t rank; + scm_t_wchar tag_buf[8]; + int tag_len; + + SCM tag, shape = SCM_BOOL_F, elements, array; + + /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but + the array code can not deal with zero-length dimensions yet, and + we want to allow zero-length vectors, of course. */ + if (c == '(') + return scm_read_vector (c, port, line, column); + + /* Disambiguate between '#f' and uniform floating point vectors. */ + if (c == 'f') + { + c = scm_getc (port); + if (c != '3' && c != '6') + { + if (c != EOF) + scm_ungetc (c, port); + return SCM_BOOL_F; + } + rank = 1; + tag_buf[0] = 'f'; + tag_len = 1; + goto continue_reading_tag; + } + + /* Read rank. */ + rank = 1; + c = read_decimal_integer (port, c, &rank); + if (rank < 0) + scm_i_input_error (NULL, port, "array rank must be non-negative", + SCM_EOL); + + /* Read tag. */ + tag_len = 0; + continue_reading_tag: + while (c != EOF && c != '(' && c != '@' && c != ':' + && tag_len < sizeof tag_buf / sizeof tag_buf[0]) + { + tag_buf[tag_len++] = c; + c = scm_getc (port); + } + if (tag_len == 0) + tag = SCM_BOOL_T; else - return maybe_annotate_source (result, port, line, column); + { + tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len)); + if (tag_len == sizeof tag_buf / sizeof tag_buf[0]) + scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a", + scm_list_1 (tag)); + } + + /* Read shape. */ + if (c == '@' || c == ':') + { + shape = SCM_EOL; + + do + { + ssize_t lbnd = 0, len = 0; + SCM s; + + if (c == '@') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &lbnd); + } + + s = scm_from_ssize_t (lbnd); + + if (c == ':') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &len); + if (len < 0) + scm_i_input_error (NULL, port, + "array length must be non-negative", + SCM_EOL); + + s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); + } + + shape = scm_cons (s, shape); + } while (c == '@' || c == ':'); + + shape = scm_reverse_x (shape, SCM_EOL); + } + + /* Read nested lists of elements. */ + if (c != '(') + scm_i_input_error (NULL, port, + "missing '(' in vector or array literal", + SCM_EOL); + elements = scm_read_sexp (c, port); + + if (scm_is_false (shape)) + shape = scm_from_ssize_t (rank); + else if (scm_ilength (shape) != rank) + scm_i_input_error + (NULL, port, + "the number of shape specifications must match the array rank", + SCM_EOL); + + /* Handle special print syntax of rank zero arrays; see + scm_i_print_array for a rationale. */ + if (rank == 0) + { + if (!scm_is_pair (elements)) + scm_i_input_error (NULL, port, + "too few elements in array literal, need 1", + SCM_EOL); + if (!scm_is_null (SCM_CDR (elements))) + scm_i_input_error (NULL, port, + "too many elements in array literal, want 1", + SCM_EOL); + elements = SCM_CAR (elements); + } + + /* Construct array, annotate with source location, and return. */ + array = scm_list_to_typed_array (tag, shape, elements); + return maybe_annotate_source (array, port, line, column); } static SCM From 603234c611b50cdc8770b2a822cd333812eed98d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 22 Oct 2012 23:28:56 -0400 Subject: [PATCH 41/52] Minor tweaks to delimiter handling in read.c * libguile/read.c (CHAR_IS_R5RS_DELIMITER, CHAR_IS_DELIMITER): Move the '[' and ']' delimiters from CHAR_IS_R5RS_DELIMITER to CHAR_IS_DELIMITER. Parenthesize all references to the macro parameter. Don't check the global square-brackets read option until after we know the character is '[' or ']'. (scm_read_sexp): Don't check the global square-brackets read option until after we know the character is ']'. --- libguile/read.c | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 7fb1c21bc..d112e3d2e 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -185,10 +185,11 @@ scm_i_read_hash_procedures_set_x (SCM value) structure''). */ #define CHAR_IS_R5RS_DELIMITER(c) \ (CHAR_IS_BLANK (c) \ - || (c == ')') || (c == '(') || (c == ';') || (c == '"') \ - || (SCM_SQUARE_BRACKETS_P && ((c == '[') || (c == ']')))) + || (c) == ')' || (c) == '(' || (c) == ';' || (c) == '"') -#define CHAR_IS_DELIMITER CHAR_IS_R5RS_DELIMITER +#define CHAR_IS_DELIMITER(c) \ + (CHAR_IS_R5RS_DELIMITER (c) \ + || (((c) == ']' || (c) == '[') && SCM_SQUARE_BRACKETS_P)) /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical Structure''. */ @@ -405,7 +406,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port) { SCM new_tail; - if (c == ')' || (SCM_SQUARE_BRACKETS_P && c == ']')) + if (c == ')' || (c == ']' && SCM_SQUARE_BRACKETS_P)) scm_i_input_error (FUNC_NAME, port, "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); From b1b5433d66ccc8267a70c6ca3c0a630bddea4edb Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 17:11:41 -0400 Subject: [PATCH 42/52] Change reader to pass read options to helpers via explicit parameter. * libguile/read.c (enum t_keyword_style, struct t_read_opts, scm_t_read_opts): New types. (init_read_options): New function. (CHAR_IS_DELIMITER): Look up square-brackets option via local 'opts'. (scm_read): Call 'init_read_options', and pass 'opts' to helpers. (flush_ws, maybe_annotate_source, read_complete_token, read_token, scm_read_bytevector, scm_read_character, scm_read_commented_expression, scm_read_expression, scm_read_guile_bit_vector, scm_read_keyword, scm_read_mixed_case_symbol, scm_read_nil, scm_read_number, scm_read_number_and_radix, scm_read_quote, scm_read_sexp, scm_read_sharp, scm_read_sharp_extension, scm_read_shebang, scm_read_srfi4_vector, scm_read_string, scm_read_syntax, scm_read_vector, scm_read_array): Add 'opts' as an additional parameter, and use it to look up read options. Previously the global read options were consulted directly. --- libguile/read.c | 279 ++++++++++++++++++++++++++++++------------------ 1 file changed, 173 insertions(+), 106 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index d112e3d2e..9c8bff65f 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -80,6 +80,57 @@ scm_t_option scm_read_opts[] = { "In strings, consume leading whitespace after an escaped end-of-line."}, { 0, }, }; + +/* Internal read options structure. This is initialized by 'scm_read' + from the global read options, and a pointer is passed down to all + helper functions. */ +enum t_keyword_style { + KEYWORD_STYLE_HASH_PREFIX, + KEYWORD_STYLE_PREFIX, + KEYWORD_STYLE_POSTFIX +}; + +struct t_read_opts { + enum t_keyword_style keyword_style; + unsigned int copy_source_p : 1; + unsigned int record_positions_p : 1; + unsigned int case_insensitive_p : 1; + unsigned int r6rs_escapes_p : 1; + unsigned int square_brackets_p : 1; + unsigned int hungry_eol_escapes_p : 1; +}; + +typedef struct t_read_opts scm_t_read_opts; + +/* Initialize OPTS from the global read options. */ +static void +init_read_options (scm_t_read_opts *opts) +{ + SCM val; + int x; + + val = SCM_PACK (SCM_KEYWORD_STYLE); + if (scm_is_eq (val, scm_keyword_prefix)) + x = KEYWORD_STYLE_PREFIX; + else if (scm_is_eq (val, scm_keyword_postfix)) + x = KEYWORD_STYLE_POSTFIX; + else + x = KEYWORD_STYLE_HASH_PREFIX; + opts->keyword_style = x; + +#define RESOLVE_BOOLEAN_OPTION(NAME, name) \ + (opts->name = !!SCM_ ## NAME) + + RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p); + RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p); + RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p); + RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p); + RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p); + RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p); + +#undef RESOLVE_BOOLEAN_OPTION +} + /* Give meaningful error messages for errors @@ -189,7 +240,7 @@ scm_i_read_hash_procedures_set_x (SCM value) #define CHAR_IS_DELIMITER(c) \ (CHAR_IS_R5RS_DELIMITER (c) \ - || (((c) == ']' || (c) == '[') && SCM_SQUARE_BRACKETS_P)) + || (((c) == ']' || (c) == '[') && opts->square_brackets_p)) /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical Structure''. */ @@ -200,8 +251,8 @@ scm_i_read_hash_procedures_set_x (SCM value) /* Read an SCSH block comment. */ static SCM scm_read_scsh_block_comment (scm_t_wchar, SCM); static SCM scm_read_r6rs_block_comment (scm_t_wchar, SCM); -static SCM scm_read_commented_expression (scm_t_wchar, SCM); -static SCM scm_read_shebang (scm_t_wchar, SCM); +static SCM scm_read_commented_expression (scm_t_wchar, SCM, scm_t_read_opts *); +static SCM scm_read_shebang (scm_t_wchar, SCM, scm_t_read_opts *); static SCM scm_get_hash_procedure (int); /* Read from PORT until a delimiter (e.g., a whitespace) is read. Put the @@ -209,7 +260,8 @@ static SCM scm_get_hash_procedure (int); fewer than BUF_SIZE bytes, non-zero otherwise. READ will be set the number of bytes actually read. */ static int -read_token (SCM port, char *buf, size_t buf_size, size_t *read) +read_token (SCM port, scm_t_read_opts *opts, + char *buf, size_t buf_size, size_t *read) { *read = 0; @@ -239,8 +291,8 @@ read_token (SCM port, char *buf, size_t buf_size, size_t *read) /* Like `read_token', but return either BUFFER, or a GC-allocated buffer if the token doesn't fit in BUFFER_SIZE bytes. */ static char * -read_complete_token (SCM port, char *buffer, size_t buffer_size, - size_t *read) +read_complete_token (SCM port, scm_t_read_opts *opts, + char *buffer, size_t buffer_size, size_t *read) { int overflow = 0; size_t bytes_read, overflow_size = 0; @@ -248,7 +300,7 @@ read_complete_token (SCM port, char *buffer, size_t buffer_size, do { - overflow = read_token (port, buffer, buffer_size, &bytes_read); + overflow = read_token (port, opts, buffer, buffer_size, &bytes_read); if (bytes_read == 0) break; if (overflow || overflow_size != 0) @@ -285,7 +337,7 @@ read_complete_token (SCM port, char *buffer, size_t buffer_size, /* Skip whitespace from PORT and return the first non-whitespace character read. Raise an error on end-of-file. */ static int -flush_ws (SCM port, const char *eoferr) +flush_ws (SCM port, scm_t_read_opts *opts, const char *eoferr) { scm_t_wchar c; while (1) @@ -322,10 +374,10 @@ flush_ws (SCM port, const char *eoferr) eoferr = "read_sharp"; goto goteof; case '!': - scm_read_shebang (c, port); + scm_read_shebang (c, port, opts); break; case ';': - scm_read_commented_expression (c, port); + scm_read_commented_expression (c, port, opts); break; case '|': if (scm_is_false (scm_get_hash_procedure (c))) @@ -356,20 +408,22 @@ flush_ws (SCM port, const char *eoferr) /* Token readers. */ -static SCM scm_read_expression (SCM port); -static SCM scm_read_sharp (int chr, SCM port, long line, int column); +static SCM scm_read_expression (SCM port, scm_t_read_opts *opts); +static SCM scm_read_sharp (int chr, SCM port, scm_t_read_opts *opts, + long line, int column); static SCM -maybe_annotate_source (SCM x, SCM port, long line, int column) +maybe_annotate_source (SCM x, SCM port, scm_t_read_opts *opts, + long line, int column) { - if (SCM_RECORD_POSITIONS_P) + if (opts->record_positions_p) scm_i_set_source_properties_x (x, line, column, SCM_FILENAME (port)); return x; } static SCM -scm_read_sexp (scm_t_wchar chr, SCM port) +scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #define FUNC_NAME "scm_i_lreadparen" { int c; @@ -380,20 +434,20 @@ scm_read_sexp (scm_t_wchar chr, SCM port) long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - c = flush_ws (port, FUNC_NAME); + c = flush_ws (port, opts, FUNC_NAME); if (terminating_char == c) return SCM_EOL; scm_ungetc (c, port); - tmp = scm_read_expression (port); + tmp = scm_read_expression (port, opts); /* 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))) + ans = scm_read_expression (port, opts); + if (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) scm_i_input_error (FUNC_NAME, port, "missing close paren", SCM_EOL); return ans; @@ -402,24 +456,24 @@ scm_read_sexp (scm_t_wchar chr, SCM port) /* Build the head of the list structure. */ ans = tl = scm_cons (tmp, SCM_EOL); - while (terminating_char != (c = flush_ws (port, FUNC_NAME))) + while (terminating_char != (c = flush_ws (port, opts, FUNC_NAME))) { SCM new_tail; - if (c == ')' || (c == ']' && SCM_SQUARE_BRACKETS_P)) + if (c == ')' || (c == ']' && opts->square_brackets_p)) scm_i_input_error (FUNC_NAME, port, "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); scm_ungetc (c, port); - tmp = scm_read_expression (port); + tmp = scm_read_expression (port, opts); /* See above note about scm_sym_dot. */ if (c == '.' && scm_is_eq (scm_sym_dot, tmp)) { - SCM_SETCDR (tl, scm_read_expression (port)); + SCM_SETCDR (tl, scm_read_expression (port, opts)); - c = flush_ws (port, FUNC_NAME); + c = flush_ws (port, opts, FUNC_NAME); if (terminating_char != c) scm_i_input_error (FUNC_NAME, port, "in pair: missing close paren", SCM_EOL); @@ -432,7 +486,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port) } exit: - return maybe_annotate_source (ans, port, line, column); + return maybe_annotate_source (ans, port, opts, line, column); } #undef FUNC_NAME @@ -488,7 +542,7 @@ skip_intraline_whitespace (SCM port) } static SCM -scm_read_string (int chr, SCM port) +scm_read_string (int chr, SCM port, scm_t_read_opts *opts) #define FUNC_NAME "scm_lreadr" { /* For strings smaller than C_STR, this function creates only one Scheme @@ -527,7 +581,7 @@ scm_read_string (int chr, SCM port) case '\\': break; case '\n': - if (SCM_HUNGRY_EOL_ESCAPES_P) + if (opts->hungry_eol_escapes_p) skip_intraline_whitespace (port); continue; case '0': @@ -555,19 +609,19 @@ scm_read_string (int chr, SCM port) c = '\010'; break; case 'x': - if (SCM_R6RS_ESCAPES_P) + if (opts->r6rs_escapes_p) SCM_READ_HEX_ESCAPE (10, ';'); else SCM_READ_HEX_ESCAPE (2, '\0'); break; case 'u': - if (!SCM_R6RS_ESCAPES_P) + if (!opts->r6rs_escapes_p) { SCM_READ_HEX_ESCAPE (4, '\0'); break; } case 'U': - if (!SCM_R6RS_ESCAPES_P) + if (!opts->r6rs_escapes_p) { SCM_READ_HEX_ESCAPE (6, '\0'); break; @@ -594,13 +648,13 @@ scm_read_string (int chr, SCM port) str = scm_string_concatenate_reverse (str, SCM_UNDEFINED, SCM_UNDEFINED); } - return maybe_annotate_source (str, port, line, column); + return maybe_annotate_source (str, port, opts, line, column); } #undef FUNC_NAME static SCM -scm_read_number (scm_t_wchar chr, SCM port) +scm_read_number (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { SCM result, str = SCM_EOL; char local_buffer[READER_BUFFER_SIZE], *buffer; @@ -612,7 +666,7 @@ scm_read_number (scm_t_wchar chr, SCM port) int column = SCM_COL (port) - 1; scm_ungetc (chr, port); - buffer = read_complete_token (port, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler); @@ -621,30 +675,30 @@ scm_read_number (scm_t_wchar chr, SCM port) if (scm_is_false (result)) { /* Return a symbol instead of a number */ - if (SCM_CASE_INSENSITIVE_P) + if (opts->case_insensitive_p) str = scm_string_downcase_x (str); result = scm_string_to_symbol (str); } else if (SCM_NIMP (result)) - result = maybe_annotate_source (result, port, line, column); + result = maybe_annotate_source (result, port, opts, line, column); SCM_COL (port) += scm_i_string_length (str); return result; } static SCM -scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) +scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { SCM result; int ends_with_colon = 0; size_t bytes_read; - int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix); + int postfix = (opts->keyword_style == KEYWORD_STYLE_POSTFIX); char local_buffer[READER_BUFFER_SIZE], *buffer; scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM str; scm_ungetc (chr, port); - buffer = read_complete_token (port, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &bytes_read); if (bytes_read > 0) ends_with_colon = buffer[bytes_read - 1] == ':'; @@ -654,7 +708,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) str = scm_from_stringn (buffer, bytes_read - 1, pt->encoding, pt->ilseq_handler); - if (SCM_CASE_INSENSITIVE_P) + if (opts->case_insensitive_p) str = scm_string_downcase_x (str); result = scm_symbol_to_keyword (scm_string_to_symbol (str)); } @@ -663,7 +717,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) str = scm_from_stringn (buffer, bytes_read, pt->encoding, pt->ilseq_handler); - if (SCM_CASE_INSENSITIVE_P) + if (opts->case_insensitive_p) str = scm_string_downcase_x (str); result = scm_string_to_symbol (str); } @@ -673,7 +727,7 @@ scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) } static SCM -scm_read_number_and_radix (scm_t_wchar chr, SCM port) +scm_read_number_and_radix (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #define FUNC_NAME "scm_lreadr" { SCM result; @@ -711,7 +765,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port) radix = 10; } - buffer = read_complete_token (port, local_buffer, sizeof local_buffer, + buffer = read_complete_token (port, opts, local_buffer, sizeof local_buffer, &read); pt = SCM_PTAB_ENTRY (port); @@ -731,7 +785,7 @@ scm_read_number_and_radix (scm_t_wchar chr, SCM port) #undef FUNC_NAME static SCM -scm_read_quote (int chr, SCM port) +scm_read_quote (int chr, SCM port, scm_t_read_opts *opts) { SCM p; long line = SCM_LINUM (port); @@ -768,8 +822,8 @@ scm_read_quote (int chr, SCM port) abort (); } - p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); - return maybe_annotate_source (p, port, line, column); + p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); + return maybe_annotate_source (p, port, opts, line, column); } SCM_SYMBOL (sym_syntax, "syntax"); @@ -778,7 +832,7 @@ SCM_SYMBOL (sym_unsyntax, "unsyntax"); SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing"); static SCM -scm_read_syntax (int chr, SCM port) +scm_read_syntax (int chr, SCM port, scm_t_read_opts *opts) { SCM p; long line = SCM_LINUM (port); @@ -815,14 +869,14 @@ scm_read_syntax (int chr, SCM port) abort (); } - p = scm_cons2 (p, scm_read_expression (port), SCM_EOL); - return maybe_annotate_source (p, port, line, column); + p = scm_cons2 (p, scm_read_expression (port, opts), SCM_EOL); + return maybe_annotate_source (p, port, opts, line, column); } static SCM -scm_read_nil (int chr, SCM port) +scm_read_nil (int chr, SCM port, scm_t_read_opts *opts) { - SCM id = scm_read_mixed_case_symbol (chr, port); + SCM id = scm_read_mixed_case_symbol (chr, port, opts); if (!scm_is_eq (id, sym_nil)) scm_i_input_error ("scm_read_nil", port, @@ -868,7 +922,7 @@ scm_read_boolean (int chr, SCM port) } static SCM -scm_read_character (scm_t_wchar chr, SCM port) +scm_read_character (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) #define FUNC_NAME "scm_lreadr" { char buffer[READER_CHAR_NAME_MAX_SIZE]; @@ -878,7 +932,8 @@ scm_read_character (scm_t_wchar chr, SCM port) int overflow; scm_t_port *pt; - overflow = read_token (port, buffer, READER_CHAR_NAME_MAX_SIZE, &bytes_read); + overflow = read_token (port, opts, buffer, READER_CHAR_NAME_MAX_SIZE, + &bytes_read); if (overflow) scm_i_input_error (FUNC_NAME, port, "character name too long", SCM_EOL); @@ -974,7 +1029,7 @@ scm_read_character (scm_t_wchar chr, SCM port) #undef FUNC_NAME static SCM -scm_read_keyword (int chr, SCM port) +scm_read_keyword (int chr, SCM port, scm_t_read_opts *opts) { SCM symbol; @@ -983,7 +1038,7 @@ scm_read_keyword (int chr, SCM port) to adapt to the delimiters currently valid of symbols. XXX: This implementation allows sloppy syntaxes like `#: key'. */ - symbol = scm_read_expression (port); + symbol = scm_read_expression (port, opts); if (!scm_is_symbol (symbol)) scm_i_input_error ("scm_read_keyword", port, "keyword prefix `~a' not followed by a symbol: ~s", @@ -993,14 +1048,15 @@ scm_read_keyword (int chr, SCM port) } static SCM -scm_read_vector (int chr, SCM port, long line, int column) +scm_read_vector (int chr, SCM port, scm_t_read_opts *opts, + long line, int column) { /* Note: We call `scm_read_sexp ()' rather than READER here in order to guarantee that it's going to do what we want. After all, this is an implementation detail of `scm_read_vector ()', not a desirable property. */ - return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port)), - port, line, column); + return maybe_annotate_source (scm_vector (scm_read_sexp (chr, port, opts)), + port, opts, line, column); } /* Helper used by scm_read_array */ @@ -1033,9 +1089,10 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) vectors. Also, the conflict between '#f' and '#f32' and '#f64' is handled here. - C is the first character read after the '#'. */ + C is the first character read after the '#'. +*/ static SCM -scm_read_array (int c, SCM port, long line, int column) +scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) { ssize_t rank; scm_t_wchar tag_buf[8]; @@ -1045,11 +1102,13 @@ scm_read_array (int c, SCM port, long line, int column) /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but the array code can not deal with zero-length dimensions yet, and - we want to allow zero-length vectors, of course. */ + we want to allow zero-length vectors, of course. + */ if (c == '(') - return scm_read_vector (c, port, line, column); + return scm_read_vector (c, port, opts, line, column); - /* Disambiguate between '#f' and uniform floating point vectors. */ + /* Disambiguate between '#f' and uniform floating point vectors. + */ if (c == 'f') { c = scm_getc (port); @@ -1132,7 +1191,7 @@ scm_read_array (int c, SCM port, long line, int column) scm_i_input_error (NULL, port, "missing '(' in vector or array literal", SCM_EOL); - elements = scm_read_sexp (c, port); + elements = scm_read_sexp (c, port, opts); if (scm_is_false (shape)) shape = scm_from_ssize_t (rank); @@ -1159,17 +1218,19 @@ scm_read_array (int c, SCM port, long line, int column) /* Construct array, annotate with source location, and return. */ array = scm_list_to_typed_array (tag, shape, elements); - return maybe_annotate_source (array, port, line, column); + return maybe_annotate_source (array, port, opts, line, column); } static SCM -scm_read_srfi4_vector (int chr, SCM port, long line, int column) +scm_read_srfi4_vector (int chr, SCM port, scm_t_read_opts *opts, + long line, int column) { - return scm_read_array (chr, port, line, column); + return scm_read_array (chr, port, opts, line, column); } static SCM -scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column) +scm_read_bytevector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, + long line, int column) { chr = scm_getc (port); if (chr != 'u') @@ -1184,8 +1245,8 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column) goto syntax; return maybe_annotate_source - (scm_u8_list_to_bytevector (scm_read_sexp (chr, port)), - port, line, column); + (scm_u8_list_to_bytevector (scm_read_sexp (chr, port, opts)), + port, opts, line, column); syntax: scm_i_input_error ("read_bytevector", port, @@ -1195,7 +1256,8 @@ scm_read_bytevector (scm_t_wchar chr, SCM port, long line, int column) } static SCM -scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, long line, int column) +scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, + long line, int column) { /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is terribly inefficient but who cares? */ @@ -1213,7 +1275,7 @@ scm_read_guile_bit_vector (scm_t_wchar chr, SCM port, long line, int column) return maybe_annotate_source (scm_bitvector (scm_reverse_x (s_bits, SCM_EOL)), - port, line, column); + port, opts, line, column); } static SCM @@ -1241,7 +1303,7 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) } static SCM -scm_read_shebang (scm_t_wchar chr, SCM port) +scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { int c = 0; if ((c = scm_get_byte_or_eof (port)) != 'r') @@ -1313,16 +1375,17 @@ scm_read_r6rs_block_comment (scm_t_wchar chr, SCM port) } static SCM -scm_read_commented_expression (scm_t_wchar chr, SCM port) +scm_read_commented_expression (scm_t_wchar chr, SCM port, + scm_t_read_opts *opts) { scm_t_wchar c; - c = flush_ws (port, (char *) NULL); + c = flush_ws (port, opts, (char *) NULL); if (EOF == c) scm_i_input_error ("read_commented_expression", port, "no expression after #; comment", SCM_EOL); scm_ungetc (c, port); - scm_read_expression (port); + scm_read_expression (port, opts); return SCM_UNSPECIFIED; } @@ -1424,7 +1487,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port) /* Top-level token readers, i.e., dispatchers. */ static SCM -scm_read_sharp_extension (int chr, SCM port) +scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) { SCM proc; @@ -1449,39 +1512,40 @@ scm_read_sharp_extension (int chr, SCM port) /* The reader for the sharp `#' character. It basically dispatches reads among the above token readers. */ static SCM -scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column) +scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, + long line, int column) #define FUNC_NAME "scm_lreadr" { SCM result; chr = scm_getc (port); - result = scm_read_sharp_extension (chr, port); + result = scm_read_sharp_extension (chr, port, opts); if (!scm_is_eq (result, SCM_UNSPECIFIED)) return result; switch (chr) { case '\\': - return (scm_read_character (chr, port)); + return (scm_read_character (chr, port, opts)); case '(': - return (scm_read_vector (chr, port, line, column)); + return (scm_read_vector (chr, port, opts, line, column)); case 's': case 'u': case 'f': case 'c': /* This one may return either a boolean or an SRFI-4 vector. */ - return (scm_read_srfi4_vector (chr, port, line, column)); + return (scm_read_srfi4_vector (chr, port, opts, line, column)); case 'v': - return (scm_read_bytevector (chr, port, line, column)); + return (scm_read_bytevector (chr, port, opts, line, column)); case '*': - return (scm_read_guile_bit_vector (chr, port, line, column)); + return (scm_read_guile_bit_vector (chr, port, opts, line, column)); case 't': case 'T': case 'F': return (scm_read_boolean (chr, port)); case ':': - return (scm_read_keyword (chr, port)); + return (scm_read_keyword (chr, port, opts)); case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '@': @@ -1492,7 +1556,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column) case 'h': case 'l': #endif - return (scm_read_array (chr, port, line, column)); + return (scm_read_array (chr, port, opts, line, column)); case 'i': case 'e': @@ -1504,7 +1568,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column) if (next_c != EOF) scm_ungetc (next_c, port); if (next_c == '(') - return scm_read_array (chr, port, line, column); + return scm_read_array (chr, port, opts, line, column); /* Fall through. */ } #endif @@ -1518,21 +1582,21 @@ scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column) case 'X': case 'I': case 'E': - return (scm_read_number_and_radix (chr, port)); + return (scm_read_number_and_radix (chr, port, opts)); case '{': return (scm_read_extended_symbol (chr, port)); case '!': - return (scm_read_shebang (chr, port)); + return (scm_read_shebang (chr, port, opts)); case ';': - return (scm_read_commented_expression (chr, port)); + return (scm_read_commented_expression (chr, port, opts)); case '`': case '\'': case ',': - return (scm_read_syntax (chr, port)); + return (scm_read_syntax (chr, port, opts)); case 'n': - return (scm_read_nil (chr, port)); + return (scm_read_nil (chr, port, opts)); default: - result = scm_read_sharp_extension (chr, port); + result = scm_read_sharp_extension (chr, port, opts); if (scm_is_eq (result, SCM_UNSPECIFIED)) { /* To remain compatible with 1.8 and earlier, the following @@ -1556,7 +1620,7 @@ scm_read_sharp (scm_t_wchar chr, SCM port, long line, int column) #undef FUNC_NAME static SCM -scm_read_expression (SCM port) +scm_read_expression (SCM port, scm_t_read_opts *opts) #define FUNC_NAME "scm_read_expression" { while (1) @@ -1574,22 +1638,22 @@ scm_read_expression (SCM port) (void) scm_read_semicolon_comment (chr, port); break; case '[': - if (!SCM_SQUARE_BRACKETS_P) - return (scm_read_mixed_case_symbol (chr, port)); + if (!opts->square_brackets_p) + return (scm_read_mixed_case_symbol (chr, port, opts)); /* otherwise fall through */ case '(': - return (scm_read_sexp (chr, port)); + return (scm_read_sexp (chr, port, opts)); case '"': - return (scm_read_string (chr, port)); + return (scm_read_string (chr, port, opts)); case '\'': case '`': case ',': - return (scm_read_quote (chr, port)); + return (scm_read_quote (chr, port, opts)); case '#': { long line = SCM_LINUM (port); int column = SCM_COL (port) - 1; - SCM result = scm_read_sharp (chr, port, line, column); + SCM result = scm_read_sharp (chr, port, opts, line, column); if (scm_is_eq (result, SCM_UNSPECIFIED)) /* We read a comment or some such. */ break; @@ -1600,23 +1664,23 @@ scm_read_expression (SCM port) scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL); break; case ']': - if (SCM_SQUARE_BRACKETS_P) + if (opts->square_brackets_p) scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); /* otherwise fall through */ case EOF: return SCM_EOF_VAL; case ':': - if (scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) - return scm_symbol_to_keyword (scm_read_expression (port)); + if (opts->keyword_style == KEYWORD_STYLE_PREFIX) + return scm_symbol_to_keyword (scm_read_expression (port, opts)); /* Fall through. */ default: { if (((chr >= '0') && (chr <= '9')) || (strchr ("+-.", chr))) - return (scm_read_number (chr, port)); + return (scm_read_number (chr, port, opts)); else - return (scm_read_mixed_case_symbol (chr, port)); + return (scm_read_mixed_case_symbol (chr, port, opts)); } } } @@ -1633,18 +1697,21 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, "Any whitespace before the next token is discarded.") #define FUNC_NAME s_scm_read { + scm_t_read_opts opts; int c; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - c = flush_ws (port, (char *) NULL); + init_read_options (&opts); + + c = flush_ws (port, &opts, (char *) NULL); if (EOF == c) return SCM_EOF_VAL; scm_ungetc (c, port); - return (scm_read_expression (port)); + return (scm_read_expression (port, &opts)); } #undef FUNC_NAME From 3655ed89834b9896fe267107c50cc4af8e0b5ecf Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 00:21:12 -0400 Subject: [PATCH 43/52] Add source properties to more datum types in scm_read_sharp_extension. * libguile/read.c (scm_read_sharp_extension): Attach source properties to the result of a custom token reader if the returned datum is not immediate. Previously, source properties were added to pairs only. --- libguile/read.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/read.c b/libguile/read.c index 9c8bff65f..0bbabc27b 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1500,7 +1500,8 @@ scm_read_sharp_extension (int chr, SCM port, scm_t_read_opts *opts) got = scm_call_2 (proc, SCM_MAKE_CHAR (chr), port); - if (scm_is_pair (got) && !scm_i_has_source_properties (got)) + if (opts->record_positions_p && SCM_NIMP (got) + && !scm_i_has_source_properties (got)) scm_i_set_source_properties_x (got, line, column, SCM_FILENAME (port)); return got; From 02327c0c5159809e204a561c2e12b84cbb8f0c20 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 00:29:07 -0400 Subject: [PATCH 44/52] Generalize scm_read_shebang to handle other reader directives. * libguile/read.c (READER_DIRECTIVE_NAME_MAX_SIZE): New C macro. (scm_read_shebang): Rewrite to handle arbitrary reader directives. --- libguile/read.c | 55 +++++++++++++++++++++++++------------------------ 1 file changed, 28 insertions(+), 27 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 0bbabc27b..6c916130c 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -218,6 +218,9 @@ scm_i_read_hash_procedures_set_x (SCM value) /* The maximum size of Scheme character names. */ #define READER_CHAR_NAME_MAX_SIZE 50 +/* The maximum size of reader directive names. */ +#define READER_DIRECTIVE_NAME_MAX_SIZE 50 + /* `isblank' is only in C99. */ #define CHAR_IS_BLANK_(_chr) \ @@ -1305,35 +1308,33 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) static SCM scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { - int c = 0; - if ((c = scm_get_byte_or_eof (port)) != 'r') + char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1]; + int c; + int i = 0; + + while (i <= READER_DIRECTIVE_NAME_MAX_SIZE) { - scm_ungetc (c, port); - return scm_read_scsh_block_comment (chr, port); + c = scm_getc (port); + if (c == EOF) + scm_i_input_error ("skip_block_comment", port, + "unterminated `#! ... !#' comment", SCM_EOL); + else if (('a' <= c && c <= 'z') || ('0' <= c && c <= '9') || c == '-') + name[i++] = c; + else if (CHAR_IS_DELIMITER (c)) + { + scm_ungetc (c, port); + name[i] = '\0'; + if (0 == strcmp ("r6rs", name)) + ; /* Silently ignore */ + else + break; + + return SCM_UNSPECIFIED; + } } - if ((c = scm_get_byte_or_eof (port)) != '6') - { - scm_ungetc (c, port); - scm_ungetc ('r', port); - return scm_read_scsh_block_comment (chr, port); - } - if ((c = scm_get_byte_or_eof (port)) != 'r') - { - scm_ungetc (c, port); - scm_ungetc ('6', port); - scm_ungetc ('r', port); - return scm_read_scsh_block_comment (chr, port); - } - if ((c = scm_get_byte_or_eof (port)) != 's') - { - scm_ungetc (c, port); - scm_ungetc ('r', port); - scm_ungetc ('6', port); - scm_ungetc ('r', port); - return scm_read_scsh_block_comment (chr, port); - } - - return SCM_UNSPECIFIED; + while (i > 0) + scm_ungetc (name[--i], port); + return scm_read_scsh_block_comment (chr, port); } static SCM From 851c3cd16e6b9caee069581aa34e198d1df14c71 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 00:36:12 -0400 Subject: [PATCH 45/52] Repurpose scm_i_port_weak_hash to associate an alist with each port. * libguile/ports.c (scm_i_port_weak_hash): Document that the values in this hash table will now be alists. Previously the value slots were unused. (scm_new_port_table_entry): Change the initial value of the entry in scm_i_port_weak_hash from SCM_BOOL_F to SCM_EOL. --- libguile/ports.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/libguile/ports.c b/libguile/ports.c index 301bc448b..55808e272 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -533,7 +533,8 @@ scm_i_dynwind_current_load_port (SCM port) /* We need a global registry of ports to flush them all at exit, and to - get all the ports matching a file descriptor. + get all the ports matching a file descriptor. The associated values + are alists, where additional information can be associated with ports. */ SCM scm_i_port_weak_hash; @@ -633,7 +634,7 @@ scm_new_port_table_entry (scm_t_bits tag) SCM_SET_CELL_TYPE (z, tag); SCM_SETPTAB_ENTRY (z, entry); - scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_BOOL_F); + scm_hashq_set_x (scm_i_port_weak_hash, z, SCM_EOL); /* For each new port, register a finalizer so that it port type's free function can be invoked eventually. */ From ea8c97615590ec60f2df0f7f356b04aa0a174eef Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 17:28:43 -0400 Subject: [PATCH 46/52] Implement per-port read options. * libguile/read.c (scm_t_read_opts): Update comment to mention the per-port read options. (sym_port_read_options): New variable. (set_port_read_option): New function. (init_read_options): Add new 'port' parameter, and consult the per-port read option overrides when initializing the 'scm_t_read_opts' struct. Move to bottom of file. (scm_read): Pass 'port' parameter to init_read_options. --- libguile/read.c | 161 ++++++++++++++++++++++++++++++++++++------------ 1 file changed, 123 insertions(+), 38 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 6c916130c..f3f7d395b 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -82,15 +82,18 @@ scm_t_option scm_read_opts[] = { }; /* Internal read options structure. This is initialized by 'scm_read' - from the global read options, and a pointer is passed down to all - helper functions. */ -enum t_keyword_style { - KEYWORD_STYLE_HASH_PREFIX, - KEYWORD_STYLE_PREFIX, - KEYWORD_STYLE_POSTFIX -}; + from the global and per-port read options, and a pointer is passed + down to all helper functions. */ -struct t_read_opts { +enum t_keyword_style + { + KEYWORD_STYLE_HASH_PREFIX, + KEYWORD_STYLE_PREFIX, + KEYWORD_STYLE_POSTFIX + }; + +struct t_read_opts +{ enum t_keyword_style keyword_style; unsigned int copy_source_p : 1; unsigned int record_positions_p : 1; @@ -102,35 +105,6 @@ struct t_read_opts { typedef struct t_read_opts scm_t_read_opts; -/* Initialize OPTS from the global read options. */ -static void -init_read_options (scm_t_read_opts *opts) -{ - SCM val; - int x; - - val = SCM_PACK (SCM_KEYWORD_STYLE); - if (scm_is_eq (val, scm_keyword_prefix)) - x = KEYWORD_STYLE_PREFIX; - else if (scm_is_eq (val, scm_keyword_postfix)) - x = KEYWORD_STYLE_POSTFIX; - else - x = KEYWORD_STYLE_HASH_PREFIX; - opts->keyword_style = x; - -#define RESOLVE_BOOLEAN_OPTION(NAME, name) \ - (opts->name = !!SCM_ ## NAME) - - RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p); - RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p); - RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p); - RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p); - RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p); - RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p); - -#undef RESOLVE_BOOLEAN_OPTION -} - /* Give meaningful error messages for errors @@ -1692,6 +1666,8 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) /* Actual reader. */ +static void init_read_options (SCM port, scm_t_read_opts *opts); + SCM_DEFINE (scm_read, "read", 0, 1, 0, (SCM port), "Read an s-expression from the input port @var{port}, or from\n" @@ -1706,7 +1682,7 @@ SCM_DEFINE (scm_read, "read", 0, 1, 0, port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); - init_read_options (&opts); + init_read_options (port, &opts); c = flush_ws (port, &opts, (char *) NULL); if (EOF == c) @@ -1970,6 +1946,115 @@ SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0, } #undef FUNC_NAME + +/* Per-port read options. + + We store per-port read options in the 'port-read-options' key of the + port's alist, which is stored in 'scm_i_port_weak_hash'. The value + stored in the alist is a single integer that contains a two-bit field + for each read option. + + If a bit field contains READ_OPTION_INHERIT (3), that indicates that + the applicable value should be inherited from the corresponding + global read option. Otherwise, the bit field contains the value of + the read option. For boolean read options that have been set + per-port, the possible values are 0 or 1. If the 'keyword_style' + read option has been set per-port, its possible values are those in + 'enum t_keyword_style'. */ + +/* Key to read options in per-port alists. */ +SCM_SYMBOL (sym_port_read_options, "port-read-options"); + +/* Offsets of bit fields for each per-port override */ +#define READ_OPTION_COPY_SOURCE_P 0 +#define READ_OPTION_RECORD_POSITIONS_P 2 +#define READ_OPTION_CASE_INSENSITIVE_P 4 +#define READ_OPTION_KEYWORD_STYLE 6 +#define READ_OPTION_R6RS_ESCAPES_P 8 +#define READ_OPTION_SQUARE_BRACKETS_P 10 +#define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12 + +#define READ_OPTIONS_NUM_BITS 14 + +#define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1) +#define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL + +#define READ_OPTION_MASK 3 +#define READ_OPTION_INHERIT 3 + +static void +set_port_read_option (SCM port, int option, int new_value) +{ + SCM alist, scm_read_options; + unsigned int read_options; + + new_value &= READ_OPTION_MASK; + scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); + alist = scm_hashq_ref (scm_i_port_weak_hash, port, SCM_BOOL_F); + scm_read_options = scm_assq_ref (alist, sym_port_read_options); + if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE)) + read_options = scm_to_uint (scm_read_options); + else + read_options = READ_OPTIONS_INHERIT_ALL; + read_options &= ~(READ_OPTION_MASK << option); + read_options |= new_value << option; + scm_read_options = scm_from_uint (read_options); + alist = scm_assq_set_x (alist, sym_port_read_options, scm_read_options); + scm_hashq_set_x (scm_i_port_weak_hash, port, alist); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); +} + +/* Initialize OPTS based on PORT's read options and the global read + options. */ +static void +init_read_options (SCM port, scm_t_read_opts *opts) +{ + SCM alist, val, scm_read_options; + unsigned int read_options, x; + + scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); + alist = scm_hashq_ref (scm_i_port_weak_hash, port, SCM_BOOL_F); + scm_read_options = scm_assq_ref (alist, sym_port_read_options); + scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); + + if (scm_is_unsigned_integer (scm_read_options, 0, READ_OPTIONS_MAX_VALUE)) + read_options = scm_to_uint (scm_read_options); + else + read_options = READ_OPTIONS_INHERIT_ALL; + + x = READ_OPTION_MASK & (read_options >> READ_OPTION_KEYWORD_STYLE); + if (x == READ_OPTION_INHERIT) + { + val = SCM_PACK (SCM_KEYWORD_STYLE); + if (scm_is_eq (val, scm_keyword_prefix)) + x = KEYWORD_STYLE_PREFIX; + else if (scm_is_eq (val, scm_keyword_postfix)) + x = KEYWORD_STYLE_POSTFIX; + else + x = KEYWORD_STYLE_HASH_PREFIX; + } + opts->keyword_style = x; + +#define RESOLVE_BOOLEAN_OPTION(NAME, name) \ + do \ + { \ + x = READ_OPTION_MASK & (read_options >> READ_OPTION_ ## NAME); \ + if (x == READ_OPTION_INHERIT) \ + x = !!SCM_ ## NAME; \ + opts->name = x; \ + } \ + while (0) + + RESOLVE_BOOLEAN_OPTION (COPY_SOURCE_P, copy_source_p); + RESOLVE_BOOLEAN_OPTION (RECORD_POSITIONS_P, record_positions_p); + RESOLVE_BOOLEAN_OPTION (CASE_INSENSITIVE_P, case_insensitive_p); + RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p); + RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p); + RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p); + +#undef RESOLVE_BOOLEAN_OPTION +} + void scm_init_read () { From 9331ffd891d03bc736f98bf92628b4b2fa714e68 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 24 Oct 2012 14:37:36 -0400 Subject: [PATCH 47/52] Implement #!fold-case and #!no-fold-case reader directives. * libguile/read.c (set_port_case_insensitive_p): New function. (scm_read_shebang): Handle #!fold-case and #!no-fold-case. * doc/ref/api-evaluation.texi (Case Sensitivity, Scheme Read): Document the #!fold-case and #!no-fold-case reader directives. * test-suite/tests/reader.test ("per-port-read-options"): Add tests. --- doc/ref/api-evaluation.texi | 22 +++++++++++++++------- libguile/read.c | 16 ++++++++++++++++ test-suite/tests/reader.test | 13 +++++++++++++ 3 files changed, 44 insertions(+), 7 deletions(-) diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index 611283225..c7bf97a3f 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -254,6 +254,8 @@ Encoding of Source Files}. @node Case Sensitivity @subsubsection Case Sensitivity +@cindex fold-case +@cindex no-fold-case @c FIXME::martin: Review me! @@ -275,9 +277,9 @@ options, @xref{Scheme Read}. (read-enable 'case-insensitive) @end lisp -Note that this is seldom a problem, because Scheme programmers tend not -to use uppercase letters in their identifiers anyway. - +It is also possible to disable (or enable) case sensitivity within a +single file by placing the reader directives @code{#!fold-case} (or +@code{#!no-fold-case}) within the file itself. @node Keyword Syntax @subsubsection Keyword Syntax @@ -315,10 +317,10 @@ its read options. @cindex options - read @cindex read options @deffn {Scheme Procedure} read-options [setting] -Display the current settings of the read options. If @var{setting} is -omitted, only a short form of the current read options is printed. -Otherwise if @var{setting} is the symbol @code{help}, a complete options -description is displayed. +Display the current settings of the global read options. If +@var{setting} is omitted, only a short form of the current read options +is printed. Otherwise if @var{setting} is the symbol @code{help}, a +complete options description is displayed. @end deffn The set of available options, and their default values, may be had by @@ -338,6 +340,12 @@ hungry-eol-escapes no In strings, consume leading whitespace after an escaped end-of-line. @end smalllisp +Note that Guile also includes a preliminary mechanism for setting read +options on a per-port basis. For instance, the @code{case-insensitive} +read option is set (or unset) on the port when the reader encounters the +@code{#!fold-case} or @code{#!no-fold-case} reader directives. There is +currently no other way to access or set the per-port read options. + The boolean options may be toggled with @code{read-enable} and @code{read-disable}. The non-boolean @code{keywords} option must be set using @code{read-set!}. diff --git a/libguile/read.c b/libguile/read.c index f3f7d395b..ec1d394ce 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1279,6 +1279,9 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) return SCM_UNSPECIFIED; } +static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, + int value); + static SCM scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { @@ -1300,6 +1303,10 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) name[i] = '\0'; if (0 == strcmp ("r6rs", name)) ; /* Silently ignore */ + else if (0 == strcmp ("fold-case", name)) + set_port_case_insensitive_p (port, opts, 1); + else if (0 == strcmp ("no-fold-case", name)) + set_port_case_insensitive_p (port, opts, 0); else break; @@ -2004,6 +2011,15 @@ set_port_read_option (SCM port, int option, int new_value) scm_i_pthread_mutex_unlock (&scm_i_port_table_mutex); } +/* Set OPTS and PORT's case-insensitivity according to VALUE. */ +static void +set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value) +{ + value = !!value; + opts->case_insensitive_p = value; + set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value); +} + /* Initialize OPTS based on PORT's read options and the global read options. */ static void diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test index 60c853cf4..6e02255ad 100644 --- a/test-suite/tests/reader.test +++ b/test-suite/tests/reader.test @@ -401,6 +401,19 @@ (lambda () (read-disable 'hungry-eol-escapes)))))) +(with-test-prefix "per-port-read-options" + (pass-if "case-sensitive" + (equal? '(guile GuiLe gUIle) + (with-read-options '(case-insensitive) + (lambda () + (with-input-from-string "GUIle #!no-fold-case GuiLe gUIle" + (lambda () + (list (read) (read) (read)))))))) + (pass-if "case-insensitive" + (equal? '(GUIle guile guile) + (with-input-from-string "GUIle #!fold-case GuiLe gUIle" + (lambda () + (list (read) (read) (read))))))) (with-test-prefix "#;" (for-each From bf9eb54aab23ebe01779ad0bbaab624e6ceb47b2 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 26 Oct 2012 17:20:16 -0400 Subject: [PATCH 48/52] Implement SRFI-105 curly infix expressions. * libguile/private-options.h: Add SCM_CURLY_INFIX_P macro, and increment SCM_N_READ_OPTIONS. * libguile/read.c (sym_nfx, sym_bracket_list, sym_bracket_apply): New variables. (scm_read_opts): Add curly-infix reader option. Reformat to comply with GNU coding standards. (scm_t_read_opts): Add curly_infix_p and neoteric_p fields. (init_read_options): Initialize new fields. (CHAR_IS_DELIMITER): Add '{', '}', '[', and ']' as delimiters if curly_infix_p is set. (set_port_square_brackets_p, set_port_curly_infix_p): New functions. (read_inner_expression): New function which contains the code that was previously in 'scm_read_expression'. Handle curly braces when curly_infix_p is set. If curly_infix_p is set and square_brackets_p is unset, follow the Kawa convention: [...] => ($bracket-list$ ...) (scm_read_expression): New function body to handle neoteric expressions where appropriate. (scm_read_shebang): Handle the new reader directives: '#!curly-infix' and the non-standard '#!curly-infix-and-bracket-lists'. (scm_read_sexp): Handle curly infix lists. * module/ice-9/boot-9.scm (%cond-expand-features): Add srfi-105 feature identifier. * doc/ref/srfi-modules.texi (SRFI-105): Add stub doc for SRFI-105. * doc/ref/api-evaluation.texi (Scheme Read): Add documentation for the 'curly-infix' read option, and the '#!curly-infix' and '#!curly-infix-and-bracket-lists' reader directives. * doc/ref/api-options.texi (Runtime Options): Add 'curly-infix' to the list of read options. * test-suite/Makefile.am: Add tests/srfi-105.test. * test-suite/tests/srfi-105.test: New file. --- doc/ref/api-evaluation.texi | 7 +- doc/ref/api-options.texi | 1 + doc/ref/srfi-modules.texi | 51 +++++++ libguile/private-options.h | 3 +- libguile/read.c | 263 +++++++++++++++++++++++++++++---- module/ice-9/boot-9.scm | 3 +- test-suite/Makefile.am | 1 + test-suite/tests/srfi-105.test | 240 ++++++++++++++++++++++++++++++ 8 files changed, 538 insertions(+), 31 deletions(-) create mode 100644 test-suite/tests/srfi-105.test diff --git a/doc/ref/api-evaluation.texi b/doc/ref/api-evaluation.texi index c7bf97a3f..c471f643b 100644 --- a/doc/ref/api-evaluation.texi +++ b/doc/ref/api-evaluation.texi @@ -338,12 +338,17 @@ r6rs-hex-escapes no Use R6RS variable-length character and string hex escape square-brackets yes Treat `[' and `]' as parentheses, for R6RS compatibility. hungry-eol-escapes no In strings, consume leading whitespace after an escaped end-of-line. +curly-infix no Support SRFI-105 curly infix expressions. @end smalllisp Note that Guile also includes a preliminary mechanism for setting read options on a per-port basis. For instance, the @code{case-insensitive} read option is set (or unset) on the port when the reader encounters the -@code{#!fold-case} or @code{#!no-fold-case} reader directives. There is +@code{#!fold-case} or @code{#!no-fold-case} reader directives. +Similarly, the @code{#!curly-infix} reader directive sets the +@code{curly-infix} read option on the port, and +@code{#!curly-infix-and-bracket-lists} sets @code{curly-infix} and +unsets @code{square-brackets} on the port (@pxref{SRFI-105}). There is currently no other way to access or set the per-port read options. The boolean options may be toggled with @code{read-enable} and diff --git a/doc/ref/api-options.texi b/doc/ref/api-options.texi index f63597824..173431890 100644 --- a/doc/ref/api-options.texi +++ b/doc/ref/api-options.texi @@ -390,6 +390,7 @@ r6rs-hex-escapes no Use R6RS variable-length character and string hex escape square-brackets yes Treat `[' and `]' as parentheses, for R6RS compatibility. hungry-eol-escapes no In strings, consume leading whitespace after an escaped end-of-line. +curly-infix no Support SRFI-105 curly infix expressions. scheme@@(guile-user) [1]> (read-enable 'case-insensitive) $2 = (square-brackets keywords #f case-insensitive positions) scheme@@(guile-user) [1]> ,q diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index ba701a264..0e2fa9d38 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -54,6 +54,7 @@ get the relevant SRFI documents from the SRFI home page * SRFI-69:: Basic hash tables. * SRFI-88:: Keyword objects. * SRFI-98:: Accessing environment variables. +* SRFI-105:: Curly-infix expressions. @end menu @@ -4469,6 +4470,56 @@ Returns the names and values of all the environment variables as an association list in which both the keys and the values are strings. @end deffn +@node SRFI-105 +@subsection SRFI-105 Curly-infix expressions. +@cindex SRFI-105 +@cindex curly-infix +@cindex curly-infix-and-bracket-lists + +Guile's built-in reader includes support for SRFI-105 curly-infix +expressions. See @uref{http://srfi.schemers.org/srfi-105/srfi-105.html, +the specification of SRFI-105}. Some examples: + +@example +@{n <= 5@} @result{} (<= n 5) +@{a + b + c@} @result{} (+ a b c) +@{a * @{b + c@}@} @result{} (* a (+ b c)) +@{(- a) / b@} @result{} (/ (- a) b) +@{-(a) / b@} @result{} (/ (- a) b) as well +@{(f a b) + (g h)@} @result{} (+ (f a b) (g h)) +@{f(a b) + g(h)@} @result{} (+ (f a b) (g h)) as well +@{f[a b] + g(h)@} @result{} (+ ($bracket-apply$ f a b) (g h)) +'@{a + f(b) + x@} @result{} '(+ a (f b) x) +@{length(x) >= 6@} @result{} (>= (length x) 6) +@{n-1 + n-2@} @result{} (+ n-1 n-2) +@{n * factorial@{n - 1@}@} @result{} (* n (factorial (- n 1))) +@{@{a > 0@} and @{b >= 1@}@} @result{} (and (> a 0) (>= b 1)) +@{f@{n - 1@}(x)@} @result{} ((f (- n 1)) x) +@{a . z@} @result{} ($nfx$ a . z) +@{a + b - c@} @result{} ($nfx$ a + b - c) +@end example + +To enable curly-infix expressions within a file, place the reader +directive @code{#!curly-infix} before the first use of curly-infix +notation. To globally enable curly-infix expressions in Guile's reader, +set the @code{curly-infix} read option. + +Guile also implements the following non-standard extension to SRFI-105: +if @code{curly-infix} is enabled and there is no other meaning assigned +to square brackets (i.e. the @code{square-brackets} read option is +turned off), then lists within square brackets are read as normal lists +but with the special symbol @code{$bracket-list$} added to the front. +To enable this combination of read options within a file, use the reader +directive @code{#!curly-infix-and-bracket-lists}. For example: + +@example +[a b] @result{} ($bracket-list$ a b) +[a . b] @result{} ($bracket-list$ a . b) +@end example + + +For more information on reader options, @xref{Scheme Read}. + @c srfi-modules.texi ends here @c Local Variables: diff --git a/libguile/private-options.h b/libguile/private-options.h index 9d2d43cf5..ed0f314e5 100644 --- a/libguile/private-options.h +++ b/libguile/private-options.h @@ -67,7 +67,8 @@ SCM_INTERNAL scm_t_option scm_read_opts[]; #define SCM_R6RS_ESCAPES_P scm_read_opts[4].val #define SCM_SQUARE_BRACKETS_P scm_read_opts[5].val #define SCM_HUNGRY_EOL_ESCAPES_P scm_read_opts[6].val +#define SCM_CURLY_INFIX_P scm_read_opts[7].val -#define SCM_N_READ_OPTIONS 6 +#define SCM_N_READ_OPTIONS 7 #endif /* PRIVATE_OPTIONS */ diff --git a/libguile/read.c b/libguile/read.c index ec1d394ce..ebd1119eb 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -63,23 +63,31 @@ SCM_SYMBOL (scm_keyword_prefix, "prefix"); SCM_SYMBOL (scm_keyword_postfix, "postfix"); SCM_SYMBOL (sym_nil, "nil"); -scm_t_option scm_read_opts[] = { - { SCM_OPTION_BOOLEAN, "copy", 0, - "Copy source code expressions." }, - { SCM_OPTION_BOOLEAN, "positions", 1, - "Record positions of source code expressions." }, - { SCM_OPTION_BOOLEAN, "case-insensitive", 0, - "Convert symbols to lower case."}, - { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS, - "Style of keyword recognition: #f, 'prefix or 'postfix."}, - { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0, - "Use R6RS variable-length character and string hex escapes."}, - { SCM_OPTION_BOOLEAN, "square-brackets", 1, - "Treat `[' and `]' as parentheses, for R6RS compatibility."}, - { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0, - "In strings, consume leading whitespace after an escaped end-of-line."}, - { 0, }, -}; +/* SRFI-105 curly infix expression support */ +SCM_SYMBOL (sym_nfx, "$nfx$"); +SCM_SYMBOL (sym_bracket_list, "$bracket-list$"); +SCM_SYMBOL (sym_bracket_apply, "$bracket-apply$"); + +scm_t_option scm_read_opts[] = + { + { SCM_OPTION_BOOLEAN, "copy", 0, + "Copy source code expressions." }, + { SCM_OPTION_BOOLEAN, "positions", 1, + "Record positions of source code expressions." }, + { SCM_OPTION_BOOLEAN, "case-insensitive", 0, + "Convert symbols to lower case."}, + { SCM_OPTION_SCM, "keywords", (scm_t_bits) SCM_BOOL_F_BITS, + "Style of keyword recognition: #f, 'prefix or 'postfix."}, + { SCM_OPTION_BOOLEAN, "r6rs-hex-escapes", 0, + "Use R6RS variable-length character and string hex escapes."}, + { SCM_OPTION_BOOLEAN, "square-brackets", 1, + "Treat `[' and `]' as parentheses, for R6RS compatibility."}, + { SCM_OPTION_BOOLEAN, "hungry-eol-escapes", 0, + "In strings, consume leading whitespace after an escaped end-of-line."}, + { SCM_OPTION_BOOLEAN, "curly-infix", 0, + "Support SRFI-105 curly infix expressions."}, + { 0, }, + }; /* Internal read options structure. This is initialized by 'scm_read' from the global and per-port read options, and a pointer is passed @@ -101,6 +109,8 @@ struct t_read_opts unsigned int r6rs_escapes_p : 1; unsigned int square_brackets_p : 1; unsigned int hungry_eol_escapes_p : 1; + unsigned int curly_infix_p : 1; + unsigned int neoteric_p : 1; }; typedef struct t_read_opts scm_t_read_opts; @@ -217,7 +227,9 @@ scm_i_read_hash_procedures_set_x (SCM value) #define CHAR_IS_DELIMITER(c) \ (CHAR_IS_R5RS_DELIMITER (c) \ - || (((c) == ']' || (c) == '[') && opts->square_brackets_p)) + || (((c) == ']' || (c) == '[') && (opts->square_brackets_p \ + || opts->curly_infix_p)) \ + || (((c) == '}' || (c) == '{') && opts->curly_infix_p)) /* Exponent markers, as defined in section 7.1.1 of R5RS, ``Lexical Structure''. */ @@ -405,7 +417,10 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { int c; SCM tmp, tl, ans = SCM_EOL; - const int terminating_char = ((chr == '[') ? ']' : ')'); + const int curly_list_p = (chr == '{') && opts->curly_infix_p; + const int terminating_char = ((chr == '{') ? '}' + : ((chr == '[') ? ']' + : ')')); /* Need to capture line and column numbers here. */ long line = SCM_LINUM (port); @@ -437,7 +452,8 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) { SCM new_tail; - if (c == ')' || (c == ']' && opts->square_brackets_p)) + if (c == ')' || (c == ']' && opts->square_brackets_p) + || ((c == '}' || c == ']') && opts->curly_infix_p)) scm_i_input_error (FUNC_NAME, port, "in pair: mismatched close paren: ~A", scm_list_1 (SCM_MAKE_CHAR (c))); @@ -454,7 +470,7 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) if (terminating_char != c) scm_i_input_error (FUNC_NAME, port, "in pair: missing close paren", SCM_EOL); - goto exit; + break; } new_tail = scm_cons (tmp, SCM_EOL); @@ -462,7 +478,59 @@ scm_read_sexp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) tl = new_tail; } - exit: + if (curly_list_p) + { + /* In addition to finding the length, 'scm_ilength' checks for + improper or circular lists, in which case it returns -1. */ + int len = scm_ilength (ans); + + /* The (len == 0) case is handled above */ + if (len == 1) + /* Return directly to avoid re-annotating the element's source + location with the position of the outer brace. Also, it + might not be possible to annotate the element. */ + return scm_car (ans); /* {e} => e */ + else if (len == 2) + ; /* Leave the list unchanged: {e1 e2} => (e1 e2) */ + else if (len >= 3 && (len & 1)) + { + /* It's a proper list whose length is odd and at least 3. If + the elements at odd indices (the infix operator positions) + are all 'equal?', then it's a simple curly-infix list. + Otherwise it's a mixed curly-infix list. */ + SCM op = scm_cadr (ans); + + /* Check to see if the elements at odd indices are 'equal?' */ + for (tl = scm_cdddr (ans); ; tl = scm_cddr (tl)) + { + if (scm_is_null (tl)) + { + /* Convert simple curly-infix list to prefix: + {a b ...} => ( a b ...) */ + tl = ans; + while (scm_is_pair (scm_cdr (tl))) + { + tmp = scm_cddr (tl); + SCM_SETCDR (tl, tmp); + tl = tmp; + } + ans = scm_cons (op, ans); + break; + } + else if (scm_is_false (scm_equal_p (op, scm_car (tl)))) + { + /* Mixed curly-infix list: {e ...} => ($nfx$ e ...) */ + ans = scm_cons (sym_nfx, ans); + break; + } + } + } + else + /* Mixed curly-infix (possibly improper) list: + {e . tail} => ($nfx$ e . tail) */ + ans = scm_cons (sym_nfx, ans); + } + return maybe_annotate_source (ans, port, opts, line, column); } #undef FUNC_NAME @@ -1281,6 +1349,10 @@ scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) static void set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value); +static void set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, + int value); +static void set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, + int value); static SCM scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) @@ -1307,6 +1379,13 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) set_port_case_insensitive_p (port, opts, 1); else if (0 == strcmp ("no-fold-case", name)) set_port_case_insensitive_p (port, opts, 0); + else if (0 == strcmp ("curly-infix", name)) + set_port_curly_infix_p (port, opts, 1); + else if (0 == strcmp ("curly-infix-and-bracket-lists", name)) + { + set_port_curly_infix_p (port, opts, 1); + set_port_square_brackets_p (port, opts, 0); + } else break; @@ -1603,8 +1682,8 @@ scm_read_sharp (scm_t_wchar chr, SCM port, scm_t_read_opts *opts, #undef FUNC_NAME static SCM -scm_read_expression (SCM port, scm_t_read_opts *opts) -#define FUNC_NAME "scm_read_expression" +read_inner_expression (SCM port, scm_t_read_opts *opts) +#define FUNC_NAME "read_inner_expression" { while (1) { @@ -1620,10 +1699,42 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) case ';': (void) scm_read_semicolon_comment (chr, port); break; + case '{': + if (opts->curly_infix_p) + { + if (opts->neoteric_p) + return scm_read_sexp (chr, port, opts); + else + { + SCM expr; + + /* Enable neoteric expressions within curly braces */ + opts->neoteric_p = 1; + expr = scm_read_sexp (chr, port, opts); + opts->neoteric_p = 0; + return expr; + } + } + else + return scm_read_mixed_case_symbol (chr, port, opts); case '[': - if (!opts->square_brackets_p) - return (scm_read_mixed_case_symbol (chr, port, opts)); - /* otherwise fall through */ + if (opts->square_brackets_p) + return scm_read_sexp (chr, port, opts); + else if (opts->curly_infix_p) + { + /* The syntax of neoteric expressions requires that '[' be + a delimiter when curly-infix is enabled, so it cannot + be part of an unescaped symbol. We might as well do + something useful with it, so we adopt Kawa's convention: + [...] => ($bracket-list$ ...) */ + long line = SCM_LINUM (port); + int column = SCM_COL (port) - 1; + return maybe_annotate_source + (scm_cons (sym_bracket_list, scm_read_sexp (chr, port, opts)), + port, opts, line, column); + } + else + return scm_read_mixed_case_symbol (chr, port, opts); case '(': return (scm_read_sexp (chr, port, opts)); case '"': @@ -1646,6 +1757,11 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) case ')': scm_i_input_error (FUNC_NAME, port, "unexpected \")\"", SCM_EOL); break; + case '}': + if (opts->curly_infix_p) + scm_i_input_error (FUNC_NAME, port, "unexpected \"}\"", SCM_EOL); + else + return scm_read_mixed_case_symbol (chr, port, opts); case ']': if (opts->square_brackets_p) scm_i_input_error (FUNC_NAME, port, "unexpected \"]\"", SCM_EOL); @@ -1670,6 +1786,74 @@ scm_read_expression (SCM port, scm_t_read_opts *opts) } #undef FUNC_NAME +static SCM +scm_read_expression (SCM port, scm_t_read_opts *opts) +#define FUNC_NAME "scm_read_expression" +{ + if (!opts->neoteric_p) + return read_inner_expression (port, opts); + else + { + long line = 0; + int column = 0; + SCM expr; + + if (opts->record_positions_p) + { + /* We need to get the position of the first non-whitespace + character in order to correctly annotate neoteric + expressions. For example, for the expression 'f(x)', the + first call to 'read_inner_expression' reads the 'f' (which + cannot be annotated), and then we later read the '(x)' and + use it to construct the new list (f x). */ + int c = flush_ws (port, opts, (char *) NULL); + if (c == EOF) + return SCM_EOF_VAL; + scm_ungetc (c, port); + line = SCM_LINUM (port); + column = SCM_COL (port); + } + + expr = read_inner_expression (port, opts); + + /* 'expr' is the first component of the neoteric expression. Now + we loop, and as long as the next character is '(', '[', or '{', + (without any intervening whitespace), we use it to construct a + new expression. For example, f{n - 1}(x) => ((f (- n 1)) x). */ + for (;;) + { + int chr = scm_getc (port); + + if (chr == '(') + /* e(...) => (e ...) */ + expr = scm_cons (expr, scm_read_sexp (chr, port, opts)); + else if (chr == '[') + /* e[...] => ($bracket-apply$ e ...) */ + expr = scm_cons (sym_bracket_apply, + scm_cons (expr, + scm_read_sexp (chr, port, opts))); + else if (chr == '{') + { + SCM arg = scm_read_sexp (chr, port, opts); + + if (scm_is_null (arg)) + expr = scm_list_1 (expr); /* e{} => (e) */ + else + expr = scm_list_2 (expr, arg); /* e{...} => (e {...}) */ + } + else + { + if (chr != EOF) + scm_ungetc (chr, port); + break; + } + maybe_annotate_source (expr, port, opts, line, column); + } + return expr; + } +} +#undef FUNC_NAME + /* Actual reader. */ @@ -1980,8 +2164,10 @@ SCM_SYMBOL (sym_port_read_options, "port-read-options"); #define READ_OPTION_R6RS_ESCAPES_P 8 #define READ_OPTION_SQUARE_BRACKETS_P 10 #define READ_OPTION_HUNGRY_EOL_ESCAPES_P 12 +#define READ_OPTION_CURLY_INFIX_P 14 -#define READ_OPTIONS_NUM_BITS 14 +/* The total width in bits of the per-port overrides */ +#define READ_OPTIONS_NUM_BITS 16 #define READ_OPTIONS_INHERIT_ALL ((1UL << READ_OPTIONS_NUM_BITS) - 1) #define READ_OPTIONS_MAX_VALUE READ_OPTIONS_INHERIT_ALL @@ -2020,6 +2206,24 @@ set_port_case_insensitive_p (SCM port, scm_t_read_opts *opts, int value) set_port_read_option (port, READ_OPTION_CASE_INSENSITIVE_P, value); } +/* Set OPTS and PORT's square_brackets_p option according to VALUE. */ +static void +set_port_square_brackets_p (SCM port, scm_t_read_opts *opts, int value) +{ + value = !!value; + opts->square_brackets_p = value; + set_port_read_option (port, READ_OPTION_SQUARE_BRACKETS_P, value); +} + +/* Set OPTS and PORT's curly_infix_p option according to VALUE. */ +static void +set_port_curly_infix_p (SCM port, scm_t_read_opts *opts, int value) +{ + value = !!value; + opts->curly_infix_p = value; + set_port_read_option (port, READ_OPTION_CURLY_INFIX_P, value); +} + /* Initialize OPTS based on PORT's read options and the global read options. */ static void @@ -2067,8 +2271,11 @@ init_read_options (SCM port, scm_t_read_opts *opts) RESOLVE_BOOLEAN_OPTION (R6RS_ESCAPES_P, r6rs_escapes_p); RESOLVE_BOOLEAN_OPTION (SQUARE_BRACKETS_P, square_brackets_p); RESOLVE_BOOLEAN_OPTION (HUNGRY_EOL_ESCAPES_P, hungry_eol_escapes_p); + RESOLVE_BOOLEAN_OPTION (CURLY_INFIX_P, curly_infix_p); #undef RESOLVE_BOOLEAN_OPTION + + opts->neoteric_p = 0; } void diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index d679f6eaf..4b111aa1e 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -3716,7 +3716,7 @@ module '(ice-9 q) '(make-q q-length))}." ;;; ;;; Currently, the following feature identifiers are supported: ;;; -;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 +;;; guile r5rs srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-55 srfi-61 srfi-105 ;;; ;;; Remember to update the features list when adding more SRFIs. ;;; @@ -3735,6 +3735,7 @@ module '(ice-9 q) '(make-q q-length))}." srfi-39 ;; parameterize srfi-55 ;; require-extension srfi-61 ;; general cond clause + srfi-105 ;; curly infix expressions )) ;; This table maps module public interfaces to the list of features. diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 168e79901..a843fcd39 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -136,6 +136,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/srfi-67.test \ tests/srfi-69.test \ tests/srfi-88.test \ + tests/srfi-105.test \ tests/srfi-4.test \ tests/srfi-9.test \ tests/statprof.test \ diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test new file mode 100644 index 000000000..c4f48aa16 --- /dev/null +++ b/test-suite/tests/srfi-105.test @@ -0,0 +1,240 @@ +;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*- +;;;; +;;;; Copyright (C) 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 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 + +(define-module (test-srfi-105) + #:use-module (test-suite lib) + #:use-module (srfi srfi-1)) + +(define (read-string s) + (with-fluids ((%default-port-encoding #f)) + (with-input-from-string s read))) + +(define (with-read-options opts thunk) + (let ((saved-options (read-options))) + (dynamic-wind + (lambda () + (read-options opts)) + thunk + (lambda () + (read-options saved-options))))) + +;; Verify that curly braces are allowed in identifiers and that neoteric +;; expressions are not recognized by default. +(with-test-prefix "no-curly-infix" + (pass-if (equal? '({f(x) + g[y] + h{z} + [a]}) + `(,(string->symbol "{f") + (x) + g [y] + + ,(string->symbol "h{z}") + + [a] + ,(string->symbol "}"))))) + +#!curly-infix + +(with-test-prefix "curly-infix" + (pass-if (equal? '{n <= 5} '(<= n 5))) + (pass-if (equal? '{x + 1} '(+ x 1))) + (pass-if (equal? '{a + b + c} '(+ a b c))) + (pass-if (equal? '{x ,op y ,op z} '(,op x y z))) + (pass-if (equal? '{x eqv? `a} '(eqv? x `a))) + (pass-if (equal? '{'a eq? b} '(eq? 'a b))) + (pass-if (equal? '{n-1 + n-2} '(+ n-1 n-2))) + (pass-if (equal? '{a * {b + c}} '(* a (+ b c)))) + (pass-if (equal? '{a + {b - c}} '(+ a (- b c)))) + (pass-if (equal? '{{a + b} - c} '(- (+ a b) c))) + (pass-if (equal? '{{a > 0} and {b >= 1}} '(and (> a 0) (>= b 1)))) + (pass-if (equal? '{} '())) + (pass-if (equal? '{5} '5)) + (pass-if (equal? '{- x} '(- x))) + (pass-if (equal? '{length(x) >= 6} '(>= (length x) 6))) + (pass-if (equal? '{f(x) + g(y) + h(z)} '(+ (f x) (g y) (h z)))) + (pass-if (equal? '{(f a b) + (g h)} '(+ (f a b) (g h)))) + (pass-if (equal? '{f(a b) + g(h)} '(+ (f a b) (g h)))) + (pass-if (equal? '{a + f(b) + x} '(+ a (f b) x))) + (pass-if (equal? '{(- a) / b} '(/ (- a) b))) + (pass-if (equal? '{-(a) / b} '(/ (- a) b))) + (pass-if (equal? '{cos(q)} '(cos q))) + (pass-if (equal? '{e{}} '(e))) + (pass-if (equal? '{pi{}} '(pi))) + (pass-if (equal? '{'f(x)} '(quote (f x)))) + + (pass-if (equal? '{ (f (g h(x))) } '(f (g (h x))))) + (pass-if (equal? '{#(1 2 f(a) 4)} '#(1 2 (f a) 4))) + (pass-if (equal? '{ (f #;g(x) h(x)) } '(f (h x)))) + (pass-if (equal? '{ (f #; g(x)[y] h(x)) } '(f (h x)))) + (pass-if (equal? '{ (f #; g[x]{y} h(x)) } '(f (h x)))) + + (pass-if (equal? '{ (f #(g h(x))) } '(f #(g (h x))))) + (pass-if (equal? '{ (f '(g h(x))) } '(f '(g (h x))))) + (pass-if (equal? '{ (f `(g h(x))) } '(f `(g (h x))))) + (pass-if (equal? '{ (f #'(g h(x))) } '(f #'(g (h x))))) + (pass-if (equal? '{ (f #2((g) (h(x)))) } '(f #2((g) ((h x)))))) + + (pass-if (equal? '{(map - ns)} '(map - ns))) + (pass-if (equal? '{map(- ns)} '(map - ns))) + (pass-if (equal? '{n * factorial{n - 1}} '(* n (factorial (- n 1))))) + (pass-if (equal? '{2 * sin{- x}} '(* 2 (sin (- x))))) + + (pass-if (equal? '{3 + 4 +} '($nfx$ 3 + 4 +))) + (pass-if (equal? '{3 + 4 + 5 +} '($nfx$ 3 + 4 + 5 +))) + (pass-if (equal? '{a . z} '($nfx$ a . z))) + (pass-if (equal? '{a + b - c} '($nfx$ a + b - c))) + + (pass-if (equal? '{read(. options)} '(read . options))) + + (pass-if (equal? '{a(x)(y)} '((a x) y))) + (pass-if (equal? '{x[a]} '($bracket-apply$ x a))) + (pass-if (equal? '{y[a b]} '($bracket-apply$ y a b))) + + (pass-if (equal? '{f(g(x))} '(f (g x)))) + (pass-if (equal? '{f(g(x) h(x))} '(f (g x) (h x)))) + + + (pass-if (equal? '{} '())) + (pass-if (equal? '{e} 'e)) + (pass-if (equal? '{e1 e2} '(e1 e2))) + + (pass-if (equal? '{a . t} '($nfx$ a . t))) + (pass-if (equal? '{a b . t} '($nfx$ a b . t))) + (pass-if (equal? '{a b c . t} '($nfx$ a b c . t))) + (pass-if (equal? '{a b c d . t} '($nfx$ a b c d . t))) + (pass-if (equal? '{a + b +} '($nfx$ a + b +))) + (pass-if (equal? '{a + b + c +} '($nfx$ a + b + c +))) + (pass-if (equal? '{q + r * s} '($nfx$ q + r * s))) + + ;; The following two tests will become relevant when Guile's reader + ;; supports datum labels, specified in SRFI-38 (External + ;; Representation for Data With Shared Structure). + + ;;(pass-if (equal? '#1=f(#1#) '#1=(f #1#))) + ;;(pass-if (equal? '#1={a + . #1#} '($nfx$ . #1=(a + . #1#)))) + + (pass-if (equal? '{e()} '(e))) + (pass-if (equal? '{e{}} '(e))) + (pass-if (equal? '{e(1)} '(e 1))) + (pass-if (equal? '{e{1}} '(e 1))) + (pass-if (equal? '{e(1 2)} '(e 1 2))) + (pass-if (equal? '{e{1 2}} '(e (1 2)))) + (pass-if (equal? '{f{n - 1}} '(f (- n 1)))) + (pass-if (equal? '{f{n - 1}(x)} '((f (- n 1)) x))) + (pass-if (equal? '{f{n - 1}{y - 1}} '((f (- n 1)) (- y 1)))) + (pass-if (equal? '{f{- x}[y]} '($bracket-apply$ (f (- x)) y))) + (pass-if (equal? '{g{- x}} '(g (- x)))) + (pass-if (equal? '{( . e)} 'e)) + + (pass-if (equal? '{e[]} '($bracket-apply$ e))) + (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2))) + (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2))) + + ;; Verify that source position information is not recorded if not + ;; asked for. + (with-test-prefix "no positions" + (pass-if "simple curly-infix list" + (let ((sexp (with-read-options '(curly-infix) + (lambda () + (read-string " {1 + 2 + 3}"))))) + (and (not (source-property sexp 'line)) + (not (source-property sexp 'column))))) + (pass-if "mixed curly-infix list" + (let ((sexp (with-read-options '(curly-infix) + (lambda () + (read-string " {1 + 2 * 3}"))))) + (and (not (source-property sexp 'line)) + (not (source-property sexp 'column))))) + (pass-if "singleton curly-infix list" + (let ((sexp (with-read-options '(curly-infix) + (lambda () + (read-string " { 1.0 }"))))) + (and (not (source-property sexp 'line)) + (not (source-property sexp 'column))))) + (pass-if "neoteric expression" + (let ((sexp (with-read-options '(curly-infix) + (lambda () + (read-string " { f(x) }"))))) + (and (not (source-property sexp 'line)) + (not (source-property sexp 'column)))))) + + ;; Verify that source position information is properly recorded. + (with-test-prefix "positions" + (pass-if "simple curly-infix list" + (let ((sexp (with-read-options '(curly-infix positions) + (lambda () + (read-string " {1 + 2 + 3}"))))) + (and (equal? (source-property sexp 'line) 0) + (equal? (source-property sexp 'column) 1)))) + (pass-if "mixed curly-infix list" + (let ((sexp (with-read-options '(curly-infix positions) + (lambda () + (read-string " {1 + 2 * 3}"))))) + (and (equal? (source-property sexp 'line) 0) + (equal? (source-property sexp 'column) 1)))) + (pass-if "singleton curly-infix list" + (let ((sexp (with-read-options '(curly-infix positions) + (lambda () + (read-string " { 1.0 }"))))) + (and (equal? (source-property sexp 'line) 0) + (equal? (source-property sexp 'column) 3)))) + (pass-if "neoteric expression" + (let ((sexp (with-read-options '(curly-infix positions) + (lambda () + (read-string " { f(x) }"))))) + (and (equal? (source-property sexp 'line) 0) + (equal? (source-property sexp 'column) 3))))) + + ;; Verify that neoteric expressions are recognized only within curly braces. + (pass-if (equal? '(a(x)(y)) '(a (x) (y)))) + (pass-if (equal? '(x[a]) '(x [a]))) + (pass-if (equal? '(y[a b]) '(y [a b]))) + (pass-if (equal? '(a f{n - 1}) '(a f (- n 1)))) + (pass-if (equal? '(a f{n - 1}(x)) '(a f (- n 1) (x)))) + (pass-if (equal? '(a f{n - 1}[x]) '(a f (- n 1) [x]))) + (pass-if (equal? '(a f{n - 1}{y - 1}) '(a f (- n 1) (- y 1)))) + + ;; Verify that bracket lists are not recognized by default. + (pass-if (equal? '{[]} '())) + (pass-if (equal? '{[a]} '(a))) + (pass-if (equal? '{[a b]} '(a b))) + (pass-if (equal? '{[a . b]} '(a . b))) + (pass-if (equal? '[] '())) + (pass-if (equal? '[a] '(a))) + (pass-if (equal? '[a b] '(a b))) + (pass-if (equal? '[a . b] '(a . b)))) + + +#!curly-infix-and-bracket-lists + +(with-test-prefix "curly-infix-and-bracket-lists" + ;; Verify that these neoteric expressions still work properly + ;; when the 'square-brackets' read option is unset (which is done by + ;; the '#!curly-infix-and-bracket-lists' reader directive above). + (pass-if (equal? '{e[]} '($bracket-apply$ e))) + (pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2))) + (pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2))) + + ;; The following expressions are not actually part of SRFI-105, but + ;; they are handled when the 'curly-infix' read option is set and the + ;; 'square-brackets' read option is unset. This is a non-standard + ;; extension of SRFI-105, and follows the convention of GNU Kawa. + (pass-if (equal? '{[]} '($bracket-list$))) + (pass-if (equal? '{[a]} '($bracket-list$ a))) + (pass-if (equal? '{[a b]} '($bracket-list$ a b))) + (pass-if (equal? '{[a . b]} '($bracket-list$ a . b))) + + (pass-if (equal? '[] '($bracket-list$))) + (pass-if (equal? '[a] '($bracket-list$ a))) + (pass-if (equal? '[a b] '($bracket-list$ a b))) + (pass-if (equal? '[a . b] '($bracket-list$ a . b)))) From 8d5000586849d2997ffd7f88e78cab1e9aebcbbf Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 29 Oct 2012 19:37:56 -0400 Subject: [PATCH 49/52] Minor tweaks to srfi-105.test * test-suite/tests/srfi-105.test ("curly-infix"): Minor tweaks. --- test-suite/tests/srfi-105.test | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test index c4f48aa16..99a084bb3 100644 --- a/test-suite/tests/srfi-105.test +++ b/test-suite/tests/srfi-105.test @@ -64,7 +64,7 @@ (pass-if (equal? '{f(x) + g(y) + h(z)} '(+ (f x) (g y) (h z)))) (pass-if (equal? '{(f a b) + (g h)} '(+ (f a b) (g h)))) (pass-if (equal? '{f(a b) + g(h)} '(+ (f a b) (g h)))) - (pass-if (equal? '{a + f(b) + x} '(+ a (f b) x))) + (pass-if (equal? ''{a + f(b) + x} ''(+ a (f b) x))) (pass-if (equal? '{(- a) / b} '(/ (- a) b))) (pass-if (equal? '{-(a) / b} '(/ (- a) b))) (pass-if (equal? '{cos(q)} '(cos q))) @@ -120,7 +120,7 @@ ;; supports datum labels, specified in SRFI-38 (External ;; Representation for Data With Shared Structure). - ;;(pass-if (equal? '#1=f(#1#) '#1=(f #1#))) + ;;(pass-if (equal? '{#1=f(#1#)} '#1=(f #1#))) ;;(pass-if (equal? '#1={a + . #1#} '($nfx$ . #1=(a + . #1#)))) (pass-if (equal? '{e()} '(e))) From fb210d8d165ea234a72f0f4dd25239ad21f64991 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 30 Oct 2012 02:23:07 -0400 Subject: [PATCH 50/52] Test number-theoretic division by -0.0. * test-suite/tests/numbers.test ("Number-theoretic division"): Fix typo so that we actually test for division by -0.0. --- test-suite/tests/numbers.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index a6697c9a3..ddbd2097e 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -4845,7 +4845,7 @@ (test+/- n d)))))) (with-test-prefix "divide by zero" - (for `((0 0.0 +0.0)) ;; denominators + (for `((0 0.0 -0.0)) ;; denominators (lambda (d) (for `((15 ,(* 3/2 big) 18.0 33/7 0 0.0 -0.0 +inf.0 -inf.0 +nan.0)) ;; numerators From fa746547fc0cd15f5edbb690477d37a23de4f183 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 30 Oct 2012 22:53:22 -0400 Subject: [PATCH 51/52] scm_read_shebang: handle non-ascii characters properly. * libguile/read.c (scm_read_shebang): Abort scan for reader directive if a character other than [-a-z0-9] is encountered. --- libguile/read.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/read.c b/libguile/read.c index ebd1119eb..469ed5b38 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1391,6 +1391,11 @@ scm_read_shebang (scm_t_wchar chr, SCM port, scm_t_read_opts *opts) return SCM_UNSPECIFIED; } + else + { + scm_ungetc (c, port); + break; + } } while (i > 0) scm_ungetc (name[--i], port); From 10744b7c5007ccac19ea9654be6e749fe6a60992 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 30 Oct 2012 22:58:19 -0400 Subject: [PATCH 52/52] Fix formatting of comments in scm_read_array. * libguile/read.c (scm_read_array): Fix formatting of comments. --- libguile/read.c | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/libguile/read.c b/libguile/read.c index 469ed5b38..222891b7f 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1134,8 +1134,7 @@ read_decimal_integer (SCM port, int c, ssize_t *resp) vectors. Also, the conflict between '#f' and '#f32' and '#f64' is handled here. - C is the first character read after the '#'. -*/ + C is the first character read after the '#'. */ static SCM scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) { @@ -1147,13 +1146,11 @@ scm_read_array (int c, SCM port, scm_t_read_opts *opts, long line, int column) /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but the array code can not deal with zero-length dimensions yet, and - we want to allow zero-length vectors, of course. - */ + we want to allow zero-length vectors, of course. */ if (c == '(') return scm_read_vector (c, port, opts, line, column); - /* Disambiguate between '#f' and uniform floating point vectors. - */ + /* Disambiguate between '#f' and uniform floating point vectors. */ if (c == 'f') { c = scm_getc (port);