home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / src / lisp.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-19  |  39.4 KB  |  1,686 lines
  1. /* lisp.c -- Core of the Lisp, reading and evaluating...
  2.    Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
  3.  
  4. This file is part of Jade.
  5.  
  6. Jade is free software; you can redistribute it and/or modify it
  7. under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2, or (at your option)
  9. any later version.
  10.  
  11. Jade is distributed in the hope that it will be useful, but
  12. 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 Jade; see the file COPYING.    If not, write to
  18. the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.  */
  19.  
  20. #include "jade.h"
  21. #include "jade_protos.h"
  22.  
  23. #include <string.h>
  24. #include <stdlib.h>
  25. #include <ctype.h>
  26.  
  27. _PR VALUE readlispexp(VALUE, int *);
  28.  
  29. _PR VALUE evallambda(VALUE, VALUE, bool);
  30. _PR VALUE funcall(VALUE, VALUE);
  31. _PR VALUE evalstring(u_char *, bool);
  32.  
  33. _PR VALUE calllisp0(VALUE);
  34. _PR VALUE calllisp1(VALUE, VALUE);
  35. _PR VALUE calllisp2(VALUE, VALUE, VALUE);
  36.  
  37. _PR void lisp_prin(VALUE, VALUE);
  38. _PR void string_princ(VALUE, VALUE);
  39. _PR void string_print(VALUE, VALUE);
  40.  
  41. _PR VALUE findmemberbyindex(VALUE, int);
  42. _PR VALUE movedownlist(VALUE, int);
  43. _PR int listlen(VALUE);
  44. _PR VALUE copylist(VALUE);
  45. _PR VALUE handlevarint(VALUE, long *);
  46.  
  47. _PR void handleerror(VALUE, VALUE);
  48. _PR void signalargerror(VALUE, int);
  49.  
  50. _PR void lisp_init(void);
  51.  
  52. _PR VALUE sym_debug_entry, sym_debug_exit, sym_debug_error_entry;
  53. VALUE sym_debug_entry, sym_debug_exit, sym_debug_error_entry;
  54.  
  55. _PR VALUE sym_quote, sym_lambda, sym_macro, sym_autoload, sym_function;
  56. VALUE sym_quote, sym_lambda, sym_macro, sym_autoload, sym_function;
  57.  
  58. _PR VALUE sym_standard_input, sym_standard_output, sym_defun;
  59. VALUE sym_standard_input, sym_standard_output, sym_defun;
  60.  
  61. _PR VALUE sym_amp_optional, sym_amp_rest, sym_amp_aux;
  62. VALUE sym_amp_optional, sym_amp_rest, sym_amp_aux;
  63.  
  64. /*
  65.  * When a `throw' happens a function stuffs a cons-cell in here with,
  66.  * (TAG . VALUE).
  67.  * An error is the above with TAG=sym_error and VALUE a list of relevant
  68.  * data.
  69.  */
  70. _PR VALUE ThrowValue;
  71. VALUE ThrowValue;
  72.  
  73. _PR VALUE sym_error, sym_error_message, sym_invalid_function;
  74. _PR VALUE sym_void_function, sym_void_value, sym_bad_arg, sym_invalid_read_syntax;
  75. _PR VALUE sym_end_of_stream, sym_invalid_lambda_list, sym_missing_arg;
  76. _PR VALUE sym_invalid_macro, sym_invalid_autoload, sym_no_catcher;
  77. _PR VALUE sym_buffer_read_only, sym_bad_event_desc, sym_file_error;
  78. _PR VALUE sym_invalid_stream, sym_setting_constant, sym_process_error;
  79. _PR VALUE sym_invalid_area;
  80.  
  81. VALUE sym_error, sym_error_message, sym_invalid_function,
  82.     sym_void_function, sym_void_value, sym_bad_arg, sym_invalid_read_syntax,
  83.     sym_end_of_stream, sym_invalid_lambda_list, sym_missing_arg,
  84.     sym_invalid_macro, sym_invalid_autoload, sym_no_catcher,
  85.     sym_buffer_read_only, sym_bad_event_desc, sym_file_error,
  86.     sym_invalid_stream, sym_setting_constant, sym_process_error,
  87.     sym_invalid_area;
  88.  
  89. #ifdef MINSTACK
  90. _PR VALUE sym_stack_error;
  91. VALUE sym_stack_error;
  92. #endif
  93.  
  94. _PR VALUE DebugOnError, sym_error_info;
  95. VALUE DebugOnError, sym_error_info;
  96.  
  97. /*
  98.  * When TRUE cmd_eval() calls the "debug-entry" function
  99.  */
  100. _PR bool SingleStepFlag;
  101. bool SingleStepFlag;
  102.  
  103. _PR struct LispCall *LispCallStack;
  104. struct LispCall *LispCallStack;
  105.  
  106. static long LispDepth, MaxLispDepth = 250;
  107.  
  108. /*
  109.  * All of the read-related functions are now stream based. This will
  110.  * probably add some (much?) overhead but I think it's worth it?
  111.  *
  112.  * The `c' variable which keeps coming up is the lookahead character,
  113.  * since each read*() routine normally has to look at the next character
  114.  * to see if it's what it wants. If not, this char is given to someone
  115.  * else...
  116.  */
  117.  
  118. /*
  119.  * Steps over white space, if a semi-colon is found the rest of the line
  120.  * is ignored.
  121.  */
  122. static int
  123. nextlispexp(VALUE strm, int c)
  124. {
  125.     while(c != EOF)
  126.     {
  127.     switch(c)
  128.     {
  129.     case ' ':
  130.     case '\t':
  131.     case '\n':
  132.     case '\f':
  133.         break;
  134.     case ';':
  135.         while((c = streamgetc(strm)) != EOF)
  136.         {
  137.         if((c == '\n') || (c == '\f'))
  138.             break;
  139.         }
  140.         break;
  141.     default:
  142.         return(c);
  143.     }
  144.     c = streamgetc(strm);
  145.     }
  146.     return(c);
  147. }
  148.  
  149. static VALUE
  150. readlisplist(VALUE strm, int *c_p)
  151. {
  152.     VALUE result = sym_nil;
  153.     VALUE last = NULL;
  154.     int c = streamgetc(strm);
  155.     c = nextlispexp(strm, c);
  156.     while((c != EOF) && (c != ')') && (c != ']'))
  157.     {
  158.     if(c == '.')
  159.     {
  160.         c = streamgetc(strm);
  161.         if(last)
  162.         {
  163.         if(!(VCDR(last) = readlispexp(strm, &c)))
  164.             return(NULL);
  165.         }
  166.         else
  167.         {
  168.         cmd_signal(sym_invalid_read_syntax,
  169.                LIST_1(MKSTR("Nothing to dot second element of cons-cell to")));
  170.         return(NULL);
  171.         }
  172.     }
  173.     else
  174.     {
  175.         VALUE this;
  176.         if(!(this = cmd_cons(sym_nil, sym_nil)))
  177.         return(NULL);
  178.         if(last)
  179.         VCDR(last) = this;
  180.         else
  181.         result = this;
  182.         if(!(VCAR(this) = readlispexp(strm, &c)))
  183.         return(NULL);
  184.         last = this;
  185.     }
  186.     c = nextlispexp(strm, c);
  187.     }
  188.     if(c == EOF)
  189.     return(cmd_signal(sym_end_of_stream, LIST_1(strm)));
  190.     *c_p = streamgetc(strm);
  191.     return(result);
  192. }
  193. /*
  194.  * could be number *or* symbol
  195.  */
  196. static VALUE
  197. readlispsymbol(VALUE strm, int *c_p)
  198. {
  199.     VALUE result;
  200.     u_char buff[256];
  201.     u_char *buf = buff + 1;
  202.     int c = *c_p;
  203.     int i = 0;
  204.     bool couldbenum = TRUE;
  205.     buff[0] = V_StaticString;
  206.     while(c != EOF)
  207.     {
  208.     switch(c)
  209.     {
  210.     case ' ':
  211.     case '\t':
  212.     case '\n':
  213.     case '\f':
  214.     case '(':
  215.     case ')':
  216.     case '[':
  217.     case ']':
  218.     case '\'':
  219.     case '"':
  220.     case ';':
  221.         goto done;
  222.     case '\\':
  223.         couldbenum = FALSE;
  224.         c = streamgetc(strm);
  225.         if(c == EOF)
  226.         return(cmd_signal(sym_end_of_stream, LIST_1(strm)));
  227.         buf[i++] = c;
  228.         break;
  229.     case '|':
  230.         couldbenum = FALSE;
  231.         c = streamgetc(strm);
  232.         while((c != EOF) && (c != '|'))
  233.         {
  234.         buf[i++] = c;
  235.         c = streamgetc(strm);
  236.         }
  237.         if(c == EOF)
  238.         return(cmd_signal(sym_end_of_stream, LIST_1(strm)));
  239.         break;
  240.     default:
  241.         if(couldbenum)
  242.         {
  243.         /*
  244.          * if c isn't a digit (decimal or hex) and c isn't a sign
  245.          * at the start of the string then it's not a number!
  246.          */
  247.         if(!(isdigit(c) || ((i >= 2) && isxdigit(c)) || ((i == 1) && (toupper(c) == 'X'))))
  248.         {
  249.             if(!((i == 0) && ((c == '+') || (c == '-'))))
  250.             couldbenum = FALSE;
  251.         }
  252.         }
  253.         buf[i++] = c;
  254.     }
  255.     c = streamgetc(strm);
  256.     }
  257. done:
  258.     buf[i] = 0;
  259.     if(couldbenum && ((i > 1) || isdigit(*buf)))
  260.     {
  261.     char *dummy;
  262.     result = newnumber(strtol(buf, &dummy, 0));
  263.     }
  264.     else
  265.     {
  266.     if(!(result = cmd_find_symbol(buff, sym_nil))
  267.        || (NILP(result) && strcmp(buf, "nil")))
  268.     {
  269.         VALUE name;
  270.         if((name = valstrdup(buf)) && (result = cmd_make_symbol(name)))
  271.         result = cmd_intern_symbol(result, sym_nil);
  272.         else
  273.         result = NULL;
  274.     }
  275.     }
  276.     *c_p = c;
  277.     return(result);
  278. }
  279. static VALUE
  280. readlispvector(VALUE strm, int *c_p)
  281. {
  282.     VALUE result;
  283.     VALUE list = readlisplist(strm, c_p);
  284.     if(list)
  285.     {
  286.     VALUE cur = list;
  287.     int len;
  288.     for(len = 0; CONSP(cur); len++)
  289.         cur = VCDR(cur);
  290.     result = newvector(len);
  291.     if(result)
  292.     {
  293.         int i;
  294.         cur = list;
  295.         for(i = 0; i < len; i++)
  296.         {
  297.         VALUE nxt = VCDR(cur);
  298.         VVECT(result)->vc_Array[i] =  VCAR(cur);
  299. #if 1
  300.         /* I think it's okay to put the cons cells back onto their
  301.            freelist. There can't be any references to them??  */
  302.         cons_free(cur);
  303. #endif
  304.         cur = nxt;
  305.         }
  306.     }
  307.     else
  308.         result = NULL;
  309.     }
  310.     else
  311.     result = NULL;
  312.     return(result);
  313. }
  314. static VALUE
  315. readlispstr(VALUE strm, int *c_p)
  316. {
  317.     VALUE result;
  318.     int buflen = 128, i = 0;
  319.     int c = streamgetc(strm);
  320.     u_char *buf = mystralloc(buflen);
  321.     if(buf)
  322.     {
  323.     while((c != EOF) && (c != '"'))
  324.     {
  325.         if(i == buflen)
  326.         {
  327.         int newbuflen = buflen * 2;
  328.         u_char *newbuf = mystralloc(newbuflen);
  329.         if(newbuf)
  330.         {
  331.             memcpy(newbuf, buf, i);
  332.             mystrfree(buf);
  333.             buf = newbuf;
  334.             buflen = newbuflen;
  335.         }
  336.         else
  337.         {
  338.             settitle(NoMemMsg);
  339.             return(NULL);
  340.         }
  341.         }
  342.         if(c == '\\')
  343.         {
  344.         c = streamgetc(strm);
  345.         buf[i++] = escstreamchar(strm, &c);
  346.         }
  347.         else
  348.         {
  349.         buf[i++] = c;
  350.         c = streamgetc(strm);
  351.         }
  352.     }
  353.     if(c == EOF)
  354.         result = cmd_signal(sym_end_of_stream, LIST_1(strm));
  355.     else
  356.     {
  357.         *c_p = streamgetc(strm);
  358.         result = valstrdupn(buf, i);
  359.     }
  360.     mystrfree(buf);
  361.     return(result);
  362.     }
  363.     settitle(NoMemMsg);
  364.     return(NULL);
  365. }
  366. /*
  367.  * Using the above readlisp*() functions this classifies each type
  368.  * of expression and translates it into a lisp object (VALUE).
  369.  * Returns NULL in case of error.
  370.  */
  371. VALUE
  372. readlispexp(VALUE strm, int *c_p)
  373. {
  374.     VALUE result;
  375.     int c;
  376. #ifdef MINSTACK
  377.     if(STK_SIZE <= MINSTACK)
  378.     {
  379.     STK_WARN("read");
  380.     return(cmd_signal(sym_stack_error, sym_nil));
  381.     }
  382. #endif
  383.     switch(c = nextlispexp(strm, *c_p))
  384.     {
  385.     case EOF:
  386.     *c_p = c;
  387.     return(sym_nil);
  388.     case '\(':
  389.     result = readlisplist(strm, &c);
  390.     break;
  391.     case '\'':
  392.     /*
  393.      * transmogrify 'X into (quote X)
  394.      */
  395.     result = cmd_cons(sym_quote, cmd_cons(sym_nil, sym_nil));
  396.     if(result)
  397.     {
  398.         c = streamgetc(strm);
  399.         if(c == EOF)
  400.         goto eof;
  401.         else if(!(VCAR(VCDR(result)) = readlispexp(strm, &c)))
  402.         result = NULL;
  403.     }
  404.     break;
  405.     case '[':
  406.     result = readlispvector(strm, &c);
  407.     break;
  408.     case '"':
  409.     result = readlispstr(strm, &c);
  410.     break;
  411.     case '?':
  412.     switch(c = streamgetc(strm))
  413.     {
  414.     case EOF:
  415.         goto eof;
  416.     case '\\':
  417.         if((c = streamgetc(strm)) == EOF)
  418.         goto eof;
  419.         else
  420.         result = newnumber(escstreamchar(strm, &c));
  421.         break;
  422.     default:
  423.         result = newnumber(c);
  424.         c = streamgetc(strm);
  425.     }
  426.     break;
  427.     case '#':
  428.     switch(c = streamgetc(strm))
  429.     {
  430.     case EOF:
  431.         goto eof;
  432.     case '\'':
  433.         result = cmd_cons(sym_function, cmd_cons(sym_nil, sym_nil));
  434.         if(result)
  435.         {
  436.         if((c = streamgetc(strm)) == EOF)
  437.             goto eof;
  438.         if(!(VCAR(VCDR(result)) = readlispexp(strm, &c)))
  439.             result = NULL;
  440.         }
  441.         break;
  442.     default:
  443.         result = cmd_signal(sym_invalid_read_syntax, LIST_1(strm));
  444.     }
  445.     break;
  446.     default:
  447.     result = readlispsymbol(strm, &c);
  448.     }
  449.     *c_p = c;
  450.     return(result);
  451.  
  452. eof:
  453.     return(cmd_signal(sym_end_of_stream, LIST_1(strm)));
  454. }
  455.  
  456. /*
  457.  * Evaluates each element of `list' and builds them into a new list.
  458.  */
  459. static VALUE
  460. evallist(VALUE list)
  461. {
  462.     VALUE result = sym_nil;
  463.     VALUE *last = &result;
  464.     GCVAL gcv_result, gcv_list;
  465.     PUSHGC(gcv_result, result);
  466.     PUSHGC(gcv_list, list);
  467.     while(CONSP(list))
  468.     {
  469.     VALUE tmp;
  470.     if(!(tmp = cmd_eval(VCAR(list))))
  471.     {
  472.         result = NULL;
  473.         break;
  474.     }
  475.     if(!(*last = cmd_cons(tmp, sym_nil)))
  476.     {
  477.         result = NULL;
  478.         break;
  479.     }
  480.     list = VCDR(list);
  481.     last = &VCDR(*last);
  482.     }
  483.     if(result && last && !NILP(list))
  484.     *last = cmd_eval(list);
  485.     POPGC; POPGC;
  486.     return(result);
  487. }
  488.  
  489. /*
  490.  * format of lambda-lists is something like,
  491.  *
  492.  * [{required-symbols}] [&optional {optional-symbols}] [&rest symbol]
  493.  * [&aux {auxiliary-symbols}]
  494.  *
  495.  * NB: auxiliary symbols are set to nil.
  496.  */
  497. static VALUE
  498. bindlambdalist(VALUE lambdaList, VALUE argList, int evalArgs)
  499. {
  500. #define STATE_REQUIRED 1
  501. #define STATE_OPTIONAL 2
  502. #define STATE_REST     3
  503. #define STATE_AUX      4
  504.     VALUE boundlist = sym_nil;
  505.     if(CONSP(lambdaList))
  506.     {
  507.     GCVAL gcv_boundlist;
  508.     char state = STATE_REQUIRED;
  509.     PUSHGC(gcv_boundlist, boundlist);
  510.     while(CONSP(lambdaList) && SYMBOLP(VCAR(lambdaList)))
  511.     {
  512.         VALUE argobj;
  513.         VALUE argspec = VCAR(lambdaList);
  514.         if(VSTR(VSYM(argspec)->sym_Name)[0] == '&')
  515.         {
  516.         if(argspec == sym_amp_optional)
  517.         {
  518.             if(state > STATE_OPTIONAL)
  519.             {
  520.             cmd_signal(sym_invalid_lambda_list, LIST_1(lambdaList));
  521.             goto error;
  522.             }
  523.             state = STATE_OPTIONAL;
  524.             lambdaList = VCDR(lambdaList);
  525.             continue;
  526.         }
  527.         else if(argspec == sym_amp_rest)
  528.         {
  529.             if(state > STATE_REST)
  530.             {
  531.             cmd_signal(sym_invalid_lambda_list, LIST_1(lambdaList));
  532.             goto error;
  533.             }
  534.             state = STATE_REST;
  535.             lambdaList = VCDR(lambdaList);
  536.             continue;
  537.         }
  538.         else if(argspec == sym_amp_aux)
  539.         {
  540.             state = STATE_AUX;
  541.             lambdaList = VCDR(lambdaList);
  542.             continue;
  543.         }
  544.         }
  545.         switch(state)
  546.         {
  547.         case STATE_REQUIRED:
  548.         if(!CONSP(argList))
  549.         {
  550.             cmd_signal(sym_missing_arg, LIST_1(argspec));
  551.             goto error;
  552.         }
  553.         /* FALL THROUGH */
  554.         case STATE_OPTIONAL:
  555.         if(CONSP(argList))
  556.         {
  557.             if(evalArgs)
  558.             {
  559.             if(!(argobj = cmd_eval(VCAR(argList))))
  560.                 goto error;
  561.             }
  562.             else
  563.             argobj = VCAR(argList);
  564.             argList = VCDR(argList);
  565.         }
  566.         else
  567.             argobj = sym_nil;
  568.         boundlist = bindsymbol(boundlist, argspec, argobj);
  569.         break;
  570.         case STATE_REST:
  571.         if(evalArgs)
  572.         {
  573.             if(!(argobj = evallist(argList)))
  574.             goto error;
  575.         }
  576.         else
  577.             argobj = argList;
  578.         boundlist = bindsymbol(boundlist, argspec, argobj);
  579.         state = STATE_AUX;
  580.         break;
  581.         case STATE_AUX:
  582.         boundlist = bindsymbol(boundlist, argspec, sym_nil);
  583.         }
  584.         lambdaList = VCDR(lambdaList);
  585.     }
  586.     POPGC;
  587.     }
  588.     return(boundlist);
  589.  
  590. error:
  591.     POPGC;
  592.     unbindsymbols(boundlist);
  593.     return(NULL);
  594. }
  595.  
  596. VALUE
  597. evallambda(VALUE lambdaExp, VALUE argList, bool evalArgs)
  598. {
  599.     VALUE result = NULL;
  600.     if(CONSP(VCDR(lambdaExp)))
  601.     {
  602.     VALUE boundlist;
  603.     GCVAL gcv_lambdaExp, gcv_argList;
  604.     PUSHGC(gcv_lambdaExp, lambdaExp);
  605.     PUSHGC(gcv_argList, argList);
  606.     lambdaExp = VCDR(lambdaExp);
  607.     boundlist = bindlambdalist(VCAR(lambdaExp), argList, evalArgs);
  608.     if(boundlist)
  609.     {
  610.         GCVAL gcv_boundlist;
  611.         PUSHGC(gcv_boundlist, boundlist);
  612.         result = cmd_progn(VCDR(lambdaExp));
  613.         POPGC;
  614.         unbindsymbols(boundlist);
  615.     }
  616.     else
  617.         result = NULL;
  618.     POPGC; POPGC;
  619.     }
  620.     return(result);
  621. }
  622.  
  623. static VALUE
  624. _eval(VALUE obj)
  625. {
  626.     VALUE result = NULL;
  627.     GCVAL gcv_obj;
  628. #ifdef MINSTACK
  629.     if(STK_SIZE <= MINSTACK)
  630.     {
  631.     STK_WARN("eval");
  632.     return(cmd_signal(sym_stack_error, sym_nil));
  633.     }
  634. #endif
  635.     if(++LispDepth > MaxLispDepth)
  636.     {
  637.     cmd_signal(sym_error, LIST_1(MKSTR("max-lisp-depth exceeded, possible infite recursion?")));
  638.     }
  639.     else if(obj)
  640.     {
  641.     switch(VTYPE(obj))
  642.     {
  643.         VALUE funcobj, arglist;
  644.         int type;
  645.     case V_Symbol:
  646.         if(!(result = cmd_symbol_value(obj)))
  647.         cmd_signal(sym_void_value, LIST_1(obj));
  648.         break;
  649.     case V_Cons:
  650. again:
  651.         funcobj = VCAR(obj);
  652.         arglist = VCDR(obj);
  653.         if(SYMBOLP(funcobj))
  654.         {
  655.         if(VSYM(funcobj)->sym_Flags & SF_DEBUG)
  656.             SingleStepFlag = TRUE;
  657.         funcobj = cmd_symbol_function(funcobj);
  658.         if(!funcobj)
  659.         {
  660.             cmd_signal(sym_void_function, LIST_1(VCAR(obj)));
  661.             goto end;
  662.         }
  663.         }
  664.         switch(type = VTYPE(funcobj))
  665.         {
  666.         VALUE alist, car, args[5];
  667.         GCVALN gcvn_args;
  668.         int i, nargs;
  669.         case V_Subr0:
  670.         result = VSUBR0FUN(funcobj)();
  671.         break;
  672.         case V_SubrN:
  673.         PUSHGC(gcv_obj, obj);
  674.         alist = evallist(arglist);
  675.         if(alist)
  676.             result = VSUBRNFUN(funcobj)(alist);
  677.         POPGC;
  678.         break;
  679.         case V_Subr1:
  680.         nargs = 1;
  681.         args[0] = sym_nil;
  682.         goto do_subr;
  683.         case V_Subr2:
  684.         nargs = 2;
  685.         args[0] = args[1] = sym_nil;
  686.         goto do_subr;
  687.         case V_Subr3:
  688.         nargs = 3;
  689.         args[0] = args[1] = args[2] = sym_nil;
  690.         goto do_subr;
  691.         case V_Subr4:
  692.         nargs = 4;
  693.         args[0] = args[1] = args[2] = args[3] = sym_nil;
  694.         goto do_subr;
  695.         case V_Subr5:
  696.         nargs = 5;
  697.         args[0] = args[1] = args[2] = args[3] = args[4] = sym_nil;
  698. do_subr:
  699.         PUSHGCN(gcvn_args, args, nargs);
  700.         PUSHGC(gcv_obj, obj);
  701.         for(i = 0; i < nargs; i++)
  702.         {
  703.             if(CONSP(arglist))
  704.             {
  705.             if(!(args[i] = cmd_eval(VCAR(arglist))))
  706.             {
  707.                 POPGC; POPGCN;
  708.                 goto end;
  709.             }
  710.             arglist = VCDR(arglist);
  711.             }
  712.             else
  713.             break;
  714.         }
  715.         POPGC; POPGCN;
  716.         switch(type)
  717.         {
  718.         case V_Subr1:
  719.             result = VSUBR1FUN(funcobj)(args[0]);
  720.             break;
  721.         case V_Subr2:
  722.             result = VSUBR2FUN(funcobj)(args[0], args[1]);
  723.             break;
  724.         case V_Subr3:
  725.             result = VSUBR3FUN(funcobj)(args[0], args[1], args[2]);
  726.             break;
  727.         case V_Subr4:
  728.             result = VSUBR4FUN(funcobj)(args[0], args[1],
  729.                         args[2], args[3]);
  730.             break;
  731.         case V_Subr5:
  732.             result = VSUBR5FUN(funcobj)(args[0], args[1], args[2],
  733.                         args[3], args[4]);
  734.             break;
  735.         }
  736.         break;
  737.         case V_SF:
  738.         result = VSFFUN(funcobj)(arglist);
  739.         break;
  740.         case V_Cons:
  741.         car = VCAR(funcobj);
  742.         if(car == sym_lambda)
  743.         {
  744.             struct LispCall lc;
  745.             lc.lc_Next = LispCallStack;
  746.             lc.lc_Fun = VCAR(obj);
  747.             lc.lc_Args = arglist;
  748.             lc.lc_ArgsEvalledP = sym_nil;
  749.             LispCallStack = &lc;
  750.             if(!(result = evallambda(funcobj, arglist, TRUE))
  751.                && ThrowValue && (VCAR(ThrowValue) == sym_defun))
  752.             {
  753.             result = VCDR(ThrowValue);
  754.             ThrowValue = NULL;
  755.             }
  756.             LispCallStack = lc.lc_Next;
  757.         }
  758.         else if(car == sym_macro)
  759.         {
  760.             funcobj = VCDR(funcobj);
  761.             if(CONSP(funcobj) && (VCAR(funcobj) == sym_lambda))
  762.             {
  763.             VALUE form = evallambda(funcobj, arglist, FALSE);
  764.             if(form)
  765.                 result = cmd_eval(form);
  766.             }
  767.             else
  768.             cmd_signal(sym_invalid_macro, LIST_1(VCAR(obj)));
  769.         }
  770.         else if(car == sym_autoload)
  771.         {
  772.             if(!SYMBOLP(VCAR(obj)))
  773.             {
  774.             /* Unless the car of the original `obj' we're evalling
  775.                is a symbol don't bother.  (Because it wouldn't
  776.                be possible to find the new definition.)  */
  777.             cmd_signal(sym_invalid_autoload,
  778.                    list_2(VCAR(obj),
  779.                      MKSTR("Can only autoload from symbols")));
  780.             }
  781.             else
  782.             {
  783.             VALUE autoload = VCDR(funcobj);
  784.             if(CONSP(autoload))
  785.             {
  786.                 PUSHGC(gcv_obj, obj);
  787.                 /* trash the autoload defn, this way I make sure
  788.                    that we don't keep trying to autoload a function
  789.                    indefinitely.  */
  790.                 VCAR(funcobj) = sym_nil;
  791.                 result = cmd_load(VCAR(autoload), sym_t, sym_nil, sym_nil);
  792.                 POPGC;
  793.                 if(result && !NILP(result))
  794.                 {
  795.                 result = NULL;
  796.                 goto again;
  797.                 }
  798.             }
  799.             else
  800.                 cmd_signal(sym_invalid_autoload, LIST_1(VCAR(obj)));
  801.             }
  802.         }
  803.         else
  804.             cmd_signal(sym_invalid_function, LIST_1(VCAR(obj)));
  805.         break;
  806.         default:
  807.         cmd_signal(sym_invalid_function, LIST_1(VCAR(obj)));
  808.         break;
  809.         }
  810.         break;
  811.     case V_Var:
  812.         if(!(result = VVARFUN(obj)(NULL)))
  813.         cmd_signal(sym_void_value, LIST_1(obj));
  814.         break;
  815.     default:
  816.         result = obj;
  817.         break;
  818.     }
  819.     }
  820.     else
  821.     cmd_signal(sym_error, LIST_1(MKSTR("Void object to `eval'")));
  822.     /* In case I missed a non-local exit somewhere.  */
  823.     if(result && ThrowValue)
  824.     result = NULL;
  825. end:
  826.     LispDepth--;
  827.     return(result);
  828. }
  829. _PR VALUE cmd_eval(VALUE);
  830. DEFUN("eval", cmd_eval, subr_eval, (VALUE obj), V_Subr1, DOC_eval) /*
  831. ::doc:eval::
  832. (eval FORM)
  833. Evaluates FORM and returns its value.
  834. ::end:: */
  835. {
  836.     static int DbDepth;
  837.     bool newssflag = TRUE;
  838.     VALUE result;
  839.  
  840.     /*
  841.      * Safety barrier... when the last window is closed the only safe
  842.      * thing to do is die :(
  843.      */
  844.     if(!CurrVW)
  845.     return(NULL);
  846.  
  847.     if((DataAfterGC >= DataBeforeGC) && !GCinhibit)
  848.     {
  849.     GCVAL gcv_obj;
  850.     PUSHGC(gcv_obj, obj);
  851.     cmd_garbage_collect(sym_t);
  852.     POPGC;
  853.     }
  854.  
  855.     if(!SingleStepFlag)
  856.     return(_eval(obj));
  857.  
  858.     DbDepth++;
  859.     result = NULL;
  860.     if(VSYM(sym_debug_entry)->sym_Function)
  861.     {
  862.     VALUE dbres;
  863.     VALUE dbargs = cmd_cons(obj, cmd_cons(newnumber(DbDepth), sym_nil));
  864.     if(dbargs)
  865.     {
  866.         GCVAL gcv_dbargs;
  867.         PUSHGC(gcv_dbargs, dbargs);
  868.         SingleStepFlag = FALSE;
  869.         if((dbres = funcall(sym_debug_entry, dbargs)) && CONSP(dbres))
  870.         {
  871.         switch(VNUM(VCAR(dbres)))
  872.         {
  873.         case 1:
  874.             /* single step cdr and following stuff  */
  875.             SingleStepFlag = TRUE;
  876.             result = _eval(VCDR(dbres));
  877.             SingleStepFlag = FALSE;
  878.             break;
  879.         case 2:
  880.             /* run through cdr and step following  */
  881.             result = _eval(VCDR(dbres));
  882.             break;
  883.         case 3:
  884.             /* run cdr and following  */
  885.             result = _eval(VCDR(dbres));
  886.             newssflag = FALSE;
  887.             break;
  888.         case 4:
  889.             /* result = cdr  */
  890.             SingleStepFlag = TRUE;
  891.             result = VCDR(dbres);
  892.             SingleStepFlag = FALSE;
  893.             break;
  894.         }
  895.         if(result)
  896.         {
  897.             if(VSYM(sym_debug_exit)->sym_Function)
  898.             {
  899.             VCAR(dbargs) = result;
  900.             if(!(dbres = funcall(sym_debug_exit, dbargs)))
  901.                 result = NULL;
  902.             }
  903.         }
  904.         }
  905.         POPGC;
  906.     }
  907.     }
  908.     else
  909.     {
  910.     cmd_signal(sym_error, LIST_1(MKSTR("No debugger installed")));
  911.     newssflag = FALSE;
  912.     result = NULL;
  913.     }
  914.     DbDepth--;
  915.     SingleStepFlag = newssflag;
  916.     return(result);
  917. }
  918.  
  919. VALUE
  920. funcall(VALUE fun, VALUE arglist)
  921. {
  922.     int type;
  923.     VALUE result = NULL, origfun = fun;
  924.     GCVAL gcv_origfun, gcv_arglist;
  925. #ifdef MINSTACK
  926.     if(STK_SIZE <= MINSTACK)
  927.     {
  928.     STK_WARN("funcall");
  929.     return(cmd_signal(sym_stack_error, sym_nil));
  930.     }
  931. #endif
  932.     if(++LispDepth > MaxLispDepth)
  933.     {
  934.     LispDepth--;
  935.     return(cmd_signal(sym_error, LIST_1(MKSTR("max-lisp-depth exceeded, possible infite recursion?"))));
  936.     }
  937.     if((DataAfterGC >= DataBeforeGC) && !GCinhibit)
  938.     {
  939.     PUSHGC(gcv_origfun, origfun);
  940.     PUSHGC(gcv_arglist, arglist);
  941.     cmd_garbage_collect(sym_t);
  942.     POPGC; POPGC;
  943.     }
  944.  
  945. again:
  946.     if(SYMBOLP(fun))
  947.     {
  948.     if(VSYM(fun)->sym_Flags & SF_DEBUG)
  949.         SingleStepFlag = TRUE;
  950.     fun = cmd_symbol_function(fun);
  951.     if(!fun)
  952.     {
  953.         cmd_signal(sym_void_function, LIST_1(origfun));
  954.         goto end;
  955.     }
  956.     }
  957.     switch(type = VTYPE(fun))
  958.     {
  959.     int i, nargs;
  960.     VALUE car, argv[5];
  961.     case V_SubrN:
  962.     result = VSUBRNFUN(fun)(arglist);
  963.     break;
  964.     case V_Subr0:
  965.     result = VSUBR0FUN(fun)();
  966.     break;
  967.     case V_Subr1:
  968.     nargs = 1;
  969.     argv[0] = sym_nil;
  970.     goto do_subr;
  971.     case V_Subr2:
  972.     nargs = 2;
  973.     argv[0] = argv[1] = sym_nil;
  974.     goto do_subr;
  975.     case V_Subr3:
  976.     nargs = 3;
  977.     argv[0] = argv[1] = argv[2] = sym_nil;
  978.     goto do_subr;
  979.     case V_Subr4:
  980.     nargs = 4;
  981.     argv[0] = argv[1] = argv[2] = argv[3] = sym_nil;
  982.     goto do_subr;
  983.     case V_Subr5:
  984.     nargs = 5;
  985.     argv[0] = argv[1] = argv[2] = argv[3] = argv[4] = sym_nil;
  986. do_subr:
  987.     for(i = 0; i < nargs; i++)
  988.     {
  989.         if(CONSP(arglist))
  990.         {
  991.         argv[i] = VCAR(arglist);
  992.         arglist = VCDR(arglist);
  993.         }
  994.         else
  995.         break;
  996.     }
  997.     switch(type)
  998.     {
  999.     case V_Subr1:
  1000.         result = VSUBR1FUN(fun)(argv[0]);
  1001.         break;
  1002.     case V_Subr2:
  1003.         result = VSUBR2FUN(fun)(argv[0], argv[1]);
  1004.         break;
  1005.     case V_Subr3:
  1006.         result = VSUBR3FUN(fun)(argv[0], argv[1], argv[2]);
  1007.         break;
  1008.     case V_Subr4:
  1009.         result = VSUBR4FUN(fun)(argv[0], argv[1], argv[2], argv[3]);
  1010.         break;
  1011.     case V_Subr5:
  1012.         result = VSUBR5FUN(fun)(argv[0], argv[1], argv[2],
  1013.                     argv[3], argv[4]);
  1014.         break;
  1015.     }
  1016.     break;
  1017.     case V_Cons:
  1018.     car = VCAR(fun);
  1019.     if(car == sym_lambda)
  1020.     {
  1021.         struct LispCall lc;
  1022.         lc.lc_Next = LispCallStack;
  1023.         lc.lc_Fun = origfun;
  1024.         lc.lc_Args = arglist;
  1025.         lc.lc_ArgsEvalledP = sym_t;
  1026.         LispCallStack = &lc;
  1027.         if(!(result = evallambda(fun, arglist, FALSE))
  1028.            && ThrowValue && (VCAR(ThrowValue) == sym_defun))
  1029.         {
  1030.         result = VCDR(ThrowValue);
  1031.         ThrowValue = NULL;
  1032.         }
  1033.         LispCallStack = lc.lc_Next;
  1034.     }
  1035.     else if(car == sym_autoload)
  1036.     {
  1037.         if(!SYMBOLP(origfun))
  1038.         {
  1039.         /* Unless the function we're funcall'ing is a symbol don't
  1040.            bother.  */
  1041.         cmd_signal(sym_invalid_autoload, list_2(fun, MKSTR("Can only autoload from symbols")));
  1042.         }
  1043.         else
  1044.         {
  1045.         VALUE autoload = VCDR(fun);
  1046.         if(CONSP(autoload))
  1047.         {
  1048.             PUSHGC(gcv_origfun, origfun);
  1049.             PUSHGC(gcv_arglist, arglist);
  1050.             /* trash the autoload defn, this way I make sure
  1051.                that we don't keep trying to autoload a function
  1052.                indefinitely. */
  1053.             VCAR(fun) = sym_nil;
  1054.             autoload = cmd_load(VCAR(autoload), sym_t, sym_nil, sym_nil);
  1055.             POPGC; POPGC;
  1056.             if(autoload && !NILP(autoload))
  1057.             {
  1058.             fun = origfun;
  1059.             goto again;
  1060.             }
  1061.         }
  1062.         else
  1063.             cmd_signal(sym_invalid_autoload, LIST_1(fun));
  1064.         }
  1065.     }
  1066.     else
  1067.         cmd_signal(sym_invalid_function, LIST_1(fun));
  1068.     break;
  1069.     default:
  1070.     cmd_signal(sym_invalid_function, LIST_1(fun));
  1071.     }
  1072.     /* In case I missed a non-local exit somewhere.  */
  1073.     if(result && ThrowValue)
  1074.     result = NULL;
  1075. end:
  1076.     LispDepth--;
  1077.     return(result);
  1078. }
  1079.  
  1080. _PR VALUE cmd_funcall(VALUE);
  1081. DEFUN("funcall", cmd_funcall, subr_funcall, (VALUE args), V_SubrN, DOC_funcall) /*
  1082. ::doc:funcall::
  1083. (funcall FUNCTION ARGS...)
  1084. Calls FUNCTION with arguments ARGS... and returns its result.
  1085. ::end:: */
  1086. {
  1087.     if(!CONSP(args))
  1088.     return(cmd_signal(sym_bad_arg, list_2(sym_nil, newnumber(1))));
  1089.     return(funcall(VCAR(args), VCDR(args)));
  1090. }
  1091.  
  1092. _PR VALUE cmd_progn(VALUE);
  1093. DEFUN("progn", cmd_progn, subr_progn, (VALUE args), V_SF, DOC_progn) /*
  1094. ::doc:progn::
  1095. (progn FORMS... ) <SPECIAL-FORM>
  1096. Eval's each of the FORMS in order returning the value of the last
  1097. one.
  1098. ::end:: */
  1099. {
  1100.     VALUE result = sym_nil;
  1101.     GCVAL gcv_args;
  1102.     PUSHGC(gcv_args, args);
  1103.     while(CONSP(args))
  1104.     {
  1105.     result = cmd_eval(VCAR(args));
  1106.     args = VCDR(args);
  1107.     if(!result)
  1108.         break;
  1109.     }
  1110.     if(result && !NILP(args))
  1111.     result = cmd_eval(args);
  1112.     POPGC;
  1113.     return(result);
  1114. }
  1115.  
  1116. VALUE
  1117. evalstring(u_char *str, bool isValString)
  1118. {
  1119.     VALUE res = sym_nil;
  1120.     VALUE stream = cmd_cons(newnumber(0), sym_nil);
  1121.     if(stream)
  1122.     {
  1123.     VALUE obj;
  1124.     int c;
  1125.     GCVAL gcv_stream;
  1126.     if(isValString)
  1127.         VCDR(stream) = STRING_HDR(str);
  1128.     else
  1129.     {
  1130.         if(!(VCDR(stream) = valstrdup(str)))
  1131.         return(NULL);
  1132.     }
  1133.     PUSHGC(gcv_stream, stream);
  1134.     obj = sym_nil;
  1135.     c = streamgetc(stream);
  1136.     while(res && (c != EOF) && (obj = readlispexp(stream, &c)))
  1137.         res = cmd_eval(obj);
  1138.     POPGC;
  1139.     }
  1140.     return(res);
  1141. }
  1142.  
  1143. VALUE
  1144. calllisp0(VALUE function)
  1145. {
  1146.     return(funcall(function, sym_nil));
  1147. }
  1148. VALUE
  1149. calllisp1(VALUE function, VALUE arg1)
  1150. {
  1151.     return(funcall(function, LIST_1(arg1)));
  1152. }
  1153. VALUE
  1154. calllisp2(VALUE function, VALUE arg1, VALUE arg2)
  1155. {
  1156.     return(funcall(function, LIST_2(arg1, arg2)));
  1157. }
  1158.  
  1159. void
  1160. lisp_prin(VALUE strm, VALUE obj)
  1161. {
  1162.     switch(VTYPE(obj))
  1163.     {
  1164.     u_char tbuf[40];
  1165.     int j;
  1166.     case V_Number:
  1167.     sprintf(tbuf, "%ld", VNUM(obj));
  1168.     streamputs(strm, tbuf, FALSE);
  1169.     break;
  1170.     case V_Cons:
  1171.     streamputc(strm, '\(');
  1172.     while(CONSP(VCDR(obj)))
  1173.     {
  1174.         printval(strm, VCAR(obj));
  1175.         obj = VCDR(obj);
  1176.         streamputc(strm, ' ');
  1177.     }
  1178.     printval(strm, VCAR(obj));
  1179.     if(!NILP(VCDR(obj)))
  1180.     {
  1181.         streamputs(strm, " . ", FALSE);
  1182.         printval(strm, VCDR(obj));
  1183.     }
  1184.     streamputc(strm, ')');
  1185.     break;
  1186.     case V_Vector:
  1187.     streamputc(strm, '\[');
  1188.     for(j = 0; j < VVECT(obj)->vc_Size; j++)
  1189.     {
  1190.         if(VVECT(obj)->vc_Array[j])
  1191.         printval(strm, VVECT(obj)->vc_Array[j]);
  1192.         else
  1193.         streamputs(strm, "#<void>", FALSE);
  1194.         if(j != (VVECT(obj)->vc_Size - 1))
  1195.         streamputc(strm, ' ');
  1196.     }
  1197.     streamputc(strm, ']');
  1198.     break;
  1199.     case V_Subr0:
  1200.     case V_Subr1:
  1201.     case V_Subr2:
  1202.     case V_Subr3:
  1203.     case V_Subr4:
  1204.     case V_Subr5:
  1205.     case V_SubrN:
  1206.     sprintf(tbuf, "#<subr %s>", VSTR(VXSUBR(obj)->subr_Name));
  1207.     streamputs(strm, tbuf, FALSE);
  1208.     break;
  1209.     case V_SF:
  1210.     sprintf(tbuf, "#<special-form %s>", VSTR(VXSUBR(obj)->subr_Name));
  1211.     streamputs(strm, tbuf, FALSE);
  1212.     break;
  1213.     case V_Var:
  1214.     sprintf(tbuf, "#<var %s>", VSTR(VXSUBR(obj)->subr_Name));
  1215.     streamputs(strm, tbuf, FALSE);
  1216.     break;
  1217. #ifndef HAVE_UNIX
  1218.     case V_Process:
  1219.     streamputs(strm, "#<process>", FALSE);
  1220.     break;
  1221. #endif
  1222.     default:
  1223.     streamputs(strm, "#<unknown object type>", FALSE);
  1224.     }
  1225. }
  1226.  
  1227. void
  1228. string_princ(VALUE strm, VALUE obj)
  1229. {
  1230.     streamputs(strm, VSTR(obj), FALSE);
  1231. }
  1232. void
  1233. string_print(VALUE strm, VALUE obj)
  1234. {
  1235.     u_char *s = VSTR(obj);
  1236.     u_char c;
  1237.     streamputc(strm, '\"');
  1238.     while((c = *s++))
  1239.     {
  1240.     switch(c)
  1241.     {
  1242.     case '\t':
  1243.         streamputs(strm, "\\t", FALSE);
  1244.         break;
  1245.     case '\n':
  1246.         streamputs(strm, "\\n", FALSE);
  1247.         break;
  1248.     case '\\':
  1249.         streamputs(strm, "\\\\", FALSE);
  1250.         break;
  1251.     case '"':
  1252.         streamputs(strm, "\\\"", FALSE);
  1253.         break;
  1254.     default:
  1255.         streamputc(strm, (int)c);
  1256.     }
  1257.     }
  1258.     streamputc(strm, '\"');
  1259. }
  1260.  
  1261. VALUE
  1262. findmemberbyindex(VALUE list, int index)
  1263. {
  1264.     while((--index) && CONSP(list))
  1265.     list = VCDR(list);
  1266.     if(CONSP(list))
  1267.     return(VCAR(list));
  1268.     return(sym_nil);
  1269. }
  1270. VALUE
  1271. movedownlist(VALUE list, int nodes)
  1272. {
  1273.     while((nodes--) && CONSP(list))
  1274.     list = VCDR(list);
  1275.     return(list);
  1276. }
  1277. int
  1278. listlen(VALUE list)
  1279. {
  1280.     int i = 0;
  1281.     while(CONSP(list))
  1282.     {
  1283.     i++;
  1284.     list = VCDR(list);
  1285.     }
  1286.     return(i);
  1287. }
  1288. VALUE
  1289. copylist(VALUE list)
  1290. {
  1291.     VALUE result;
  1292.     VALUE *last = &result;
  1293.     while(CONSP(list))
  1294.     {
  1295.     if(!(*last = cmd_cons(VCAR(list), sym_nil)))
  1296.         return(NULL);
  1297.     list = VCDR(list);
  1298.     last = &VCDR(*last);
  1299.     }
  1300.     *last = list;
  1301.     return(result);
  1302. }
  1303.  
  1304. /*
  1305.  * Used for easy handling of `var' objects
  1306.  */
  1307. VALUE
  1308. handlevarint(VALUE val, long *data)
  1309. {
  1310.     if(val)
  1311.     {
  1312.     if(NUMBERP(val))
  1313.         *data = VNUM(val);
  1314.     return(NULL);
  1315.     }
  1316.     return(newnumber(*data));
  1317. }
  1318.  
  1319. _PR VALUE cmd_break(void);
  1320. DEFUN("break", cmd_break, subr_break, (void), V_Subr0, DOC_break) /*
  1321. ::doc:break::
  1322. (break)
  1323. The next form to be evaluated will be done so through the Lisp debugger.
  1324. ::end:: */
  1325. {
  1326.     SingleStepFlag = TRUE;
  1327.     return(sym_t);
  1328. }
  1329.  
  1330. _PR VALUE cmd_step(VALUE);
  1331. DEFUN("step", cmd_step, subr_step, (VALUE form), V_Subr1, DOC_step) /*
  1332. ::doc:step::
  1333. (step FORM)
  1334. Use the Lisp debugger to evaluate FORM.
  1335. ::end:: */
  1336. {
  1337.     VALUE res;
  1338.     bool oldssf = SingleStepFlag;
  1339.     SingleStepFlag = TRUE;
  1340.     res = cmd_eval(form);
  1341.     SingleStepFlag = oldssf;
  1342.     return(res);
  1343. }
  1344.  
  1345. _PR VALUE cmd_macroexpand(VALUE, VALUE);
  1346. DEFUN("macroexpand", cmd_macroexpand, subr_macroexpand, (VALUE form, VALUE env), V_Subr2, DOC_macroexpand) /*
  1347. ::doc:macroexpand::
  1348. (macroexpand FORM [ENVIRONMENT])
  1349. If FORM is a macro call, expand it until it isn't. If ENVIRONMENT is
  1350. specified it is an alist of `(MACRO-NAME . DEFINITION)'.
  1351. ::end:: */
  1352. {
  1353.     VALUE car;
  1354.     GCVAL gcv_form, gcv_env, gcv_car;
  1355.     PUSHGC(gcv_form, form);
  1356.     PUSHGC(gcv_env, env);
  1357.     PUSHGC(gcv_car, car);
  1358. top:
  1359.     if(CONSP(form))
  1360.     {
  1361.     car = VCAR(form);
  1362.     if(SYMBOLP(car))
  1363.     {
  1364.         VALUE tmp;
  1365.         if(!NILP(env) && (tmp = cmd_assq(car, env)) && CONSP(tmp))
  1366.         {
  1367.         car = VCDR(tmp);
  1368.         form = evallambda(car, VCDR(form), FALSE);
  1369.         if(form)
  1370.             goto top;
  1371.         }
  1372.         else
  1373.         {
  1374.         car = cmd_symbol_function(car);
  1375.         if(!car || NILP(car))
  1376.             goto end;
  1377.         if(CONSP(car) && (VCAR(car) == sym_macro) && (VCAR(VCDR(car)) == sym_lambda))
  1378.         {
  1379.             form = evallambda(VCDR(car), VCDR(form), FALSE);
  1380.             if(form)
  1381.             goto top;
  1382.         }
  1383.         }
  1384.     }
  1385.     }
  1386. end:
  1387.     POPGC; POPGC; POPGC;
  1388.     return(form);
  1389. }
  1390.  
  1391. _PR VALUE cmd_get_doc_string(VALUE idx);
  1392. DEFUN("get-doc-string", cmd_get_doc_string, subr_get_doc_string, (VALUE idx), V_Subr1, DOC_get_doc_string) /*
  1393. ::doc:get_doc_string::
  1394. (get-doc-string INDEX)
  1395. Returns the document-string number INDEX.
  1396. ::end:: */
  1397. {
  1398.     DECLARE1(idx, NUMBERP);
  1399.     return(cmd_read_file_from_to(MKSTR(DOC_FILE), idx, newnumber((int)'\f')));
  1400. }
  1401.  
  1402. _PR VALUE cmd_add_doc_string(VALUE str);
  1403. DEFUN("add-doc-string", cmd_add_doc_string, subr_add_doc_string, (VALUE str), V_Subr1, DOC_add_doc_string) /*
  1404. ::doc:add_doc_string::
  1405. (add-doc-string STRING)
  1406. Appends STRING to the end of the doc-file and returns the index position of
  1407. it's first character (a number).
  1408. ::end:: */
  1409. {
  1410.     FILE *docs;
  1411.     DECLARE1(str, STRINGP);
  1412.     docs = fopen(DOC_FILE, "a");
  1413.     if(docs)
  1414.     {
  1415.     int len = strlen(VSTR(str));
  1416.     VALUE idx = newnumber(ftell(docs));
  1417.     if(fwrite(VSTR(str), 1, len, docs) != len)
  1418.     {
  1419.         return(cmd_signal(sym_file_error,
  1420.                   LIST_1(MKSTR("Can't append to doc-file"))));
  1421.     }
  1422.     putc('\f', docs);
  1423.     fclose(docs);
  1424.     return(idx);
  1425.     }
  1426.     return(cmd_signal(sym_file_error,
  1427.               list_2(MKSTR("Can't open doc-file"), MKSTR(DOC_FILE))));
  1428. }
  1429.  
  1430. _PR VALUE var_debug_on_error(VALUE val);
  1431. DEFUN("debug-on-error", var_debug_on_error, subr_debug_on_error, (VALUE val), V_Var, DOC_debug_on_error) /*
  1432. ::doc:debug_on_error::
  1433. When an error is signalled this variable controls whether or not to enter the
  1434. Lisp debugger immediately. If the variable's value is t or a list of symbols
  1435. - one of which is the signalled error symbol - the debugger is entered.
  1436. See `signal'.
  1437. ::end:: */
  1438. {
  1439.     if(val)
  1440.     DebugOnError = val;
  1441.     return(DebugOnError);
  1442. }
  1443.  
  1444. _PR VALUE cmd_signal(VALUE error, VALUE data);
  1445. DEFUN("signal", cmd_signal, subr_signal, (VALUE error, VALUE data), V_Subr2, DOC_signal) /*
  1446. ::doc:signal::
  1447. (signal ERROR-SYMBOL DATA)
  1448. Signal that an error has happened. ERROR-SYMBOL is the name of a symbol
  1449. classifying the type of error, it should have a property `error-message' (a
  1450. string) with a short description of the error message.
  1451. DATA is a list of objects which are relevant to the error -- they will
  1452. be made available to any error-handler or printed by the default error
  1453. -handler.
  1454. ::end:: */
  1455. {
  1456.     VALUE tmp, errlist;
  1457.     /* Can only have one error at once.     */
  1458.     if(ThrowValue)
  1459.     return(NULL);
  1460.     DECLARE1(error, SYMBOLP);
  1461.  
  1462.     errlist = cmd_cons(error, data);
  1463.  
  1464.     if(((DebugOnError == sym_t)
  1465.     || (CONSP(DebugOnError) && (tmp = cmd_memq(error, DebugOnError))
  1466.         && !NILP(tmp)))
  1467.        && VSYM(sym_debug_error_entry)->sym_Function)
  1468.     {
  1469.     /* Enter debugger. */
  1470.     VALUE oldDebugOnError = DebugOnError;
  1471.     GCVAL gcv_odoe;
  1472.     bool oldssflag = SingleStepFlag;
  1473.     DebugOnError = sym_nil;
  1474.     SingleStepFlag = FALSE;
  1475.     PUSHGC(gcv_odoe, oldDebugOnError);
  1476.     tmp = funcall(sym_debug_error_entry, cmd_cons(errlist, sym_nil));
  1477.     POPGC;
  1478.     DebugOnError = oldDebugOnError;
  1479.     if(tmp && (tmp == sym_t))
  1480.         SingleStepFlag = TRUE;
  1481.     else
  1482.         SingleStepFlag = oldssflag;
  1483.     }
  1484.     ThrowValue = cmd_cons(sym_error, errlist);
  1485.     return(NULL);
  1486. }
  1487.  
  1488. _PR VALUE cmd_error_protect(VALUE args);
  1489. DEFUN("error-protect", cmd_error_protect, subr_error_protect, (VALUE args), V_SF, DOC_error_protect) /*
  1490. ::doc:error_protect::
  1491. (error-protect FORM HANDLERS...) <SPECIAL-FORM>
  1492. Evaluates FORM with error-handlers in place, if no errors occur return the
  1493. value returned by FORM, else the value of whichever handler's body was
  1494. evaluated.
  1495. Each HANDLER is a list looking like `(ERROR-SYMBOL BODY...)'. If an error
  1496. of type ERROR-SYMBOL occurs BODY is evaluated with the symbol `error-info'
  1497. temporarily set to `(ERROR-SYMBOL . DATA)' (these were the arguments given to
  1498. the `signal' which caused the error).
  1499. ::end:: */
  1500. {
  1501.     VALUE res;
  1502.     GCVAL gcv_args;
  1503.     if(!CONSP(args))
  1504.     return(cmd_signal(sym_bad_arg, list_2(sym_nil, newnumber(1))));
  1505.     PUSHGC(gcv_args, args);
  1506.     if(!(res = cmd_eval(VCAR(args))) && ThrowValue
  1507.        && (VCAR(ThrowValue) == sym_error))
  1508.     {
  1509.     /* an error.  */
  1510.     VALUE errorsym = VCAR(VCDR(ThrowValue)), handlers = VCDR(args);
  1511.     while(CONSP(handlers) && CONSP(VCAR(handlers)))
  1512.     {
  1513.         VALUE handler = VCAR(handlers);
  1514.         if((VCAR(handler) == errorsym) || (VCAR(handler) == sym_error))
  1515.         {
  1516.         VALUE bindlist = sym_nil;
  1517.         GCVAL gcv_bindlist;
  1518.         bindlist = bindsymbol(sym_nil, sym_error_info, VCDR(ThrowValue));
  1519.         ThrowValue = NULL;
  1520.         PUSHGC(gcv_bindlist, bindlist);
  1521.         res = cmd_progn(VCDR(handler));
  1522.         POPGC;
  1523.         unbindsymbols(bindlist);
  1524.         break;
  1525.         }
  1526.         handlers = VCDR(handlers);
  1527.     }
  1528.     }
  1529.     POPGC;
  1530.     return(res);
  1531. }
  1532.  
  1533. void
  1534. handleerror(VALUE error, VALUE data)
  1535. {
  1536.     VALUE errstr;
  1537.     cmd_beep();
  1538.     if(!(errstr = cmd_get(error, sym_error_message)) || !STRINGP(errstr))
  1539.     errstr = MKSTR("Unknown error");
  1540.     switch(listlen(data))
  1541.     {
  1542.     case 0:
  1543.     cmd_format(list_3(sym_t, MKSTR("%s"), errstr));
  1544.     break;
  1545.     case 1:
  1546.     cmd_format(list_4(sym_t, MKSTR("%s: %s"), errstr, VCAR(data)));
  1547.     break;
  1548.     case 2:
  1549.     cmd_format(list_5(sym_t, MKSTR("%s: %s, %s"), errstr,
  1550.               VCAR(data), VCAR(VCDR(data))));
  1551.     break;
  1552.     case 3:
  1553.     cmd_format(cmd_cons(sym_t, list_5(MKSTR("%s: %s, %s, %s"), errstr,
  1554.               VCAR(data), VCAR(VCDR(data)), VCAR(VCDR(VCDR(data))))));
  1555.     break;
  1556.     default:
  1557.     cmd_format(list_3(sym_t, MKSTR("%s: ..."), errstr));
  1558.     }
  1559. }
  1560.  
  1561. void
  1562. signalargerror(VALUE obj, int argNum)
  1563. {
  1564.     cmd_signal(sym_bad_arg, list_2(obj, newnumber(argNum)));
  1565. }
  1566.  
  1567. _PR VALUE cmd_backtrace(VALUE strm);
  1568. DEFUN("backtrace", cmd_backtrace, subr_backtrace, (VALUE strm), V_Subr1, DOC_backtrace) /*
  1569. ::doc:backtrace::
  1570. (backtrace [STREAM])
  1571. Prints a backtrace of the current Lisp call stack to STREAM (or to
  1572. `standard-output').
  1573. The format is something like:
  1574.   FUNCTION (ARGLIST) ARGS-EVALLED-P
  1575. where ARGS-EVALLED-P is either `t' or `nil', depending on whether or not
  1576. ARGLIST had been evaluated or not before being put into the stack.
  1577. ::end:: */
  1578. {
  1579.     struct LispCall *lc;
  1580.     if(NILP(strm) && !(strm = cmd_symbol_value(sym_standard_output)))
  1581.     return(cmd_signal(sym_bad_arg, list_2(strm, newnumber(1))));
  1582.     lc = LispCallStack;
  1583.     while(lc)
  1584.     {
  1585.     streamputc(strm, '\n');
  1586.     printval(strm, lc->lc_Fun);
  1587.     streamputc(strm, ' ');
  1588.     printval(strm, lc->lc_Args);
  1589.     streamputc(strm, ' ');
  1590.     printval(strm, lc->lc_ArgsEvalledP);
  1591.     lc = lc->lc_Next;
  1592.     }
  1593.     return(sym_t);
  1594. }
  1595.  
  1596. _PR VALUE var_max_lisp_depth(VALUE val);
  1597. DEFUN("max-lisp-depth", var_max_lisp_depth, subr_max_lisp_depth, (VALUE val), V_Var, DOC_max_lisp_depth) /*
  1598. ::doc:max_lisp_depth::
  1599. The maximum number of times that eval and funcall can be called recursively.
  1600. This is intended to stop infinite recursion, if the default value of 250 is
  1601. too small (you get errors in normal use) set it to something larger.
  1602. ::end:: */
  1603. {
  1604.     return(handlevarint(val, &MaxLispDepth));
  1605. }
  1606.  
  1607. void
  1608. lisp_init(void)
  1609. {
  1610.     INTERN(sym_quote, "quote");
  1611.     INTERN(sym_lambda, "lambda");
  1612.     INTERN(sym_macro, "macro");
  1613.     INTERN(sym_autoload, "autoload");
  1614.     INTERN(sym_function, "function");
  1615.     INTERN(sym_standard_input, "standard-input");
  1616.     INTERN(sym_standard_output, "standard-output");
  1617.     INTERN(sym_defun, "defun");
  1618.     INTERN(sym_debug_entry, "debug-entry");
  1619.     INTERN(sym_debug_exit, "debug-exit");
  1620.     INTERN(sym_debug_error_entry, "debug-error-entry");
  1621.     INTERN(sym_amp_optional, "&optional");
  1622.     INTERN(sym_amp_rest, "&rest");
  1623.     INTERN(sym_amp_aux, "&aux");
  1624.     markstatic(&ThrowValue);
  1625.     ADD_SUBR(subr_eval);
  1626.     ADD_SUBR(subr_funcall);
  1627.     ADD_SUBR(subr_progn);
  1628.     ADD_SUBR(subr_break);
  1629.     ADD_SUBR(subr_step);
  1630.     ADD_SUBR(subr_macroexpand);
  1631.     ADD_SUBR(subr_get_doc_string);
  1632.     ADD_SUBR(subr_add_doc_string);
  1633.     ADD_SUBR(subr_debug_on_error);
  1634.     ADD_SUBR(subr_signal);
  1635.     ADD_SUBR(subr_error_protect);
  1636.     ADD_SUBR(subr_backtrace);
  1637.     ADD_SUBR(subr_max_lisp_depth);
  1638.  
  1639.     /* Stuff for error-handling */
  1640.     DebugOnError = sym_nil;
  1641.     INTERN(sym_error_message, "error-message");
  1642.     INTERN(sym_error, "error");
  1643.     cmd_put(sym_error, sym_error_message, MKSTR("Error"));
  1644.     INTERN(sym_invalid_function, "invalid-function");
  1645.     cmd_put(sym_invalid_function, sym_error_message, MKSTR("Invalid function"));
  1646.     INTERN(sym_void_function, "void-function");
  1647.     cmd_put(sym_void_function, sym_error_message, MKSTR("Function value is void"));
  1648.     INTERN(sym_void_value, "void-value");
  1649.     cmd_put(sym_void_value, sym_error_message, MKSTR("Value as variable is void"));
  1650.     INTERN(sym_bad_arg, "bad-arg");
  1651.     cmd_put(sym_bad_arg, sym_error_message, MKSTR("Bad argument"));
  1652.     INTERN(sym_invalid_read_syntax, "invalid-read-syntax");
  1653.     cmd_put(sym_invalid_read_syntax, sym_error_message, MKSTR("Invalid read syntax"));
  1654.     INTERN(sym_end_of_stream, "end-of-stream");
  1655.     cmd_put(sym_end_of_stream, sym_error_message, MKSTR("Premature end of stream"));
  1656.     INTERN(sym_invalid_lambda_list, "invalid-lambda-list");
  1657.     cmd_put(sym_invalid_lambda_list, sym_error_message, MKSTR("Invalid lambda-list"));
  1658.     INTERN(sym_missing_arg, "missing-arg");
  1659.     cmd_put(sym_missing_arg, sym_error_message, MKSTR("Required argument missing"));
  1660.     INTERN(sym_invalid_macro, "invalid-macro");
  1661.     cmd_put(sym_invalid_macro, sym_error_message, MKSTR("Invalid macro definition"));
  1662.     INTERN(sym_invalid_autoload, "invalid-autoload");
  1663.     cmd_put(sym_invalid_autoload, sym_error_message, MKSTR("Invalid autoload definition"));
  1664.     INTERN(sym_no_catcher, "no-catcher");
  1665.     cmd_put(sym_no_catcher, sym_error_message, MKSTR("No catch'er for throw"));
  1666.     INTERN(sym_buffer_read_only, "buffer-read-only");
  1667.     cmd_put(sym_buffer_read_only, sym_error_message, MKSTR("Buffer is read-only"));
  1668.     INTERN(sym_bad_event_desc, "bad_event_desc");
  1669.     cmd_put(sym_bad_event_desc, sym_error_message, MKSTR("Invalid event description"));
  1670.     INTERN(sym_file_error, "file-error");
  1671.     cmd_put(sym_file_error, sym_error_message, MKSTR("File error"));
  1672.     INTERN(sym_invalid_stream, "invalid-stream");
  1673.     cmd_put(sym_invalid_stream, sym_error_message, MKSTR("Invalid stream"));
  1674.     INTERN(sym_setting_constant, "setting-constant");
  1675.     cmd_put(sym_setting_constant, sym_error_message, MKSTR("Attempt to set value of constant"));
  1676.     INTERN(sym_process_error, "process-error");
  1677.     cmd_put(sym_process_error, sym_error_message, MKSTR("Process error"));
  1678.     INTERN(sym_invalid_area, "invalid-area");
  1679.     cmd_put(sym_invalid_area, sym_error_message, MKSTR("Invalid area"));
  1680. #ifdef MINSTACK
  1681.     INTERN(sym_stack_error, "stack-error");
  1682.     cmd_put(sym_stack_error, sym_error_message, MKSTR("Stack overflow"));
  1683. #endif
  1684.     INTERN(sym_error_info, "error-info");
  1685. }
  1686.