From ecbded71bb423a6055c541d6272796aefd1486f9 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 31 Jul 2012 22:52:17 -0400 Subject: 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(-) (limited to 'libguile') 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)) { -- cgit v1.2.3 From 93723f3d1d4ed211a7a0d1ec547dfeb005424490 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 7 Aug 2012 18:13:48 -0400 Subject: 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(-) (limited to 'libguile') 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)) { -- cgit v1.2.3 From ee26a9ebe2d93263473db7d68e74a317eaf053ac Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 17 Aug 2012 16:41:27 +0200 Subject: 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(+) (limited to 'libguile') 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) -- cgit v1.2.3 From b908768a7ec79f78def344c464186a51f55b69e8 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 20 Aug 2012 23:38:21 +0200 Subject: 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(-) (limited to 'libguile') 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); -- cgit v1.2.3 From 226a56a3d454b18b2b57c4489fdb8efbf4cd8332 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 6 Oct 2012 06:04:29 -0400 Subject: 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(-) (limited to 'libguile') 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))) -- cgit v1.2.3 From 5f085775aba737c6e829b3e06abb66a64c83b057 Mon Sep 17 00:00:00 2001 From: Daniel Hartwig Date: Mon, 8 Oct 2012 18:35:00 +0800 Subject: 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(-) (limited to 'libguile') 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) + { + const char *buf = scm_i_string_chars (str); + while (idx >= 0) + { + 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 { - last_idx = idx; - while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr)) - idx--; - if (idx >= 0) + const scm_t_wchar *buf = scm_i_string_wide_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] != 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!" -- cgit v1.2.3 From 8ac870dee4397c3b3f0ac24b072e88e87b91e47e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Oct 2012 23:03:39 +0200 Subject: 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(-) (limited to 'libguile') 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 ;; -- cgit v1.2.3 From b3a2259ce3ffeb6a33093f5d02fa04aba15c633a Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Sat, 13 Oct 2012 20:41:45 -0400 Subject: 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(-) (limited to 'libguile') 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); -- cgit v1.2.3 From 493ceb99e520a307c51fbee3633d89f688e2d3f7 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 22 Oct 2012 23:23:45 -0400 Subject: 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 | 159 +++++++++++++++++++++++++++++++++++++++++++++++-- 3 files changed, 158 insertions(+), 180 deletions(-) (limited to 'libguile') 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); } +/* Helper used by scm_read_array */ +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; +} + +/* 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 chr, SCM port, long line, int column) +scm_read_array (int c, SCM port, long line, int column) { - SCM result = scm_i_read_array (port, chr); - if (scm_is_false (result)) - return result; + 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 -- cgit v1.2.3 From 603234c611b50cdc8770b2a822cd333812eed98d Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Mon, 22 Oct 2012 23:28:56 -0400 Subject: 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(-) (limited to 'libguile') 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))); -- cgit v1.2.3 From b1b5433d66ccc8267a70c6ca3c0a630bddea4edb Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 17:11:41 -0400 Subject: 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(-) (limited to 'libguile') 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 -- cgit v1.2.3 From 3655ed89834b9896fe267107c50cc4af8e0b5ecf Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 00:21:12 -0400 Subject: 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(-) (limited to 'libguile') 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; -- cgit v1.2.3 From 02327c0c5159809e204a561c2e12b84cbb8f0c20 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 00:29:07 -0400 Subject: 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(-) (limited to 'libguile') 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') - { - scm_ungetc (c, port); - return scm_read_scsh_block_comment (chr, port); - } - 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') + char name[READER_DIRECTIVE_NAME_MAX_SIZE + 1]; + int c; + int i = 0; + + while (i <= READER_DIRECTIVE_NAME_MAX_SIZE) { - scm_ungetc (c, port); - scm_ungetc ('r', port); - scm_ungetc ('6', port); - scm_ungetc ('r', 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; + } } - - return SCM_UNSPECIFIED; + while (i > 0) + scm_ungetc (name[--i], port); + return scm_read_scsh_block_comment (chr, port); } static SCM -- cgit v1.2.3 From 851c3cd16e6b9caee069581aa34e198d1df14c71 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 00:36:12 -0400 Subject: 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(-) (limited to 'libguile') 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. */ -- cgit v1.2.3 From ea8c97615590ec60f2df0f7f356b04aa0a174eef Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 23 Oct 2012 17:28:43 -0400 Subject: 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(-) (limited to 'libguile') 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. */ + +enum t_keyword_style + { + KEYWORD_STYLE_HASH_PREFIX, + KEYWORD_STYLE_PREFIX, + KEYWORD_STYLE_POSTFIX + }; -struct t_read_opts { +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 () { -- cgit v1.2.3 From 9331ffd891d03bc736f98bf92628b4b2fa714e68 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Wed, 24 Oct 2012 14:37:36 -0400 Subject: 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(-) (limited to 'libguile') 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 -- cgit v1.2.3 From bf9eb54aab23ebe01779ad0bbaab624e6ceb47b2 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Fri, 26 Oct 2012 17:20:16 -0400 Subject: 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 (limited to 'libguile') 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)))) -- cgit v1.2.3 From fa746547fc0cd15f5edbb690477d37a23de4f183 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 30 Oct 2012 22:53:22 -0400 Subject: 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(+) (limited to 'libguile') 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); -- cgit v1.2.3 From 10744b7c5007ccac19ea9654be6e749fe6a60992 Mon Sep 17 00:00:00 2001 From: Mark H Weaver Date: Tue, 30 Oct 2012 22:58:19 -0400 Subject: 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(-) (limited to 'libguile') 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); -- cgit v1.2.3