home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / XLISP / XLISP11.ARK / XLLIST.C < prev    next >
Text File  |  1986-10-12  |  12KB  |  515 lines
  1. /* xllist - xlisp list builtin functions */
  2.  
  3. #ifdef AZTEC
  4. #include "a:stdio.h"
  5. #else
  6. #include <stdio.h>
  7. #endif
  8.  
  9. #include "xlisp.h"
  10.  
  11. /* external variables */
  12. extern struct node *xlstack;
  13.  
  14. /* local variables */
  15. static struct node *t;
  16. static struct node *a_subr;
  17. static struct node *a_list;
  18. static struct node *a_sym;
  19. static struct node *a_int;
  20. static struct node *a_str;
  21. static struct node *a_obj;
  22. static struct node *a_fptr;
  23. static struct node *a_kmap;
  24.  
  25. /* xlist - builtin function list */
  26. static struct node *xlist(args)
  27.   struct node *args;
  28. {
  29.     struct node *oldstk,arg,list,val,*last,*lptr;
  30.  
  31.     /* create a new stack frame */
  32.     oldstk = xlsave(&arg,&list,&val,NULL);
  33.  
  34.     /* initialize */
  35.     arg.n_ptr = args;
  36.  
  37.     /* evaluate and append each argument */
  38.     for (last = NULL; arg.n_ptr != NULL; last = lptr) {
  39.  
  40.     /* evaluate the next argument */
  41.     val.n_ptr = xlevarg(&arg.n_ptr);
  42.  
  43.     /* append this argument to the end of the list */
  44.     lptr = newnode(LIST);
  45.     if (last == NULL)
  46.         list.n_ptr = lptr;
  47.     else
  48.         last->n_listnext = lptr;
  49.     lptr->n_listvalue = val.n_ptr;
  50.     }
  51.  
  52.     /* restore the previous stack frame */
  53.     xlstack = oldstk;
  54.  
  55.     /* return the list */
  56.     return (list.n_ptr);
  57. }
  58.  
  59. /* cond - builtin function cond */
  60. static struct node *cond(args)
  61.   struct node *args;
  62. {
  63.     struct node *oldstk,arg,list,*val;
  64.  
  65.     /* create a new stack frame */
  66.     oldstk = xlsave(&arg,&list,NULL);
  67.  
  68.     /* initialize */
  69.     arg.n_ptr = args;
  70.  
  71.     /* initialize the return value */
  72.     val = NULL;
  73.  
  74.     /* find a predicate that is true */
  75.     while (arg.n_ptr != NULL) {
  76.  
  77.     /* get the next conditional */
  78.     list.n_ptr = xlmatch(LIST,&arg.n_ptr);
  79.  
  80.     /* evaluate the predicate part */
  81.     if (xlevarg(&list.n_ptr) != NULL) {
  82.  
  83.         /* evaluate each expression */
  84.         while (list.n_ptr != NULL)
  85.         val = xlevarg(&list.n_ptr);
  86.  
  87.         /* exit the loop */
  88.         break;
  89.     }
  90.     }
  91.  
  92.     /* restore the previous stack frame */
  93.     xlstack = oldstk;
  94.  
  95.     /* return the value */
  96.     return (val);
  97. }
  98.  
  99. /* atom - is this an atom? */
  100. static struct node *atom(args)
  101.   struct node *args;
  102. {
  103.     struct node *arg;
  104.  
  105.     /* get the argument */
  106.     if ((arg = xlevarg(&args)) == NULL || arg->n_type != LIST)
  107.     return (t);
  108.     else
  109.     return (NULL);
  110. }
  111.  
  112. /* null - is this null? */
  113. static struct node *null(args)
  114.   struct node *args;
  115. {
  116.     /* get the argument */
  117.     if (xlevarg(&args) == NULL)
  118.     return (t);
  119.     else
  120.     return (NULL);
  121. }
  122.  
  123. /* type - return type of a thing */
  124. static struct node *type(args)
  125.     struct node *args;
  126. {
  127.     struct node *arg;
  128.  
  129.     if (!(arg = xlevarg(&args)))
  130.     return (NULL);
  131.  
  132.     switch (arg->n_type) {
  133.     case SUBR: return (a_subr);
  134.     case LIST: return (a_list);
  135.     case SYM: return (a_sym);
  136.     case INT: return (a_int);
  137.     case STR: return (a_str);
  138.     case OBJ: return (a_obj);
  139.     case FPTR: return (a_fptr);
  140.     case KMAP: return (a_kmap);
  141.     default: xlfail("Bad node.");
  142.     }
  143. }
  144.  
  145. /* listp - is this a list? */
  146. static struct node *listp(args)
  147.   struct node *args;
  148. {
  149.     /* get the argument */
  150.     if (xlistp(xlevarg(&args)))
  151.     return (t);
  152.     else
  153.     return (NULL);
  154. }
  155.  
  156. /* xlistp - internal listp function */
  157. static int xlistp(arg)
  158.   struct node *arg;
  159. {
  160.     return (arg == NULL || arg->n_type == LIST);
  161. }
  162.  
  163. /* eq - are these equal? */
  164. static struct node *eq(args)
  165.   struct node *args;
  166. {
  167.     struct node *oldstk,arg,arg1,arg2,*val;
  168.  
  169.     /* create a new stack frame */
  170.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  171.  
  172.     /* initialize */
  173.     arg.n_ptr = args;
  174.  
  175.     /* first argument */
  176.     arg1.n_ptr = xlevarg(&arg.n_ptr);
  177.  
  178.     /* second argument */
  179.     arg2.n_ptr = xlevarg(&arg.n_ptr);
  180.  
  181.     /* make sure there aren't any more arguments */
  182.     xllastarg(arg.n_ptr);
  183.  
  184.     /* compare the arguments */
  185.     if (xeq(arg1.n_ptr,arg2.n_ptr))
  186.     val = t;
  187.     else
  188.     val = NULL;
  189.  
  190.     /* restore the previous stack frame */
  191.     xlstack = oldstk;
  192.  
  193.     /* return the result */
  194.     return (val);
  195. }
  196.  
  197. /* xeq - internal eq function */
  198. static int xeq(arg1,arg2)
  199.   struct node *arg1,*arg2;
  200. {
  201.     /* compare the arguments */
  202.     if (arg1 != NULL && arg1->n_type == INT &&
  203.         arg2 != NULL && arg2->n_type == INT)
  204.     return (arg1->n_int == arg2->n_int);
  205.     else
  206.     return (arg1 == arg2);
  207. }
  208.  
  209. /* equal - are these equal? */
  210. static struct node *equal(args)
  211.   struct node *args;
  212. {
  213.     struct node *oldstk,arg,arg1,arg2,*val;
  214.  
  215.     /* create a new stack frame */
  216.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  217.  
  218.     /* initialize */
  219.     arg.n_ptr = args;
  220.  
  221.     /* first argument */
  222.     arg1.n_ptr = xlevarg(&arg.n_ptr);
  223.  
  224.     /* second argument */
  225.     arg2.n_ptr = xlevarg(&arg.n_ptr);
  226.  
  227.     /* make sure there aren't any more arguments */
  228.     xllastarg(arg.n_ptr);
  229.  
  230.     /* compare the arguments */
  231.     if (xequal(arg1.n_ptr,arg2.n_ptr))
  232.     val = t;
  233.     else
  234.     val = NULL;
  235.  
  236.     /* restore the previous stack frame */
  237.     xlstack = oldstk;
  238.  
  239.     /* return the result */
  240.     return (val);
  241. }
  242.  
  243. /* xequal - internal equal function */
  244. static int xequal(arg1,arg2)
  245.   struct node *arg1,*arg2;
  246. {
  247.     /* compare the arguments */
  248.     if (xeq(arg1,arg2))
  249.     return (TRUE);
  250.     else if (xlistp(arg1) && xlistp(arg2))
  251.     return (xequal(arg1->n_listvalue,arg2->n_listvalue) &&
  252.         xequal(arg1->n_listnext, arg2->n_listnext));
  253.     else
  254.     return (FALSE);
  255. }
  256.  
  257. /* head - return the head of a list */
  258. static struct node *head(args)
  259.   struct node *args;
  260. {
  261.     struct node *list;
  262.  
  263.     /* get the list */
  264.     if ((list = xlevmatch(LIST,&args)) == NULL)
  265.     xlfail("null list");
  266.  
  267.     /* make sure this is the only argument */
  268.     xllastarg(args);
  269.  
  270.     /* return the head of the list */
  271.     return (list->n_listvalue);
  272. }
  273.  
  274. /* tail - return the tail of a list */
  275. static struct node *tail(args)
  276.   struct node *args;
  277. {
  278.     struct node *list;
  279.  
  280.     /* get the list */
  281.     if ((list = xlevmatch(LIST,&args)) == NULL)
  282.     xlfail("null list");
  283.  
  284.     /* make sure this is the only argument */
  285.     xllastarg(args);
  286.  
  287.     /* return the tail of the list */
  288.     return (list->n_listnext);
  289. }
  290.  
  291. /* nth - return the nth element of a list */
  292. static struct node *nth(args)
  293.   struct node *args;
  294. {
  295.     struct node *oldstk,arg,list;
  296.     int n;
  297.  
  298.     /* create a new stack frame */
  299.     oldstk = xlsave(&arg,&list,NULL);
  300.  
  301.     /* initialize */
  302.     arg.n_ptr = args;
  303.  
  304.     /* get n */
  305.     if ((n = xlevmatch(INT,&arg.n_ptr)->n_int) < 1)
  306.     xlfail("invalid argument");
  307.  
  308.     /* get the list */
  309.     if ((list.n_ptr = xlevmatch(LIST,&arg.n_ptr)) == NULL)
  310.     xlfail("invalid argument");
  311.  
  312.     /* make sure this is the only argument */
  313.     xllastarg(arg.n_ptr);
  314.  
  315.     /* find the nth element */
  316.     for (; n > 1; n--) {
  317.     list.n_ptr = list.n_ptr->n_listnext;
  318.     if (list.n_ptr == NULL || list.n_ptr->n_type != LIST)
  319.         xlfail("invalid argument");
  320.     }
  321.  
  322.     /* restore the previous stack frame */
  323.     xlstack = oldstk;
  324.  
  325.     /* return the list nth list element */
  326.     return (list.n_ptr->n_listvalue);
  327. }
  328.  
  329. /* length - return the length of a list */
  330. static struct node *length(args)
  331.   struct node *args;
  332. {
  333.     struct node *oldstk,list,*val;
  334.     int n;
  335.  
  336.     /* create a new stack frame */
  337.     oldstk = xlsave(&list,NULL);
  338.  
  339.     /* get the list */
  340.     list.n_ptr = xlevmatch(LIST,&args);
  341.  
  342.     /* make sure this is the only argument */
  343.     xllastarg(args);
  344.  
  345.     /* find the length */
  346.     for (n = 0; list.n_ptr != NULL; n++)
  347.     list.n_ptr = list.n_ptr->n_listnext;
  348.  
  349.     /* restore the previous stack frame */
  350.     xlstack = oldstk;
  351.  
  352.     /* create the value node */
  353.     val = newnode(INT);
  354.     val->n_int = n;
  355.  
  356.     /* return the length */
  357.     return (val);
  358. }
  359.  
  360. /* append - builtin function append */
  361. static struct node *append(args)
  362.   struct node *args;
  363. {
  364.     struct node *oldstk,arg,list,last,val,*lptr;
  365.  
  366.     /* create a new stack frame */
  367.     oldstk = xlsave(&arg,&list,&last,&val,NULL);
  368.  
  369.     /* initialize */
  370.     arg.n_ptr = args;
  371.  
  372.     /* evaluate and append each argument */
  373.     while (arg.n_ptr != NULL) {
  374.  
  375.     /* evaluate the next argument */
  376.     list.n_ptr = xlevmatch(LIST,&arg.n_ptr);
  377.  
  378.     /* append each element of this list to the result list */
  379.     while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {
  380.  
  381.         /* append this element */
  382.         lptr = newnode(LIST);
  383.         if (last.n_ptr == NULL)
  384.         val.n_ptr = lptr;
  385.         else
  386.         last.n_ptr->n_listnext = lptr;
  387.         lptr->n_listvalue = list.n_ptr->n_listvalue;
  388.  
  389.         /* save the new last element */
  390.         last.n_ptr = lptr;
  391.  
  392.         /* move to the next element */
  393.         list.n_ptr = list.n_ptr->n_listnext;
  394.     }
  395.  
  396.     /* make sure the list ended in a nil */
  397.     if (list.n_ptr != NULL)
  398.         xlfail("bad list");
  399.     }
  400.  
  401.     /* restore previous stack frame */
  402.     xlstack = oldstk;
  403.  
  404.     /* return the list */
  405.     return (val.n_ptr);
  406. }
  407.  
  408. /* reverse - builtin function reverse */
  409. static struct node *reverse(args)
  410.   struct node *args;
  411. {
  412.     struct node *oldstk,list,val,*lptr;
  413.  
  414.     /* create a new stack frame */
  415.     oldstk = xlsave(&list,&val,NULL);
  416.  
  417.     /* get the list to reverse */
  418.     list.n_ptr = xlevmatch(LIST,&args);
  419.  
  420.     /* make sure there aren't any more arguments */
  421.     xllastarg(args);
  422.  
  423.     /* append each element of this list to the result list */
  424.     while (list.n_ptr != NULL && list.n_ptr->n_type == LIST) {
  425.  
  426.     /* append this element */
  427.     lptr = newnode(LIST);
  428.     lptr->n_listvalue = list.n_ptr->n_listvalue;
  429.     lptr->n_listnext = val.n_ptr;
  430.     val.n_ptr = lptr;
  431.  
  432.     /* move to the next element */
  433.     list.n_ptr = list.n_ptr->n_listnext;
  434.     }
  435.  
  436.     /* make sure the list ended in a nil */
  437.     if (list.n_ptr != NULL)
  438.     xlfail("bad list");
  439.  
  440.     /* restore previous stack frame */
  441.     xlstack = oldstk;
  442.  
  443.     /* return the list */
  444.     return (val.n_ptr);
  445. }
  446.  
  447. /* cons - construct a new list cell */
  448. static struct node *cons(args)
  449.   struct node *args;
  450. {
  451.     struct node *oldstk,arg,arg1,arg2,*lptr;
  452.  
  453.     /* create a new stack frame */
  454.     oldstk = xlsave(&arg,&arg1,&arg2,NULL);
  455.  
  456.     /* initialize */
  457.     arg.n_ptr = args;
  458.  
  459.     /* first argument */
  460.     arg1.n_ptr = xlevarg(&arg.n_ptr);
  461.  
  462.     /* second argument */
  463.     arg2.n_ptr = xlevarg(&arg.n_ptr);
  464.  
  465.     /* make sure there aren't any more arguments */
  466.     xllastarg(arg.n_ptr);
  467.  
  468.     /* construct a new list element */
  469.     lptr = newnode(LIST);
  470.     lptr->n_listvalue = arg1.n_ptr;
  471.     lptr->n_listnext  = arg2.n_ptr;
  472.  
  473.     /* restore the previous stack frame */
  474.     xlstack = oldstk;
  475.  
  476.     /* return the list */
  477.     return (lptr);
  478. }
  479.  
  480. /* xllinit - xlisp list initialization routine */
  481. xllinit()
  482. {
  483.     /* define some symbols */
  484.     t = xlenter("t");
  485.     a_subr = xlenter("SUBR");
  486.     a_list = xlenter("LIST");
  487.     a_sym = xlenter("SYM");
  488.     a_int = xlenter("INT");
  489.     a_str = xlenter("STR");
  490.     a_obj = xlenter("OBJ");
  491.     a_fptr = xlenter("FPTR");
  492.     a_kmap = xlenter("KMAP");
  493.  
  494.     /* functions with reasonable names */
  495.     xlsubr("head",head);
  496.     xlsubr("tail",tail);
  497.     xlsubr("nth",nth);
  498.  
  499.     /* real lisp functions */
  500.     xlsubr("atom",atom);
  501.     xlsubr("eq",eq);
  502.     xlsubr("equal",equal);
  503.     xlsubr("null",null);
  504.     xlsubr("type",type);
  505.     xlsubr("listp",listp);
  506.     xlsubr("cond",cond);
  507.     xlsubr("list",xlist);
  508.     xlsubr("cons",cons);
  509.     xlsubr("car",head);
  510.     xlsubr("cdr",tail);
  511.     xlsubr("append",append);
  512.     xlsubr("reverse",reverse);
  513.     xlsubr("length",length);
  514. }
  515.