home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 4 / FreshFish_May-June1994.bin / bbs / may94 / util / edit / jade.lha / Jade / src / lispmach.c < prev    next >
C/C++ Source or Header  |  1994-04-19  |  19KB  |  888 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_BIT_NOT 0x5c
  67. #define OP_NOT 0x5d
  68. #define OP_BIT_OR_2 0x5e
  69. #define OP_BIT_AND_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.  
  101. #define OP_SET_CURRENT_BUFFER 0xb0
  102. #define OP_SWAP_BUFFER 0xb1
  103. #define OP_CURRENT_BUFFER 0xb2
  104. #define OP_BUFFERP 0xb3
  105. #define OP_MARK_P 0xb4
  106. #define OP_WINDOWP 0xb5
  107. #define OP_SWAP_WINDOW 0xb6
  108.  
  109. #define OP_LAST_BEFORE_JMPS 0xfa
  110. #define OP_JMP 0xfb
  111. #define OP_JMP_NIL 0xfc
  112. #define OP_JMP_T 0xfd
  113. #define OP_JMP_NIL_ELSE_POP 0xfe
  114. #define OP_JMP_T_ELSE_POP 0xff
  115.  
  116. #define TOP        (*stackp)
  117. #define RET_POP        (*stackp--)
  118. #define POP        (stackp--)
  119. #define POPN(n)        (stackp -= n)
  120. #define PUSH(v)        (*(++stackp) = (v))
  121. #define STK_USE        (stackp - (stackbase - 1))
  122.  
  123. #define ARG_MASK     0x7f
  124. #define ARG_SHIFT    7
  125. #define OP_ARG_MASK  0x07
  126. #define OP_OP_MASK   0xf8
  127. #define OP_ARG_1BYTE 6
  128. #define OP_ARG_2BYTE 7
  129.  
  130. _PR VALUE cmd_lisp_code(VALUE code, VALUE consts, VALUE stkreq);
  131. DEFUN("lisp-code", cmd_lisp_code, subr_lisp_code, (VALUE code, VALUE consts, VALUE stkreq), V_Subr3, DOC_lisp_code) /*
  132. ::doc:lisp_code::
  133. (lisp-code CODE-STRING CONST-VEC MAX-STACK)
  134. Evaluates the string of byte codes CODE-STRING, the constants that it
  135. references are contained in the vector CONST-VEC. MAX-STACK is a number
  136. defining how much stack space is required to evaluate the code.
  137.  
  138. Do *not* attempt to call this function manually, the lisp file `compiler.jl'
  139. contains a simple compiler which translates files of lisp forms into files
  140. of byte code. See the functions `compile-file', `compile-directory' and
  141. `compile-lisp-lib' for more details.
  142. ::end:: */
  143. {
  144.     VALUE *stackbase;
  145.     register VALUE *stackp;
  146.     /* This holds a list of sets of bindings, it can also hold the form of
  147.        an unwind-protect that always gets eval'd (when the car is t).  */
  148.     VALUE bindstack = sym_nil;
  149.     register u_char *pc;
  150.     u_char c;
  151.     GCVAL gcv_code, gcv_consts, gcv_bindstack;
  152.     /* The `gcv_N' field is only filled in with the stack-size when there's
  153.        a chance of gc.    */
  154.     GCVALN gcv_stackbase;
  155.  
  156.     DECLARE1(code, STRINGP);
  157.     DECLARE2(consts, VECTORP);
  158.     DECLARE3(stkreq, NUMBERP);
  159.  
  160. #ifdef HAVE_ALLOCA
  161.     stackbase = alloca(sizeof(VALUE) * VNUM(stkreq));
  162. #else
  163.     if(!(stackbase = mystralloc(sizeof(VALUE) * VNUM(stkreq))))
  164.     return(NULL);
  165. #endif
  166.  
  167.     stackp = stackbase - 1;
  168.     PUSHGC(gcv_code, code);
  169.     PUSHGC(gcv_consts, consts);
  170.     PUSHGC(gcv_bindstack, bindstack);
  171.     PUSHGCN(gcv_stackbase, stackbase, 0);
  172.  
  173.     pc = VSTR(code);
  174.     while((c = *pc++) != 0)
  175.     {
  176.     if(c < OP_LAST_WITH_ARGS)
  177.     {
  178.         register short arg;
  179.         switch(c & OP_ARG_MASK)
  180.         {
  181.         case OP_ARG_1BYTE:
  182.         arg = *pc++ & ARG_MASK;
  183.         break;
  184.         case OP_ARG_2BYTE:
  185.         arg = ((pc[0] & ARG_MASK) << ARG_SHIFT) | (pc[1] & ARG_MASK);
  186.         pc += 2;
  187.         break;
  188.         default:
  189.         arg = c & OP_ARG_MASK;
  190.         }
  191.         switch(c & OP_OP_MASK)
  192.         {
  193.         register VALUE tmp;
  194.         VALUE tmp2;
  195.         case OP_CALL:
  196. #ifdef MINSTACK
  197.         if(STK_SIZE <= MINSTACK)
  198.         {
  199.             STK_WARN("lisp-code");
  200.             TOP = cmd_signal(sym_stack_error, sym_nil);
  201.             goto quit;
  202.         }
  203. #endif
  204.         if((DataAfterGC >= DataBeforeGC) && !GCinhibit)
  205.         {
  206.             gcv_stackbase.gcv_N = STK_USE;
  207.             cmd_garbage_collect(sym_t);
  208.         }
  209.         /* args are still available above the top of the stack,
  210.            this just makes things a bit easier.     */
  211.         POPN(arg);
  212.         tmp = TOP;
  213.         if(SYMBOLP(tmp))
  214.         {
  215.             if(VSYM(tmp)->sym_Flags & SF_DEBUG)
  216.             SingleStepFlag = TRUE;
  217.             /* The `+ arg' is to make sure that our args (which were
  218.                sort of popped) are protected from gc as well.  */
  219.             if(!(tmp = cmd_symbol_function(tmp)))
  220.             {
  221.             cmd_signal(sym_void_function, LIST_1(TOP));
  222.             goto error;
  223.             }
  224.         }
  225.         gcv_stackbase.gcv_N = STK_USE;
  226.         switch(VTYPE(tmp))
  227.         {
  228.         case V_Subr0:
  229.             TOP = VSUBR0FUN(tmp)();
  230.             break;
  231.         case V_Subr1:
  232.             TOP = VSUBR1FUN(tmp)(arg >= 1 ? stackp[1] : sym_nil);
  233.             break;
  234.         case V_Subr2:
  235.             switch(arg)
  236.             {
  237.             case 0:
  238.             TOP = VSUBR2FUN(tmp)(sym_nil, sym_nil);
  239.             break;
  240.             case 1:
  241.             TOP = VSUBR2FUN(tmp)(stackp[1], sym_nil);
  242.             break;
  243.             default:
  244.             TOP = VSUBR2FUN(tmp)(stackp[1], stackp[2]);
  245.             break;
  246.             }
  247.             break;
  248.         case V_Subr3:
  249.             switch(arg)
  250.             {
  251.             case 0:
  252.             TOP = VSUBR3FUN(tmp)(sym_nil, sym_nil, sym_nil);
  253.             break;
  254.             case 1:
  255.             TOP = VSUBR3FUN(tmp)(stackp[1], sym_nil, sym_nil);
  256.             break;
  257.             case 2:
  258.             TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], sym_nil);
  259.             break;
  260.             default:
  261.             TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], stackp[3]);
  262.             break;
  263.             }
  264.             break;
  265.         case V_Subr4:
  266.             switch(arg)
  267.             {
  268.             case 0:
  269.             TOP = VSUBR4FUN(tmp)(sym_nil, sym_nil,
  270.                          sym_nil, sym_nil);
  271.             break;
  272.             case 1:
  273.             TOP = VSUBR4FUN(tmp)(stackp[1], sym_nil,
  274.                          sym_nil, sym_nil);
  275.             break;
  276.             case 2:
  277.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  278.                          sym_nil, sym_nil);
  279.             break;
  280.             case 3:
  281.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  282.                          stackp[3], sym_nil);
  283.             break;
  284.             default:
  285.             TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
  286.                          stackp[3], stackp[4]);
  287.             break;
  288.             }
  289.             break;
  290.         case V_Subr5:
  291.             switch(arg)
  292.             {
  293.             case 0:
  294.             TOP = VSUBR5FUN(tmp)(sym_nil, sym_nil, sym_nil,
  295.                          sym_nil, sym_nil);
  296.             break;
  297.             case 1:
  298.             TOP = VSUBR5FUN(tmp)(stackp[1], sym_nil, sym_nil,
  299.                          sym_nil, sym_nil);
  300.             break;
  301.             case 2:
  302.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], sym_nil,
  303.                          sym_nil, sym_nil);
  304.             break;
  305.             case 3:
  306.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3],
  307.                          sym_nil, sym_nil);
  308.             break;
  309.             case 4:
  310.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3],
  311.                          stackp[4], sym_nil);
  312.             default:
  313.             TOP = VSUBR5FUN(tmp)(stackp[1], stackp[2], stackp[3],
  314.                          stackp[4], stackp[5]);
  315.             break;
  316.             }
  317.             break;
  318.         case V_SubrN:
  319.             tmp2 = sym_nil;
  320.             POPN(-arg); /* reclaim my args */
  321.             while(ar