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