diff options
author | Marius Vollmer <mvo@zagadka.de> | 2004-11-10 01:55:26 +0000 |
---|---|---|
committer | Marius Vollmer <mvo@zagadka.de> | 2004-11-10 01:55:26 +0000 |
commit | 03a5397a5300e496c235353d48a910a5ecf7a833 (patch) | |
tree | 3664f04282c72d360eb9cd09557ef4a9aa16754b /libguile/unif.c | |
parent | b4b33636209c5bf4567dcaf1b05b7a27fca87cc3 (diff) | |
download | guile-03a5397a5300e496c235353d48a910a5ecf7a833.tar.gz |
Changed all uses of scm_array_prototype to
scm_array_creator. (scm_i_get_old_prototype): Signal error when no
prototype is known.
(scm_uniform_array_read_x, scm_uniform_array_write): Reimplemented
in terms of scm_uniform_vector_read_x and
scm_uniform_vector_write, respectively. Strings and
bitvector support has been dropped.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 272 |
1 files changed, 51 insertions, 221 deletions
diff --git a/libguile/unif.c b/libguile/unif.c index df1fb9491..5e96dfdec 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -178,7 +178,7 @@ scm_i_get_old_prototype (SCM uvec) else if (scm_is_vector (uvec)) return SCM_EOL; else - return SCM_UNSPECIFIED; + scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec)); } #endif @@ -561,9 +561,9 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (s[k].ubnd < s[k].lbnd) { if (1 == SCM_ARRAY_NDIM (ra)) - ra = scm_make_uve (0L, scm_array_prototype (ra)); + ra = scm_make_uve (0L, scm_array_creator (ra)); else - SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra)); + SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_creator (ra)); return ra; } } @@ -621,7 +621,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) return v; if (s->ubnd < s->lbnd) - return scm_make_uve (0L, scm_array_prototype (ra)); + return scm_make_uve (0L, scm_array_creator (ra)); } scm_ra_set_contp (ra); return ra; @@ -1114,7 +1114,7 @@ scm_ra2contig (SCM ra, int copy) SCM_ARRAY_DIMS (ret)[k].inc = inc; inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1; } - SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_prototype (ra)); + SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_creator (ra)); if (copy) scm_array_copy_x (ra, ret); return ret; @@ -1123,7 +1123,7 @@ scm_ra2contig (SCM ra, int copy) SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, - (SCM ra, SCM port_or_fd, SCM start, SCM end), + (SCM ura, SCM port_or_fd, SCM start, SCM end), "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" "binary objects from @var{port-or-fdes}.\n" @@ -1139,157 +1139,47 @@ SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, "returned by @code{(current-input-port)}.") #define FUNC_NAME s_scm_uniform_array_read_x { - SCM cra = SCM_UNDEFINED, v = ra; - long sz, ans; - long cstart = 0; - long cend; - long offset = 0; - size_t vlen; - char *base; - if (SCM_UNBNDP (port_or_fd)) port_or_fd = scm_cur_inp; - else - SCM_ASSERT (scm_is_integer (port_or_fd) - || (SCM_OPINPORTP (port_or_fd)), - port_or_fd, SCM_ARG2, FUNC_NAME); - vlen = (SCM_ARRAYP (v) ? - 0 : scm_c_generalized_vector_length (v)); - - scm_frame_begin (0); -loop: - if (scm_is_uniform_vector (v)) - { - base = scm_uniform_vector_elements (v); - sz = scm_uniform_vector_element_size (v); - scm_frame_uniform_vector_release (v); - } - else if (scm_is_bitvector (v)) + if (scm_is_uniform_vector (ura)) { - base = (char *) scm_bitvector_elements (v); - scm_frame_bitvector_release (v); - vlen = (vlen + 31) / 32; - cstart /= 32; - sz = sizeof (scm_t_uint32); + return scm_uniform_vector_read_x (ura, port_or_fd, start, end); } - else if (scm_is_string (v)) + else if (SCM_ARRAYP (ura)) { - base = NULL; /* writing to strings is special, see below. */ - sz = sizeof (char); - } - else if (SCM_ARRAYP (v)) - { - cra = scm_ra2contig (ra, 0); - cstart += SCM_ARRAY_BASE (cra); + size_t base, vlen, cstart, cend; + SCM cra, ans; + + cra = scm_ra2contig (ura, 0); + base = SCM_ARRAY_BASE (cra); vlen = SCM_ARRAY_DIMS (cra)->inc * (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); - v = SCM_ARRAY_V (cra); - goto loop; - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "array"); - - cend = vlen; - if (!SCM_UNBNDP (start)) - { - offset = - SCM_NUM2LONG (3, start); - if (offset < 0 || offset >= cend) - scm_out_of_range (FUNC_NAME, start); - - if (!SCM_UNBNDP (end)) + cstart = 0; + cend = vlen; + if (!SCM_UNBNDP (start)) { - long tend = - SCM_NUM2LONG (4, end); - - if (tend <= offset || tend > cend) - scm_out_of_range (FUNC_NAME, end); - cend = tend; + cstart = scm_to_unsigned_integer (start, 0, vlen); + if (!SCM_UNBNDP (end)) + cend = scm_to_unsigned_integer (end, cstart, vlen); } - } - - if (SCM_NIMP (port_or_fd)) - { - scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd); - int remaining = (cend - offset) * sz; - size_t off = (cstart + offset) * sz; - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port_or_fd); + ans = scm_uniform_vector_read_x (SCM_ARRAY_V (cra), port_or_fd, + scm_from_size_t (base + cstart), + scm_from_size_t (base + cend)); - ans = cend - offset; - while (remaining > 0) - { - if (pt->read_pos < pt->read_end) - { - int to_copy = min (pt->read_end - pt->read_pos, - remaining); - - if (base == NULL) - { - /* strings */ - char *b = scm_i_string_writable_chars (v); - memcpy (b + off, pt->read_pos, to_copy); - scm_i_string_stop_writing (); - } - else - memcpy (base + off, pt->read_pos, to_copy); - pt->read_pos += to_copy; - remaining -= to_copy; - off += to_copy; - } - else - { - if (scm_fill_input (port_or_fd) == EOF) - { - if (remaining % sz != 0) - { - SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); - } - ans -= remaining / sz; - break; - } - } - } - - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; - } - else /* file descriptor. */ - { - if (base == NULL) - { - /* strings */ - char *b = scm_i_string_writable_chars (v); - SCM_SYSCALL (ans = read (scm_to_int (port_or_fd), - b + (cstart + offset) * sz, - (sz * (cend - offset)))); - scm_i_string_stop_writing (); - } - else - SCM_SYSCALL (ans = read (scm_to_int (port_or_fd), - base + (cstart + offset) * sz, - (sz * (cend - offset)))); - if (ans == -1) - SCM_SYSERROR; + if (!scm_is_eq (cra, ura)) + scm_array_copy_x (cra, ura); + return ans; } - if (scm_is_bitvector (v)) - ans *= 32; - - if (!scm_is_eq (v, ra) && !scm_is_eq (cra, ra)) - scm_array_copy_x (cra, ra); - - scm_frame_end (); - - return scm_from_long (ans); + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); } #undef FUNC_NAME SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, - (SCM v, SCM port_or_fd, SCM start, SCM end), - "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n" + (SCM ura, SCM port_or_fd, SCM start, SCM end), "Writes all elements of @var{ura} as binary objects to\n" "@var{port-or-fdes}.\n\n" "The optional arguments @var{start}\n" @@ -1301,100 +1191,40 @@ SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, "@code{(current-output-port)}.") #define FUNC_NAME s_scm_uniform_array_write { - long sz, ans; - long offset = 0; - long cstart = 0; - long cend; - const char *base; - size_t vlen; - - port_or_fd = SCM_COERCE_OUTPORT (port_or_fd); - if (SCM_UNBNDP (port_or_fd)) port_or_fd = scm_cur_outp; - else - SCM_ASSERT (scm_is_integer (port_or_fd) - || (SCM_OPOUTPORTP (port_or_fd)), - port_or_fd, SCM_ARG2, FUNC_NAME); - vlen = (SCM_ARRAYP(v) - ? 0 - : scm_c_generalized_vector_length (v)); - scm_frame_begin (0); - -loop: - if (scm_is_uniform_vector (v)) - { - base = scm_uniform_vector_elements (v); - sz = scm_uniform_vector_element_size (v); - scm_frame_uniform_vector_release (v); - } - else if (scm_is_bitvector (v)) + if (scm_is_uniform_vector (ura)) { - base = (char *) scm_bitvector_elements (v); - scm_frame_bitvector_release (v); - vlen = (vlen + 31) / 32; - cstart /= 32; - sz = sizeof (scm_t_uint32); + return scm_uniform_vector_write (ura, port_or_fd, start, end); } - else if (scm_is_string (v)) - { - base = scm_i_string_chars (v); - sz = sizeof (char); - } - else if (SCM_ARRAYP (v)) + else if (SCM_ARRAYP (ura)) { - v = scm_ra2contig (v, 1); - cstart = SCM_ARRAY_BASE (v); - vlen = (SCM_ARRAY_DIMS (v)->inc - * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1)); - v = SCM_ARRAY_V (v); - goto loop; - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "array"); - - cend = vlen; - if (!SCM_UNBNDP (start)) - { - offset = - SCM_NUM2LONG (3, start); - - if (offset < 0 || offset >= cend) - scm_out_of_range (FUNC_NAME, start); + size_t base, vlen, cstart, cend; + SCM cra, ans; + + cra = scm_ra2contig (ura, 1); + base = SCM_ARRAY_BASE (cra); + vlen = SCM_ARRAY_DIMS (cra)->inc * + (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1); - if (!SCM_UNBNDP (end)) + cstart = 0; + cend = vlen; + if (!SCM_UNBNDP (start)) { - long tend = - SCM_NUM2LONG (4, end); - - if (tend <= offset || tend > cend) - scm_out_of_range (FUNC_NAME, end); - cend = tend; + cstart = scm_to_unsigned_integer (start, 0, vlen); + if (!SCM_UNBNDP (end)) + cend = scm_to_unsigned_integer (end, cstart, vlen); } - } - if (SCM_NIMP (port_or_fd)) - { - const char *source = base + (cstart + offset) * sz; + ans = scm_uniform_vector_write (SCM_ARRAY_V (cra), port_or_fd, + scm_from_size_t (base + cstart), + scm_from_size_t (base + cend)); - ans = cend - offset; - scm_lfwrite (source, ans * sz, port_or_fd); + return ans; } - else /* file descriptor. */ - { - SCM_SYSCALL (ans = write (scm_to_int (port_or_fd), - base + (cstart + offset) * sz, - (sz * (cend - offset)))); - if (ans == -1) - SCM_SYSERROR; - } - if (scm_is_bitvector (v)) - ans *= 32; - - scm_frame_end (); - - return scm_from_long (ans); + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); } #undef FUNC_NAME |