home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / src / lisp.c < prev    next >
C/C++ Source or Header  |  1994-04-19  |  40KB  |  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.