home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / unix / volume13 / funcproglang / part02 < prev    next >
Encoding:
Internet Message Format  |  1988-01-30  |  33.8 KB
  1. Subject:  v13i015:  Functional programming language, Part02/02
  2. Newsgroups: comp.sources.unix
  3. Sender: sources
  4. Approved: rsalz@uunet.UU.NET
  5.  
  6. Submitted-by: Andy Valencia <vandys@lindy.stanford.edu>
  7. Posting-number: Volume 13, Issue 15
  8. Archive-name: funcproglang/part02
  9.  
  10. [  This doesn't have a manual page; for details see Backus's writing
  11.    on FP, and the FP paper in the UCB manuals.  --r$  ]
  12.  
  13. #!/bin/sh
  14. #    This is a shell archive.
  15. #    It contains fp.shar, 2/2
  16. #    Run the following text with /bin/sh to extract.
  17.  
  18. cat - << \Funky!Stuff! > exec.c
  19. /*
  20.  * Execution module for FP.  Runs along the AST and executes actions.
  21.  *
  22.  *    Copyright (c) 1986 by Andy Valencia
  23.  */
  24. #include "fp.h"
  25. #include "y.tab.h"
  26.  
  27.     /*
  28.      * This ugly set of macros makes access to objects easier.
  29.      *
  30.      * UNDEFINED generates the undefined object & returns it
  31.      * NUMVAL generates a value for C of the correct type
  32.      * CAR manipulates the object as a list & gives its first part
  33.      * CDR is like CAR but gives all but the first
  34.      * ISNUM provides a boolean saying if the named object is a number
  35.      */
  36. #define UNDEFINED return(obj_alloc(T_UNDEF));
  37. #define NUMVAL(x) ( ((x)->o_type == T_INT) ? \
  38.     (((x)->o_val).o_int) : (((x)->o_val).o_double) )
  39. #define CAR(x) ( ((x)->o_val).o_list.car )
  40. #define CDR(x) ( ((x)->o_val).o_list.cdr )
  41. #define ISNUM(x) ( ((x)->o_type == T_INT) || (x->o_type == T_FLOAT) )
  42.  
  43. extern struct object *do_charfun(), *do_intrinsics();
  44. static struct object *do_rinsert(), *do_binsert();
  45.  
  46.     /*
  47.      * Given an AST for an action, and an object to do the action upon,
  48.      *    execute the action and return the result.
  49.      */
  50. struct object *
  51. execute( act, obj )
  52.     register struct ast *act;
  53.     register struct object *obj;
  54. {
  55.     register struct object *p, *q;
  56.     int x;
  57.  
  58.     /*
  59.      * Broad categories of executable entities
  60.      */
  61.     switch( act->tag ){
  62.  
  63.     /*
  64.      * Invoke a user-defined function
  65.      */
  66.     case 'U':
  67.     return( invoke( act->val.YYsym, obj) );
  68.  
  69.     /*
  70.      * Right-insert operator
  71.      */
  72.     case '!':
  73.     return( do_rinsert(act->left,obj) );
  74.  
  75.     /*
  76.      * Binary-insert operator
  77.      */
  78.     case '|':
  79.     return( do_binsert(act->left,obj) );
  80.  
  81.     /*
  82.      * Intrinsics
  83.      */
  84.     case 'i':
  85.     return( do_intrinsics(act->val.YYsym, obj) );
  86.  
  87.     /*
  88.      * Select one element from a list
  89.      */
  90.     case 'S':
  91.     if(
  92.         (obj->o_type != T_LIST) ||
  93.         !CAR(obj)
  94.     ){
  95.         obj_unref(obj);
  96.         UNDEFINED;
  97.     }
  98.     p = obj;
  99.     if( (x = act->val.YYint) == 0 ){
  100.         obj_unref(obj);
  101.         UNDEFINED;
  102.     }
  103.  
  104.         /*
  105.          * Negative selectors count from end of list
  106.          */
  107.     if( x < 0 ){
  108.         int tmp = listlen(p);
  109.  
  110.         x += (tmp+1);
  111.         if( x < 0 ){
  112.         obj_unref(obj);
  113.         UNDEFINED;
  114.         }
  115.     }
  116.     while( --x ){        /* Scan down list X times */
  117.         if( !p ) break;
  118.         p = CDR(p);
  119.     }
  120.     if( !p ){        /* Fell off bottom of list */
  121.         obj_unref(obj);
  122.         UNDEFINED;
  123.     }
  124.     p = CAR(p);
  125.     p->o_refs += 1;        /* Add reference to this elem */
  126.     obj_unref(obj);        /* Unreference list as a whole */
  127.     return(p);
  128.  
  129.     /*
  130.      * Apply the action on the left to the result of executing
  131.      *    the action on the right against the object.
  132.      */
  133.     case '@':
  134.     p = execute( act->right, obj );
  135.     return( execute( act->left, p ) );
  136.  
  137.     /*
  138.      * Build a new list by applying the listed actions to the object
  139.      *    All is complicated by the fact that we must be clean in
  140.      *    the presence of T_UNDEF popping up along the way.
  141.      */
  142.     case '[':{
  143.     struct object *hd, **hdp = &hd;
  144.  
  145.     act = act->left;
  146.     hd = (struct object *)0;
  147.     while( act ){
  148.         obj->o_refs += 1;
  149.         if( (p = execute(act->left,obj))->o_type == T_UNDEF ){
  150.         obj_unref(hd);
  151.         obj_unref(obj);
  152.         return(p);
  153.         }
  154.         *hdp = q = obj_alloc(T_LIST);
  155.         hdp = &(CDR(q));
  156.         CAR(q) = p;
  157.         act = act->right;
  158.     }
  159.     obj_unref(obj);
  160.     return(hd);
  161.     }
  162.  
  163.     /*
  164.      * These are the single-character operations (+, -, etc.)
  165.      */
  166.     case 'c':
  167.     return(do_charfun(act,obj));
  168.  
  169.     /*
  170.      * Conditional.  Evaluate & return one of the two paths
  171.      */
  172.     case '>':
  173.     obj->o_refs += 1;
  174.     p = execute(act->left,obj);
  175.     if( p->o_type == T_UNDEF ){
  176.         obj_unref(obj);
  177.         return(p);
  178.     }
  179.     if( p->o_type != T_BOOL ){
  180.         obj_unref(obj);
  181.         obj_unref(p);
  182.         UNDEFINED;
  183.     }
  184.     if( p->o_val.o_int ) q = execute(act->middle,obj);
  185.     else q = execute(act->right,obj);
  186.     obj_unref(p);
  187.     return(q);
  188.  
  189.     /*
  190.      * Apply the action to each member of a list
  191.      */
  192.     case '&': {
  193.     struct object *hd, **hdp = &hd, *r;
  194.  
  195.     hd = 0;
  196.     if( obj->o_type != T_LIST ){
  197.         obj_unref(obj);
  198.         UNDEFINED;
  199.     }
  200.     if( !CAR(obj) ) return(obj);
  201.     for( p = obj; p; p = CDR(p) ){
  202.         (p->o_val.o_list.car)->o_refs += 1;
  203.         if( (q = execute(act->left,CAR(p)))->o_type == T_UNDEF ){
  204.         obj_unref(hd); obj_unref(obj);
  205.         return(q);
  206.         }
  207.         *hdp = r = obj_alloc(T_LIST);
  208.         CAR(r) = q;
  209.         hdp = &CDR(r);
  210.     }
  211.     obj_unref(obj);
  212.     return(hd);
  213.     }
  214.  
  215.     /*
  216.      * Introduce an object
  217.      */
  218.     case '%':
  219.     if( obj->o_type == T_UNDEF ) return(obj);
  220.     obj_unref(obj);
  221.     p = act->val.YYobj;
  222.     p->o_refs += 1;
  223.     return(p);
  224.     
  225.     /*
  226.      * Do a while loop
  227.      */
  228.     case 'W':
  229.     while( 1 ){
  230.         if( obj->o_type == T_UNDEF ){
  231.         obj_unref(obj);
  232.         UNDEFINED;
  233.         }
  234.         obj->o_refs += 1;
  235.         p = execute(act->left,obj);
  236.         if( p->o_type != T_BOOL ){
  237.         obj_unref(obj);
  238.         obj_unref(p);
  239.         UNDEFINED;
  240.         }
  241.         if( p->o_val.o_int ){
  242.         obj_unref(p);
  243.         obj = execute(act->right,obj);
  244.         } else {
  245.         obj_unref(p);
  246.         return(obj);
  247.         }
  248.     }
  249.  
  250.     default:
  251.     fatal_err("Undefined AST tag in execute()");
  252.     }
  253.     /*NOTREACHED*/
  254. }
  255.  
  256.     /*
  257.      * Local function to handle the tedious right-inserting
  258.      */
  259. static struct object *
  260. do_rinsert(act,obj)
  261.     struct ast *act;
  262.     struct object *obj;
  263. {
  264.     register struct object *p, *q;
  265.  
  266.     if( obj->o_type != T_LIST ){
  267.     obj_unref(obj);
  268.     UNDEFINED;
  269.     }
  270.  
  271.     /*
  272.      * If the list is empty, then we need to look at the applied
  273.      *    operator.  If it's one for which we have an identity,
  274.      *    return the identity.  Otherwise, undefined.  Bletch.
  275.      */
  276.     if( !CAR(obj) ){
  277.     obj_unref(obj);
  278.     if( act->tag == 'c' ){
  279.         switch( act->val.YYint ){
  280.         case '+':
  281.         case '-':
  282.         p = obj_alloc(T_INT);
  283.         p->o_val.o_int = 0;
  284.         break;
  285.         case '/':
  286.         case '*':
  287.         p = obj_alloc(T_INT);
  288.         p->o_val.o_int = 1;
  289.         break;
  290.         default:
  291.         UNDEFINED;
  292.         }
  293.     } else if ( act->tag == 'i' ){
  294.         switch( (act->val.YYsym)->sym_val.YYint ){
  295.         case AND:
  296.         p = obj_alloc(T_BOOL);
  297.         p->o_val.o_int = 1;
  298.         break;
  299.         case OR:
  300.         case XOR:
  301.         p = obj_alloc(T_BOOL);
  302.         p->o_val.o_int = 0;
  303.         break;
  304.         default:
  305.         UNDEFINED;
  306.         }
  307.     } else UNDEFINED;
  308.     return(p);
  309.     }
  310.  
  311.     /*
  312.      * If the list has only one element, we return that element.
  313.      */
  314.     if( !(p = CDR(obj)) ){
  315.     p = CAR(obj);
  316.     p->o_refs += 1;
  317.     obj_unref(obj);
  318.     return(p);
  319.     }
  320.  
  321.     /*
  322.      * If the list has two elements, we apply our operator and reduce
  323.      */
  324.     if( !CDR(p) ){
  325.     return( execute(act,obj) );
  326.     }
  327.  
  328.     /*
  329.      * Here's the nasty one.  We have three or more, so recurse on our-
  330.      *    selves to handle all but the first, then apply operation to
  331.      *    first linked onto the result.  Normal business over undefined
  332.      *    objects popping up.
  333.      */
  334.     CDR(obj)->o_refs += 1;
  335.     p = do_rinsert(act,CDR(obj));
  336.     if( p->o_type == T_UNDEF ){
  337.     obj_unref(obj);
  338.     return(p);
  339.     }
  340.     q = obj_alloc(T_LIST);
  341.     CAR(q) = CAR(obj);
  342.     CAR(obj)->o_refs += 1;
  343.     CAR(CDR(q) = obj_alloc(T_LIST)) = p;
  344.     obj_unref(obj);
  345.     return( execute(act,q) );
  346. }
  347.  
  348.     /*
  349.      * Local function to handle the tedious binary inserting
  350.      */
  351. static struct object *
  352. do_binsert(act,obj)
  353.     struct ast *act;
  354.     struct object *obj;
  355. {
  356.     register struct object *p, *q;
  357.     struct object *hd, **hdp, *r;
  358.     int x;
  359.  
  360.     if( obj->o_type != T_LIST ){
  361.     obj_unref(obj);
  362.     UNDEFINED;
  363.     }
  364.  
  365.     /*
  366.      * If the list is empty, then we need to look at the applied
  367.      *    operator.  If it's one for which we have an identity,
  368.      *    return the identity.  Otherwise, undefined.  Bletch.
  369.      */
  370.     if( !CAR(obj) ){
  371.     obj_unref(obj);
  372.     if( act->tag == 'c' ){
  373.         switch( act->val.YYint ){
  374.         case '+':
  375.         case '-':
  376.         p = obj_alloc(T_INT);
  377.         p->o_val.o_int = 0;
  378.         break;
  379.         case '/':
  380.         case '*':
  381.         p = obj_alloc(T_INT);
  382.         p->o_val.o_int = 1;
  383.         break;
  384.         default:
  385.         UNDEFINED;
  386.         }
  387.     } else if ( act->tag == 'i' ){
  388.         switch( (act->val.YYsym)->sym_val.YYint ){
  389.         case AND:
  390.         p = obj_alloc(T_BOOL);
  391.         p->o_val.o_int = 1;
  392.         break;
  393.         case OR:
  394.         case XOR:
  395.         p = obj_alloc(T_BOOL);
  396.         p->o_val.o_int = 0;
  397.         break;
  398.         default:
  399.         UNDEFINED;
  400.         }
  401.     } else UNDEFINED;
  402.     return(p);
  403.     }
  404.  
  405.     /*
  406.      * If the list has only one element, we return that element.
  407.      */
  408.     if( !(p = CDR(obj)) ){
  409.     p = CAR(obj);
  410.     p->o_refs += 1;
  411.     obj_unref(obj);
  412.     return(p);
  413.     }
  414.  
  415.     /*
  416.      * If the list has two elements, we apply our operator and reduce
  417.      */
  418.     if( !CDR(p) ){
  419.     return( execute(act,obj) );
  420.     }
  421.  
  422.     /*
  423.      * For three or more elements, we must set up to split the list
  424.      *    into halves.  For every two steps which 'p' makes forward,
  425.      *    'q' advances one.  When 'p' hits the end, 'q' names the 2nd
  426.      *    half, and 'hd' names a copy of the first.
  427.      */
  428.     x = 0;
  429.     hd = 0;
  430.     hdp = &hd;
  431.     for( q = obj; p; p = CDR(p) ){
  432.     if( x ){
  433.         *hdp = r = obj_alloc(T_LIST);
  434.         hdp = &CDR(r);
  435.         CAR(r) = CAR(q);
  436.         CAR(q)->o_refs += 1;
  437.         q = CDR(q);
  438.         x = 0;
  439.     } else
  440.         x = 1;
  441.     }
  442.     *hdp = p = obj_alloc(T_LIST);
  443.     CAR(p) = CAR(q);
  444.     CAR(q)->o_refs += 1;
  445.  
  446.     /*
  447.      * 'q' names the second half, but we must add a reference, otherwise
  448.      *    our use of it via execute() will consume it (and obj still
  449.      *    references it...).
  450.      */
  451.     q = CDR(q);
  452.     q->o_refs += 1;
  453.  
  454.     /*
  455.      * Almost there... "hd" is the first, "q" is the second, we encase
  456.      *    them in an outer list, and call execute on them.
  457.      */
  458.     p = obj_alloc(T_LIST);
  459.     CAR(p) = do_binsert(act,hd);
  460.     CAR(CDR(p) = obj_alloc(T_LIST)) = do_binsert(act,q);
  461.     obj_unref(obj);
  462.     return(execute(act,p));
  463. }
  464. Funky!Stuff!
  465. cat - << \Funky!Stuff! > intrin.c
  466. /*
  467.  * intrin.c--intrinsic functions for FP.  These are the ones which
  468.  *    parse as an identifier, and are symbol-tabled.
  469.  *
  470.  *     Copyright (c) 1986 by Andy Valencia
  471.  */
  472. #include "fp.h"
  473. #include "y.tab.h"
  474. #include "math.h"
  475.  
  476.     /*
  477.      * This ugly set of macros makes access to objects easier.
  478.      *
  479.      * UNDEFINED generates the undefined object & returns it
  480.      * NUMVAL generates a value for C of the correct type
  481.      * CAR manipulates the object as a list & gives its first part
  482.      * CDR is like CAR but gives all but the first
  483.      * ISNUM provides a boolean saying if the named object is a number
  484.      */
  485. #define UNDEFINED return(obj_alloc(T_UNDEF));
  486. #define NUMVAL(x) ( (x->o_type == T_INT) ? \
  487.     ((x->o_val).o_int) : ((x->o_val).o_double) )
  488. #define CAR(x) ( ((x)->o_val).o_list.car )
  489. #define CDR(x) ( ((x)->o_val).o_list.cdr )
  490. #define ISNUM(x) ( (x->o_type == T_INT) || (x->o_type == T_FLOAT) )
  491.  
  492. static struct object *do_dist(), *do_trans(), *do_bool();
  493. extern int numargs();
  494. extern struct object *eqobj();
  495.  
  496.     /*
  497.      * Main intrinsic processing routine
  498.      */
  499. struct object *
  500. do_intrinsics(act,obj)
  501.     struct symtab *act;
  502.     register struct object *obj;
  503. {
  504.     register struct object *p, *q;
  505.     double f;
  506.  
  507.     /*
  508.      * Switch off the tokenal value assigned by YACC.  Depending on the
  509.      *    sophistication of your C compiler, this can generate some
  510.      *    truly horrendous code.  Be prepared!  Perhaps it would be
  511.      *    better to store a pointer to a function in with the symbol
  512.      *    table...
  513.      */
  514.     switch( act->sym_val.YYint ){
  515.  
  516.     case LENGTH:{    /* Length of a list */
  517.     int l;
  518.  
  519.     if( obj->o_type != T_LIST ){
  520.         obj_unref(obj);
  521.         UNDEFINED;
  522.     }
  523.     for( p = obj, l = 0; p && CAR(p); p = CDR(p) ) l++;
  524.     obj_unref(obj);
  525.     p = obj_alloc(T_INT);
  526.     p->o_val.o_int = l;
  527.     return(p);
  528.     }
  529.  
  530.     case ID:        /* Identity */
  531.     return(obj);
  532.     case OUT:        /* Identity, but print debug line too */
  533.     printf("out: ");
  534.     obj_prtree(obj);
  535.     putchar('\n');
  536.     return(obj);
  537.     
  538.     case FIRST:
  539.     case HD:        /* First elem of a list */
  540.     if( obj->o_type != T_LIST ){
  541.         obj_unref(obj); UNDEFINED;
  542.     }
  543.     if( !(p = CAR(obj)) ) return(obj);
  544.     p->o_refs += 1;
  545.     obj_unref(obj);
  546.     return(p);
  547.  
  548.     case TL:        /* Remainder of list */
  549.     if( (obj->o_type != T_LIST) || !CAR(obj) ){
  550.         obj_unref(obj); UNDEFINED;
  551.     }
  552.     if( !(p = CDR(obj)) ){
  553.         p = obj_alloc(T_LIST);
  554.     } else {
  555.         p->o_refs += 1;
  556.     }
  557.     obj_unref(obj);
  558.     return(p);
  559.  
  560.     case IOTA:{        /* Given arg N, generate <1..N> */
  561.     int x, l;
  562.     struct object *hd, **hdp = &hd;
  563.  
  564.     if( (obj->o_type != T_INT) && (obj->o_type != T_FLOAT) ){
  565.         obj_unref(obj);
  566.         UNDEFINED;
  567.     }
  568.     l = (obj->o_type == T_INT) ? obj->o_val.o_int : obj->o_val.o_double;
  569.     obj_unref(obj);
  570.     if( l < 0 ) UNDEFINED;
  571.     if( l == 0 ) return( obj_alloc(T_LIST) );
  572.     for( x = 1; x <= l; x++ ){
  573.         *hdp = p = obj_alloc(T_LIST);
  574.         q = obj_alloc(T_INT);
  575.         q->o_val.o_int = x;
  576.         CAR(p) = q;
  577.         hdp = &CDR(p);
  578.     }
  579.     return(hd);
  580.     } /* Local block for IOTA */
  581.  
  582.     case PICK:{        /* Parameterized selection */
  583.     int x;
  584.  
  585.         /*
  586.          * Verify all elements which we will use
  587.          */
  588.     if(
  589.         (obj->o_type != T_LIST) ||
  590.         ( (p = CAR(obj))->o_type != T_INT ) ||
  591.         !(q = CDR(obj)) ||
  592.         ( (q = CAR(q))->o_type != T_LIST) ||
  593.         ( (x = p->o_val.o_int) == 0 )
  594.     ){
  595.         obj_unref(obj);
  596.         UNDEFINED;
  597.     }
  598.  
  599.         /*
  600.          * If x is negative, we are counting from the end
  601.          */
  602.     if( x < 0 ){
  603.         int tmp = listlen(q);
  604.  
  605.         x += (tmp + 1);
  606.         if( x < 1 ){
  607.         obj_unref(obj);
  608.         UNDEFINED;
  609.         }
  610.     }
  611.  
  612.         /*
  613.          * Loop along the list until our count is expired
  614.          */
  615.     for( ; x > 1; --x ){
  616.         if( !q ) break;
  617.         q = CDR(q);
  618.     }
  619.  
  620.         /*
  621.          * If fell off the list, error
  622.          */
  623.     if( !q || !(q = CAR(q)) ){
  624.         obj_unref(obj);
  625.         UNDEFINED;
  626.     }
  627.  
  628.         /*
  629.          * Add a reference to the named object, release the old object
  630.          */
  631.     q->o_refs += 1;
  632.     obj_unref(obj);
  633.     return(q);
  634.     }
  635.  
  636.     case LAST:        /* Return last element of list */
  637.     if( (q = obj)->o_type != T_LIST ){
  638.         obj_unref(obj);
  639.         UNDEFINED;
  640.     }
  641.     if( !CAR(obj) ) return(obj);
  642.     while( p = CDR(q) ) q = p;
  643.     q = CAR(q);
  644.     q->o_refs += 1;
  645.     obj_unref(obj);
  646.     return(q);
  647.     
  648.     case FRONT:
  649.     case TLR:{        /* Return a list of all but list */
  650.     struct object *hd = 0, **hdp = &hd;
  651.  
  652.     if(
  653.         ((q = obj)->o_type != T_LIST) ||
  654.         !CAR(obj)
  655.     ){
  656.         obj_unref(obj);
  657.         UNDEFINED;
  658.     }
  659.     while( CDR(q) ){
  660.         *hdp = p = obj_alloc(T_LIST);
  661.         if( CAR(p) = CAR(q) ){
  662.         CAR(p)->o_refs += 1;
  663.         }
  664.         hdp = &CDR(p);
  665.         q = CDR(q);
  666.     }
  667.     obj_unref(obj);
  668.     if( !hd ) return( obj_alloc(T_LIST) );
  669.     else return(hd);
  670.     }
  671.  
  672.     case DISTL:        /* Distribute from left-most element */
  673.     if(
  674.         (obj->o_type != T_LIST) ||
  675.         ( !(q = CAR(obj)) ) ||
  676.         (!CDR(obj)) ||
  677.         (!(p = CAR(CDR(obj))) ) ||
  678.         (p->o_type != T_LIST)
  679.     ){
  680.         obj_unref(obj);
  681.         UNDEFINED;
  682.     }
  683.     return( do_dist(q,p,obj,0) );
  684.  
  685.     case DISTR:        /* Distribute from left-most element */
  686.     if(
  687.         (obj->o_type != T_LIST) ||
  688.         ( !(q = CAR(obj)) ) ||
  689.         (!CDR(obj)) ||
  690.         (!(p = CAR(CDR(obj))) ) ||
  691.         (q->o_type != T_LIST)
  692.     ){
  693.         obj_unref(obj);
  694.         UNDEFINED;
  695.     }
  696.     return( do_dist(p,q,obj,1) );
  697.     
  698.     case APNDL:{    /* Append element from left */
  699.     struct object *r;
  700.  
  701.     if(
  702.         (obj->o_type != T_LIST) ||
  703.         ( !(q = CAR(obj)) ) ||
  704.         (!CDR(obj)) ||
  705.         (!(p = CAR(CDR(obj))) ) ||
  706.         (p->o_type != T_LIST)
  707.     ){
  708.         obj_unref(obj);
  709.         UNDEFINED;
  710.     }
  711.     q->o_refs += 1;
  712.     if( !CAR(p) ){        /* Null list? */
  713.         obj_unref(obj);
  714.         p = obj_alloc(T_LIST);
  715.         CAR(p) = q;
  716.         return(p);        /* Just return element */
  717.     }
  718.     p->o_refs += 1;
  719.     r = obj_alloc(T_LIST);
  720.     CDR(r) = p;
  721.     CAR(r) = q;
  722.     obj_unref(obj);
  723.     return(r);
  724.     }
  725.  
  726.     case APNDR:{    /* Append element from right */
  727.     struct object *hd = 0, **hdp = &hd, *r;
  728.  
  729.     if(
  730.         (obj->o_type != T_LIST) ||
  731.         ( !(q = CAR(obj)) ) ||
  732.         (!CDR(obj)) ||
  733.         (!(r = CAR(CDR(obj))) ) ||
  734.         (q->o_type != T_LIST)
  735.     ){
  736.         obj_unref(obj);
  737.         UNDEFINED;
  738.     }
  739.     r->o_refs += 1;
  740.     if( !CAR(q) ){        /* Empty list */
  741.         obj_unref(obj);
  742.         p = obj_alloc(T_LIST);
  743.         CAR(p) = r;
  744.         return(p);        /* Just return elem */
  745.     }
  746.  
  747.         /*
  748.          * Loop through list, building a new one.  We can't just reuse
  749.          *    the old one because we're modifying its end.
  750.          */
  751.     while( q ){
  752.         *hdp = p = obj_alloc(T_LIST);
  753.         CAR(q)->o_refs += 1;
  754.         CAR(p) = CAR(q);
  755.         hdp = &CDR(p);
  756.         q = CDR(q);
  757.     }
  758.  
  759.         /*
  760.          * Tack the element onto the end of the built list
  761.          */
  762.     *hdp = p = obj_alloc(T_LIST);
  763.     CAR(p) = r;
  764.     obj_unref(obj);
  765.     return(hd);
  766.     }
  767.  
  768.     case TRANS:        /* Transposition */
  769.     return( do_trans(obj) );
  770.     
  771.     case REVERSE:{    /* Reverse all elements of a list */
  772.     struct object *r;
  773.  
  774.     if( obj->o_type != T_LIST ){
  775.         obj_unref(obj);
  776.         UNDEFINED;
  777.     }
  778.     if( !CAR(obj) ) return(obj);
  779.     for( p = 0, q = obj; q; q = CDR(q) ){
  780.         r = obj_alloc(T_LIST);
  781.         CDR(r) = p;
  782.         p = r;
  783.         CAR(p) = CAR(q);
  784.         CAR(q)->o_refs += 1;
  785.     }
  786.     obj_unref(obj);
  787.     return(p);
  788.     }
  789.  
  790.     case ROTL:{        /* Rotate left */
  791.     struct object *hd = 0, **hdp = &hd;
  792.  
  793.         /*
  794.          * Wanna list
  795.          */
  796.     if( obj->o_type != T_LIST ){
  797.         obj_unref(obj);
  798.         UNDEFINED;
  799.     }
  800.  
  801.         /*
  802.          * Need two elems, otherwise be ID function
  803.          */
  804.     if(
  805.         !(CAR(obj)) ||
  806.         !(q = CDR(obj)) ||
  807.         !(CAR(q))
  808.     ){
  809.         return(obj);
  810.     }
  811.  
  812.         /*
  813.          * Loop, starting from second.  Build parallel list.
  814.          */
  815.     for( /* q has CDR(obj) */ ; q; q = CDR(q) ){
  816.         *hdp = p = obj_alloc(T_LIST);
  817.         hdp = &CDR(p);
  818.         CAR(p) = CAR(q);
  819.         CAR(q)->o_refs += 1;
  820.     }
  821.     *hdp = p = obj_alloc(T_LIST);
  822.     CAR(p) = CAR(obj);
  823.     CAR(obj)->o_refs += 1;
  824.     obj_unref(obj);
  825.     return(hd);
  826.     }
  827.  
  828.     case ROTR:{        /* Rotate right */
  829.     struct object *hd = 0, **hdp = &hd;
  830.  
  831.         /*
  832.          * Wanna list
  833.          */
  834.     if( obj->o_type != T_LIST ){
  835.         obj_unref(obj);
  836.         UNDEFINED;
  837.     }
  838.  
  839.         /*
  840.          * Need two elems, otherwise be ID function
  841.          */
  842.     if(
  843.         !(CAR(obj)) ||
  844.         !(q = CDR(obj)) ||
  845.         !(CAR(q))
  846.     ){
  847.         return(obj);
  848.     }
  849.  
  850.         /*
  851.          * Loop over list.  Stop one short of end.
  852.          */
  853.     for( q = obj; CDR(q); q = CDR(q) ){
  854.         *hdp = p = obj_alloc(T_LIST);
  855.         hdp = &CDR(p);
  856.         CAR(p) = CAR(q);
  857.         CAR(q)->o_refs += 1;
  858.     }
  859.     p = obj_alloc(T_LIST);
  860.     CAR(p) = CAR(q);
  861.     CAR(q)->o_refs += 1;
  862.     CDR(p) = hd;
  863.     obj_unref(obj);
  864.     return(p);
  865.     }
  866.  
  867.     case CONCAT:{        /* Concatenate several lists */
  868.     struct object *hd = 0, **hdp = &hd, *r;
  869.  
  870.     if( obj->o_type != T_LIST ){
  871.         obj_unref(obj);
  872.         UNDEFINED;
  873.     }
  874.     if( !CAR(obj) ) return(obj);
  875.     for( p = obj; p; p = CDR(p) ){
  876.         q = CAR(p);
  877.         if( q->o_type != T_LIST ){
  878.         obj_unref(obj);
  879.         obj_unref(hd);
  880.         UNDEFINED;
  881.         }
  882.         if( !CAR(q) ) continue;
  883.         for( ; q; q = CDR(q) ){
  884.         *hdp = r = obj_alloc(T_LIST);
  885.         hdp = &CDR(r);
  886.         CAR(r) = CAR(q);
  887.         CAR(q)->o_refs += 1;
  888.         }
  889.     }
  890.     obj_unref(obj);
  891.     if( !hd )
  892.         return(obj_alloc(T_LIST));
  893.     return(hd);
  894.     }
  895.  
  896.     case SIN:        /* sin() function */
  897.     if( !ISNUM(obj) ){
  898.         obj_unref(obj);
  899.         UNDEFINED;
  900.     }
  901.     p = obj_alloc(T_FLOAT);
  902.     f = NUMVAL(obj);
  903.     p->o_val.o_double = sin(f);
  904.     obj_unref(obj);
  905.     return(p);
  906.  
  907.     case COS:        /* cos() function */
  908.     if( !ISNUM(obj) ){
  909.         obj_unref(obj);
  910.         UNDEFINED;
  911.     }
  912.     p = obj_alloc(T_FLOAT);
  913.     f = NUMVAL(obj);
  914.     p->o_val.o_double = cos(f);
  915.     obj_unref(obj);
  916.     return(p);
  917.  
  918.     case TAN:        /* tan() function */
  919.     if( !ISNUM(obj) ){
  920.         obj_unref(obj);
  921.         UNDEFINED;
  922.     }
  923.     p = obj_alloc(T_FLOAT);
  924.     f = NUMVAL(obj);
  925.     p->o_val.o_double = tan(f);
  926.     obj_unref(obj);
  927.     return(p);
  928.  
  929.     case ASIN:        /* asin() function */
  930.     if( !ISNUM(obj) ){
  931.         obj_unref(obj);
  932.         UNDEFINED;
  933.     }
  934.     p = obj_alloc(T_FLOAT);
  935.     f = NUMVAL(obj);
  936.     p->o_val.o_double = asin(f);
  937.     obj_unref(obj);
  938.     return(p);
  939.  
  940.     case ACOS:        /* acos() function */
  941.     if( !ISNUM(obj) ){
  942.         obj_unref(obj);
  943.         UNDEFINED;
  944.     }
  945.     p = obj_alloc(T_FLOAT);
  946.     f = NUMVAL(obj);
  947.     p->o_val.o_double = acos(f);
  948.     obj_unref(obj);
  949.     return(p);
  950.  
  951.     case ATAN:        /* atan() function */
  952.     if( !ISNUM(obj) ){
  953.         obj_unref(obj);
  954.         UNDEFINED;
  955.     }
  956.     p = obj_alloc(T_FLOAT);
  957.     f = NUMVAL(obj);
  958.     p->o_val.o_double = atan(f);
  959.     obj_unref(obj);
  960.     return(p);
  961.     
  962.     case EXP:        /* exp() function */
  963.     if( !ISNUM(obj) ){
  964.         obj_unref(obj);
  965.         UNDEFINED;
  966.     }
  967.     p = obj_alloc(T_FLOAT);
  968.     f = NUMVAL(obj);
  969.     p->o_val.o_double = exp(f);
  970.     obj_unref(obj);
  971.     return(p);
  972.     
  973.     case LOG:        /* log() function */
  974.     if( !ISNUM(obj) ){
  975.         obj_unref(obj);
  976.         UNDEFINED;
  977.     }
  978.     p = obj_alloc(T_FLOAT);
  979.     f = NUMVAL(obj);
  980.     p->o_val.o_double = log(f);
  981.     obj_unref(obj);
  982.     return(p);
  983.     
  984.     case MOD:        /* Modulo */
  985.     switch( numargs(obj) ){
  986.     case T_UNDEF:
  987.         obj_unref(obj);
  988.         UNDEFINED;
  989.     case T_FLOAT:
  990.     case T_INT:{
  991.         int x1, x2;
  992.  
  993.         x1 = NUMVAL(CAR(obj));
  994.         if( (x2 = NUMVAL(CAR(CDR(obj)))) == 0 ){
  995.         obj_unref(obj);
  996.         UNDEFINED;
  997.         }
  998.         p = obj_alloc(T_INT);
  999.         (p->o_val).o_int = x1 % x2;
  1000.         obj_unref(obj);
  1001.         return(p);
  1002.     }
  1003.     }
  1004.     
  1005.     case PAIR:{        /* Pair up successive elements of a list */
  1006.     struct object *hd = 0, **hdp = &hd, *r;
  1007.     int x;
  1008.  
  1009.     if(
  1010.         (obj->o_type != T_LIST) ||
  1011.         !CAR(obj)
  1012.     ){
  1013.         obj_unref(obj);
  1014.         UNDEFINED;
  1015.     }
  1016.     for( p = obj, x = 0; p; p = CDR(p) ){
  1017.         if( x == 0 ){
  1018.         *hdp = q = obj_alloc(T_LIST);
  1019.         hdp = &CDR(q);
  1020.         CAR(q) = r = obj_alloc(T_LIST);
  1021.         CAR(r) = CAR(p);
  1022.         CAR(p)->o_refs += 1;
  1023.         x++;
  1024.         } else {
  1025.         CDR(r) = q = obj_alloc(T_LIST);
  1026.         CAR(q) = CAR(p);
  1027.         CAR(p)->o_refs += 1;
  1028.         x = 0;
  1029.         }
  1030.     }
  1031.     obj_unref(obj);
  1032.     return(hd);
  1033.     }
  1034.  
  1035.     case SPLIT:{    /* Split list into two (roughly) equal halves */
  1036.     int l,x;
  1037.     struct object *hd = 0, **hdp = &hd, *top;
  1038.  
  1039.     if(
  1040.         (obj->o_type != T_LIST) ||
  1041.         ( (l = listlen(obj)) == 0 )
  1042.     ){
  1043.         obj_unref(obj);
  1044.         UNDEFINED;
  1045.     }
  1046.     l = ((l-1) >> 1)+1;
  1047.     for( x = 0, p = obj; x < l; ++x, p = CDR(p) ){
  1048.         *hdp = q = obj_alloc(T_LIST);
  1049.         hdp = &CDR(q);
  1050.         CAR(q) = CAR(p);
  1051.         CAR(p)->o_refs += 1;
  1052.     }
  1053.     CAR(top = obj_alloc(T_LIST)) = hd;
  1054.     hd = 0; hdp = &hd;
  1055.     while(p){
  1056.         *hdp = q = obj_alloc(T_LIST);
  1057.         hdp = &CDR(q);
  1058.         CAR(q) = CAR(p);
  1059.         CAR(p)->o_refs += 1;
  1060.         p = CDR(p);
  1061.     }
  1062.     if( !hd ) hd = obj_alloc(T_LIST);
  1063.     CAR(CDR(top) = obj_alloc(T_LIST)) = hd;
  1064.     obj_unref(obj);
  1065.     return(top);
  1066.     }
  1067.  
  1068.     case ATOM:{
  1069.     int result;
  1070.  
  1071.     switch( obj->o_type ){
  1072.     case T_UNDEF:
  1073.         return(obj);
  1074.     case T_INT:
  1075.     case T_BOOL:
  1076.     case T_FLOAT:
  1077.         result = 1;
  1078.         break;
  1079.     default:
  1080.         result = 0;
  1081.     }
  1082.     p = obj_alloc(T_BOOL);
  1083.     p->o_val.o_int = result;
  1084.     obj_unref(obj);
  1085.     return(p);
  1086.     }
  1087.  
  1088.     case DIV:        /* Like '/', but forces integer operation */
  1089.     switch( numargs(obj) ){
  1090.     case T_UNDEF:
  1091.         obj_unref(obj);
  1092.         UNDEFINED;
  1093.     case T_FLOAT:
  1094.     case T_INT:{
  1095.         int x1, x2;
  1096.  
  1097.         x1 = NUMVAL(CAR(obj));
  1098.         if( (x2 = NUMVAL(CAR(CDR(obj)))) == 0 ){
  1099.         obj_unref(obj);
  1100.         UNDEFINED;
  1101.         }
  1102.         p = obj_alloc(T_INT);
  1103.         (p->o_val).o_int = x1 / x2;
  1104.         obj_unref(obj);
  1105.         return(p);
  1106.     }
  1107.     }
  1108.     
  1109.  
  1110.     case NIL:
  1111.     if( obj->o_type != T_LIST ){
  1112.         obj_unref(obj);
  1113.         UNDEFINED;
  1114.     }
  1115.     p = obj_alloc(T_BOOL);
  1116.     if( CAR(obj) ) p->o_val.o_int = 0;
  1117.     else p->o_val.o_int = 1;
  1118.     obj_unref(obj);
  1119.     return(p);
  1120.     
  1121.     case EQ:
  1122.     return( eqobj(obj) );
  1123.     
  1124.     case AND:
  1125.     return( do_bool(obj,AND) );
  1126.     case OR:
  1127.     return( do_bool(obj,OR) );
  1128.     case XOR:
  1129.     return( do_bool(obj,XOR) );
  1130.     case NOT:
  1131.     if( obj->o_type != T_BOOL ){
  1132.         obj_unref(obj);
  1133.         UNDEFINED;
  1134.     }
  1135.     (p = obj_alloc(T_BOOL))->o_val.o_int = !obj->o_val.o_int;
  1136.     obj_unref(obj);
  1137.     return(p);
  1138.     
  1139.     default:
  1140.     fatal_err("Unrecognized symbol in do_intrinsics()");
  1141.     } /* Switch() */
  1142.     /*NOTREACHED*/
  1143. }
  1144.  
  1145.     /*
  1146.      * listlen()--return length of a list
  1147.      */
  1148. listlen(p)
  1149.     register struct object *p;
  1150. {
  1151.     register l = 0;
  1152.  
  1153.     while( p && CAR(p) ){
  1154.     ++l;
  1155.     p = CDR(p);
  1156.     }
  1157.     return(l);
  1158. }
  1159.  
  1160.     /*
  1161.      * Common code between distribute-left and -right
  1162.      */
  1163. static struct object *
  1164. do_dist(elem,lst,obj,side)
  1165.     register struct object *elem, *lst;
  1166.     struct object *obj;        /* Source object */
  1167.     int side;            /* Which side to stick on */
  1168. {
  1169.     register struct object *r, *r2;
  1170.     struct object *hd, **hdp = &hd;
  1171.  
  1172.     if( !CAR(lst) ){        /* Distributing over NULL list */
  1173.     lst->o_refs += 1;
  1174.     obj_unref(obj);
  1175.     return(lst);
  1176.     }
  1177.  
  1178.     /*
  1179.      * Evil C!  Line-by-line, here's what's happening
  1180.      * 1. Get the first list element for the "lower" list
  1181.      * 2. Bind the CAR of it to the distributing object,
  1182.      *    incrementing that object's reference counter.
  1183.      * 3. Get the second element for the "lower" list, bind
  1184.      *    the CDR of the first element to it.
  1185.      * 4. Bind the CAR of the second element to the current
  1186.      *    element in the list being distributed over, increment
  1187.      *    that object's reference count.
  1188.      * 5. Allocate the "upper" list element, build it into the
  1189.      *    chain.
  1190.      * 6. Advance the chain building pointer to be ready to add
  1191.      *    the next element.
  1192.      * 7. Advance to next element of list being distributed over.
  1193.      *
  1194.      *  Gee, wasn't that easy?
  1195.      */
  1196.     while( lst ){
  1197.     r = obj_alloc(T_LIST);
  1198.     if( !side ){
  1199.         CAR(r) = elem;
  1200.         elem->o_refs += 1;
  1201.     } else {
  1202.         CAR(r) = CAR(lst);
  1203.         CAR(lst)->o_refs += 1;
  1204.     }
  1205.     r2 = CDR(r) = obj_alloc(T_LIST);
  1206.     if( !side ){
  1207.         CAR(r2) = CAR(lst);
  1208.         CAR(lst)->o_refs += 1;
  1209.     } else {
  1210.         CAR(r2) = elem;
  1211.         elem->o_refs += 1;
  1212.     }
  1213.     *hdp = obj_alloc(T_LIST);
  1214.     CAR(*hdp) = r;
  1215.     hdp = &CDR(*hdp);
  1216.  
  1217.     lst = CDR(lst);
  1218.     }
  1219.     obj_unref(obj);
  1220.     return(hd);
  1221. }
  1222.  
  1223.     /*
  1224.      * do_trans()--transpose the elements of the "matrix"
  1225.      */
  1226. static struct object *
  1227. do_trans(obj)
  1228.     register struct object *obj;
  1229. {
  1230.     int len = 0, x, y;
  1231.     register struct object *p, *q, *r;
  1232.     struct object *hd = 0, **hdp = &hd;
  1233.  
  1234.     /*
  1235.      * Check argument, make sure first element is a list.
  1236.      */
  1237.     if(
  1238.     ( (p = obj)->o_type != T_LIST) ||
  1239.     !( p = CAR(obj) ) ||
  1240.     ( p->o_type != T_LIST )
  1241.     ){
  1242.     obj_unref(obj);
  1243.     UNDEFINED;
  1244.     }
  1245.  
  1246.     /*
  1247.      * Get how many down (len)
  1248.      */
  1249.     len = listlen(p);
  1250.  
  1251.     /*
  1252.      * Verify the structure.  Make sure each across is a list,
  1253.      *    and of the same length.
  1254.      */
  1255.     for( q = obj; q ; q = CDR(q) ){
  1256.     r = CAR(q);
  1257.     if(
  1258.         (r->o_type != T_LIST) ||
  1259.         (listlen(r) != len)
  1260.     ){
  1261.         obj_unref(obj);
  1262.         UNDEFINED;
  1263.     }
  1264.     }
  1265.  
  1266.     /*
  1267.      * By definition, list of NULL lists returns <>
  1268.      */
  1269.     if( len == 0 ){
  1270.     obj_unref(obj);
  1271.     return( obj_alloc(T_LIST) );
  1272.     }
  1273.  
  1274.     /*
  1275.      * Here is an O(n^3) way of building a transposed matrix.
  1276.      *    Loop over each depth, building across.  I'm so debonnair
  1277.      *    about it because I never use this blinking function.
  1278.      */
  1279.     for( x = 0; x < len; ++x ){
  1280.     struct object *s = obj_alloc(T_LIST), *hd2 = 0, **hdp2 = &hd2;
  1281.  
  1282.     *hdp = s;
  1283.     hdp = &CDR(s);
  1284.     for( p = obj; p; p = CDR(p) ){
  1285.         q = CAR(p);
  1286.         for( y = 0; y < x; ++y )
  1287.         q = CDR(q);
  1288.         q = CAR(q);
  1289.         r = obj_alloc(T_LIST);
  1290.         *hdp2 = r;
  1291.         hdp2 = &CDR(r);
  1292.         CAR(r) = q;
  1293.         q->o_refs += 1;
  1294.     }
  1295.     CAR(s) = hd2;
  1296.     }
  1297.     obj_unref(obj);
  1298.     return(hd);
  1299. }
  1300.  
  1301.     /*
  1302.      * do_bool()--do the three boolean binary operators
  1303.      */
  1304. static struct object *
  1305. do_bool(obj,op)
  1306.     struct object *obj;
  1307.     int op;
  1308. {
  1309.     register struct object *p, *q;
  1310.     struct object *r;
  1311.     int i;
  1312.  
  1313.     if(
  1314.     (obj->o_type != T_LIST) ||
  1315.     ( (p = CAR(obj))->o_type != T_BOOL) ||
  1316.     ( (q = CAR(CDR(obj)))->o_type != T_BOOL)
  1317.     ){
  1318.     obj_unref(obj);
  1319.     UNDEFINED;
  1320.     }
  1321.     r = obj_alloc(T_BOOL);
  1322.     switch( op ){
  1323.     case AND:
  1324.     i = p->o_val.o_int && q->o_val.o_int;
  1325.     break;
  1326.     case OR:
  1327.     i = p->o_val.o_int || q->o_val.o_int;
  1328.     break;
  1329.     case XOR:
  1330.     i = (p->o_val.o_int || q->o_val.o_int) &&
  1331.         !(p->o_val.o_int && q->o_val.o_int);
  1332.     break;
  1333.     default:
  1334.     fatal_err("Illegal binary logical op in do_bool()");
  1335.     }
  1336.     r->o_val.o_int = i;
  1337.     obj_unref(obj);
  1338.     return(r);
  1339. }
  1340. Funky!Stuff!
  1341. cat - << \Funky!Stuff! > lex.c
  1342. /*
  1343.  * A standard lexical analyzer
  1344.  *
  1345.  *    Copyright (c) 1986 by Andy Valencia
  1346.  */
  1347. #include "symtab.h"
  1348. #include <stdio.h>
  1349. #include <ctype.h>
  1350.  
  1351. static char buf[80];
  1352. static int donum();
  1353. extern YYSTYPE yylval;
  1354. extern void exit(), perror();
  1355.  
  1356. static FILE *cur_in = stdin;
  1357. static nextc();
  1358. char prompt;
  1359.  
  1360. #define MAXNEST 5        /* How deep can we get? */
  1361. static FILE *fstack[MAXNEST];    /* For nested loads */
  1362. static int fpos = 0;
  1363.  
  1364.     /*
  1365.      * Skip leading white space in current input stream
  1366.      */
  1367. static void
  1368. skipwhite(){
  1369.     register c;
  1370.  
  1371.     /*
  1372.      * Skip leading blank space
  1373.      */
  1374.     while( (c = nextc()) != EOF )
  1375.     if( !isspace(c) ) break;
  1376.     ungetc(c,cur_in);
  1377. }
  1378.  
  1379.     /*
  1380.      * Lexical analyzer for YACC
  1381.      */
  1382. yylex(){
  1383.     register char *p = buf;
  1384.     register c, c1;
  1385.  
  1386.     /*
  1387.      * Skip over white space
  1388.      */
  1389. again:
  1390.     skipwhite();
  1391.     c = nextc();
  1392.  
  1393.     /*
  1394.      * Return EOF
  1395.      */
  1396.     if( c == EOF ) return(c);
  1397.  
  1398.     /*
  1399.      * An "identifier"?
  1400.      */
  1401.     if( isalpha(c) ){
  1402.     struct symtab *q;
  1403.  
  1404.         /*
  1405.          * Assemble a "word" out of the input stream, symbol table it
  1406.          */
  1407.     *p++ = c;
  1408.     while( isalnum(c = nextc()) ) *p++ = c;
  1409.     ungetc(c,cur_in);
  1410.     *p = '\0';
  1411.     q = lookup(buf);
  1412.  
  1413.         /*
  1414.          * yylval is always set to the symbol table entry
  1415.          */
  1416.     yylval.YYsym = q;
  1417.  
  1418.         /*
  1419.          * For built-ins, return the token value
  1420.          */
  1421.     if( q->sym_type == SYM_BUILTIN ) return( q->sym_val.YYint );
  1422.  
  1423.         /*
  1424.          * For user-defined (or new),
  1425.          *    return "User Defined"--UDEF
  1426.          */
  1427.     return( UDEF );
  1428.     }
  1429.  
  1430.     /*
  1431.      * For numbers, call our number routine.
  1432.      */
  1433.     if( isdigit(c) ) return( donum(c) );
  1434.  
  1435.     /*
  1436.      * For possible unary operators, see if a digit
  1437.      *    immediately follows.
  1438.      */
  1439.     if( (c == '+') || (c == '-') ){
  1440.     char c2 = nextc();
  1441.  
  1442.     ungetc(c2,cur_in);
  1443.     if( isdigit(c2) )
  1444.         return( donum(c) );
  1445.     }
  1446.  
  1447.     /*
  1448.      * For certain C operators, need to look at following char to
  1449.      *    assemble relationals.  Otherwise, just return the char.
  1450.      */
  1451.     yylval.YYint = c;
  1452.     switch( c ){
  1453.     case '<':
  1454.     if( (c1 = nextc()) == '=' ) return( yylval.YYint = LE );
  1455.     ungetc( c1, cur_in );
  1456.     return(c);
  1457.     case '>':
  1458.     if( (c1 = nextc()) == '=' ) return( yylval.YYint = GE );
  1459.     ungetc( c1, cur_in );
  1460.     return(c);
  1461.     case '~':
  1462.     if( (c1 = nextc()) == '=' ) return( yylval.YYint = NE );
  1463.     ungetc( c1, cur_in );
  1464.     return(c);
  1465.     default:
  1466.     return(c);
  1467.     }
  1468. }
  1469.  
  1470. static int
  1471. donum(startc)
  1472.     char startc;
  1473. {
  1474.     char isdouble = 0;
  1475.     register char c, *p = buf;
  1476.  
  1477.     *p++ = startc;
  1478.     for(;;){
  1479.     c = nextc();
  1480.     if( isdigit(c) ){
  1481.         *p++ = c;
  1482.         continue;
  1483.     }
  1484.     if( c == '.' ){
  1485.         *p++ = c;
  1486.         isdouble = 1;
  1487.         continue;
  1488.     }
  1489.     ungetc( c, cur_in );
  1490.     break;
  1491.     }
  1492.     *p = '\0';
  1493.     if( isdouble ){
  1494.     sscanf(buf,"%lf",&(yylval.YYdouble));
  1495.     return( FLOAT );
  1496.     } else {
  1497.     sscanf(buf,"%d",&(yylval.YYint));
  1498.     return( INT );
  1499.     }
  1500. }
  1501.  
  1502.     /*
  1503.      * getchar() function for lexical analyzer.  Adds a prompt if
  1504.      *    input is from keyboard, also localizes I/O redirection.
  1505.      */
  1506. static
  1507. nextc(){
  1508.     register int c;
  1509.     static saw_eof = 0;
  1510.  
  1511. again:
  1512.     if( cur_in == stdin ){
  1513.     if( saw_eof ) return(EOF);
  1514.     if( !stdin->_cnt )
  1515.         putchar(prompt);
  1516.     }
  1517.     c = fgetc(cur_in);
  1518.     if( c == '#' ){
  1519.     while( (c = fgetc(cur_in)) != EOF )
  1520.         if( c == '\n' ) goto again;
  1521.     }
  1522.     /*
  1523.      * Pop up a level of indirection on EOF
  1524.      */
  1525.     if( c == EOF ){
  1526.     if( cur_in != stdin ){
  1527.         fclose(cur_in);
  1528.         cur_in = fstack[--fpos];
  1529.         goto again;
  1530.     } else {
  1531.         saw_eof++;
  1532.     }
  1533.     }
  1534.     return(c);
  1535. }
  1536.  
  1537.     /*
  1538.      * Command processor.  The reason it's here is that we play with
  1539.      *    I/O redirection.  Shrug.
  1540.      */
  1541. void
  1542. fp_cmd(){
  1543.     char cmd[80], *p = cmd, arg[80];
  1544.     register c;
  1545.     FILE *newf;
  1546.  
  1547.     /*
  1548.      * Assemble a word, the command
  1549.      */
  1550.     skipwhite();
  1551.     if( (c = nextc()) == EOF ) return;
  1552.     *p++ = c;
  1553.     while( (c = nextc()) != EOF )
  1554.     if( isalpha(c) ) *p++ = c;
  1555.     else break;
  1556.     *p = '\0';
  1557.  
  1558.     /*
  1559.      * Process the command
  1560.      */
  1561.     if( strcmp(cmd,"load") == 0 ){    /* Load command */
  1562.  
  1563.         /*
  1564.          * Get next word, the file to load
  1565.          */
  1566.     skipwhite();
  1567.     p = arg;
  1568.     while( (c = nextc()) != EOF )
  1569.         if( isspace(c) ) break;
  1570.         else *p++ = c;
  1571.     *p = '\0';
  1572.  
  1573.         /*
  1574.          * Can we push down any more?
  1575.          */
  1576.     if( fpos == MAXNEST-1 ){
  1577.         printf(")load'ed files nested too deep\n");
  1578.         return;
  1579.     }
  1580.  
  1581.         /*
  1582.          * Try and open the file
  1583.          */
  1584.     if( (newf = fopen(arg,"r")) == 0 ){
  1585.         perror(arg);
  1586.         return;
  1587.     }
  1588.  
  1589.         /*
  1590.          * Pushdown the current file, make this one it.
  1591.          */
  1592.     fstack[fpos++] = cur_in;
  1593.     cur_in = newf;
  1594.     return;
  1595.     }
  1596.  
  1597.     if( strcmp(cmd,"quit") == 0 ){    /* Leave */
  1598.     printf("\nDone\n");
  1599.     exit( 0 );
  1600.     }
  1601.     if( strcmp(cmd,"help") == 0 ){    /* Give help */
  1602.         printf("Commands are:\n");
  1603.     printf(" quit - leave FP\n");
  1604.     printf(" help - this message\n");
  1605.     printf(" load - redirect input from a file\n");
  1606. #ifdef YYDEBUG
  1607.     printf(" yydebug - toggle parser tracing\n");
  1608. #endif
  1609.     return;
  1610.     }
  1611. #ifdef YYDEBUG
  1612.     if( strcmp(cmd,"yydebug") == 0 ){    /* Toggle parser trace */
  1613.     extern int yydebug;
  1614.  
  1615.     yydebug = !yydebug;
  1616.     return;
  1617.     }
  1618. #endif
  1619.     printf("Unknown command '%s'\n",cmd);
  1620. }
  1621. Funky!Stuff!
  1622. cat - << \Funky!Stuff! > obj.c
  1623. /*
  1624.  * obj.c--implement the type "object" and its operators
  1625.  *
  1626.  *    Copyright (c) 1986 by Andy Valencia
  1627.  */
  1628. #include "fp.h"
  1629.  
  1630. static struct object *free_objs = 0;
  1631.  
  1632. #ifdef MEMSTAT
  1633. int obj_out = 0;
  1634. #endif
  1635.  
  1636.     /*
  1637.      * Allocate an object
  1638.      */
  1639. struct object *
  1640. obj_alloc(ty)
  1641.     uchar ty;
  1642. {
  1643.     register struct object *p;
  1644.  
  1645. #ifdef MEMSTAT
  1646.     obj_out++;
  1647. #endif
  1648.     /*
  1649.      * Have a free one on the list
  1650.      */
  1651.     if( p = free_objs ){
  1652.     free_objs = (p->o_val).o_list.car;
  1653.     } else if( (p = (struct object *)malloc(sizeof(struct object))) == 0 )
  1654.     fatal_err("out of memory in obj_alloc()");
  1655.     p->o_refs = 1;
  1656.     if( (p->o_type = ty) == T_LIST )
  1657.     p->o_val.o_list.car = p->o_val.o_list.cdr = 0;
  1658.     return(p);
  1659. }
  1660.  
  1661.     /*
  1662.      * Free an object
  1663.      */
  1664. void
  1665. obj_free(p)
  1666.     struct object *p;
  1667. {
  1668. #ifdef MEMSTAT
  1669.     obj_out--;
  1670. #endif
  1671.     if( !p ) fatal_err("Null object to obj_free()");
  1672.     (p->o_val).o_list.car = free_objs;
  1673.     free_objs = p;
  1674. }
  1675.  
  1676.     /*
  1677.      * Unreference this pointer, updating objects which it might
  1678.      *    reference.
  1679.      */
  1680. void
  1681. obj_unref(p)
  1682.     register struct object *p;
  1683. {
  1684.     if( !p ) return;
  1685.     if( --(p->o_refs) ) return;
  1686.     switch( p->o_type ){
  1687.     case T_INT:
  1688.     case T_FLOAT:
  1689.     case T_UNDEF:
  1690.     case T_BOOL:
  1691.     obj_free(p);
  1692.     return;
  1693.     case T_LIST:
  1694.     obj_unref( (p->o_val).o_list.car );
  1695.     obj_unref( (p->o_val).o_list.cdr );
  1696.     obj_free(p);
  1697.     return;
  1698.     default:
  1699.     fatal_err("Unknown type in obj_unref()");
  1700.     }
  1701.     /*NOTREACHED*/
  1702. }
  1703.  
  1704. static char last_close = 0;
  1705. void
  1706. obj_prtree(p)
  1707.     struct object *p;
  1708. {
  1709.     if( !p ) return;
  1710.     switch( p->o_type ){
  1711.     case T_INT:
  1712.     last_close = 0;
  1713.     printf("%d ",(p->o_val).o_int); return;
  1714.     case T_FLOAT:
  1715.     last_close = 0;
  1716.     printf("%.9g ",(p->o_val).o_double); return;
  1717.     case T_BOOL:
  1718.     last_close = 0;
  1719.     printf("%s ",
  1720.         (p->o_val).o_int ? "T" : "F"); return;
  1721.     case T_UNDEF:
  1722.     last_close = 0;
  1723.     printf("? "); return;
  1724.     case T_LIST:
  1725.     printf("<");
  1726.     last_close = 0;
  1727.     if( !p->o_val.o_list.car ){
  1728.         printf(">");
  1729.         last_close = 1;
  1730.         return;
  1731.     }
  1732.     while( p ){
  1733.         obj_prtree( (p->o_val).o_list.car );
  1734.         p = (p->o_val).o_list.cdr;
  1735.     }
  1736.     if( !last_close ) putchar('\b');
  1737.     printf("> ");
  1738.     last_close = 1;
  1739.     return;
  1740.     }
  1741.     /*NOTREACHED*/
  1742. }
  1743. Funky!Stuff!
  1744.