/* xlarray - Implementation of Common Lisp multi-dimensional arrays. */
/* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney */
/* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz */
/* You may give out copies of this software; for conditions see the */
/* file COPYING included with this distribution. */
#include "xlisp.h"
/**** check int/long/FIXNUM stuff; also signs */
/**** review for efficiency */
/**** check error messages */
/* forward declarations */
LOCAL int inboundsp P3H(LVAL, LVAL, int);
LOCAL FIXTYPE sizefordim P1H(LVAL);
LOCAL int rankfordim P1H(LVAL);
LOCAL LVAL getnextarg P2H(LVAL *, int);
#define getdim(x,d) getelement(getdarraydim(x),d)
/***************************************************************************/
/** **/
/** Utility Functions **/
/** **/
/***************************************************************************/
/* find length of a list */
FIXTYPE llength P1C(LVAL, x)
{
FIXTYPE n;
for (n = 0; consp(x); n++, x = cdr(x))
if (n > nnodes) xlcircular();
return(n);
}
LVAL coerce_to_list P1C(LVAL, x)
{
LVAL next, result;
int n, i;
/* save the result pointer */
xlsave1(result);
if (darrayp(x))
result = array_to_nested_list(x);
else if (vectorp(x) || stringp(x) || tvecp(x)) {
n = gettvecsize(x);
result = mklist(n, NIL);
for (i = 0, next = result; i < n; i++, next = cdr(next))
rplaca(next, gettvecelement(x, i));
}
else if (objectp(x))
result = NIL; /***** include standard coercion message later */
else if (listp(x))
result = x;
else if (atom(x)) {
result = consa(x);
}
else result = NIL;
/* restore the stack frame */
xlpop();
return(result);
}
LVAL coerce_to_tvec P2C(LVAL, x, LVAL, type)
{
LVAL val;
int n;
xlsave1(val);
switch (ntype(x)) {
case SYMBOL:
if (! null(x))
xlbadtype(x);
/* fall through */
case CONS:
n = llength(x);
val = mktvec(n, type);
xlreplace(val, x, 0, n, 0, n);
break;
case DARRAY:
x = getdarraydata(x);
/* fall through */
case VECTOR:
case STRING:
case TVEC:
if (gettvecetype(x) == type)
val = x;
else {
n = gettvecsize(x);
val = mktvec(n, type);
xlreplace(val, x, 0, n, 0, n);
}
break;
default:
if (atom(x)) {
val = newvector(1);
setelement(val, 0, x);
}
else {
xlbadtype(x);
val = NIL; /* not reached */
}
}
xlpop();
return val;
}
LVAL split_list P2C(LVAL, list, int, len)
{
LVAL result, sublist, next_r, next_s, next;
int numlists, n;
if (len < 1) xlfail("invalid length for sublists");
/* protect some pointers */
xlsave1(result);
n = llength(list);
if ((n % len) != 0)
xlfail("list not divisible by this length");
numlists = n / len;
result = mklist(numlists, NIL);
for (next = list, next_r = result; consp(next_r); next_r = cdr(next_r)) {
sublist = mklist(len, NIL);
rplaca(next_r, sublist);
for (next_s = sublist; consp(next_s);
next_s = cdr(next_s), next = cdr(next))
rplaca(next_s, car(next));
}
/* restore the stack frame */
xlpop();
return(result);
}
/* Check for a nonnegative integer */
LVAL checknonnegint P1C(LVAL, x)
{
if (! fixp(x) || getfixnum(x) < 0) xlerror("Not a nonnegative integer", x);
return(x);
}
/* Flatten a nested list to depth rank */
LVAL nested_list_to_list P2C(LVAL, list, int, rank)
{
LVAL result, temp, nextr, nexte, sublist;
int i;
if (rank > 1) {
/* protect some pointers */
xlstkcheck(3);
xlsave(result);
xlsave(temp);
xlsave(sublist);
for (i = 1, result = coerce_to_list(list); i < rank; i++) {
/* flatten the lists in reverse order */
for (temp = NIL, nextr = result; consp(nextr); nextr = cdr(nextr)) {
sublist = coerce_to_list(car(nextr));
for (nexte = sublist; consp(nexte); nexte = cdr(nexte)) {
temp = cons(car(nexte), temp);
}
}
result = temp;
/* nreverse the result */
for (temp = NIL; consp(result);) {
nextr = cdr(result);
rplacd(result, temp);
temp = result;
result = nextr;
}
result = temp;
}
/* restore the previous stack frame */
xlpopn(3);
}
else result = coerce_to_list(list);
return (result);
}
/* Get the next argument from the list or the stack; cdr the list */
LOCAL LVAL getnextarg P2C(LVAL *, plist, int, from_stack)
{
LVAL arg;
if (from_stack) arg = xlgetarg();
else if (consp(*plist)) {
arg = car(*plist);
*plist = cdr(*plist);
}
else {
xlfail("no arguments left"); /**** xltoofew?? */
arg = NIL; /* to keep compiler happy */
}
return(arg);
}
/* Compute the rank of an array with dimensions given by list or vector dim */
LOCAL int rankfordim P1C(LVAL, dim)
{
if (listp(dim)) return(llength(dim));
else if (vectorp(dim)) return(getsize(dim));
else xlerror("bad dimension specifier", dim);
return(0); /* not reached */
}
/* Compute the size of an array with dimensions given by list or vector dim */
LOCAL FIXTYPE sizefordim P1C(LVAL, dim)
{
int rank, i;
FIXTYPE size;
size = 1;
if (vectorp(dim)) {
rank = getsize(dim);
for (i = 0; i < rank; i++)
size *= getfixnum(checknonnegint(getelement(dim, i)));
}
else
for (; consp(dim); dim = cdr(dim))
size *= getfixnum(checknonnegint(car(dim)));
return(size);
}
LVAL copylist P1C(LVAL, list)
{
LVAL result, nextl, nextr;
if (! listp(list)) xlbadtype(list);
/* protect the result pointer */
xlsave1(result);
result = mklist(llength(list), NIL);
for (nextl = list, nextr = result; consp(nextl);
nextl = cdr(nextl), nextr = cdr(nextr)) {
rplaca(nextr, car(nextl));
}
if (! null(nextl)) {
for (nextr = result; consp(cdr(nextr)); nextr = cdr(nextr));
rplacd(nextr, nextl);
}
/* restore the stack frame */
xlpop();
return(result);
}
LVAL copyvector P1C(LVAL, v)
{
LVAL result;
int n;
switch (ntype(v)) {
case VECTOR:
case STRING:
case TVEC:
/* protect the result pointer */
xlsave1(result);
n = gettvecsize(v);
result = mktvec(n, gettvecetype(v));
/*for (i = 0; i < n; i++)
settvecelement(result, i, gettvecelement(v, i));*/
xlreplace(result, v, 0, n, 0, n);
/* restore the stack frame */
xlpop();
break;
default: xlbadtype(v);
}
return(result);
}
/***************************************************************************/
/***************************************************************************/
/**** ****/
/**** Internal Representation ****/
/**** ****/
/***************************************************************************/
/***************************************************************************/
/* Multidimensional arrays are implemented as displaced arrays. */
/* Internally they are represented as a cons cell. The car component */
/* is the dimension vector and the cdr is the data vector. */
/***************************************************************************/
/** **/
/** Basic Predicates **/
/** **/
/***************************************************************************/
/* check if a subscript sequence is in array bounds */
LOCAL int inboundsp P3C(LVAL, x, LVAL, indices, int, from_stack)
{
LVAL index;
int i, rank;
if (darrayp(x)) {
rank = getdarrayrank(x);
for (i = 0; i < rank; i++) {
index = getnextarg(&indices, from_stack);
if (! fixp(index) || getfixnum(index) < 0
|| getfixnum(index) >= getfixnum(getdim(x, i)))
return(FALSE);
}
xllastarg();
return(TRUE);
}
else if (vectorp(x) || stringp(x) || tvecp(x)) {
index = getnextarg(&indices, from_stack);
xllastarg();
return(fixp(index) && getfixnum(index) >= 0 &&
getfixnum(index) < gettvecsize(x));
}
else xlerror("not an array", x);
return(0); /* not reached */
}
/***************************************************************************/
/** **/
/** Basic Constructor **/
/** **/
/***************************************************************************/
/* Form an array representation from dim sequence and data vector */
/* Both arguments should be protected from garbage collection */
/**** should be in xldmem.c */
LVAL newdarray P2C(LVAL, dim, LVAL, data)
{
LVAL dimvector, result;
int rank;
FIXTYPE size;
rank = rankfordim(dim);
/* Check dim and data for consistency */
size = sizefordim(dim);
if (! (vectorp(data) || stringp(data) || tvecp(data)))
xlerror("bad data argument", data);
if (size != gettvecsize(data))
xlfail("dimensions do not match data length");
if (rank == 1) {
result = data;
}
else {
/* protect some pointers */
xlstkcheck(2);
xlsave(dimvector);
xlsave(result);
dimvector = coerce_to_tvec(dim, s_true);
result = cons(dimvector,data);
setntype(result, DARRAY);
xlpopn(2);
}
return(result);
}
/***************************************************************************/
/***************************************************************************/
/**** ****/
/**** Implementation Independent Part ****/
/**** ****/
/***************************************************************************/
/***************************************************************************/
/***************************************************************************/
/** **/
/** Predicates **/
/** **/
/***************************************************************************/
/* Common Lisp ARRAYP function */
LVAL xarrayp(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
switch (ntype(x)) {
case DARRAY:
case VECTOR:
case STRING:
case TVEC:
return(s_true);
default:
return(NIL);
}
}
/****************************************************************************/
/** **/
/** Selectors **/
/** **/
/****************************************************************************/
/* Common Lisp ARRAY-DIMENSIONS function */
LVAL xarraydimensions(V)
{
LVAL x;
LVAL result;
x = xlgetarg();
xllastarg();
xlsave1(result);
if (vectorp(x) || stringp(x) || tvecp(x)) {
result = cvfixnum((FIXTYPE) gettvecsize(x));
result = consa(result);
}
else if (darrayp(x))
result = coerce_to_list(getdarraydim(x));
else xlbadtype(x);
xlpop();
return(result);
}
/* Common Lisp ARRAY-RANK function */
LVAL xarrayrank(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
if (vectorp(x) || stringp(x) || tvecp(x)) return(cvfixnum((FIXTYPE) 1));
else if (darrayp(x)) return(cvfixnum((FIXTYPE) getdarrayrank(x)));
else xlbadtype(x);
return(NIL); /* not reached */
}
/* Common Lisp ARRAY-TOTAL-SIZE function */
LVAL xarraytotalsize(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
if (darrayp(x)) x = getdarraydata(x);
if (vectorp(x) || stringp(x) || tvecp(x))
return(cvfixnum((FIXTYPE) gettvecsize(x)));
else
xlbadtype(x);
return(NIL); /* not reached */
}
/* Common Lisp ARRAY-DIMENSION function */
LVAL xarraydimension(V)
{
LVAL x, i;
x = xlgetarg();
i = checknonnegint(xlgafixnum());
xllastarg();
if (getfixnum(i) >= (darrayp(x) ? getdarrayrank(x) : 1))
xlerror("dimension exceeds rank", i);
else if (vectorp(x) || stringp(x) || tvecp(x))
return(cvfixnum((FIXTYPE) gettvecsize(x)));
else if (darrayp(x)) return(getdim(x, (int) getfixnum(i)));
else xlbadtype(x);
return(NIL); /* not reached */
}
/* Common Lisp ARRAY-IN-BOUNDS-P function */
LVAL xarrayinboundsp(V)
{
return((inboundsp(xlgetarg(), NIL, TRUE)) ? s_true : NIL);
}
/* Compute row major index from indices list or array or from stack args */
FIXTYPE rowmajorindex P3C(LVAL, x, LVAL, indices, int, from_stack)
{
LVAL dim=NIL, index=NIL;
int rank, fsize, i;
FIXTYPE k;
if (vectorp(x) || stringp(x) || tvecp(x)) {
index = checknonnegint(getnextarg(&indices, from_stack));
if (getfixnum(index) >= gettvecsize(x))
xlerror("index out of range", index);
return(getfixnum(index));
}
else if (darrayp(x)) {
dim = getdarraydim(x);
rank = getdarrayrank(x);
for (i = 0, k = 0; i < rank; i++) {
index = checknonnegint(getnextarg(&indices, from_stack));
fsize = getfixnum(getelement(dim, i));
if (getfixnum(index) >= getfixnum(getdim(x, i)))
xlerror("index out of range", index);
k = fsize * k + getfixnum(index);
}
if (k >= gettvecsize(getdarraydata(x)))
xlerror("index out of range", index);
return(k);
}
else xlerror("not an array", x);
return(0); /* not reached */
}
/* Common Lisp ARRAY-ROW-MAJOR-INDEX function */
LVAL xarrayrowmajorindex(V)
{
LVAL x;
x = xlgetarg();
return(cvfixnum((FIXTYPE) rowmajorindex(x, NIL, TRUE)));
}
/* Common Lisp AREF function */
LVAL xaref(V)
{
LVAL x, data, v;
x = xlgetarg();
data = darrayp(x) ? getdarraydata(x) : x;
if (darrayp(x) || vectorp(x) || stringp(x) || tvecp(x))
v = gettvecelement(data, rowmajorindex(x, NIL, TRUE));
else {
xlbadtype(x);
v = NIL; /* to keep compiler happy */
}
return(v);
}
LVAL xrowmajoraref(V)
{
LVAL x, v;
LVAL index;
FIXTYPE i;
x = xlgetarg();
index = xlgafixnum();
i = getfixnum(index);
xllastarg();
if (darrayp(x)) x = getdarraydata(x);
if (vectorp(x) || stringp(x) || tvecp(x)) {
if (i < 0 || i >= gettvecsize(x))
xlerror("array index out of bounds",index);
v = gettvecelement(x, i);
}
else {
xlbadtype(x);
v = NIL; /* to keep compiler happy */
}
return(v);
}
LVAL xarrayelementtype(V)
{
LVAL x;
x = xlgetarg();
xllastarg();
if (darrayp(x)) x = getdarraydata(x);
return(gettvecetype(x));
}
/****************************************************************************/
/** **/
/** Constructors **/
/** **/
/****************************************************************************/
/* Make a new array of dimension dim with contents specified by the keyword */
/* argument. */
LVAL mkarray P4C(LVAL, dim, LVAL, key, LVAL, key_arg, LVAL, etype)
{
LVAL data, contents, result;
int rank, i;
FIXTYPE size;
/* protect some pointers */
xlstkcheck(3);
xlsave(data);
xlsave(contents);
xlsave(result);
/* make the array data vector */
if (key == NIL) {
data = mktvec(sizefordim(dim), etype);
}
else if (key == k_initelem) {
size = sizefordim(dim);
data = mktvec(size, etype);
for (i = 0; i < size; i++)
settvecelement(data, i, key_arg);
}
else if (key == k_initcont) {
rank = rankfordim(dim);
if (rank == 0) {
data = mktvec(1, etype);
settvecelement(data, 0, key_arg);
}
else if (rank == 1) {
size = sizefordim(dim);
data = mktvec(size, etype);
xlreplace(data, key_arg, 0, size, 0, size);
}
else {
size = sizefordim(dim);
contents = nested_list_to_list(key_arg, rank);
if (llength(contents) != size)
xlerror("initial contents does not match dimensions", key_arg);
data = mktvec(size, etype);
for (i = 0; i < size && consp(contents); i++, contents = cdr(contents))
settvecelement(data, i, car(contents));
}
}
else if (key == k_displacedto)
data = darrayp(key_arg) ? getdarraydata(key_arg) : key_arg;
else
xlerror("bad keyword", key);
result = newdarray(dim, data);
/* restore the stack frame */
xlpopn(3);
return (result);
}
/* convert nested list to array - used by read macro. Determines dimension */
/* from first list element, without checking others, then calls mkarray. */
LVAL nested_list_to_array P2C(LVAL, list, int, rank)
{
LVAL next, dim, data, result;
int i;
/* protect some pointers */
xlstkcheck(2);
xlsave(dim);
xlsave(result);
dim = mklist(rank, NIL);
for (i = 0, data = list, next = dim; i < rank; i++, next = cdr(next)) {
rplaca(next, cvfixnum((FIXTYPE) llength(data)));
if ((i < rank) && (! listp(data)))
xlerror("data does not match rank", list);
data = consp(data) ? car(data) : NIL;
}
result = mkarray(dim, k_initcont, list, s_true);
/* restore the stack frame */
xlpopn(2);
return (result);
}
/* Common Lisp MAKE-ARRAY function. Allows one of the keywords */
/* :INITIAL-ELEMENT, :INITIAL-CONTENTS, or :DISPLACED-TO */
LVAL xmkarray(V)
{
LVAL dim, key = NIL, key_arg = NIL, etype, result;
/* protect some pointes */
xlstkcheck(2);
xlsave(dim);
xlsave(result);
dim = xlgetarg();
if (xlgetkeyarg(k_initelem, &key_arg)) key = k_initelem;
else if (xlgetkeyarg(k_initcont, &key_arg)) key = k_initcont;
else if (xlgetkeyarg(k_displacedto, &key_arg)) key = k_displacedto;
if (!xlgetkeyarg(k_elementtype, &etype)) etype = s_true;
if (fixp(dim)) dim = consa(dim);
if (! listp(dim)) xlerror("bad dimension argument", dim);
result = mkarray(dim, key, key_arg, etype);
/* restore the stack frame */
xlpopn(2);
return (result);
}
/*************************************************************************/
/** **/
/** Print Array **/
/** **/
/*************************************************************************/
/* Convert to a nested list for printing */
LVAL array_to_nested_list P1C(LVAL, array)
{
int i, n;
LVAL alist;
if (! darrayp(array))
xlerror("not a displaced array", array);
/* protect the result pointer */
xlsave1(alist);
n = getdarrayrank(array);
if (n == 0)
alist = gettvecelement(getdarraydata(array), 0);
else {
alist = coerce_to_list(getdarraydata(array));
if (alist != NIL)
for (i = n - 1; i > 0; i--)
alist = split_list(alist, (int) getfixnum(getdim(array, i)));
}
/* restore the stack frame */
xlpop();
return(alist);
}
syntax highlighted by Code2HTML, v. 0.9.1