summaryrefslogtreecommitdiffstats
path: root/unif.c
diff options
context:
space:
mode:
Diffstat (limited to 'unif.c')
-rw-r--r--unif.c115
1 files changed, 41 insertions, 74 deletions
diff --git a/unif.c b/unif.c
index 88250c2..ae5c1b7 100644
--- a/unif.c
+++ b/unif.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 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
@@ -15,26 +15,26 @@
* the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
*
* As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * for additional uses of the text contained in its release of SCM.
*
- * The exception is that, if you link the GUILE library with other files
+ * The exception is that, if you link the SCM library with other files
* to produce an executable, this does not by itself cause the
* resulting executable to be covered by the GNU General Public License.
* Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * linking the SCM library code into it.
*
* This exception does not however invalidate any other reasons why
* the executable file might be covered by the GNU General Public License.
*
* This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
+ * Free Software Foundation under the name SCM. If you copy
* code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
+ * SCM, as the General Public License permits, the exception does
* not apply to the code that you add in this way. To avoid misleading
* anyone as to the status of such modified files, you must delete
* this exception notice from them.
*
- * If you write modifications of your own for GUILE, it is your choice
+ * If you write modifications of your own for SCM, it is your choice
* whether to permit this exception to apply to your modifications.
* If you do not wish that, delete this exception notice.
*/
@@ -61,7 +61,6 @@ complex double cvect
#endif
long tc16_array = 0;
-static SCM i_short;
char s_resizuve[] = "vector-set-length!";
SCM resizuve(vect, len)
@@ -112,7 +111,7 @@ SCM resizuve(vect, len)
siz = l * sz;
if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve);
DEFER_INTS;
- must_realloc_cell(vect, (long)ol*sz, (long)siz, s_resizuve);
+ must_realloc_cell(vect, ol*sz, (long)siz, s_resizuve);
if VECTORP(vect)
while(l > ol)
VELTS(vect)[--l] = UNSPECIFIED;
@@ -149,34 +148,22 @@ long scm_prot2type(prot)
{
if (BOOL_T==prot) return tc7_bvect;
if ICHRP(prot) return tc7_string;
- if INUMP(prot)
- return INUM(prot)>0 ? tc7_uvect : tc7_ivect;
- if (i_short==prot) return tc7_svect;
+ if (MAKINUM(32L)==prot) return tc7_uvect;
+ if (MAKINUM(-32L)==prot) return tc7_ivect;
+ if (MAKINUM(-16L)==prot) return tc7_svect;
+ if INUMP(prot) return INUM(prot) > 0 ? tc7_uvect : tc7_ivect;
if IMP(prot) return tc7_vector;
# ifdef FLOATS
if INEXP(prot) {
double x;
- float fx;
if CPLXP(prot) return tc7_cvect;
x = REALPART(prot);
- fx = x;
- return (x == fx) ? tc7_fvect : tc7_dvect;
- }
-# endif
-# ifdef BIGDIG
- if (TYP16(prot)==tc16_bigpos) {
- if (DIGSPERLONG < NUMDIGS(prot)) return tc7_vector;
- return tc7_uvect;
- }
- if (TYP16(prot)==tc16_bigneg) {
- long res = 0;
- sizet l = NUMDIGS(prot);
- if (DIGSPERLONG < l) return tc7_vector;
- for(;l--;) res = BIGUP(res) + BDIGITS(prot)[l];
- if (0>=res) return tc7_vector;
- return tc7_ivect;
+ if (32.0==x) return tc7_fvect;
+ if (64.0==x) return tc7_dvect;
+ return tc7_dvect;
}
# endif
+ return tc7_vector;
}
SCM make_uve(k, prot)
@@ -216,34 +203,21 @@ SCM make_uve(k, prot)
}
DEFER_INTS;
v = must_malloc_cell((i ? i : 1L),
- MAKE_LENGTH((k<LENGTH_MAX ? k : LENGTH_MAX), type),
+ MAKE_LENGTH((k < LENGTH_MAX ? k : LENGTH_MAX), type),
s_vector);
if (tc7_string==type) CHARS(v)[k] = 0;
ALLOW_INTS;
return v;
}
-static char s_uve_len[] = "uniform-vector-length";
-SCM uve_len(v)
- SCM v;
-{
- ASRTGO(NIMP(v), badarg1);
- switch TYP7(v) {
- default: badarg1: wta(v, (char *)ARG1, s_uve_len);
- case tc7_vector:
- case tcs_uves:
- return MAKINUM(LENGTH(v));
- }
-}
-
SCM arrayp(v, prot)
SCM v, prot;
{
int enclosed = 0;
long typ;
if IMP(v) return BOOL_F;
- typ = TYP7(v);
loop:
+ typ = TYP7(v);
switch (typ) {
case tc7_smob: if (!ARRAYP(v)) return BOOL_F;
if (UNBNDP(prot)) return BOOL_T;
@@ -866,7 +840,7 @@ SCM aref(v, args)
int k = ARRAY_NDIM(v);
SCM res = make_ra(k);
if (!ARRAYP(v)) {
- ASRTGO(NULLP(args),badarg);
+ ASRTGO(NULLP(args), badarg);
return v;
}
ARRAY_V(res) = ARRAY_V(v);
@@ -1125,7 +1099,7 @@ SCM uve_read(v, port)
long sz, len, ans;
long start=0;
if UNBNDP(port) port = cur_inp;
- else ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
+ ASSERT(NIMP(port) && OPINFPORTP(port), port, ARG2, s_uve_rd);
ASRTGO(NIMP(v), badarg1);
len = LENGTH(v);
loop:
@@ -1190,7 +1164,7 @@ SCM uve_write(v, port)
long sz, len, ans;
long start=0;
if UNBNDP(port) port = cur_outp;
- else ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
+ ASSERT(NIMP(port) && OPOUTFPORTP(port), port, ARG2, s_uve_wr);
ASRTGO(NIMP(v), badarg1);
len = LENGTH(v);
loop:
@@ -1233,7 +1207,7 @@ SCM uve_write(v, port)
break;
# endif
}
- SYSCALL(ans = fwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, STREAM(port)););
+ ans = lfwrite(CHARS(v)+start*sz, (sizet)sz, (sizet)len, port);
if (TYP7(v)==tc7_bvect) ans *= LONG_BIT;
return MAKINUM(ans);
}
@@ -1299,7 +1273,7 @@ SCM lcount(item, seq)
}
}
static char s_uve_pos[] = "bit-position";
-SCM position(item, v, k)
+SCM bit_position(item, v, k)
SCM item, v, k;
{
long i, len, lenw, xbits, pos = INUM(k), offset = 0;
@@ -1669,10 +1643,9 @@ SCM list2ura(ndim, prot, lst)
SCM shp=EOL;
SCM row=lst;
SCM ra;
- sizet k;
long n;
+ sizet k = INUM(ndim);
ASSERT(INUMP(ndim), ndim, ARG1, s_list2ura);
- k = INUM(ndim);
for (; k--; NIMP(row) && (row = CAR(row))) {
n = ilength(row);
ASSERT(n>=0, lst, ARG2, s_list2ura);
@@ -1879,18 +1852,18 @@ int raprin1(exp, port, writing)
case tc7_string:
lputs("A\\", port); break;
case tc7_uvect:
- lputs("Au", port); break;
+ lputs("Au32", port); break;
case tc7_ivect:
- lputs("Ae", port); break;
+ lputs("As32", port); break;
case tc7_svect:
- lputs("Aes", port); break;
+ lputs("As16", port); break;
# ifdef FLOATS
case tc7_fvect:
- lputs("Aif", port); break;
+ lputs("Ar32", port); break;
case tc7_dvect:
- lputs("Ai", port); break;
+ lputs("Ar64", port); break;
case tc7_cvect:
- lputs("Aic", port); break;
+ lputs("Ac64", port); break;
# endif /*FLOATS*/
}
if ((v != exp) && 0==ARRAY_NDIM(exp)) {
@@ -1921,13 +1894,13 @@ SCM array_prot(ra)
case tc7_vector: return EOL;
case tc7_bvect: return BOOL_T;
case tc7_string: return MAKICHR('a');
- case tc7_svect: return i_short;
- case tc7_uvect: return MAKINUM(1L);
- case tc7_ivect: return MAKINUM(-1L);
+ case tc7_uvect: return MAKINUM(32L);
+ case tc7_ivect: return MAKINUM(-32L);
+ case tc7_svect: return MAKINUM(-16L);
# ifdef FLOATS
- case tc7_fvect: return makflo(1.0);
- case tc7_dvect: return makdbl(1.0/3.0, 0.0);
- case tc7_cvect: return makdbl(0.0, 1.0);
+ case tc7_fvect: return makflo(32.0);
+ case tc7_dvect: return makdbl(64.0, 0.0);
+ case tc7_cvect: return makdbl(0.0, 64.0);
# endif
}
}
@@ -2007,23 +1980,21 @@ SCM scm_logaset(ra, obj, args)
else if (BOOL_F==obj)
obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) :
scm_logand(oval, MAKINUM(~(1<<INUM(ibit))));
-#ifndef RECKLESS
+# ifndef RECKLESS
else wta(obj, (char *)ARG2, s_logaset);
-#endif
+# endif
}
return aset(ra, obj, inds);
}
static iproc subr3s[] = {
- {"uniform-vector-set1!", aset},
- {s_uve_pos, position},
+ {s_uve_pos, bit_position},
{s_bit_set, bit_set},
{s_bit_count, bit_count},
{s_list2ura, list2ura},
{0, 0}};
static iproc subr2s[] = {
- {"uniform-vector-ref", aref},
{s_resizuve, resizuve},
{s_count, lcount},
{s_uve_fill, uve_fill},
@@ -2033,7 +2004,6 @@ static iproc subr1s[] = {
{"array-rank", array_rank},
{s_array_dims, array_dims},
{s_array2list, array2list},
- {s_uve_len, uve_len},
{s_bit_inv, bit_inv},
{s_strdown, strdown},
{s_strcap, strcap},
@@ -2059,8 +2029,6 @@ static iproc lsubr2s[] = {
static iproc subr2os[] = {
{"array?", arrayp},
{s_array_contents, array_contents},
- {s_uve_rd, uve_read},
- {s_uve_wr, uve_write},
{0, 0}};
static SCM markra(ptr)
@@ -2071,7 +2039,8 @@ static SCM markra(ptr)
static sizet freera(ptr)
CELLPTR ptr;
{
- must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
+ must_free(CHARS((SCM)ptr),
+ sizeof(array) + ARRAY_NDIM((SCM)ptr)*sizeof(array_dim));
return 0;
}
static smobfuns rasmob = {markra, freera, raprin1, 0};
@@ -2087,9 +2056,7 @@ void init_unif()
init_iprocs(lsubr2s, tc7_lsubr_2);
init_iprocs(subr2os, tc7_subr_2o);
tc16_array = newsmob(&rasmob);
- i_short = CAR(sysintern("exact-short", UNDEFINED));
add_feature(s_array);
- add_feature("string-case");
}
#else /* ARRAYS */
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 21:37:10 +0000