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