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 / compound.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-10-04  |  8.3 KB  |  290 lines
  1. /* compound - Compound data implementation and Elementwise mapping     */
  2. /* functions.                                                          */
  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 "xlisp.h"
  9. #include "osdef.h"
  10. #ifdef ANSI
  11. #include "xlproto.h"
  12. #include "xlsproto.h"
  13. #include "osproto.h"
  14. #else
  15. #include "xlfun.h"
  16. #include "xlsfun.h"
  17. #include "osfun.h"
  18. #endif ANSI
  19. #include "xlsvar.h"
  20.  
  21. /* forward declarations */
  22. #ifdef ANSI
  23. LVAL findcompound(int);
  24. int findrlen(LVAL);
  25. void fixuparglist(LVAL);
  26. #else
  27. LVAL findcompound();
  28. int findrlen();
  29. void fixuparglist();
  30. #endif ANSI
  31.  
  32. /*************************************************************************/
  33. /*************************************************************************/
  34. /**                                                                     **/
  35. /**                    Compound Data Implementation                     **/
  36. /**                                                                     **/
  37. /*************************************************************************/
  38. /*************************************************************************/
  39.  
  40. /* Compound data items contain a data sequence and structural            */
  41. /* information. The sequence can be extracted, the natural type of the   */
  42. /* sequence can be determined, the length of the sequence can be         */
  43. /* determined and a sequence of the appropriate length can be coerced to */
  44. /* match the shape of an object.                                         */
  45. /*                                                                       */
  46. /* For the moment, x is compound if it is a cons or an array of positive */
  47. /* size, or an object iheriting from COMPOUND-DATA-PROTO.                */
  48. /*                                                                       */
  49. /* If x is compound and y is a sequence then makecompound(x, seq) will   */
  50. /* return a compound item of the same shape as x with data sequence seq. */
  51. /* for sequences, same shape means same length. For arrays it means      */
  52. /* equal dimensions. For objects it means whatever x thinks it means.    */
  53.  
  54. /* internal predicate */
  55. int compoundp(x) 
  56.      LVAL x;
  57. {
  58.   if (consp(x)) return(TRUE);
  59.   else if (arrayp(x) && getsize(arraydata(x)) > 0) return(TRUE);
  60.   else if (objectp(x)) return(kind_of_p(x, getvalue(s_compound_data_proto)));
  61.   else return(FALSE);
  62. }
  63.  
  64. /* Built in COMPOUNDP */
  65. LVAL xscompoundp()
  66. {
  67.   LVAL x;
  68.  
  69.   x = xlgetarg();
  70.   xllastarg();
  71.   return((compoundp(x)) ? s_true : NIL);
  72. }
  73.  
  74. /* Check for a compound data item; pass it through or signal an error */
  75. LVAL checkcompound(x)
  76.      LVAL x;
  77. {
  78.   if (! compoundp(x)) xlerror("not a compound data item", x);
  79.   return(x);
  80. }
  81.  
  82. /* find length of a compound item's data sequence */
  83. int compounddatalen(x)
  84.      LVAL x;
  85. {
  86.   if (objectp(x)) {
  87.     LVAL n = send_message(x, sk_data_length);
  88.     if (! fixp(n) || getfixnum(n) < 0) xlerror("bad length", n);
  89.     return((int) getfixnum(n));
  90.   }
  91.   return((arrayp(x)) ? getsize(arraydata(x)) : llength(x));
  92. }
  93.  
  94. /* Built in COMPOUND-DATA-LENGTH */
  95. LVAL xscompound_length()
  96. {
  97.   LVAL x;
  98.   
  99.   x = checkcompound(xlgetarg());
  100.   xllastarg();
  101.   return(cvfixnum((FIXTYPE) compounddatalen(x)));
  102. }
  103.  
  104. /* get compound item's data sequence */
  105. LVAL compounddataseq(x) 
  106.      LVAL x;
  107. {
  108.   if (objectp(x)) {
  109.     LVAL seq = send_message(x, sk_data_seq);
  110.     if (! sequencep(seq)) xlerror("not a sequence", seq);
  111.     return(seq);
  112.   }
  113.   return((listp(x)) ? (x) : arraydata(x));
  114. }
  115.  
  116. /* Built in COMPOUND-DATA-SEQ */
  117. LVAL xscompound_seq()
  118. {
  119.   LVAL x;
  120.   
  121.   x = checkcompound(xlgetarg());
  122.   xllastarg();
  123.   return(compounddataseq(x));
  124. }
  125.  
  126. /* get 'natural' type of of compound item's data sequence */
  127. #define compoundseqtype(x) (vectorp(x)) ? s_vector : s_list;
  128.  
  129. /* Make sequence into a compound item of the same shape as form */
  130. LVAL makecompound(form, seq)
  131.      LVAL form, seq;
  132. {
  133.   LVAL result;
  134.  
  135.   xlsave1(result);
  136.   if (listp(form))
  137.     result = coerce_to_list(seq);
  138.   else if (simplevectorp(form))
  139.     result = coerce_to_vector(seq);
  140.   else if (displacedarrayp(form)) {
  141.     result = coerce_to_vector(seq);
  142.     result = makedisplacedarray(displacedarraydim(form), result);
  143.   }
  144.   else if (objectp(form)) {
  145.     result = send_message_1L(form, sk_make_data, seq);
  146.   }
  147.   else xlerror("not a compound data item", form);
  148.  
  149.   xlpop();
  150.   return(result);
  151. }
  152.  
  153. /*************************************************************************/
  154. /*************************************************************************/
  155. /**                                                                     **/
  156. /**                 Element-Wise Mapping Functions                      **/
  157. /**                                                                     **/
  158. /*************************************************************************/
  159. /*************************************************************************/
  160.  
  161. /* MAP-ELEMENTS acts like FUNCALL if all arguments are simple (i. e. not */
  162. /* compound). If one is compound all should be of the same shape. In     */
  163. /* this case simple arguments are treates as constant compound items of  */
  164. /* the appropriate shape. The function is applied elementwise and the    */
  165. /* result is returned as a compound item of the same shape as its        */
  166. /* arguments (in particular its first compound argument). If the         */
  167. /* arguments are sequences the result is a sequence of the same type as  */
  168. /* the first sequence argument.                                          */
  169.  
  170. /* Check the stack for a compound data argument and return it or NIL     */
  171. LOCAL LVAL findcompound(skip_one)
  172.      int skip_one;
  173. {
  174.   LVAL *next;
  175.   int n;
  176.   
  177.   n = xlargc;
  178.   next = xlargv;
  179.   
  180.   if (skip_one) {
  181.     n--;
  182.     next++;
  183.   }
  184.  
  185.   for (; n > 0; n--, next++) 
  186.     if (compoundp(*next))
  187.       return(*next);
  188.   return(NIL);
  189. }
  190.  
  191. /* find the length of the result sequence for map for the arguments in args */
  192. LOCAL int findrlen(args)
  193.      LVAL args;
  194. {
  195.   LVAL next;
  196.   int len, rlen;
  197.  
  198.   for (rlen = -1, next = args; consp(next); next = cdr(next))
  199.     if (compoundp(car(next))) {
  200.       len = compounddatalen(car(next));
  201.       if (rlen < 0) rlen = len;
  202.       else if (len != rlen) xlfail("arguments not all the same length");
  203.     }
  204.   return(rlen);
  205. }
  206.  
  207. /* replace displaced array arguments by their data vectors and simple */
  208. /* arguments by circular lists of one element.                        */
  209. LOCAL void fixuparglist(list)
  210.      LVAL list;
  211. {
  212.   LVAL next;
  213.   for (next = list; consp(next); next = cdr(next))
  214.     if (! compoundp(car(next))) { 
  215.       /* make circular list */
  216.       rplaca(next, consa(car(next)));
  217.       rplacd(car(next), car(next));
  218.     }
  219.     else
  220.       rplaca(next, compounddataseq(car(next)));
  221. }
  222.  
  223. /* MAP-ELEMENTS for internal subroutines */
  224. LVAL subr_map_elements(f)
  225. #ifdef ANSI
  226.      LVAL (*f)(void);
  227. #else
  228.      LVAL (*f)();
  229. #endif ANSI
  230. {
  231.   LVAL arglist, result, fcn, first_compound, type;
  232.   int rlen;
  233.  
  234.   first_compound = findcompound(FALSE);
  235.  
  236.   if (first_compound == NIL) result = (*f)();
  237.   else {
  238.     xlstkcheck(2);
  239.     xlsave(arglist);
  240.     xlsave(fcn);
  241.     fcn = cvsubr(f, SUBR, 0);
  242.     type = compoundseqtype(first_compound);
  243.     arglist = makearglist(xlargc, xlargv);
  244.     rlen = findrlen(arglist);
  245.     fixuparglist(arglist);
  246.     result = map(type, fcn, arglist, rlen);
  247.     result = makecompound(first_compound, result);
  248.     xlpopn(2);
  249.   }
  250.   return(result);
  251. }
  252.  
  253. /* recursive MAP-ELEMENTS for internal subroutines */
  254. LVAL recursive_subr_map_elements(bf, f)
  255. #ifdef ANSI
  256.      LVAL (*bf)(void), (*f)(void);
  257. #else
  258.      LVAL (*bf)(), (*f)();
  259. #endif ANSI
  260. {
  261.   if (findcompound(FALSE) == NIL) return((*bf)());
  262.   else return(subr_map_elements(f));
  263. }
  264.  
  265. /* Built in MAP-ELEMENTS */
  266. LVAL xsmap_elements()
  267. {
  268.   LVAL arglist, result, fcn, first_compound, type;
  269.   int rlen;
  270.  
  271.   if (xlargc < 2) xltoofew();
  272.   first_compound = findcompound(TRUE);
  273.  
  274.   if (first_compound == NIL) result = xfuncall();
  275.   else {
  276.     xlstkcheck(2)
  277.     xlsave(arglist);
  278.     xlsave(result);
  279.     fcn = xlgetarg();
  280.     type = compoundseqtype(first_compound);
  281.     arglist = makearglist(xlargc, xlargv);
  282.     rlen = findrlen(arglist);
  283.     fixuparglist(arglist);
  284.     result = map(type, fcn, arglist, rlen);
  285.     result = makecompound(first_compound,result);
  286.     xlpopn(2);
  287.   }
  288.   return(result);
  289. }
  290.