summaryrefslogtreecommitdiffstats
path: root/unif.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commitdb04688faa20f3576257c0fe41752ec435beab9a (patch)
tree6d638c2e1f65afd5f49d20b2d22ce35bd74705ff /unif.c
parent1edcb9b62a1a520eddae8403c19d841c9b18737f (diff)
downloadscm-db04688faa20f3576257c0fe41752ec435beab9a.tar.gz
scm-db04688faa20f3576257c0fe41752ec435beab9a.zip
Import Upstream version 5c3upstream/5c3
Diffstat (limited to 'unif.c')
-rw-r--r--unif.c114
1 files changed, 97 insertions, 17 deletions
diff --git a/unif.c b/unif.c
index 6a5fe84..35fc86e 100644
--- a/unif.c
+++ b/unif.c
@@ -107,9 +107,8 @@ SCM resizuve(vect, len)
siz = l * sz;
if (siz != l * sz) wta(MAKINUM(l * sz), (char *) NALLOC, s_resizuve);
DEFER_INTS;
- SETCHARS(vect, (char *)must_realloc((char *)CHARS(vect),
- (long)LENGTH(vect)*sz,
- (long)siz, s_resizuve));
+ must_realloc_cell(vect, (long)LENGTH(vect)*sz,
+ (long)siz, s_resizuve);
if VECTORP(vect) {
sz = LENGTH(vect);
while(l > sz) VELTS(vect)[--l] = UNSPECIFIED;
@@ -144,13 +143,13 @@ SCM make_uve(k, prot)
SCM prot;
{
SCM v;
- long i, type;
+ long i, type;
if (BOOL_T==prot) {
i = sizeof(long)*((k+LONG_BIT-1)/LONG_BIT);
type = tc7_bvect;
}
else if ICHRP(prot) {
- i = sizeof(char)*k;
+ i = sizeof(char)*(k + 1);
type = tc7_string;
}
else if INUMP(prot) {
@@ -191,11 +190,10 @@ SCM make_uve(k, prot)
type = tc7_dvect;
}
# endif
-
- NEWCELL(v);
DEFER_INTS;
- SETCHARS(v, must_malloc((i ? i : 1L), s_vector));
+ v = must_malloc_cell((i ? i : 1L), s_vector);
SETLENGTH(v, (k<LENGTH_MAX ? k : LENGTH_MAX), type);
+ if (tc7_string==type) CHARS(v)[k] = 0;
ALLOW_INTS;
return v;
}
@@ -324,10 +322,8 @@ SCM make_ra(ndim)
int ndim;
{
SCM ra;
- NEWCELL(ra);
DEFER_INTS;
- SETCDR(ra, must_malloc((long)(sizeof(array)+ndim*sizeof(array_dim)),
- "array"));
+ ra = must_malloc_cell((long)(sizeof(array)+ndim*sizeof(array_dim)), "array");
CAR(ra) = ((long)ndim << 17) + tc16_array;
ARRAY_V(ra) = nullvect;
ALLOW_INTS;
@@ -788,10 +784,10 @@ SCM array_inbp(args)
args = CDR(args);
if IMP(v) goto scalar;
switch TYP7(v) {
- default:
- scalar: if NULLP(args) return BOOL_T;
- badarg1: wta(v, (char *)ARG1, s_array_inbp);
wna: wta(UNDEFINED, (char *)WNA, s_array_inbp);
+ default: scalar:
+ if NULLP(args) return BOOL_T;
+ wta(v, (char *)ARG1, s_array_inbp);
case tc7_smob:
if (ARRAYP(v)) {
SCM ret = BOOL_T;
@@ -1765,10 +1761,10 @@ static void rapr1(ra, j, k, port, writing)
ipruk("uvect", ra, port);
break;
}
- if (n-- > 0) iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+ if (n-- > 0) intprint(VELTS(ra)[j], -10, port);
for (j += inc; n-- > 0; j += inc) {
lputc(' ', port);
- iprin1(ulong2num(VELTS(ra)[j]), port, writing);
+ intprint(VELTS(ra)[j], -10, port);
}
break;
case tc7_ivect:
@@ -1896,6 +1892,88 @@ SCM array_prot(ra)
}
}
+/* Looks like ARRAY-REF, if just enough indices are provided,
+ If one extra is provided then the last index specifies bit
+ position in an integer element.
+*/
+static char s_logaref[] = "logaref";
+SCM scm_logaref(args)
+ SCM args;
+{
+ SCM ra, inds, ibit;
+ int i, rank = 1;
+ ASSERT(NIMP(args), UNDEFINED, WNA, s_logaref);
+ ra = CAR(args);
+ ASSERT(NIMP(ra), ra, ARG1, s_logaref);
+ if ARRAYP(ra) rank = ARRAY_NDIM(ra);
+ inds = args = CDR(args);
+ for (i = rank; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
+ args = CDR(args);
+ }
+ if NULLP(args) return aref(ra, inds);
+ ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+ inds, WNA, s_logaref);
+ ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaref);
+ ibit = CAR(args);
+ if (1==rank)
+ inds = CAR(inds);
+ else { /* Destructively modify arglist */
+ args = inds;
+ for (i = rank-1; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaref);
+ args = CDR(args);
+ }
+ CDR(args) = EOL;
+ }
+ args = aref(ra, inds);
+ return INUMP(args) ?
+ ((1<<INUM(ibit)) & INUM(args) ? BOOL_T : BOOL_F) :
+ scm_logbitp(ibit, args);
+}
+
+static char s_logaset[] = "logaset!";
+SCM scm_logaset(ra, obj, args)
+ SCM ra, obj, args;
+{
+ SCM oval, inds, ibit;
+ int i, rank = 1;
+ ASSERT(NIMP(ra), ra, ARG1, s_logaset);
+ if ARRAYP(ra) rank = ARRAY_NDIM(ra);
+ inds = args;
+ for (i = rank; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
+ args = CDR(args);
+ }
+ if NNULLP(args) {
+ ASSERT(NIMP(args) && CONSP(args) && NULLP(CDR(args)),
+ inds, WNA, s_logaset);
+ ASSERT(INUMP(CAR(args)), CAR(args), ARGn, s_logaset);
+ ibit = CAR(args);
+ if (1==rank) inds = CAR(inds);
+ else { /* Destructively modify arglist */
+ args = inds;
+ for (i = rank-1; i; i--) {
+ ASSERT(NIMP(args) && CONSP(args), UNDEFINED, WNA, s_logaset);
+ args = CDR(args);
+ }
+ CDR(args) = EOL;
+ }
+ oval = aref(ra, inds);
+ ASSERT(INUMP(ibit), ibit, ARGn, s_logaset);
+ if (BOOL_T==obj)
+ obj = INUMP(oval) ? MAKINUM(INUM(oval) | (1<<INUM(ibit))) :
+ scm_logior(oval, MAKINUM(1<<INUM(ibit)));
+ else if (BOOL_F==obj)
+ obj = INUMP(oval) ? MAKINUM(INUM(oval) & (~(1<<INUM(ibit)))) :
+ scm_logand(oval, MAKINUM(~(1<<INUM(ibit))));
+#ifndef RECKLESS
+ else wta(obj, (char *)ARG2, s_logaset);
+#endif
+ }
+ return aset(ra, obj, inds);
+}
+
static iproc subr3s[] = {
{"uniform-vector-set1!", aset},
{s_uve_pos, position},
@@ -1928,12 +2006,14 @@ static iproc lsubrs[] = {
{s_trans_array, trans_array},
{s_encl_array, encl_array},
{s_array_inbp, array_inbp},
+ {s_logaref, scm_logaref},
{0, 0}};
static iproc lsubr2s[] = {
{s_make_sh_array, make_sh_array},
{s_dims2ura, dims2ura},
{s_aset, aset},
+ {s_logaset, scm_logaset},
{0, 0}};
static iproc subr2os[] = {
@@ -1953,7 +2033,7 @@ static SCM markra(ptr)
static sizet freera(ptr)
CELLPTR ptr;
{
- must_free(CHARS(ptr));
+ must_free(CHARS(ptr), sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim));
return sizeof(array) + ARRAY_NDIM(ptr)*sizeof(array_dim);
}
static smobfuns rasmob = {markra, freera, raprin1, 0};