home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d3xx / d386 / xlispstat.lha / XLispStat / src2.lzh / XLisp-Stat / commonarrays.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-10-04  |  16.9 KB  |  603 lines
  1. /* commonarrays - Implementation of Common Lisp multi-dimensional      */
  2. /* arrays for xlisp 2.1.                                               */
  3. /* XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney                  */
  4. /* Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz    */
  5. /* You may give out copies of this software; for conditions see the    */
  6. /* file COPYING included with this distribution.                       */
  7.  
  8. #include <string.h>
  9. #include <stdio.h>
  10. #include "xlisp.h"
  11. #include "osdef.h"
  12. #ifdef ANSI
  13. #include "xlproto.h"
  14. #include "xlsproto.h"
  15. #include "osproto.h"
  16. #else
  17. #include "xlfun.h"
  18. #include "xlsfun.h"
  19. #include "osfun.h"
  20. #endif ANSI
  21. #include "xlvar.h"
  22. #include "xlsvar.h"
  23.  
  24. /* Forward declarations */
  25. #ifdef ANSI
  26. LVAL getdim(LVAL,int);
  27. int rankfordim(LVAL),sizefordim(LVAL),getarraysize(LVAL);
  28. #else
  29. LVAL getdim();
  30. int rankfordim(),sizefordim(),getarraysize();
  31. #endif
  32.  
  33. /***************************************************************************/
  34. /**                                                                       **/
  35. /**                          Utility Functions                            **/
  36. /**                                                                       **/
  37. /***************************************************************************/
  38. /* Compute the rank of an array with dimensions given by list or vector dim */
  39. LOCAL int rankfordim(dim) 
  40.      LVAL dim;
  41. {
  42.   if (listp(dim)) return(llength(dim));
  43.   else if (vectorp(dim)) return(getsize(dim));
  44.   else xlerror("bad dimension specifier", dim);
  45. }
  46.  
  47. /* Compute the size of an array with dimensions given by list or vector dim */
  48. LOCAL int sizefordim(dim)
  49.      LVAL dim;
  50. {
  51.   int rank, size, i;
  52.  
  53.   if (vectorp(dim)) rank = getsize(dim);
  54.   if (dim == NIL || (vectorp(dim) && rank == 0)) size = 1;
  55.   else 
  56.     for (size = 1, i = 0; consp(dim) || (vectorp(dim) && i < rank); i++)
  57.       size *= getfixnum(checknonnegint(getnextelement(&dim, i)));
  58.   return(size);
  59. }    
  60.  
  61. /* get an array from the argument list */
  62. LVAL xsgetarray()
  63. {
  64.   LVAL arg;
  65.   arg = xlgetarg();
  66.   if (! checkarrayp(arg)) xlerror("not an array", arg);
  67.   else return(arg);
  68. }
  69.  
  70. /* get and check a displaced array argument */
  71. LVAL xsgetdisplacedarray()
  72. {
  73.   LVAL arg;
  74.     arg = xsgetarray();
  75.   if (! displacedarrayp(arg)) xlerror("not a displaced array", arg);
  76.   return(arg);
  77. }
  78.  
  79. /***************************************************************************/
  80. /***************************************************************************/
  81. /****                                                                   ****/
  82. /****                      Internal Representation                      ****/
  83. /****                                                                   ****/
  84. /***************************************************************************/
  85. /***************************************************************************/
  86.  
  87. /* Multidimensional arrays are implemented as displaced arrays.        */
  88. /* Internally they are represented as a vector of  three components.   */
  89. /* The first component is an identifying symbol, s_arrayident. The     */
  90. /* second is the dimension vector and the third is the data vector.    */
  91.  
  92. /***************************************************************************/
  93. /**                                                                       **/
  94. /**                            Basic Predicates                           **/
  95. /**                                                                       **/
  96. /***************************************************************************/
  97.  
  98. /* A displaced array is any vector of length 3 whose first component is    */
  99. /* eq to the symbol s_arrayident. Does not check for consistence of dims.  */
  100. int displacedarrayp(x)
  101.      LVAL x;
  102. {
  103. /*  return (vectorp(x) && getsize(x) == 3 && getelement(x,0) == s_arrayident);*/
  104.   return((x) && ntype(x) == DISPLACED_ARRAY);
  105. }
  106.  
  107. int simplevectorp(x)
  108.      LVAL x;
  109. {
  110.   return(vectorp(x) && ! displacedarrayp(x)); 
  111. }
  112.  
  113. /* check for consistency of dims in a displaced array. Return TRUE for a  */
  114. /* simple vector, false for a non array.                                  */
  115. int checkdims(x)
  116.      LVAL x;
  117. {
  118.   if (displacedarrayp(x))
  119.     return(sizefordim(displacedarraydim(x)) == getsize(arraydata(x)));
  120.   else if vectorp(x) return(TRUE);
  121.   else return(FALSE);
  122. }
  123.  
  124. /* check for an array; do not check dimensions */
  125. int arrayp(x)
  126.      LVAL x;
  127. {
  128.   return(displacedarrayp(x) || vectorp(x));
  129. }
  130.  
  131. /* check for an array; check dimensions if displaced */
  132. int checkarrayp(x)
  133.      LVAL x;
  134. {
  135.   return((displacedarrayp(x) && checkdims(x)) || vectorp(x));
  136. }
  137.  
  138. /* check if a subscript sequence is in array bounds */
  139. int inboundsp(x, indices, from_stack)
  140.      LVAL x, indices;
  141.      int from_stack;
  142. {
  143.   LVAL index;
  144.   int i, rank;
  145.   
  146.   if (simplevectorp(x)) {
  147.     index = getnextarg(&indices, from_stack);
  148.     xllastarg();
  149.     return(fixp(index) && getfixnum(index) >= 0 && 
  150.        getfixnum(index) < getsize(x));
  151.   }
  152.   else if (displacedarrayp(x)) {
  153.     rank = arrayrank(x);
  154.     for (i = 0; i < rank; i++) {
  155.       index = getnextarg(&indices, from_stack);
  156.       if (! fixp(index) || getfixnum(index) < 0
  157.       || getfixnum(index) >= getfixnum(getdim(x, i)))
  158.     return(FALSE);
  159.     }
  160.     xllastarg();
  161.     return(TRUE);
  162.   }
  163.   else xlerror("not an array", x);
  164. }
  165.  
  166. /***************************************************************************/
  167. /**                                                                       **/
  168. /**                            Basic Selectors                            **/
  169. /**                                                                       **/
  170. /***************************************************************************/
  171.  
  172. /* Return x if x is a simple vector or the vector x is displaced to if x   */
  173. /* is a displaced array.                                                   */
  174. LVAL arraydata(x)
  175.      LVAL x;
  176. {
  177.   if (simplevectorp(x)) return(x);
  178.   else if (displacedarrayp(x)) return(getelement(x,2));
  179.   else xlerror("not an array", x);
  180. }
  181.  
  182. /* Return the dimension vector of a displaced array. */
  183. LVAL displacedarraydim(x)
  184.      LVAL x;
  185. {
  186.   if (displacedarrayp(x)) return(getelement(x,1));
  187.   else xlerror("not a displaced array", x);
  188. }
  189.  
  190. /* Size of dimension d; no error checking */
  191. static LVAL getdim(x, d)
  192.     LVAL x;
  193.     int d;
  194. {
  195.     return(getelement(getelement(x,1), d));
  196. }
  197.  
  198. /* Rank of x; no error checking */
  199. int arrayrank(x)
  200.     LVAL x;
  201. {
  202.     return((displacedarrayp(x)) ? getsize(getelement(x,1)) : 1);
  203. }
  204.  
  205. /***************************************************************************/
  206. /**                                                                       **/
  207. /**                            Basic Constructor                          **/
  208. /**                                                                       **/
  209. /***************************************************************************/
  210.  
  211. /* Form an array representation from dim sequence and data vector */
  212. /* Both arguments should be protected from garbage collection     */
  213. LVAL makedisplacedarray(dim, data)
  214.      LVAL dim, data;
  215. {
  216.   LVAL dimvector, result;
  217.   int rank, size;
  218.  
  219.   rank = rankfordim(dim);
  220.  
  221.   /* Check dim and data for consistency */
  222.   size = sizefordim(dim);
  223.   if (! vectorp(data)) xlerror("bad data argument", data);
  224.   if (size != getsize(data)) xlfail("dimensions do not match data length");
  225.  
  226.   if (rank == 1) {
  227.     result = data;
  228.   }
  229.   else {
  230.     /* protect some pointers */
  231.     xlstkcheck(2);
  232.     xlsave(dimvector);
  233.     xlsave(result);
  234.  
  235.     dimvector = coerce_to_vector(dim);
  236.  
  237.     result = newvector(3);
  238.     result->n_type = DISPLACED_ARRAY;
  239.     setelement(result, 0, s_arrayident);
  240.     setelement(result, 1, dimvector);
  241.     setelement(result, 2, data);
  242.     
  243.     xlpopn(2);
  244.   }
  245.   return(result);
  246. }
  247.  
  248. /***************************************************************************/
  249. /***************************************************************************/
  250. /****                                                                   ****/
  251. /****                     Implementation Independent Part               ****/
  252. /****                                                                   ****/
  253. /***************************************************************************/
  254. /***************************************************************************/
  255.  
  256. /***************************************************************************/
  257. /**                                                                       **/
  258. /**                              Predicates                               **/
  259. /**                                                                       **/
  260. /***************************************************************************/
  261.  
  262. /* Common Lisp ARRAYP function */
  263. LVAL xsarrayp()
  264. {
  265.   LVAL x;
  266.   
  267.   x = xlgetarg();
  268.   xllastarg();
  269.   
  270.   return((checkarrayp(x)) ? s_true : NIL);
  271. }
  272.  
  273. /****************************************************************************/
  274. /**                                                                        **/
  275. /**                              Selectors                                 **/
  276. /**                                                                        **/
  277. /****************************************************************************/
  278.  
  279. /* Get array size */
  280. static int getarraysize(x)
  281.     LVAL x;
  282. {
  283.     return(getsize(arraydata(x)));
  284. }
  285.  
  286. /* Common Lisp ARRAY-DIMENSIONS function */
  287. LVAL xsarraydimensions()
  288. {
  289.   LVAL x;
  290.   LVAL result;
  291.   
  292.   x = xsgetarray();
  293.   xllastarg();
  294.   
  295.   xlsave1(result);
  296.   if (simplevectorp(x)) {
  297.     result = cvfixnum((FIXTYPE) getsize(x));
  298.     result = consa(result);
  299.   }
  300.   else
  301.     result = coerce_to_list(displacedarraydim(x));
  302.   xlpop();
  303.   return(result);
  304. }
  305.  
  306. /* Common Lisp ARRAY-RANK function */
  307. LVAL xsarrayrank()
  308. {
  309.   LVAL x;
  310.   
  311.   x = xsgetarray();
  312.   xllastarg();
  313.   
  314.   if (simplevectorp(x)) 
  315.     return(cvfixnum((FIXTYPE) 1));
  316.   else 
  317.     return(cvfixnum((FIXTYPE) arrayrank(x)));
  318. }
  319.  
  320. /* Common Lisp ARRAY-TOTAL-SIZE function */
  321. LVAL xsarraytotalsize()
  322. {
  323.   LVAL x;
  324.   
  325.   x = xsgetarray();
  326.   xllastarg();
  327.   
  328.   return(cvfixnum((FIXTYPE) getarraysize(x)));
  329. }
  330.  
  331. /* Common Lisp ARRAY-DIMENSION function */
  332. LVAL xsarraydimension()
  333. {
  334.   LVAL x, i;
  335.  
  336.   x = xsgetarray();
  337.   i = checknonnegint(xlgafixnum());
  338.   xllastarg();
  339.  
  340.   if (getfixnum(i) >= arrayrank(x)) xlerror("dimension exceeds rank", i);
  341.   else if (simplevectorp(x)) return(cvfixnum((FIXTYPE) getsize(x)));
  342.   else return(getdim(x, (int) getfixnum(i)));
  343. }
  344.  
  345. /* Common Lisp ARRAY-IN-BOUNDS-P function */
  346. LVAL xsarrayinboundsp()
  347. {
  348.   return((inboundsp(xsgetarray(), NIL, TRUE)) ? s_true : NIL);
  349. }
  350.  
  351. /* Compute row major index from indices list or array or from stack args */
  352. int rowmajorindex(x, indices, from_stack)
  353.      LVAL x, indices;
  354.      int from_stack;
  355. {
  356.   LVAL dim, index;
  357.   int rank, k, fsize, i;
  358.   
  359.   if (simplevectorp(x)) {
  360.     index = checknonnegint(getnextarg(&indices, from_stack));
  361.     if (getfixnum(index) >= getsize(x))
  362.       xlerror("index out of range", index);
  363.     return(getfixnum(index));
  364.   }
  365.   else if (displacedarrayp(x)) {
  366.     
  367.     dim = displacedarraydim(x);
  368.     
  369.     rank = arrayrank(x);
  370.     for (i = 0, k = 0; i < rank; i++) {
  371.       index = checknonnegint(getnextarg(&indices, from_stack));
  372.       fsize = getfixnum(getelement(dim, i));
  373.       if (getfixnum(index) < 0
  374.       || getfixnum(index) >= getfixnum(getdim(x, i)))
  375.     xlerror("index out of range", index);
  376.       k = fsize * k + getfixnum(index);
  377.     }
  378.     return(k);
  379.   }
  380.   else xlerror("not an array", x);
  381. }
  382.  
  383. /* Common Lisp ARRAY-ROW-MAJOR-INDEX function */
  384. LVAL xsarrayrowmajorindex()
  385. {
  386.   LVAL x;
  387.   
  388.   x = xlgetarg();
  389.   
  390.   return(cvfixnum((FIXTYPE) rowmajorindex(x, NIL, TRUE)));
  391. }
  392.  
  393. /* Common Lisp AREF function */
  394. LVAL xsaref()
  395. {
  396.   LVAL x;
  397.  
  398.   x = xsgetarray();
  399.  
  400.   return (getelement(arraydata(x), rowmajorindex(x, NIL, TRUE)));
  401. }
  402.  
  403.  
  404. /****************************************************************************/
  405. /**                                                                        **/
  406. /**                            Constructors                                **/
  407. /**                                                                        **/
  408. /****************************************************************************/
  409.  
  410. /* Make a new array of dimension dim with contents specified by the keyword */
  411. /* argument.                                                                 */
  412. LVAL newarray(dim, key, key_arg)
  413.      LVAL dim, key, key_arg;
  414. {
  415.   LVAL data, contents, result;
  416.   int rank, size, i;
  417.     
  418.   /* protect some pointers */
  419.   xlstkcheck(3);
  420.   xlsave(data);
  421.   xlsave(contents);
  422.   xlsave(result);
  423.   
  424.   /* make the array data vector */
  425.   if (key == NIL) 
  426.     data = newvector(sizefordim(dim));
  427.   else if (key == s_ielement) {
  428.     size = sizefordim(dim);
  429.     data = newvector(size);
  430.     for (i = 0; i < size; i++)
  431.       setelement(data, i, key_arg);
  432.   }
  433.   else if (key == s_icontents) {
  434.     rank = rankfordim(dim);
  435.     size = sizefordim(dim);
  436.     contents = nested_list_to_list(key_arg, rank);
  437.     if (llength(contents) != size)
  438.       xlerror("initial contents does not match dimensions", key_arg);
  439.     data = newvector(size);
  440.     for (i = 0; consp(contents); i++, contents = cdr(contents))
  441.       setelement(data, i, car(contents));
  442.   }
  443.   else if (key == s_displacedto)
  444.     data = arraydata(key_arg);
  445.   else
  446.     xlerror("bad keyword", key);
  447.  
  448.   result = makedisplacedarray(dim, data);
  449.   
  450.   /* restore the stack frame */
  451.   xlpopn(3);
  452.   
  453.   return (result);
  454. }
  455.  
  456. /* convert nested list to array - used by read macro. Determines dimension */
  457. /* from first list element, without checking others, then calls newarray.  */
  458. LVAL nested_list_to_array(list, rank)
  459.      LVAL list;
  460.      int rank;
  461. {
  462.   LVAL next, dim, data, result;
  463.   int i;
  464.   
  465.   /* protect some pointers */
  466.   xlstkcheck(2);
  467.   xlsave(dim);
  468.   xlsave(result);
  469.   
  470.   dim = mklist(rank, NIL);
  471.   for (i = 0, data = list, next = dim; i < rank; i++, next = cdr(next)) {
  472.     rplaca(next, cvfixnum((FIXTYPE) llength(data)));
  473.     if ((i < rank) && (! consp(data)))
  474.       xlerror("data does not match rank", list);
  475.     data = car(data);
  476.   }
  477.   
  478.   result = newarray(dim, s_icontents, list);
  479.   
  480.   /* restore the stack frame */
  481.   xlpopn(2);
  482.   
  483.   return (result);
  484. }
  485.  
  486. /* Common Lisp MAKE-ARRAY function. Allows one of the keywords */
  487. /* :INITIAL-ELEMENT, :INITIAL-CONTENTS, or :DISPLACED-TO       */
  488. LVAL xsmakearray()
  489. {
  490.   LVAL dim, key = NIL, key_arg = NIL, result;
  491.   
  492.   /* protect some pointes */
  493.   xlstkcheck(2);
  494.   xlsave(dim);
  495.   xlsave(result);
  496.   
  497.   dim = xlgetarg();
  498.   if (xlgetkeyarg(s_ielement, &key_arg)) key = s_ielement;
  499.   else if (xlgetkeyarg(s_icontents, &key_arg)) key = s_icontents;
  500.   else if (xlgetkeyarg(s_displacedto, &key_arg)) key = s_displacedto;
  501.   
  502.   if (fixp(dim)) dim = consa(dim);
  503.   if (! listp(dim)) xlerror("bad dimension argument", dim);
  504.   
  505.   result = newarray(dim, key, key_arg);
  506.   
  507.   /* restore the stack frame */
  508.   xlpopn(2);
  509.   
  510.   return (result);
  511. }
  512.  
  513. /*************************************************************************/
  514. /**                                                                     **/
  515. /**                            Mutators                                 **/
  516. /**                                                                     **/
  517. /*************************************************************************/
  518.  
  519. /* setf function for aref */
  520. void evsetarrayelement(place, value)
  521.      LVAL place, value;
  522. {
  523.   LVAL args, next, x, rest;
  524.   
  525.   /* protect args pointer */
  526.   xlsave1(args);
  527.  
  528.   args = mklist(llength(place), NIL);
  529. /*  rplaca(args, evmatch(VECTOR,&place));*/
  530.   rplaca(args, evarg(&place));
  531.   if (! arrayp(car(args))) xlerror("not an array", car(args));
  532.   for (next = cdr(args); consp(next); next = cdr(next)) {
  533.     rplaca(next, evmatch(FIXNUM,&place));
  534.   }
  535.  
  536.   x = car(args);
  537.   rest = cdr(args);
  538.   if (checkarrayp(x)) {
  539.     setelement(arraydata(x), rowmajorindex(x, rest, FALSE), value);
  540.   }
  541.   else
  542.     xlerror("not an array", x);
  543.  
  544.   xlpop();
  545. }
  546.  
  547. /*************************************************************************/
  548. /**                                                                     **/
  549. /**                             Print Array                             **/
  550. /**                                                                     **/
  551. /*************************************************************************/
  552.  
  553. /* Convert to a nested list for printing */
  554. LVAL array_to_nested_list(array)
  555.      LVAL array;
  556. {
  557.   int i;
  558.   LVAL alist;
  559.   
  560.   if (! displacedarrayp(array)) xlerror("not a displaced array", array);
  561.  
  562.   /* protect the result pointer */
  563.   xlsave1(alist);
  564.   
  565.   alist = coerce_to_list(arraydata(array));
  566.   if (alist != NIL)
  567.     for (i = arrayrank(array) - 1; i > 0; i--)
  568.       alist = splitlist(alist, (int) getfixnum(getdim(array, i)));
  569.   
  570.   /* restore the stack frame */
  571.   xlpop();
  572.   
  573.   return(alist);
  574. }
  575.  
  576. /* print an array */
  577. void putarray(fptr, array, flag)
  578.      LVAL fptr, array;
  579.      int flag;
  580. {
  581.   LVAL value;
  582.   
  583.   if (! displacedarrayp(array)) xlerror("not an array", array);
  584.   
  585.   /* protect a pointer */
  586.   xlsave1(value);
  587.   
  588.   xlputc(fptr,'#');
  589.   value = cvfixnum((FIXTYPE) arrayrank(array));
  590.   xlprint(fptr, value, flag);
  591.   xlputc(fptr, (getvalue(s_printcase) == k_downcase) ? 'a' : 'A');
  592.   value = array_to_nested_list(array);
  593.   if (value == NIL) {
  594.     xlputc(fptr,'(');
  595.     xlputc(fptr,')');
  596.   }
  597.   else
  598.     xlprint(fptr, value, flag);
  599.   
  600.   /* restore the stack frame */
  601.   xlpop();
  602. }
  603.