mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Moved scm_i_struct_hash from struct.c to hash.c and made it static.

The port's alist is now a field of 'scm_t_port'.

Conflicts:
	libguile/arrays.c
	libguile/hash.c
	libguile/ports.c
	libguile/print.h
	libguile/read.c
This commit is contained in:
Mark H Weaver 2012-10-30 23:46:31 -04:00
commit fa980bcc0f
53 changed files with 1677 additions and 531 deletions
Download patch file Download diff file Expand all files Collapse all files

175
libguile/arrays.c
View file

@ -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_unlocked (port);
}
while ('0' <= c && c <= '9')
{
res = 10*res + c-'0';
got_it = 1;
c = scm_getc_unlocked (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_unlocked (c, port);
return scm_vector (scm_read (port));
}
/* Disambiguate between '#f' and uniform floating point vectors.
*/
if (c == 'f')
{
c = scm_getc_unlocked (port);
if (c != '3' && c != '6')
{
if (c != EOF)
scm_ungetc_unlocked (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_unlocked (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_unlocked (port);
c = read_decimal_integer (port, c, &lbnd);
}
s = scm_from_ssize_t (lbnd);
if (c == ':')
{
c = scm_getc_unlocked (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_unlocked (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)
{