home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / src / lisp.c < prev    next >
C/C++ Source or Header  |  1994-10-06  |  42KB  |  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 != '"