summaryrefslogtreecommitdiff
path: root/libguile/unif.c
diff options
context:
space:
mode:
authorGary Houston <ghouston@arglist.com>1999-11-18 22:36:28 +0000
committerGary Houston <ghouston@arglist.com>1999-11-18 22:36:28 +0000
commit5c11cc9deb3962c0a7b4603327b9414579efe2bf (patch)
treea0635558e053bd1d54716f4f6e3dd4082510e431 /libguile/unif.c
parent93a6b6f5a75f3387fae66f815c794f8fcfbdebaf (diff)
downloadguile-5c11cc9deb3962c0a7b4603327b9414579efe2bf.tar.gz
* configure.in: check for hstrerror.
* socket.c (scm_htons, scm_ntohs, scm_htonl, scm_ntohl): new functions for network data conversion. * numbers.c (scm_num2long, scm_num2longlong): throw out-of-range instead of wrong-type-arg if appropriate. (scm_iint2str): handle -2^31 correctly. (scm_num2long): handle -2^31 bignum correctly. (scm_num2long_long): rewrite the bigdig case: basically copied from scm_num2long. numbers.h: (SCM_BITSPERLONGLONG): deleted. * unif.c (rapr1): use sprintf instead of intprint for unsigned longs: intprint can't cope with large values. * numbers.c (scm_num2ulong): check more consistently that the input is not negative. if it is, throw out-of-range instead of wrong-type-arg. * ramap.c (scm_array_fill_int): don't limit fill to INUM for uvect, ivect or llvect. Check that fill doesn't overflow short uniform array. * __scm.h: add another long to the definition of long_long and ulong_long. * unif.c (scm_raprin1): use 'l' instead of "long_long" in the print representation of llvect. read can't handle more than one character. (scm_dimensions_to_uniform_array): make "fill" an optional argument instead of a rest argument. * tags.h (scm_tc7_llvect): wasn't defined anywhere, so use the free tag 29 for now. * __scm.h: don't mention LONGLONGS. * unif.c, numbers.c, eq.c, gc.c, print.c, eval.c, ramap.c: replace LONGLONGS with HAVE_LONG_LONGS as set by configure. * net_db.c (scm_inet_aton): throw errors using the misc-error key instead of system-error. inet_aton doesn't set errno. system-error isn't right in gethost either, since it's throwing the value of h_errno instead of errno. so: (scm_host_not_found_key, scm_try_again_key, scm_no_recovery_key, scm_no_data_key): new error keys. (scm_resolv_error): new procedure, use the new keys. (scm_gethost): call scm_resolv_error not scm_syserror_msg. * error.c: (various): use scm_cons instead of scm_listify to build short lists. * boot-9.scm (read-hash-extend to set up arrays): add 'l' for long_long uniform vectors. * networking.scm (sethostent, setnetent, setprotoent, setservent): take an optional argument STAYOPEN. default is #f. * readline.c (scm_init_readline): set rl_readline_name to Guile, to allow conditionals in .inputrc.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r--libguile/unif.c119
1 files changed, 59 insertions, 60 deletions
diff --git a/libguile/unif.c b/libguile/unif.c
index 215897619..e1d934c39 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -68,7 +68,7 @@
* double dvect
* complex double cvect
* short svect
- * long_long llvect
+ * long long llvect
*/
long scm_tc16_array;
@@ -122,7 +122,7 @@ scm_vector_set_length_x (vect, len)
case scm_tc7_svect:
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
@@ -233,7 +233,7 @@ scm_make_uve (k, prot)
i = sizeof (short) * k;
type = scm_tc7_svect;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
else if (s == 'l')
{
i = sizeof (long_long) * k;
@@ -250,7 +250,8 @@ scm_make_uve (k, prot)
if (SCM_IMP (prot) || !SCM_INEXP (prot))
#endif
/* Huge non-unif vectors are NOT supported. */
- return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); /* no special scm_vector */
+ /* no special scm_vector */
+ return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
else if (SCM_SINGP (prot))
@@ -274,11 +275,7 @@ scm_make_uve (k, prot)
SCM_NEWCELL (v);
SCM_DEFER_INTS;
- {
- char *m;
- m = scm_must_malloc ((i ? i : 1L), "vector");
- SCM_SETCHARS (v, (char *) m);
- }
+ SCM_SETCHARS (v, (char *) scm_must_malloc (i ? i : 1, "vector"));
SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type);
SCM_ALLOW_INTS;
return v;
@@ -307,7 +304,7 @@ scm_uniform_vector_length (v)
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return SCM_MAKINUM (SCM_LENGTH (v));
@@ -355,7 +352,7 @@ loop:
&& SCM_SYMBOLP (prot)
&& (1 == SCM_LENGTH (prot))
&& ('s' == SCM_CHARS (prot)[0])));
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return ( nprot
|| (SCM_NIMP (prot)
@@ -403,7 +400,7 @@ scm_array_rank (ra)
case scm_tc7_fvect:
case scm_tc7_cvect:
case scm_tc7_dvect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_svect:
@@ -442,7 +439,7 @@ scm_array_dimensions (ra)
case scm_tc7_cvect:
case scm_tc7_dvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL);
@@ -556,7 +553,7 @@ scm_shap2ra (args, what)
return ra;
}
-SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array);
+SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, scm_dimensions_to_uniform_array);
SCM
scm_dimensions_to_uniform_array (dims, prot, fill)
@@ -572,15 +569,10 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
{
if (SCM_INUM (dims) < SCM_LENGTH_MAX)
{
- SCM answer;
- answer = scm_make_uve (SCM_INUM (dims), prot);
- if (SCM_NNULLP (fill))
- {
- SCM_ASSERT (1 == scm_ilength (fill),
- scm_makfrom0str (s_dimensions_to_uniform_array),
- SCM_WNA, NULL);
- scm_array_fill_x (answer, SCM_CAR (fill));
- }
+ SCM answer = scm_make_uve (SCM_INUM (dims), prot);
+
+ if (!SCM_UNBNDP (fill))
+ scm_array_fill_x (answer, fill);
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
scm_array_fill_x (answer, SCM_MAKINUM (0));
else
@@ -633,12 +625,9 @@ scm_dimensions_to_uniform_array (dims, prot, fill)
SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
*((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen;
}
- if (SCM_NNULLP (fill))
+ if (!SCM_UNBNDP (fill))
{
- SCM_ASSERT (1 == scm_ilength (fill),
- scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
- NULL);
- scm_array_fill_x (ra, SCM_CAR (fill));
+ scm_array_fill_x (ra, fill);
}
else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
scm_array_fill_x (ra, SCM_MAKINUM (0));
@@ -815,7 +804,7 @@ scm_transpose_array (args)
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
@@ -917,7 +906,7 @@ scm_enclose_array (axes)
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
s->lbnd = 0;
@@ -1035,7 +1024,7 @@ tail:
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_vector:
@@ -1129,7 +1118,7 @@ scm_uniform_vector_ref (v, args)
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
#endif
@@ -1160,8 +1149,7 @@ scm_cvref (v, pos, last)
scm_sizet pos;
SCM last;
{
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
@@ -1186,7 +1174,7 @@ scm_cvref (v, pos, last)
# endif
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
#endif
@@ -1319,7 +1307,7 @@ scm_array_set_x (v, obj, args)
SCM_ASRTGO (SCM_INUMP (obj), badobj);
((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x);
break;
@@ -1349,18 +1337,19 @@ scm_array_set_x (v, obj, args)
return SCM_UNSPECIFIED;
}
+/* extract an array from "ra" (regularised?), which may be an smob type.
+ returns #f on failure. */
SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
SCM
scm_array_contents (ra, strict)
SCM ra;
- SCM strict;
+ SCM strict; /* more checks if not SCM_UNDEFINED. */
{
SCM sra;
if (SCM_IMP (ra))
return SCM_BOOL_F;
- switch SCM_TYP7
- (ra)
+ switch SCM_TYP7 (ra)
{
default:
return SCM_BOOL_F;
@@ -1375,7 +1364,7 @@ scm_array_contents (ra, strict)
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return ra;
@@ -1500,7 +1489,7 @@ loop:
case scm_tc7_svect:
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
@@ -1650,7 +1639,7 @@ loop:
case scm_tc7_svect:
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
sz = sizeof (long_long);
break;
@@ -1725,8 +1714,7 @@ scm_bit_count (item, seq)
long i;
register unsigned long cnt = 0, w;
SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
- switch SCM_TYP7
- (seq)
+ switch SCM_TYP7 (seq)
{
default:
scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
@@ -1768,8 +1756,7 @@ scm_bit_position (item, v, k)
k, SCM_OUTOFRANGE, s_bit_position);
if (pos == SCM_LENGTH (v))
return SCM_BOOL_F;
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
scm_wta (v, (char *) SCM_ARG2, s_bit_position);
@@ -1832,14 +1819,12 @@ scm_bit_set_star_x (v, kv, obj)
register long i, k, vlen;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7
- (kv)
+ switch SCM_TYP7 (kv)
{
default:
badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
case scm_tc7_uvect:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
@@ -1891,8 +1876,7 @@ scm_bit_count_star (v, kv, obj)
register unsigned long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7
- (kv)
+ switch SCM_TYP7 (kv)
{
default:
badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
@@ -2099,7 +2083,7 @@ scm_array_to_list (v)
res = scm_cons(SCM_MAKINUM (data[k]), res);
return res;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: {
long_long *data;
data = (long_long *)SCM_VELTS(v);
@@ -2243,8 +2227,7 @@ rapr1 (ra, j, k, port, pstate)
long n = SCM_LENGTH (ra);
int enclosed = 0;
tail:
- switch SCM_TYP7
- (ra)
+ switch SCM_TYP7 (ra)
{
case scm_tc7_smob:
if (enclosed++)
@@ -2290,6 +2273,7 @@ tail:
ra = SCM_ARRAY_V (ra);
goto tail;
default:
+ /* scm_tc7_bvect and scm_tc7_llvect only? */
if (n-- > 0)
scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc)
@@ -2322,6 +2306,22 @@ tail:
break;
case scm_tc7_uvect:
+ {
+ char str[11];
+
+ if (n-- > 0)
+ {
+ /* intprint can't handle >= 2^31. */
+ sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
+ scm_puts (str, port);
+ }
+ for (j += inc; n-- > 0; j += inc)
+ {
+ scm_putc (' ', port);
+ sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]);
+ scm_puts (str, port);
+ }
+ }
case scm_tc7_ivect:
if (n-- > 0)
scm_intprint (SCM_VELTS (ra)[j], 10, port);
@@ -2405,8 +2405,7 @@ scm_raprin1 (exp, port, pstate)
scm_sizet base = 0;
scm_putc ('#', port);
tail:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
case scm_tc7_smob:
{
@@ -2471,9 +2470,9 @@ tail:
case scm_tc7_svect:
scm_putc ('h', port);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- scm_puts ("long_long", port);
+ scm_putc ('l', port);
break;
#endif
#ifdef SCM_FLOATS
@@ -2531,7 +2530,7 @@ loop:
return SCM_MAKINUM (-1L);
case scm_tc7_svect:
return SCM_CDR (scm_intern ("s", 1));
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
return SCM_CDR (scm_intern ("l", 1));
#endif