home *** CD-ROM | disk | FTP | other *** search
/ Source Code 1992 March / Source_Code_CD-ROM_Walnut_Creek_March_1992.iso / usenet / altsrcs / 1 / 1615 / walk < prev   
Encoding:
AWK Script  |  1990-12-28  |  12.6 KB  |  691 lines
  1. #!/bin/awk -f
  2. #
  3. # walk -- LISP in awk
  4. #
  5. # An interpreter for LISP, written in awk(1).
  6. # Copyright (c) 1988, 1990 Roger Rohrbach
  7.  
  8. BEGIN {
  9.  
  10.     # interpreter constants:
  11.  
  12.     stdin = "-";
  13.     true = 1;
  14.     false = 0;
  15.     constant = "#";            # flags literal atoms
  16.     alist = -10000;            # head of bound variable list
  17.  
  18.     # global variables:
  19.  
  20.     atom = -1;                # atoms are allocated down from -1
  21.     cell = 1;                # list cells are allocated up from 1
  22.  
  23.     environment = alist;        # pointer to current evaluation context;
  24.                     # saved in context[] before evaluating body
  25.                     # of lambda expression, restored afterwards
  26.  
  27.     # LISP constants:
  28.  
  29.     nil = intern["nil"] = atom--;   # intern[x] is the LISP atom named by x
  30.     name[nil] = "()";            # name[s] is the print name of atom s
  31.  
  32.     value[nil] = constant;        # if x < alist, value[x] is the local
  33.                     # binding of the atom `symbol[x]'; otherwise
  34.                     # it is the top-level binding of the atom x.
  35.  
  36.     t = intern["t"] = atom--;
  37.     name[t] = "t";
  38.     value[t] = constant;
  39.  
  40.     lambda = intern["lambda"] = atom--;
  41.     name[lambda] = "lambda";
  42.     value[lambda] = constant;
  43.  
  44.     # install the intrinsic functions:
  45.  
  46.     split("cons cdr car eq atom set eval error quote cond and or list", \
  47.      intrinsics);
  48.  
  49.     for (i in intrinsics)
  50.     {
  51.     id = intrinsics[i];
  52.     intern[id] = atom--;
  53.     name[intern[id]] = id;
  54.     value[intern[id]] = sprintf("@%d", i);
  55.     name[value[intern[id]]] = sprintf("<intrinsic #%d>", i);
  56.     }
  57.  
  58.     # these constants speed things up a bit
  59.  
  60.     CONS = value[intern["cons"]];
  61.     CDR = value[intern["cdr"]];
  62.     CAR = value[intern["car"]];
  63.     EQ = value[intern["eq"]];
  64.     ATOM = value[intern["atom"]];
  65.     SET = value[intern["set"]];
  66.     EVAL = value[intern["eval"]];
  67.     ERROR = value[intern["error"]];
  68.     QUOTE = value[intern["quote"]];
  69.     COND = value[intern["cond"]];
  70.     AND = value[intern["and"]];
  71.     OR = value[intern["or"]];
  72.     LIST = value[intern["list"]];
  73.  
  74.     # messages:
  75.  
  76.     TYPE_ERROR = "invalid argument to %s: %s\n";
  77.     REDEF_ERROR = "can't redefine intrinsic function %s\n";
  78.     UNDEF_ERROR = "undefined function: %s\n";
  79.  
  80.     HELLO = "walk (LISP in awk)\tCopyright (c) 1988, 1990 Roger Rohrbach\n";
  81.     GOODBYE = "%d atoms, %d list cells.\n";
  82.  
  83.  
  84.     # interpreter is ready
  85.  
  86.     if (FILENAME == stdin)
  87.     {
  88.     print HELLO;
  89.     printf("-> ");
  90.     }
  91. }
  92.  
  93. # interpreter loop:
  94.  
  95. {
  96.     pos = 0;        # current input character position
  97.     eol = length + 1;    # read past last char for endquote, below
  98.  
  99.     while (++pos <= eol)
  100.     {
  101.     #########
  102.     # read  #
  103.     #########
  104.  
  105.     if (endquote)
  106.     {
  107.         # close a quoted expr by inserting a right parenthesis
  108.         endquote = false;
  109.         c = ")";  
  110.         --pos;    # if at eol, c is null; push back on input
  111.     }
  112.     else
  113.         c = substr($0, pos, 1);
  114.  
  115.     if (c == " " || c == "\t")
  116.         continue;
  117.     else if (c == "" || c == ";")
  118.     {
  119.         # eol or comment
  120.         break;
  121.     }
  122.     else if (c == "'")
  123.     {
  124.         # expand 's to (quote s)
  125.         if (level > 0 && level != rp)
  126.         read[++rp] = CONS;
  127.         read[++rp] = CONS;
  128.         quotes[++qp] = ++level;
  129.         read[++rp] = intern["quote"];
  130.     }
  131.     else if (c == "\"")
  132.     {
  133.         string = true;
  134.     }
  135.     else if (c == "(")
  136.     {
  137.         # begin a list
  138.         read[++rp] = CONS;
  139.         ++level;
  140.     }
  141.     else if (c == ")")
  142.     {
  143.         if (level == 0)
  144.         {
  145.         printf("ignored extra right parenthesis\n");
  146.         continue;
  147.         }
  148.         else if (rp == level && read[rp] == CONS)
  149.         --rp;     # empty list read in
  150.  
  151.         # have just read a list
  152.         read[++rp] = nil;
  153.         --level;
  154.  
  155.         if (qp > 0 && quotes[qp] == level)
  156.         {
  157.         # finish quoting this list
  158.         --qp;
  159.         endquote = true;
  160.         }
  161.  
  162.         # actually construct the list
  163.         while (read[rp - 2] == CONS && read[rp - 1] != CONS)
  164.         {
  165.         cdr[cell] = read[rp];
  166.         car[cell] = read[--rp];
  167.         read[--rp] = cell++;
  168.         }
  169.     }
  170.     else if (c ~ /[0-9]/)
  171.     {
  172.         # read a number (integer)
  173.         n = c;
  174.         while ((c = substr($0, ++pos, 1)) ~ /[0-9]/)
  175.         n = n c;
  176.         --pos; 
  177.         if (level > 0 && level != rp)
  178.         read[++rp] = CONS;
  179.         if (!intern[n])
  180.         {
  181.         intern[n] = atom--;
  182.         name[intern[n]] = n;
  183.         value[intern[n]] = constant;
  184.         }
  185.         read[++rp] = intern[n];
  186.         if (qp > 0 && quotes[qp] == level)
  187.         {
  188.         --qp;
  189.         endquote = true;
  190.         }
  191.     }
  192.     else if (c ~ /[_A-Za-z]/ || string)
  193.     {
  194.         # read an identifier
  195.         id = c;
  196.         if (string)
  197.         {
  198.         while ((c = substr($0, ++pos, 1)) != "\"")
  199.             id = id c;
  200.         string = false;
  201.         }
  202.         else
  203.         {
  204.         while ((c = substr($0, ++pos, 1)) ~ /[-A-Za-z_0-9]/)
  205.             id = id c;
  206.         --pos;
  207.         }
  208.         if (level > 0 && level != rp)
  209.         read[++rp] = CONS;
  210.         if (!intern[id])
  211.         {
  212.         intern[id] = atom--;
  213.         name[intern[id]] = id;
  214.         value[intern[id]] = nil;
  215.         }
  216.         read[++rp] = intern[id];
  217.         if (qp > 0 && quotes[qp] == level)
  218.         {
  219.         --qp;
  220.         endquote = true;
  221.         }
  222.  
  223.     }
  224.     else if (c == "%")
  225.     {
  226.         # refer to objects by `address'
  227.         lispval = "";
  228.         while ((c = substr($0, ++pos, 1)) ~ /[-0-9]/)
  229.         lispval = lispval c;
  230.         if (!length(lispval))
  231.         lispval = nil;
  232.         --pos;
  233.         if (level > 0 && level != rp)
  234.         read[++rp] = CONS;
  235.         read[++rp] = lispval;
  236.         if (qp > 0 && quotes[qp] == level)
  237.         {
  238.         --qp;
  239.         endquote = true;
  240.         }
  241.     }
  242.     else
  243.         printf("illegal character: %s\n", c);
  244.  
  245.  
  246.     if (rp && level == 0)    # have read an s-expression
  247.     {
  248.         #########
  249.         # eval  #
  250.         #########
  251.  
  252.         eval[++ep] = read[rp--];
  253.  
  254.         while (ep > 0)
  255.         {
  256.         s = eval[ep];
  257.  
  258.         if (s < 0)
  259.         {
  260.             # atomic s-expression
  261.  
  262.             if (s == lambda && fp)
  263.             {
  264.             environment = context[fp--];    # restore environment
  265.             }
  266.             else if (value[s] == constant)
  267.             arg[++ap] = s;
  268.             else
  269.             {
  270.             # look up value of s in environment:
  271.             bound = false;
  272.             for (i = environment; i < alist; ++i)
  273.             {
  274.                 if (symbol[i] == s)
  275.                 {
  276.                 bound = true;
  277.                 break;
  278.                 }
  279.             }
  280.             if (bound)
  281.                 arg[++ap] = value[i];
  282.             else    # use value cell
  283.                 arg[++ap] = value[s];
  284.             }
  285.             --ep;
  286.         }
  287.         else if (index(s, "@"))
  288.         {
  289.             # intrinsic function application:
  290.  
  291.             if (s == CONS)
  292.             {
  293.             car[cell] = arg[ap];
  294.             cdr[cell] = arg[--ap];
  295.             if (cdr[cell] < 0 && cdr[cell] != nil)
  296.             {
  297.                 printf(TYPE_ERROR, "cons", name[cdr[cell]]);
  298.                 arg[ap = ep = 1] = nil; # stop evaluation
  299.             }
  300.             else
  301.                 arg[ap] = cell++;
  302.             }
  303.             else if (s == CDR)
  304.             {
  305.             if (arg[ap] < 0)
  306.             {
  307.                 printf(TYPE_ERROR, "cdr", name[arg[ap]]);
  308.                 arg[ap = ep = 1] = nil;
  309.             }
  310.             else
  311.                 arg[ap] = cdr[arg[ap]];
  312.             }
  313.             else if (s == CAR)
  314.             {
  315.             if (arg[ap] < 0)
  316.             {
  317.                 printf(TYPE_ERROR, "car", name[arg[ap]]);
  318.                 arg[ap = ep = 1] = nil;
  319.             }
  320.             else
  321.                 arg[ap] = car[arg[ap]];
  322.             }
  323.             else if (s == EQ)
  324.             {
  325.             arg1 = arg[ap];
  326.             if (arg[--ap] == arg1)
  327.                 arg[ap] = t;
  328.             else
  329.                 arg[ap] = nil;
  330.             }
  331.             else if (s == ATOM)
  332.             {
  333.             if (arg[ap] < 0)
  334.                 arg[ap] = t;
  335.             else
  336.                 arg[ap] = nil;
  337.             }
  338.             else if (s == SET)
  339.             {
  340.             if ((arg1 = arg[ap]) > 0)
  341.             {
  342.                 printf(TYPE_ERROR, "set", "must be atomic");
  343.                 arg[ap = ep = 1] = nil;
  344.             }
  345.             else if (value[arg1] == constant)
  346.             {
  347.                 printf(TYPE_ERROR, "set", name[arg1]);
  348.                 arg[ap = ep = 1] = nil;
  349.             }
  350.             else if (index(value[arg1], "@"))
  351.             {
  352.                 printf(REDEF_ERROR, name[arg1]);
  353.                 arg[ap = ep = 1] = nil;
  354.             }
  355.             else
  356.             {
  357.                 bound = false;
  358.                 for (i = environment; i < alist; ++i)
  359.                 {
  360.                 if (symbol[i] == arg1)
  361.                 {
  362.                     bound = true;
  363.                     break;
  364.                 }
  365.                 }
  366.                 arg2 = arg[--ap];
  367.  
  368.                 if (bound)    # replace binding
  369.                 arg[ap] = value[i] = arg2;
  370.                 else    # set value
  371.                 arg[ap] = value[arg1] = arg2;
  372.             }
  373.             }
  374.             else if (s == EVAL)
  375.             {
  376.             eval[ep++] = arg[ap--];
  377.             }
  378.             else if (s == ERROR)
  379.             {
  380.             if (arg[ap] > 0)
  381.                 printf(TYPE_ERROR, "error", "must be atomic");
  382.             else
  383.                 printf("%s\n", name[arg[ap]]);
  384.             arg[ap = ep = 1] = nil;
  385.             }
  386.             --ep;
  387.         }
  388.         else if (car[s] == lambda)
  389.         {
  390.             # lambda function application:
  391.  
  392.             formals = car[cdr[s]];
  393.             context[++fp] = environment;    # save environment
  394.             while (formals != nil)
  395.             {
  396.             # bind lambda variables
  397.             symbol[--environment] = car[formals];
  398.             value[environment] = arg[ap--];
  399.             formals = cdr[formals];
  400.             }
  401.             eval[ep] = lambda;            # closure
  402.             eval[++ep] = car[cdr[cdr[s]]];  # push body of expr.
  403.         }
  404.         else if (car[s] < 0)
  405.         {
  406.             # s is a form (f args)
  407.  
  408.             evlis[cdr[s]] = true;   # don't treat cdr as a form
  409.  
  410.             # special forms:
  411.  
  412.             f = value[car[s]];
  413.  
  414.             if (index(f, "@"))
  415.             {
  416.             if (f == QUOTE)
  417.             {
  418.                 arg[++ap] = car[cdr[s]];
  419.                 --ep;
  420.             }
  421.             else if (f == COND)
  422.             {
  423.                 if (cdr[s] == nil)
  424.                 {
  425.                 arg[++ap] = nil;
  426.                 --ep;
  427.                 }
  428.                 else
  429.                 {
  430.                 # save clauses, push first antecedent
  431.                 clauses[++cp] = cdr[s];
  432.                 eval[ep] = f;
  433.                 eval[++ep] = car[car[clauses[cp]]];
  434.                 }
  435.             }
  436.             else if (f == AND)
  437.             {
  438.                 if (cdr[s] == nil)
  439.                 {
  440.                 arg[++ap] = t;
  441.                 --ep;
  442.                 }
  443.                 else
  444.                 {
  445.                 # save predicates, push first
  446.                 preds[++dp] = cdr[s];
  447.                 eval[ep] = f;
  448.                 eval[++ep] = car[preds[dp]];
  449.                 }
  450.             }
  451.             else if (f == OR)
  452.             {
  453.                 if (cdr[s] == nil)
  454.                 {
  455.                 arg[++ap] = nil;
  456.                 --ep;
  457.                 }
  458.                 else
  459.                 {
  460.                 preds[++dp] = cdr[s];
  461.                 eval[ep] = f;
  462.                 eval[++ep] = car[preds[dp]];
  463.                 }
  464.             }
  465.             else if (f == LIST)
  466.             {
  467.                 # translate to (cons e1 e2 .. eN)
  468.                 for (e = cdr[s]; e != nil; e = cdr[e])
  469.                 {
  470.                 eval[ep++] = CONS;
  471.                 eval[ep++] = car[e];
  472.                 }
  473.                 eval[ep] = nil;
  474.             }
  475.             else
  476.             {
  477.                 # f takes evaluated arguments- push (f args)
  478.                 eval[ep] = f;
  479.                 eval[++ep] = cdr[s];
  480.             }
  481.             }
  482.             else if (car[f] == lambda)
  483.             {
  484.             # push lambda function, arglist
  485.             eval[ep] = f;
  486.             if (cdr[s] != nil)
  487.                 eval[++ep] = cdr[s];
  488.             }
  489.             else if (evlis[s])
  490.             {
  491.             eval[ep] = car[s];
  492.             if (cdr[s] != nil)
  493.             {
  494.                 eval[++ep] = cdr[s];
  495.                 evlis[cdr[s]] = true;
  496.             }
  497.             }
  498.             else
  499.             {
  500.             # f is not a function
  501.             printf(UNDEF_ERROR, name[car[s]]);
  502.             arg[ap = 1] = nil;
  503.             ep = 0;
  504.             }
  505.         }
  506.         else
  507.         {
  508.             # evaluate car[s], cdr[s]
  509.  
  510.             eval[ep] = car[s];
  511.             if (cdr[s] != nil)
  512.             {
  513.             eval[++ep] = cdr[s];
  514.             if (evlis[s])
  515.                 evlis[cdr[s]] = true;
  516.             }
  517.         }
  518.  
  519.         # get next unevaluated argument (cond, and, or):
  520.  
  521.         while (true)
  522.         {
  523.             s = eval[ep];
  524.  
  525.             if (s == COND)
  526.             {
  527.             if (arg[ap] == nil)
  528.             {
  529.                 # last antecedent was nil
  530.                 # push antecedent of next clause
  531.                 if ((clauses[cp] = cdr[clauses[cp]]) != nil)
  532.                 {
  533.                 eval[++ep] = car[car[clauses[cp]]];
  534.                 --ap;
  535.                 }
  536.                 else
  537.                 {
  538.                 # no more clauses, return nil
  539.                 --ep;
  540.                 --cp;
  541.                 }
  542.             }
  543.             else
  544.             {
  545.                 # last antecedent was non-nil
  546.                 # push consequent
  547.                 if (cdr[car[clauses[cp]]] != nil)
  548.                 {
  549.                 eval[ep] = car[cdr[car[clauses[cp]]]];
  550.                 --ap;
  551.                 --cp;
  552.                 }
  553.                 else
  554.                 {
  555.                 # no consequent, return antecedent
  556.                 --ep;
  557.                 --cp;
  558.                 }
  559.             }
  560.             }
  561.             else if (s == AND)
  562.             {
  563.             if (arg[ap] != nil)
  564.             {
  565.                 # last predicate non-nil
  566.                 # push next predicate if there is one
  567.                 if ((preds[dp] = cdr[preds[dp]]) != nil)
  568.                 {
  569.                 eval[++ep] = car[preds[dp]];
  570.                 --ap;
  571.                 }
  572.                 else
  573.                 {
  574.                 # return value of last predicate
  575.                 --ep;
  576.                 --dp;
  577.                 }
  578.             }
  579.             else
  580.             {
  581.                 # return nil
  582.                 --ep;
  583.                 --dp;
  584.             }
  585.             }
  586.             else if (s == OR)
  587.             {
  588.             if (arg[ap] == nil)
  589.             {
  590.                 # last predicate was nil
  591.                 # push next predicate if there is one
  592.                 if ((preds[dp] = cdr[preds[dp]]) != nil)
  593.                 {
  594.                 eval[++ep] = car[preds[dp]];
  595.                 --ap;
  596.                 }
  597.                 else
  598.                 {
  599.                 # return nil
  600.                 --ep;
  601.                 --dp;
  602.                 }
  603.             }
  604.             else
  605.             {
  606.                 # return value of last predicate
  607.                 --ep;
  608.                 --dp;
  609.             }
  610.             }
  611.             else
  612.             break;
  613.         }
  614.         }
  615.  
  616.         # throw away unused contexts (happens on errors):
  617.         fp = 0;
  618.         environment = alist;
  619.  
  620.  
  621.         #########
  622.         # print #
  623.         #########
  624.  
  625.         space = false;
  626.         s = arg[ap--];
  627.  
  628.         if (s < 0 || index(s, "@"))
  629.         {
  630.         # print atom
  631.         printf("%s", name[s]);
  632.         }
  633.         else
  634.         {
  635.         # print list
  636.  
  637.         printf("(");
  638.         Print[++pp] = s;    # push s onto stack of exprs to print
  639.  
  640.         while (pp > 0)
  641.         {
  642.             s = Print[pp];
  643.  
  644.             if (s == nil)
  645.             {
  646.             printf(")");
  647.             --pp;
  648.             }
  649.             else
  650.             {
  651.             if (space)
  652.                 printf(" ");
  653.  
  654.             Print[pp] = cdr[s]; # push cdr[s]
  655.  
  656.             if (car[s] < 0)
  657.             {
  658.                 printf("%s", name[car[s]]);
  659.                 space = true;
  660.             }
  661.             else
  662.             {
  663.                 printf("(");
  664.                 space = false;
  665.                 Print[++pp] = car[s];   # recursively expand
  666.             }
  667.             }
  668.         }
  669.         }
  670.  
  671.         printf("\n");
  672.     }
  673.     }
  674.  
  675.     if (FILENAME == stdin || FILENAME == "p")
  676.     {
  677.     if ((n = level - qp) > 0)
  678.         printf("%d> ", n);
  679.     else
  680.         printf("-> ");
  681.     }
  682. }
  683.  
  684. END {
  685.  
  686.     if (FILENAME == stdin)
  687.     printf(GOODBYE, -atom - 1, cell - 1);
  688.  
  689.     exit(0);
  690. }
  691.