diff options
Diffstat (limited to 'unif.c')
| -rw-r--r-- | unif.c | 114 |
1 files changed, 97 insertions, 17 deletions
@@ -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}; |