X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/898a256f9156643b4ceb275776372ee4380b8df1..44493941d8609c827e3dd21b2cae4d2a248271fa:/libguile/unif.c diff --git a/libguile/unif.c b/libguile/unif.c index 9f3aeefb2..4daea2bf4 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -53,6 +53,10 @@ #include "unif.h" #include "ramap.h" +#ifdef HAVE_UNISTD_H +#include +#endif + /* The set of uniform scm_vector types is: * Vector of: Called: @@ -174,8 +178,7 @@ scm_vector_set_length_x (vect, len) SCM -scm_makflo (x) - float x; +scm_makflo (float x) { SCM z; if (x == 0.0) @@ -469,7 +472,6 @@ scm_aind (ra, args, what) register scm_sizet k = SCM_ARRAY_NDIM (ra); scm_array_dim *s = SCM_ARRAY_DIMS (ra); if (SCM_INUMP (args)) - { SCM_ASSERT (1 == k, scm_makfrom0str (what), SCM_WNA, NULL); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); @@ -1041,14 +1043,13 @@ scm_uniform_vector_ref (v, args) SCM args; { long pos; - if (SCM_IMP (v)) + if (SCM_IMP (v)) { SCM_ASRTGO (SCM_NULLP (args), badarg); return v; } else if (SCM_ARRAYP (v)) - { pos = scm_aind (v, args, s_uniform_vector_ref); v = SCM_ARRAY_V (v); @@ -1075,7 +1076,9 @@ scm_uniform_vector_ref (v, args) default: if (SCM_NULLP (args)) return v; - badarg:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); + badarg: + scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref); + abort (); outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos)); wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref)); case scm_tc7_smob: @@ -1227,6 +1230,8 @@ scm_cvref (v, pos, last) SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x); SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x); +/* Note that args may be a list or an immediate object, depending which + PROC is used (and it's called from C too). */ SCM scm_array_set_x (v, obj, args) SCM v; @@ -1236,7 +1241,6 @@ scm_array_set_x (v, obj, args) long pos; SCM_ASRTGO (SCM_NIMP (v), badarg1); if (SCM_ARRAYP (v)) - { pos = scm_aind (v, args, s_array_set_x); v = SCM_ARRAY_V (v); @@ -1244,23 +1248,24 @@ scm_array_set_x (v, obj, args) else { if (SCM_NIMP (args)) - { - SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x); - pos = SCM_INUM (SCM_CAR (args)); + SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args, + SCM_ARG3, s_array_set_x); SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna); + pos = SCM_INUM (SCM_CAR (args)); } else { - SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x); + SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x); pos = SCM_INUM (args); } SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng); } switch (SCM_TYP7 (v)) { - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_set_x); + default: badarg1: + scm_wta (v, (char *) SCM_ARG1, s_array_set_x); + abort (); outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos)); wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x)); case scm_tc7_smob: /* enclosed */ @@ -1271,38 +1276,38 @@ scm_array_set_x (v, obj, args) else if (SCM_BOOL_T == obj) SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); else - badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x); + badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x); break; case scm_tc7_string: - SCM_ASRTGO (SCM_ICHRP (obj), badarg3); + SCM_ASRTGO (SCM_ICHRP (obj), badobj); SCM_CHARS (v)[pos] = SCM_ICHR (obj); break; case scm_tc7_byvect: if (SCM_ICHRP (obj)) obj = SCM_MAKINUM (SCM_ICHR (obj)); - SCM_ASRTGO (SCM_INUMP (obj), badarg3); + SCM_ASRTGO (SCM_INUMP (obj), badobj); ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); break; # ifdef SCM_INUMS_ONLY case scm_tc7_uvect: - SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3); + SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; + SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; # else case scm_tc7_uvect: - SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break; + SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break; + SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG2, s_array_set_x); break; # endif break; case scm_tc7_svect: - SCM_ASRTGO (SCM_INUMP (obj), badarg3); + SCM_ASRTGO (SCM_INUMP (obj), badobj); ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); break; #ifdef LONGLONGS case scm_tc7_llvect: - ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x); + ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x); break; #endif @@ -1310,16 +1315,16 @@ scm_array_set_x (v, obj, args) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); + SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj); ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj); break; #endif case scm_tc7_dvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3); + SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj); ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj); break; case scm_tc7_cvect: - SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3); + SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj); ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj); ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; break; @@ -1432,33 +1437,40 @@ scm_ra2contig (ra, copy) -SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x); +SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x); SCM -scm_uniform_array_read_x (ra, port) +scm_uniform_array_read_x (ra, port_or_fd, start, end) SCM ra; - SCM port; + SCM port_or_fd; + SCM start; + SCM end; { - SCM cra, v = ra; - long sz, len, ans; - long start = 0; - if (SCM_UNBNDP (port)) - port = scm_cur_inp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2, s_uniform_array_read_x); + SCM cra = SCM_UNDEFINED, v = ra; + long sz, vlen, ans; + long cstart = 0; + long cend; + long offset = 0; + SCM_ASRTGO (SCM_NIMP (v), badarg1); - len = SCM_LENGTH (v); + if (SCM_UNBNDP (port_or_fd)) + port_or_fd = scm_cur_inp; + else + SCM_ASSERT (SCM_INUMP (port_or_fd) + || (SCM_NIMP (port_or_fd) && SCM_OPINFPORTP (port_or_fd)), + port_or_fd, SCM_ARG2, s_uniform_array_read_x); + vlen = SCM_LENGTH (v); + loop: - switch SCM_TYP7 - (v) + switch SCM_TYP7 (v) { default: badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); cra = scm_ra2contig (ra, 0); - start = SCM_ARRAY_BASE (cra); - len = SCM_ARRAY_DIMS (cra)->inc * + cstart += 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; @@ -1467,8 +1479,8 @@ loop: sz = sizeof (char); break; case scm_tc7_bvect: - len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - start /= SCM_LONG_BIT; + vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + cstart /= SCM_LONG_BIT; case scm_tc7_uvect: case scm_tc7_ivect: sz = sizeof (long); @@ -1495,57 +1507,102 @@ loop: break; #endif } - /* An ungetc before an fread will not work on some systems if setbuf(0). - do #define NOSETBUF in scmfig.h to fix this. */ - if (SCM_CRDYP (port)) + + cend = vlen; + if (!SCM_UNBNDP (start)) + { + offset = + scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x); + + if (offset < 0 || offset >= cend) + scm_out_of_range (s_uniform_array_read_x, start); + + if (!SCM_UNBNDP (end)) + { + long tend = + scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x); + + if (tend <= offset || tend > cend) + scm_out_of_range (s_uniform_array_read_x, end); + cend = tend; + } + } - { /* UGGH!!! */ - ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port)); - SCM_CLRDY (port); /* Clear ungetted char */ + if (SCM_NIMP (port_or_fd)) + { + /* if we have stored a character from the port in our own buffer, + push it back onto the stream. */ + /* An ungetc before an fread will not work on some systems if + setbuf(0). do #define NOSETBUF in scmfig.h to fix this. */ + if (SCM_CRDYP (port_or_fd)) + { + ungetc (SCM_CGETUN (port_or_fd), (FILE *)SCM_STREAM (port_or_fd)); + SCM_CLRDY (port_or_fd); /* Clear ungetted char */ + } + SCM_SYSCALL (ans = fread (SCM_CHARS (v) + (cstart + offset) * sz, + (scm_sizet) sz, (scm_sizet) (cend - offset), + (FILE *)SCM_STREAM (port_or_fd))); + } + else /* file descriptor. */ + { + SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd), + SCM_CHARS (v) + (cstart + offset) * sz, + (scm_sizet) (sz * (cend - offset)))); + if (ans == -1) + scm_syserror (s_uniform_array_read_x); } - SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port))); if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; + if (v != ra && cra != ra) scm_array_copy_x (cra, ra); + return SCM_MAKINUM (ans); } -SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write); +SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write); SCM -scm_uniform_array_write (v, port) +scm_uniform_array_write (v, port_or_fd, start, end) SCM v; - SCM port; + SCM port_or_fd; + SCM start; + SCM end; { - long sz, len, ans; - long start = 0; - if (SCM_UNBNDP (port)) - port = scm_cur_outp; - else - SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write); + long sz, vlen, ans; + long offset = 0; + long cstart = 0; + long cend; + SCM_ASRTGO (SCM_NIMP (v), badarg1); - len = SCM_LENGTH (v); + if (SCM_UNBNDP (port_or_fd)) + port_or_fd = scm_cur_outp; + else + SCM_ASSERT (SCM_INUMP (port_or_fd) + || (SCM_NIMP (port_or_fd) && SCM_OPOUTFPORTP (port_or_fd)), + port_or_fd, SCM_ARG2, s_uniform_array_write); + vlen = SCM_LENGTH (v); + loop: - switch SCM_TYP7 - (v) + switch SCM_TYP7 (v) { default: badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write); case scm_tc7_smob: SCM_ASRTGO (SCM_ARRAYP (v), badarg1); v = scm_ra2contig (v, 1); - start = SCM_ARRAY_BASE (v); - len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 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; - case scm_tc7_byvect: case scm_tc7_string: + case scm_tc7_byvect: sz = sizeof (char); break; case scm_tc7_bvect: - len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; - start /= SCM_LONG_BIT; + vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT; + cstart /= SCM_LONG_BIT; case scm_tc7_uvect: case scm_tc7_ivect: sz = sizeof (long); @@ -1572,9 +1629,44 @@ loop: break; #endif } - SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port))); + + cend = vlen; + if (!SCM_UNBNDP (start)) + { + offset = + scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write); + + if (offset < 0 || offset >= cend) + scm_out_of_range (s_uniform_array_write, start); + + if (!SCM_UNBNDP (end)) + { + long tend = + scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write); + + if (tend <= offset || tend > cend) + scm_out_of_range (s_uniform_array_write, end); + cend = tend; + } + } + + if (SCM_NIMP (port_or_fd)) + { + SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + (cstart + offset) * sz, + (scm_sizet) sz, (scm_sizet) (cend - offset), + (FILE *)SCM_STREAM (port_or_fd))); + } + else /* file descriptor. */ + { + SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd), + SCM_CHARS (v) + (cstart + offset) * sz, + (scm_sizet) (sz * (cend - offset)))); + if (ans == -1) + scm_syserror (s_uniform_array_write); + } if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; + return SCM_MAKINUM (ans); } @@ -1836,56 +1928,6 @@ scm_bit_invert_x (v) } -SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x); - -SCM -scm_string_upcase_x (v) - SCM v; -{ - register long k; - register unsigned char *cs; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_string: - cs = SCM_UCHARS (v); - while (k--) - cs[k] = scm_upcase(cs[k]); - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x); - } - return v; -} - -SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x); - -SCM -scm_string_downcase_x (v) - SCM v; -{ - register long k; - register unsigned char *cs; - SCM_ASRTGO (SCM_NIMP (v), badarg1); - k = SCM_LENGTH (v); - switch SCM_TYP7 - (v) - { - case scm_tc7_string: - cs = SCM_UCHARS (v); - while (k--) - cs[k] = scm_downcase(cs[k]); - break; - default: - badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x); - } - return v; -} - - - SCM scm_istr2bve (str, len) char *str; @@ -2077,7 +2119,7 @@ scm_list_to_uniform_array (ndim, prot, lst) while (k--) { n = scm_ilength (row); - SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array); + SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array); shp = scm_cons (SCM_MAKINUM (n), shp); if (SCM_NIMP (row)) row = SCM_CAR (row); @@ -2525,6 +2567,7 @@ scm_istr2bve (str, len) void scm_init_unif () { +#include "unif.x" scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); }