-/* 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
#include "unif.h"
#include "ramap.h"
+#ifdef HAVE_UNISTD_H
+#include <unistd.h>
+#endif
+
\f
/* The set of uniform scm_vector types is:
* Vector of: Called:
SCM
-scm_makflo (x)
- float x;
+scm_makflo (float x)
{
SCM z;
if (x == 0.0)
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);
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);
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:
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;
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);
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 */
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
#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;
-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;
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);
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);
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);
}
}
-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;
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);
void
scm_init_unif ()
{
+#include "unif.x"
scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
}
HCoop / bpt / guile.git / blobdiff