home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD1.bin / new / util / edit / jade / src / lispmach.c < prev    next >
C/C++ Source or Header  |  1994-10-06  |  21KB  |  1,049 lines
  1. /* lispmach.c -- Interpreter for compiled Lisp forms
  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. #ifdef HAVE_ALLOCA
  24. # include <alloca.h>
  25. #endif
  26.  
  27. _PR void lispmach_init(void);
  28.  
  29. #define OP_CALL 0x08
  30. #define OP_PUSH 0x10
  31. #define OP_VREFC 0x18
  32. #define OP_VSETC 0x20
  33. #define OP_LIST 0x28
  34. #define OP_BIND 0x30
  35. #define OP_LAST_WITH_ARGS 0x38
  36.  
  37. #define OP_VREF 0x40
  38. #define OP_VSET 0x41
  39. #define OP_FREF 0x42
  40. #define OP_FSET 0x43
  41. #define OP_INIT_BIND 0x44
  42. #define OP_UNBIND 0x45
  43. #define OP_DUP    0x46
  44. #define OP_SWAP 0x47
  45. #define OP_POP    0x48
  46.  
  47. #define OP_NIL 0x49
  48. #define OP_T 0x4a
  49. #define OP_CONS 0x4b
  50. #define OP_CAR 0x4c
  51. #define OP_CDR 0x4d
  52. #define OP_RPLACA 0x4e
  53. #define OP_RPLACD 0x4f
  54. #define OP_NTH 0x50
  55. #define OP_NTHCDR 0x51
  56. #define OP_ASET 0x52
  57. #define OP_AREF 0x53
  58. #define OP_LENGTH 0x54
  59. #define OP_EVAL 0x55
  60. #define OP_PLUS_2 0x56
  61. #define OP_NEGATE 0x57
  62. #define OP_MINUS_2 0x58
  63. #define OP_PRODUCT_2 0x59
  64. #define OP_DIVIDE_2 0x5a
  65. #define OP_MOD_2 0x5b
  66. #define OP_LOGNOT 0x5c
  67. #define OP_NOT 0x5d
  68. #define OP_LOGIOR_2 0x5e
  69. #define OP_LOGAND_2 0x5f
  70. #define OP_EQUAL 0x60
  71. #define OP_EQ 0x61
  72. #define OP_NUM_EQ 0x62
  73. #define OP_NUM_NOTEQ 0x63
  74. #define OP_GTTHAN 0x64
  75. #define OP_GETHAN 0x65
  76. #define OP_LTTHAN 0x66
  77. #define OP_LETHAN 0x67
  78. #define OP_INC 0x68
  79. #define OP_DEC 0x69
  80. #define OP_LSH 0x6a
  81. #define OP_ZEROP 0x6b
  82. #define OP_NULL 0x6c
  83. #define OP_ATOM 0x6d
  84. #define OP_CONSP 0x6e
  85. #define OP_LISTP 0x6f
  86. #define OP_NUMBERP 0x70
  87. #define OP_STRINGP 0x71
  88. #define OP_VECTORP 0x72
  89. #define OP_CATCH_KLUDGE 0x73
  90. #define OP_THROW 0x74
  91. #define OP_UNWIND_PRO 0x75
  92. #define OP_UN_UNWIND_PRO 0x76
  93. #define OP_FBOUNDP 0x77
  94. #define OP_BOUNDP 0x78
  95. #define OP_SYMBOLP 0x79
  96. #define OP_GET 0x7a
  97. #define OP_PUT 0x7b
  98. #define OP_ERROR_PRO 0x7c
  99. #define OP_SIGNAL 0x7d
  100. #define OP_RETURN 0x7e
  101. #define OP_REVERSE 0x7f        /* new 12/7/94 */
  102. #define OP_NREVERSE 0x80
  103. #define OP_ASSOC 0x81
  104. #define OP_ASSQ 0x82
  105. #define OP_RASSOC 0x83
  106. #define OP_RASSQ 0x84
  107. #define OP_LAST 0x85
  108. #define OP_MAPCAR 0x86
  109. #define OP_MAPC 0x87
  110. #define OP_MEMBER 0x88
  111. #define OP_MEMQ 0x89
  112. #define OP_DELETE 0x8a
  113. #define OP_DELQ 0x8b
  114. #define OP_DELETE_IF 0x8c
  115. #define OP_DELETE_IF_NOT 0x8d
  116. #define OP_COPY_SEQUENCE 0x8e
  117. #define OP_SEQUENCEP 0x8f
  118. #define OP_FUNCTIONP 0x90
  119. #define OP_SPECIAL_FORM_P 0x91
  120. #define OP_SUBRP 0x92
  121. #define OP_EQL 0x93
  122. #define OP_LOGXOR_2 0x94    /* new 23-8-94 */
  123.  
  124. #define OP_SET_CURRENT_BUFFER 0xb0
  125. #define OP_SWAP_BUFFER 0xb1
  126. #define OP_CURRENT_BUFFER 0xb2
  127. #define OP_BUFFERP 0xb3
  128. #define OP_MARKP 0xb4
  129. #define OP_WINDOWP 0xb5
  130. #define OP_SWAP_WINDOW 0xb6
  131.  
  132. #define OP_LAST_BEFORE_JMPS 0xfa
  133. #define OP_JMP 0xfb
  134. #define OP_JN 0xfc
  135. #define OP_JT 0xfd
  136. #define OP_JNP 0xfe
  137. #define OP_JTP 0xff
  138.  
  139. #define TOP        (*stackp)
  140. #define RET_POP        (*stackp--)
  141. #define POP        (stackp--)
  142. #define POPN(n)        (stackp -= n)
  143. #define PUSH(v)        (*(++stackp) = (v))
  144. #define STK_USE        (stackp - (stackbase - 1))
  145.  
  146. #define ARG_SHIFT    8
  147. #define OP_ARG_MASK  0x07
  148. #define OP_OP_MASK   0xf8
  149. #define OP_ARG_1BYTE 6
  150. #define OP_ARG_2BYTE 7
  151.  
  152. /* These macros pop as many args as required then call the specified
  153.    function properly. */
  154.  
  155. #define CALL_1(cmd)                \
  156.     if((TOP = cmd (TOP)))            \
  157.     break;                    \
  158.     goto error
  159.     
  160. #define CALL_2(cmd)                \
  161.     tmp = RET_POP;                \
  162.     if((TOP = cmd (TOP, tmp)))            \
  163.     break;                    \
  164.     goto error
  165.  
  166. #define CALL_3(cmd)                \
  167.     tmp = RET_POP;                \
  168.     tmp2 = RET_POP;                \
  169.     if((TOP = cmd (TOP, tmp2, tmp)))        \
  170.     break;                    \
  171.     goto error
  172.  
  173. _PR VALUE cmd_jade_byte_code(VALUE code, VALUE consts, VALUE stkreq);
  174. DEFUN("jade-byte-code", cmd_jade_byte_code, subr_jade_byte_code, (VALUE code, VALUE consts, VALUE stkreq), V_Subr3, DOC_jade_byte_code) /*
  175. ::doc:jade_byte_code::
  176. jade-byte-code CODE-STRING CONST-VEC MAX-STACK
  177.  
  178. Evaluates the string of byte codes CODE-STRING, the constants that it
  179. references are contained in the vector CONST-VEC. MAX-STACK is a number
  180. defining how much stack space is required to evaluate the code.
  181.  
  182. Do *not* attempt to call this function manually, the lisp file `compiler.jl'
  183. contains a simple compiler which translates files of lisp forms into files
  184. of byte code. See the functions `compile-file', `compile-directory' and
  185. `compile-lisp-lib' for more details.
  186. ::end:: */
  187. {
  188.     VALUE *stackbase;
  189.     register VALUE *stackp;
  190.     /* This holds a list of sets of bindings, it can also hold the form of
  191.        an unwind-protect that always gets eval'd (when the car is t).  */
  192.     VALUE bindstack = sym_nil;
  193.     register u_char *pc;
  194.     u_char c;
  195.     GCVAL gcv_code, gcv_consts, gcv_bindstack;
  196.     /* The `gcv_N' field is only filled in with the stack-size when there's
  197.        a chance of gc.    */
  198.     GCVALN gcv_stackbase;
  199.  
  200.     DECLARE1(code, STRINGP);
  201.     DECLARE2(consts, VECTORP);
  202.     DECLARE3(stkreq, NUMBERP);
  203.  
  204. #ifdef HAVE_ALLOCA
  205.     stackbase = alloca(sizeof(VALUE) * VNUM(stkreq));
  206. #else
  207.     if(!(stackbase = str_alloc(sizeof(VALUE) * VNUM(stkreq))))
  208.     return(NULL);
  209. #endif
  210.  
  211.     stackp = stackbase - 1;
  212.     PUSHGC(gcv_code, code);
  213.     PUSHGC(gcv_consts, consts);
  214.     PUSHGC(gcv_bindstack, bindstack);
  215.     PUSHGCN(gcv_stackbase, stackbase, 0);
  216.  
  217.     pc = VSTR(code);
  218.     while((c = *pc++) != 0)
  219.     {
  220.     if(c < OP_LAST_WITH_ARGS)
  221.     {
  222.         register short arg;
  223.         switch(c & OP_ARG_MASK)
  224.         {
  225.         case OP_ARG_1BYTE:
  226.         arg = *pc++;
  227.         break;
  228.         case OP_ARG_2BYTE:
  229.         arg = (pc[0] << ARG_SHIFT) | pc[1];
  230.         pc += 2;
  231.         break;
  232.         default:
  233.         arg = c & OP_ARG_MASK;
  234.         }
  235.         switch(c & OP_OP_MASK)
  236.         {
  237.         register VALUE tmp;
  238.         VALUE tmp2;
  239.  
  240.         case OP_CALL:
  241. #ifdef MINSTACK
  242.         if(STK_SIZE <= MINSTACK)
  243.         {
  244.             STK_WARN("lisp-code");
  245.             TOP = cmd_signal(sym_stack_error, sym_nil);
  246.             goto quit;
  247.         }
  248. #endif
  249.         /* args are still available above the top of the stack,
  250.            this just makes things a bit easier.     */
  251.         POPN(arg);
  252.         tmp = TOP;
  253.         if(SYMBOLP(tmp))
  254.         {
  255.             if(VSYM(tmp)->sym_Flags & SF_DEBUG)
  256.             single_step_flag = TRUE;
  257.             if(!(tmp = cmd_symbol_function(tmp, sym_nil)))
  258.             goto error;
  259.         }
  260.         gcv_stackbase.gcv_N = STK_USE;
  261.         switch(VTYPE(tmp))
  262.         {
  263.         case V_Subr0:
  264.             TOP = VSUBR0FUN(tmp)();
  265.             break;
  266.         case V_Subr1:
  267.             TOP = VSUBR1FUN(tmp)(arg >= 1 ? stackp[1] : sym_nil);
  268.             break;
  269.         case V_Subr2:
  270.             switch(arg)
  271.             {
  272.             case 0:
  273.             TOP = VSUBR2FUN(tmp)(sym_nil, sym_nil);
  274.             break;
  275.             case 1:
  276.             TOP = VSUBR2FUN(tmp)(stackp[1], sym_nil);
  277.             break;
  278.             default:
  279.             TOP = VSUBR2FUN(tmp)(stackp[1], stackp[2]);
  280.             break;
  281.             }
  282.             break;
  283.         case V_Subr3:
  284.             switch(arg)
  285.             {
  286.             case 0:
  287.             TOP = VSUBR3FUN(tmp)(sym_nil, sym_nil, sym_nil);
  288.             break;
  289.             case 1:
  290.             TOP = VSUBR3FUN(tmp)(stackp[1], sym_nil, sym_nil);
  291.             break;
  292.             case 2:
  293.             TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], sym_nil);
  294.             break;
  295.             default:
  296.             TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], stackp[3]);
  297.             break;
  298.             }
  299.             break;
  300.         case V_Subr4:
  301.             switch(arg)
  302.             {
  303.             case 0:
  304.             TOP = VSUBR4FUN(tmp)(sym_nil, sym_nil,
  305.                          sym_nil, sym_nil);
  306.             break;
  307.             case 1:
  308.             TOP = VSUBR4FUN(tmp)(stackp[1], sym_nil,
  309.                          sym_nil, sym_nil);
  310.             break;
  311.             case 2:
  312.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  313.                          sym_nil, sym_nil);
  314.             break;
  315.             case 3:
  316.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  317.                          stackp[3], sym_nil);
  318.             break;
  319.             default:
  320.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  321.                          stackp[3], stackp[4]);
  322.             break;
  323.             }
  324.             break;
  325.         case V_Subr5:
  326.             switch(arg)
  327.             {
  328.             case 0:
  329.             TOP = VSUBR5FUN(tmp)(sym_nil, sym_nil, sym_ni