home *** CD-ROM | disk | FTP | other *** search
/ CICA 1995 May / cica_0595_4.zip / cica_0595_4 / UTIL / MSWSRC35 / LISTS.CPP < prev    next >
C/C++ Source or Header  |  1993-08-19  |  15KB  |  715 lines
  1. /*
  2.  *      lists.c         logo list functions module              dvb
  3.  *
  4.  *    Copyright (C) 1989 The Regents of the University of California
  5.  *    This Software may be copied and distributed for educational,
  6.  *    research, and not for profit purposes provided that this
  7.  *    copyright and statement are included in all such copies.
  8.  */
  9.  
  10. #include "logo.h"
  11. #include "globals.h"
  12.  
  13. typedef char *(*kludge_type)(char *, char *, int);
  14.  
  15. NODE *bfable_arg(NODE *args)
  16. {
  17.     NODE *arg = car(args);
  18.  
  19.     while ((arg == NIL || arg == UNBOUND || arg == Null_Word ||
  20.         nodetype(arg) == ARRAY) && NOT_THROWING) {
  21.     setcar(args, err_logo(BAD_DATA, arg));
  22.     arg = car(args);
  23.     }
  24.     return arg;
  25. }
  26.  
  27. NODE *list_arg(NODE *args)
  28. {
  29.     NODE *arg = car(args);
  30.  
  31.     while (!(arg == NIL || is_list(arg)) && NOT_THROWING) {
  32.     setcar(args, err_logo(BAD_DATA, arg));
  33.     arg = car(args);
  34.     }
  35.     return arg;
  36. }
  37.  
  38. NODE *lbutfirst(NODE *args)
  39. {
  40.     NODE *val = UNBOUND, *arg;
  41.  
  42.     arg = bfable_arg(args);
  43.     if (NOT_THROWING) {
  44.     if (is_list(arg))
  45.         val = cdr(arg);
  46.     else {
  47.         setcar(args, cnv_node_to_strnode(arg));
  48.         arg = car(args);
  49.         if (getstrlen(arg) > 1)
  50.         val = make_strnode(getstrptr(arg) + 1,
  51.               getstrhead(arg),
  52.               getstrlen(arg) - 1,
  53.               nodetype(arg),
  54.               strnzcpy);
  55.         else
  56.         val = Null_Word;
  57.     }
  58.     }
  59.     return(val);
  60. }
  61.  
  62. NODE *lbutlast(NODE *args)
  63. {
  64.     NODE *val = UNBOUND, *lastnode, *tnode, *arg;
  65.  
  66.     arg = bfable_arg(args);
  67.     if (NOT_THROWING) {
  68.     if (is_list(arg)) {
  69.         args = arg;
  70.         val = NIL;
  71.         while (cdr(args) != NIL) {
  72.         tnode = cons(car(args), NIL);
  73.         if (val == NIL) {
  74.             val = tnode;
  75.             lastnode = tnode;
  76.         } else {
  77.             setcdr(lastnode, tnode);
  78.             lastnode = tnode;
  79.         }
  80.         args = cdr(args);
  81.         if (check_throwing) break;
  82.         }
  83.     } else {
  84.         setcar(args, cnv_node_to_strnode(arg));
  85.         arg = car(args);
  86.         if (getstrlen(arg) > 1)
  87.         val = make_strnode(getstrptr(arg),
  88.               getstrhead(arg),
  89.               getstrlen(arg) - 1,
  90.               nodetype(arg),
  91.               strnzcpy);
  92.         else
  93.         val = Null_Word;
  94.     }
  95.     }
  96.     return(val);
  97. }
  98.  
  99. NODE *lfirst(NODE *args)
  100. {
  101.     NODE *val = UNBOUND, *arg;
  102.  
  103.     if (nodetype(car(args)) == ARRAY) {
  104.     return make_intnode((FIXNUM)getarrorg(car(args)));
  105.     }
  106.     arg = bfable_arg(args);
  107.     if (NOT_THROWING) {
  108.     if (is_list(arg))
  109.         val = car(arg);
  110.     else {
  111.         setcar(args, cnv_node_to_strnode(arg));
  112.         arg = car(args);
  113.         val = make_strnode(getstrptr(arg), getstrhead(arg), 1,
  114.                    nodetype(arg), strnzcpy);
  115.     }
  116.     }
  117.     return(val);
  118. }
  119.  
  120. NODE *lfirsts(NODE *args)
  121. {
  122.     NODE *val = UNBOUND, *arg, *argp, *tail;
  123.  
  124.     arg = list_arg(args);
  125.     if (car(args) == NIL) return(NIL);
  126.     if (NOT_THROWING) {
  127.     val = cons(lfirst(arg), NIL);
  128.     tail = val;
  129.     for (argp = cdr(arg); argp != NIL; argp = cdr(argp)) {
  130.         setcdr(tail, cons(lfirst(argp), NIL));
  131.         tail = cdr(tail);
  132.         if (check_throwing) break;
  133.     }
  134.     if (stopping_flag == THROWING) {
  135.         gcref(val);
  136.         return UNBOUND;
  137.     }
  138.     }
  139.     return(val);
  140. }
  141.  
  142. NODE *lbfs(NODE *args)
  143. {
  144.     NODE *val = UNBOUND, *arg, *argp, *tail;
  145.  
  146.     arg = list_arg(args);
  147.     if (car(args) == NIL) return(NIL);
  148.     if (NOT_THROWING) {
  149.     val = cons(lbutfirst(arg), NIL);
  150.     tail = vref(val);
  151.     for (argp = cdr(arg); argp != NIL; argp = cdr(argp)) {
  152.         setcdr(tail, cons(lbutfirst(argp), NIL));
  153.         tail = cdr(tail);
  154.         if (check_throwing) break;
  155.     }
  156.     if (stopping_flag == THROWING) {
  157.         gcref(val);
  158.         return UNBOUND;
  159.     }
  160.     }
  161.     return(val);
  162. }
  163.  
  164. NODE *llast(NODE *args)
  165. {
  166.     NODE *val = UNBOUND, *arg;
  167.  
  168.     arg = bfable_arg(args);
  169.     if (NOT_THROWING) {
  170.     if (is_list(arg)) {
  171.         args = arg;
  172.         while (cdr(args) != NIL) {
  173.         args = cdr(args);
  174.         if (check_throwing) break;
  175.         }
  176.         val = car(args);
  177.     }
  178.     else {
  179.         setcar(args, cnv_node_to_strnode(arg));
  180.         arg = car(args);
  181.         val = make_strnode(getstrptr(arg) + getstrlen(arg) - 1,
  182.                    getstrhead(arg), 1, nodetype(arg), strnzcpy);
  183.     }
  184.     }
  185.     return(val);
  186. }
  187.  
  188. NODE *llist(NODE *args)
  189. {
  190.     return(args);
  191. }
  192.  
  193. NODE *lemptyp(NODE *arg)
  194. {
  195.     return torf(car(arg) == NIL || car(arg) == Null_Word);
  196. }
  197.  
  198. NODE *char_arg(NODE *args)
  199. {
  200.     NODE *arg = car(args), *val;
  201.  
  202.     val = cnv_node_to_strnode(arg);
  203.     while ((val == UNBOUND || getstrlen(val) != 1) && NOT_THROWING) {
  204.     gcref(val);
  205.     setcar(args, err_logo(BAD_DATA, arg));
  206.     arg = car(args);
  207.     val = cnv_node_to_strnode(arg);
  208.     }
  209.     setcar(args,val);
  210.     return(val);
  211. }
  212.  
  213. NODE *lascii(NODE *args)
  214. {
  215.     FIXNUM i;
  216.     NODE *val = UNBOUND, *arg;
  217.  
  218.     arg = char_arg(args);
  219.     if (NOT_THROWING) {
  220.     i = (FIXNUM)clearparity(*getstrptr(arg)) & 0377;
  221.     val = make_intnode(i);
  222.     }
  223.     return(val);
  224. }
  225.  
  226. NODE *lbackslashedp(NODE *args)
  227. {
  228.     char i;
  229.     NODE *arg;
  230.  
  231.     arg = char_arg(args);
  232.     if (NOT_THROWING) {
  233.     i = *getstrptr(arg);
  234.     return torf(getparity(i));
  235.     }
  236.     return(UNBOUND);
  237. }
  238.  
  239. NODE *lchar(NODE *args)
  240. {
  241.     NODE *val = UNBOUND, *arg;
  242.     char c;
  243.  
  244.     arg = pos_int_arg(args);
  245.     if (NOT_THROWING) {
  246.     c = getint(arg);
  247.     val = make_strnode(&c, (char *)NULL, 1,
  248.                (getparity(c) ? STRING : BACKSLASH_STRING), strnzcpy);
  249.     }
  250.     return(val);
  251. }
  252.  
  253. NODE *lcount(NODE *args)
  254. {
  255.     int cnt = 0;
  256.     NODE *arg;
  257.  
  258.     arg = car(args);
  259.     if (arg != NIL && arg != Null_Word) {
  260.     if (is_list(arg)) {
  261.         args = arg;
  262.         for (; args != NIL; cnt++) {
  263.         args = cdr(args);
  264.         if (check_throwing) break;
  265.         }
  266.     } else if (nodetype(arg) == ARRAY) {
  267.         cnt = getarrdim(arg);
  268.     } else {
  269.         setcar(args, cnv_node_to_strnode(arg));
  270.         cnt = getstrlen(car(args));
  271.     }
  272.     }
  273.     return(make_intnode((FIXNUM)cnt));
  274. }
  275.  
  276. NODE *lfput(NODE *args)
  277. {
  278.     NODE *lst, *arg;
  279.  
  280.     arg = car(args);
  281.     lst = list_arg(cdr(args));
  282.     if (NOT_THROWING)
  283.     return cons(arg,lst);
  284.     else
  285.     return UNBOUND;
  286. }
  287.  
  288. NODE *llput(NODE *args)
  289. {
  290.     NODE *lst, *arg, *val = UNBOUND, *lastnode = NIL, *tnode = NIL;
  291.  
  292.     arg = car(args);
  293.     lst = list_arg(cdr(args));
  294.     if (NOT_THROWING) {
  295.     val = NIL;
  296.     while (lst != NIL) {
  297.         tnode = cons(car(lst), NIL);
  298.         if (val == NIL) {
  299.         val = tnode;
  300.         } else {
  301.         setcdr(lastnode, tnode);
  302.         }
  303.         lastnode = tnode;
  304.         lst = cdr(lst);
  305.         if (check_throwing) break;
  306.     }
  307.     if (val == NIL)
  308.         val = cons(arg, NIL);
  309.     else
  310.         setcdr(lastnode, cons(arg, NIL));
  311.     }
  312.     return(val);
  313. }
  314.  
  315. NODE *string_arg(NODE *args)
  316. {
  317.     NODE *arg = car(args), *val;
  318.  
  319.     val = cnv_node_to_strnode(arg);
  320.     while (val == UNBOUND && NOT_THROWING) {
  321.     gcref(val);
  322.     setcar(args, err_logo(BAD_DATA, arg));
  323.     arg = car(args);
  324.     val = cnv_node_to_strnode(arg);
  325.     }
  326.     setcar(args,val);
  327.     return(val);
  328. }
  329.  
  330. NODE *lword(NODE *args)
  331. {
  332.     NODE *val = NIL, *arg = NIL;
  333. //    NODE *tnode = NIL;
  334. //    NODE *lastnode = NIL;
  335.     int cnt = 0;
  336.     NODETYPES str_type = STRING;
  337.  
  338.     if (args == NIL) return Null_Word;
  339.     val = args;
  340.     while (val != NIL && NOT_THROWING) {
  341.     arg = string_arg(val);
  342.     val = cdr(val);
  343.     if (NOT_THROWING) {
  344.         if (backslashed(arg))
  345.         str_type = VBAR_STRING;
  346.         cnt += getstrlen(arg);
  347.     }
  348.     }
  349.     if (NOT_THROWING)
  350.     val = make_strnode((char *)args, (char *)NULL,
  351.                cnt, str_type, (kludge_type)word_strnzcpy); /* kludge */
  352.     else
  353.     val = UNBOUND;
  354.     return(val);
  355. }
  356.  
  357. NODE *lsentence(NODE *args)
  358. {
  359.     NODE *tnode = NIL, *lastnode = NIL, *val = NIL, *arg = NIL;
  360.  
  361.     while (args != NIL && NOT_THROWING) {
  362.     arg = car(args);
  363.     while (nodetype(arg) == ARRAY && NOT_THROWING) {
  364.         setcar(args, err_logo(BAD_DATA, arg));
  365.         arg = car(args);
  366.     }
  367.     args = cdr(args);
  368.     if (stopping_flag == THROWING) break;
  369.     if (is_list(arg)) {
  370.         while (arg != NIL && NOT_THROWING) {
  371.         tnode = cons(car(arg), NIL);
  372.         arg = cdr(arg);
  373.         if (val == NIL) val = tnode;
  374.         else setcdr(lastnode, tnode);
  375.         lastnode = tnode;
  376.         }
  377.     } else {
  378.         tnode = cons(arg, NIL);
  379.         if (val == NIL) val = tnode;
  380.         else setcdr(lastnode, tnode);
  381.         lastnode = tnode;
  382.     }
  383.     }
  384.     if (stopping_flag == THROWING) {
  385.     gcref(val);
  386.     return UNBOUND;
  387.     }
  388.     return(val);
  389. }
  390.  
  391. NODE *lwordp(NODE *arg)
  392. {
  393.     arg = car(arg);
  394.     return torf(arg != UNBOUND && !aggregate(arg));
  395. }
  396.  
  397. NODE *llistp(NODE *arg)
  398. {
  399.     arg = car(arg);
  400.     return torf(is_list(arg));
  401. }
  402.  
  403. NODE *lnumberp(NODE *arg)
  404. {
  405.     setcar(arg, cnv_node_to_numnode(car(arg)));
  406.     return torf(car(arg) != UNBOUND);
  407. }
  408.  
  409. NODE *larrayp(NODE *arg)
  410. {
  411.     return torf(nodetype(car(arg)) == ARRAY);
  412. }
  413.  
  414. NODE *memberp_help(NODE *args, BOOLEAN notp)
  415. {
  416.     NODE *obj1, *obj2;
  417. //    NODE *val;
  418.     int leng;
  419.     int caseig = (compare_node(valnode__caseobj(Caseignoredp),
  420.                    Truex, TRUE) == 0);
  421.  
  422. //    val = Falsex;
  423.     obj1 = car(args);
  424.     obj2 = cadr(args);
  425.     if (is_list(obj2)) {
  426.     while (obj2 != NIL && NOT_THROWING) {
  427.         if (equalp_help(obj1, car(obj2), caseig))
  428.         return (notp ? obj2 : Truex);
  429.         obj2 = cdr(obj2);
  430.         if (check_throwing) break;
  431.     }
  432.     return (notp ? NIL : Falsex);
  433.     }
  434.     else if (nodetype(obj2) == ARRAY) {
  435.     int len = getarrdim(obj2);
  436.     NODE **data = getarrptr(obj2);
  437.  
  438.     if (notp)
  439.         err_logo(BAD_DATA_UNREC,obj2);
  440.     while (--len >= 0 && NOT_THROWING) {
  441.         if (equalp_help(obj1, *data++, caseig)) return Truex;
  442.     }
  443.     return Falsex;
  444.     } else {
  445.     NODE *tmp;
  446.     int i;
  447.  
  448.     if (aggregate(obj1)) return (notp ? Null_Word : Falsex);
  449.     setcar (cdr(args), cnv_node_to_strnode(obj2));
  450.     obj2 = cadr(args);
  451.     setcar (args, cnv_node_to_strnode(obj1));
  452.     obj1 = car(args);
  453.     tmp = NIL;
  454.     if (obj1 != UNBOUND && obj2 != UNBOUND &&
  455.         getstrlen(obj1) <= getstrlen(obj2)) {
  456.         leng = getstrlen(obj2) - getstrlen(obj1);
  457.         setcar(cdr(args),make_strnode(getstrptr(obj2), getstrhead(obj2),
  458.                       getstrlen(obj1), nodetype(obj2),
  459.                       strnzcpy));
  460.         tmp = cadr(args);
  461.         for (i = 0; i <= leng; i++) {
  462.         if (equalp_help(obj1, tmp, caseig)) {
  463.             if (notp) {
  464.             setstrlen(tmp,leng+getstrlen(obj1)-i);
  465.             return tmp;
  466.             } else return Truex;
  467.         }
  468.         setstrptr(tmp, getstrptr(tmp) + 1);
  469.         }
  470.     }
  471.     return (notp ? Null_Word : Falsex);
  472.     }
  473. }
  474.  
  475. NODE *lmemberp(NODE *args)
  476. {
  477.     return(memberp_help(args, FALSE));
  478. }
  479.  
  480. NODE *lmember(NODE *args)
  481. {
  482.     return(memberp_help(args, TRUE));
  483. }
  484.  
  485. NODE *integer_arg(NODE *args)
  486. {
  487.     NODE *arg = car(args), *val;
  488.  
  489.     val = cnv_node_to_numnode(arg);
  490.     while (nodetype(val) != INT && NOT_THROWING) {
  491.     gcref(val);
  492.     setcar(args, err_logo(BAD_DATA, arg));
  493.     arg = car(args);
  494.     val = cnv_node_to_numnode(arg);
  495.     }
  496.     setcar(args,val);
  497.     if (nodetype(val) == INT) return(val);
  498.     return UNBOUND;
  499. }
  500.  
  501. FIXNUM int_arg(NODE *args)
  502. {
  503.     NODE *arg =integer_arg(args);
  504.  
  505.     if (NOT_THROWING) return getint(arg);
  506.     return 0;
  507. }
  508.  
  509. NODE *litem(NODE *args)
  510. {
  511.     int i;
  512.     NODE *obj, *val;
  513.  
  514.     val = integer_arg(args);
  515.     obj = cadr(args);
  516.     while ((obj == NIL || obj == Null_Word) && NOT_THROWING) {
  517.     setcar(cdr(args), err_logo(BAD_DATA, obj));
  518.     obj = cadr(args);
  519.     }
  520.     if (NOT_THROWING) {
  521.     i = getint(val);
  522.     if (is_list(obj)) {
  523.         if (i <= 0) {
  524.         err_logo(BAD_DATA_UNREC, val);
  525.         return UNBOUND;
  526.         }
  527.         while (--i > 0) {
  528.         obj = cdr(obj);
  529.         if (obj == NIL) {
  530.             err_logo(BAD_DATA_UNREC, val);
  531.             return UNBOUND;
  532.         }
  533.         }
  534.         return car(obj);
  535.     }
  536.     else if (nodetype(obj) == ARRAY) {
  537.         i -= getarrorg(obj);
  538.         if (i < 0 || i >= getarrdim(obj)) {
  539.         err_logo(BAD_DATA_UNREC, val);
  540.         return UNBOUND;
  541.         }
  542.         return (getarrptr(obj))[i];
  543.     }
  544.     else {
  545.         if (i <= 0) {
  546.         err_logo(BAD_DATA_UNREC, val);
  547.         return UNBOUND;
  548.         }
  549.         setcar (cdr(args), cnv_node_to_strnode(obj));
  550.         obj = cadr(args);
  551.         if (i > getstrlen(obj)) {
  552.         err_logo(BAD_DATA_UNREC, val);
  553.         return UNBOUND;
  554.         }
  555.         return make_strnode(getstrptr(obj) + i - 1, getstrhead(obj),
  556.                 1, nodetype(obj), strnzcpy);
  557.     }
  558.     }
  559.     return(UNBOUND);
  560. }
  561.  
  562. int circular(NODE *arr, NODE *newx)
  563. {
  564.     if (newx == NIL) return(0);
  565.     else if (nodetype(newx) == ARRAY) {
  566.     int i = getarrdim(newx);
  567.     NODE **p = getarrptr(newx);
  568.  
  569.     if (newx == arr) return(1);
  570.     while (--i >= 0) {
  571.         if (circular(arr,*p++)) return(1);
  572.     }
  573.     return(0);
  574.     } else if (is_list(newx)) {
  575.     while (newx != NIL) {
  576.         if (circular(arr,car(newx))) return(1);
  577.         newx = cdr(newx);
  578.     }
  579.     return(0);
  580.     } else return(0);
  581. }
  582.  
  583. NODE *setitem_helper(NODE *args, BOOLEAN safe)
  584. {
  585.     int i;
  586.     NODE *obj, *val, *cont;
  587.  
  588.     val = integer_arg(args);
  589.     obj = cadr(args);
  590.     while (nodetype(obj) != ARRAY && NOT_THROWING) {
  591.     setcar(cdr(args), err_logo(BAD_DATA, obj));
  592.     obj = cadr(args);
  593.     }
  594.     cont = car(cddr(args));
  595.     if (NOT_THROWING) {
  596.     i = getint(val);
  597.     if (safe) {
  598.         while (circular(obj,cont) && NOT_THROWING) {
  599.         setcar(cddr(args), err_logo(BAD_DATA, cont));
  600.         cont = car(cddr(args));
  601.         }
  602.     }
  603.     if (NOT_THROWING) {
  604.         i -= getarrorg(obj);
  605.         if (i < 0 || i >= getarrdim(obj))
  606.         err_logo(BAD_DATA_UNREC, val);
  607.         else {
  608.         val = (getarrptr(obj))[i];
  609.         (getarrptr(obj))[i] = vref(cont);
  610.         deref(val);
  611.         }
  612.     }
  613.     }
  614.     return(UNBOUND);
  615. }
  616.  
  617. NODE *lsetitem(NODE *args) {
  618.     return setitem_helper(args, TRUE);
  619. }
  620.  
  621. NODE *l_setitem(NODE *args) {
  622.     return setitem_helper(args, FALSE);
  623. }
  624.  
  625. NODE *larray(NODE *args)
  626. {
  627.     NODE *arg;
  628.     int d, o;
  629.  
  630.     arg = pos_int_arg(args);
  631.     if (cdr(args) != NIL) o = int_arg(cdr(args));
  632.     else o = 1;
  633.  
  634.     if (NOT_THROWING) {
  635.     d = getint(arg);
  636.     arg = make_array(d);
  637.     setarrorg(arg,o);
  638.     return arg;
  639.     }
  640.     return UNBOUND;
  641. }
  642.  
  643. FLONUM float_arg(NODE *args)
  644. {
  645.     NODE *arg = car(args), *val;
  646.  
  647.     val = cnv_node_to_numnode(arg);
  648.     while (!is_number(val) && NOT_THROWING) {
  649.     gcref(val);
  650.     setcar(args, err_logo(BAD_DATA, arg));
  651.     arg = car(args);
  652.     val = cnv_node_to_numnode(arg);
  653.     }
  654.     setcar(args,val);
  655.     if (nodetype(val) == FLOAT) return getfloat(val);
  656.     if (nodetype(val) == INT) return (FLONUM)getint(val);
  657.     return 0.0;
  658. }
  659.  
  660. NODE *lform(NODE *args)
  661. {
  662.     FLONUM number;
  663.     int width, precision;
  664.     char result[100];
  665.     char format[20];
  666.  
  667.     number = float_arg(args);
  668.     width = (int)int_arg(cdr(args));
  669.     if (width < 0) {
  670.     print_stringptr = format;
  671.     print_stringlen = 20;
  672.     ndprintf((FILE *)NULL,"%p\n",string_arg(cddr(args)));
  673.     *print_stringptr = '\0';
  674.     } else
  675.     precision = (int)int_arg(cddr(args));
  676.     if (NOT_THROWING) {
  677.     if (width >= 100) width = 99;
  678.     if (width < 0)
  679.         sprintf(result,format,number);
  680.     else
  681.         sprintf(result,"%*.*f",width,precision,number);
  682.     return(make_strnode(result, (char *)NULL, (int)strlen(result),
  683.                 STRING, strnzcpy));
  684.     }
  685.     return(UNBOUND);
  686. }
  687.  
  688. NODE *l_setfirst(NODE *args)
  689. {
  690.     NODE *list, *newval;
  691.  
  692.     list = car(args);
  693.     newval = cadr(args);
  694.     while (NOT_THROWING && (list == NIL || !is_list(list))) {
  695.     setcar(args, err_logo(BAD_DATA,list));
  696.     list = car(args);
  697.     }
  698.     setcar(list,newval);
  699.     return(UNBOUND);
  700. }
  701.  
  702. NODE *l_setbf(NODE *args)
  703. {
  704.     NODE *list, *newval;
  705.  
  706.     list = car(args);
  707.     newval = cadr(args);
  708.     while (NOT_THROWING && (list == NIL || !is_list(list))) {
  709.     setcar(args, err_logo(BAD_DATA,list));
  710.     list = car(args);
  711.     }
  712.     setcdr(list,newval);
  713.     return(UNBOUND);
  714. }
  715.