diff --git a/libguile/arrays.c b/libguile/arrays.c index a294f33ec..1eb10b981 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005, + * 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -814,178 +815,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) return scm_i_print_array_dimension (&h, 0, 0, port, pstate); } -/* Read an array. This function can also read vectors and uniform - vectors. Also, the conflict between '#f' and '#f32' and '#f64' is - handled here. - - C is the first character read after the '#'. -*/ - -static int -read_decimal_integer (SCM port, int c, ssize_t *resp) -{ - ssize_t sign = 1; - ssize_t res = 0; - int got_it = 0; - - if (c == '-') - { - sign = -1; - c = scm_getc (port); - } - - while ('0' <= c && c <= '9') - { - res = 10*res + c-'0'; - got_it = 1; - c = scm_getc (port); - } - - if (got_it) - *resp = sign * res; - return c; -} - -SCM -scm_i_read_array (SCM port, int c) -{ - ssize_t rank; - scm_t_wchar tag_buf[8]; - int tag_len; - - SCM tag, shape = SCM_BOOL_F, elements; - - /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but - the array code can not deal with zero-length dimensions yet, and - we want to allow zero-length vectors, of course. - */ - if (c == '(') - { - scm_ungetc (c, port); - return scm_vector (scm_read (port)); - } - - /* Disambiguate between '#f' and uniform floating point vectors. - */ - if (c == 'f') - { - c = scm_getc (port); - if (c != '3' && c != '6') - { - if (c != EOF) - scm_ungetc (c, port); - return SCM_BOOL_F; - } - rank = 1; - tag_buf[0] = 'f'; - tag_len = 1; - goto continue_reading_tag; - } - - /* Read rank. - */ - rank = 1; - c = read_decimal_integer (port, c, &rank); - if (rank < 0) - scm_i_input_error (NULL, port, "array rank must be non-negative", - SCM_EOL); - - /* Read tag. - */ - tag_len = 0; - continue_reading_tag: - while (c != EOF && c != '(' && c != '@' && c != ':' - && tag_len < sizeof tag_buf / sizeof tag_buf[0]) - { - tag_buf[tag_len++] = c; - c = scm_getc (port); - } - if (tag_len == 0) - tag = SCM_BOOL_T; - else - { - tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len)); - if (tag_len == sizeof tag_buf / sizeof tag_buf[0]) - scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a", - scm_list_1 (tag)); - } - - /* Read shape. - */ - if (c == '@' || c == ':') - { - shape = SCM_EOL; - - do - { - ssize_t lbnd = 0, len = 0; - SCM s; - - if (c == '@') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &lbnd); - } - - s = scm_from_ssize_t (lbnd); - - if (c == ':') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &len); - if (len < 0) - scm_i_input_error (NULL, port, - "array length must be non-negative", - SCM_EOL); - - s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); - } - - shape = scm_cons (s, shape); - } while (c == '@' || c == ':'); - - shape = scm_reverse_x (shape, SCM_EOL); - } - - /* Read nested lists of elements. - */ - if (c != '(') - scm_i_input_error (NULL, port, - "missing '(' in vector or array literal", - SCM_EOL); - scm_ungetc (c, port); - elements = scm_read (port); - - if (scm_is_false (shape)) - shape = scm_from_ssize_t (rank); - else if (scm_ilength (shape) != rank) - scm_i_input_error - (NULL, port, - "the number of shape specifications must match the array rank", - SCM_EOL); - - /* Handle special print syntax of rank zero arrays; see - scm_i_print_array for a rationale. - */ - if (rank == 0) - { - if (!scm_is_pair (elements)) - scm_i_input_error (NULL, port, - "too few elements in array literal, need 1", - SCM_EOL); - if (!scm_is_null (SCM_CDR (elements))) - scm_i_input_error (NULL, port, - "too many elements in array literal, want 1", - SCM_EOL); - elements = SCM_CAR (elements); - } - - /* Construct array. - */ - return scm_list_to_typed_array (tag, shape, elements); -} - - static SCM array_handle_ref (scm_t_array_handle *h, size_t pos) { diff --git a/libguile/arrays.h b/libguile/arrays.h index 5ea604d6a..6045ab65d 100644 --- a/libguile/arrays.h +++ b/libguile/arrays.h @@ -3,7 +3,8 @@ #ifndef SCM_ARRAY_H #define SCM_ARRAY_H -/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, + * 2010, 2012 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -73,7 +74,6 @@ typedef struct scm_i_t_array SCM_INTERNAL SCM scm_i_make_array (int ndim); SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate); -SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); SCM_INTERNAL void scm_init_arrays (void); diff --git a/libguile/read.c b/libguile/read.c index 87d73bfbe..7fb1c21bc 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -1002,14 +1002,163 @@ scm_read_vector (int chr, SCM port, long line, int column) port, line, column); } -static SCM -scm_read_array (int chr, SCM port, long line, int column) +/* Helper used by scm_read_array */ +static int +read_decimal_integer (SCM port, int c, ssize_t *resp) { - SCM result = scm_i_read_array (port, chr); - if (scm_is_false (result)) - return result; + ssize_t sign = 1; + ssize_t res = 0; + int got_it = 0; + + if (c == '-') + { + sign = -1; + c = scm_getc (port); + } + + while ('0' <= c && c <= '9') + { + res = 10*res + c-'0'; + got_it = 1; + c = scm_getc (port); + } + + if (got_it) + *resp = sign * res; + return c; +} + +/* Read an array. This function can also read vectors and uniform + vectors. Also, the conflict between '#f' and '#f32' and '#f64' is + handled here. + + C is the first character read after the '#'. */ +static SCM +scm_read_array (int c, SCM port, long line, int column) +{ + ssize_t rank; + scm_t_wchar tag_buf[8]; + int tag_len; + + SCM tag, shape = SCM_BOOL_F, elements, array; + + /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but + the array code can not deal with zero-length dimensions yet, and + we want to allow zero-length vectors, of course. */ + if (c == '(') + return scm_read_vector (c, port, line, column); + + /* Disambiguate between '#f' and uniform floating point vectors. */ + if (c == 'f') + { + c = scm_getc (port); + if (c != '3' && c != '6') + { + if (c != EOF) + scm_ungetc (c, port); + return SCM_BOOL_F; + } + rank = 1; + tag_buf[0] = 'f'; + tag_len = 1; + goto continue_reading_tag; + } + + /* Read rank. */ + rank = 1; + c = read_decimal_integer (port, c, &rank); + if (rank < 0) + scm_i_input_error (NULL, port, "array rank must be non-negative", + SCM_EOL); + + /* Read tag. */ + tag_len = 0; + continue_reading_tag: + while (c != EOF && c != '(' && c != '@' && c != ':' + && tag_len < sizeof tag_buf / sizeof tag_buf[0]) + { + tag_buf[tag_len++] = c; + c = scm_getc (port); + } + if (tag_len == 0) + tag = SCM_BOOL_T; else - return maybe_annotate_source (result, port, line, column); + { + tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len)); + if (tag_len == sizeof tag_buf / sizeof tag_buf[0]) + scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a", + scm_list_1 (tag)); + } + + /* Read shape. */ + if (c == '@' || c == ':') + { + shape = SCM_EOL; + + do + { + ssize_t lbnd = 0, len = 0; + SCM s; + + if (c == '@') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &lbnd); + } + + s = scm_from_ssize_t (lbnd); + + if (c == ':') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &len); + if (len < 0) + scm_i_input_error (NULL, port, + "array length must be non-negative", + SCM_EOL); + + s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); + } + + shape = scm_cons (s, shape); + } while (c == '@' || c == ':'); + + shape = scm_reverse_x (shape, SCM_EOL); + } + + /* Read nested lists of elements. */ + if (c != '(') + scm_i_input_error (NULL, port, + "missing '(' in vector or array literal", + SCM_EOL); + elements = scm_read_sexp (c, port); + + if (scm_is_false (shape)) + shape = scm_from_ssize_t (rank); + else if (scm_ilength (shape) != rank) + scm_i_input_error + (NULL, port, + "the number of shape specifications must match the array rank", + SCM_EOL); + + /* Handle special print syntax of rank zero arrays; see + scm_i_print_array for a rationale. */ + if (rank == 0) + { + if (!scm_is_pair (elements)) + scm_i_input_error (NULL, port, + "too few elements in array literal, need 1", + SCM_EOL); + if (!scm_is_null (SCM_CDR (elements))) + scm_i_input_error (NULL, port, + "too many elements in array literal, want 1", + SCM_EOL); + elements = SCM_CAR (elements); + } + + /* Construct array, annotate with source location, and return. */ + array = scm_list_to_typed_array (tag, shape, elements); + return maybe_annotate_source (array, port, line, column); } static SCM