home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 5 / FreshFish_July-August1994.bin / bbs / util / jade-3.0.lha / Jade / src / lispmach.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-04-19  |  18.6 KB  |  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(arg--)
  322.             tmp2 = cmd_cons(RET_POP, tmp2);
  323.             TOP = VSUBRNFUN(tmp)(tmp2);
  324.             break;
  325.         case V_Cons:
  326.             tmp2 = sym_nil;
  327.             POPN(-arg);
  328.             while(arg--)
  329.             tmp2 = cmd_cons(RET_POP, tmp2);
  330.             if(VCAR(tmp) == sym_lambda)
  331.             {
  332.             struct LispCall lc;
  333.             lc.lc_Next = LispCallStack;
  334.             lc.lc_Fun = TOP;
  335.             lc.lc_Args = tmp2;
  336.             lc.lc_ArgsEvalledP = sym_t;
  337.             LispCallStack = &lc;
  338.             if(!(TOP = evallambda(tmp, tmp2, FALSE))
  339.                && ThrowValue && (VCAR(ThrowValue) == sym_defun))
  340.             {
  341.                 TOP = VCDR(ThrowValue);
  342.                 ThrowValue = NULL;
  343.             }
  344.             LispCallStack = lc.lc_Next;
  345.             }
  346.             else if(VCAR(tmp) == sym_autoload)
  347.             /* I can't be bothered to go to all the hassle
  348.                of doing this here, it's going to be slow
  349.                anyway so just pass it to funcall.  */
  350.             TOP = funcall(TOP, tmp2);
  351.             else
  352.             {
  353.             cmd_signal(sym_invalid_function, LIST_1(TOP));
  354.             goto error;
  355.             }
  356.             break;
  357.         default:
  358.             cmd_signal(sym_invalid_function, LIST_1(TOP));
  359.             goto error;
  360.         }
  361.         if(!TOP)
  362.             goto error;
  363.         break;
  364.         case OP_PUSH:
  365.         PUSH(VVECT(consts)->vc_Array[arg]);
  366.         break;
  367.         case OP_VREFC:
  368.         if(PUSH(cmd_symbol_value(VVECT(consts)->vc_Array[arg])))
  369.             break;
  370.         goto error;
  371.         case OP_VSETC:
  372.         if(cmd_set(VVECT(consts)->vc_Array[arg], RET_POP))
  373.             break;
  374.         goto error;
  375.         case OP_LIST:
  376.         tmp = sym_nil;
  377.         while(arg--)
  378.             tmp = cmd_cons(RET_POP, tmp);
  379.         PUSH(tmp);
  380.         break;
  381.         case OP_BIND:
  382.         tmp = VVECT(consts)->vc_Array[arg];
  383.         if(SYMBOLP(tmp))
  384.         {
  385.             VCAR(bindstack) = bindsymbol(VCAR(bindstack), tmp, RET_POP);
  386.             break;
  387.         }
  388.         goto error;
  389.         }
  390.     }
  391.     else
  392.     {
  393.         switch(c)
  394.         {
  395.         register VALUE tmp;
  396.         VALUE tmp2;
  397.         int i;
  398.         case OP_POP:
  399.         POP;
  400.         break;
  401.         case OP_VREF:
  402.         if((TOP = cmd_symbol_value(TOP)))
  403.             break;
  404.         goto error;
  405.         case OP_VSET:
  406.         tmp = RET_POP;
  407.         if(cmd_set(tmp, RET_POP))
  408.             break;
  409.         goto error;
  410.         case OP_FREF:
  411.         if((TOP = cmd_symbol_function(TOP)))
  412.             break;
  413.         goto error;
  414.         case OP_FSET:
  415.         tmp = RET_POP;
  416.         if(cmd_fset(tmp, RET_POP))
  417.             break;
  418.         goto error;
  419.         case OP_INIT_BIND:
  420.         bindstack = cmd_cons(sym_nil, bindstack);
  421.         break;
  422.         case OP_UNBIND:
  423.         unbindsymbols(VCAR(bindstack));
  424.         bindstack = VCDR(bindstack);
  425.         break;
  426.         case OP_DUP:
  427.         tmp = TOP;
  428.         PUSH(tmp);
  429.         break;
  430.         case OP_SWAP:
  431.         tmp = TOP;
  432.         TOP = stackp[-1];
  433.         stackp[-1] = tmp;
  434.         break;
  435.         case OP_NIL:
  436.         PUSH(sym_nil);
  437.         break;
  438.         case OP_T:
  439.         PUSH(sym_t);
  440.         break;
  441.         case OP_CONS:
  442.         tmp = RET_POP;
  443.         if((TOP = cmd_cons(TOP, tmp)))
  444.             break;
  445.         goto error;
  446.         case OP_CAR:
  447.         tmp = TOP;
  448.         if(CONSP(tmp))
  449.             TOP = VCAR(tmp);
  450.         else
  451.             TOP = sym_nil;
  452.         break;
  453.         case OP_CDR:
  454.         tmp = TOP;
  455.         if(CONSP(tmp))
  456.             TOP = VCDR(tmp);
  457.         else
  458.             TOP = sym_nil;
  459.         break;
  460.         case OP_RPLACA:
  461.         tmp = RET_POP;
  462.         if((TOP = cmd_rplaca(TOP, tmp)))
  463.             break;
  464.         goto error;
  465.         case OP_RPLACD:
  466.         tmp = RET_POP;
  467.         if((TOP = cmd_rplacd(TOP, tmp)))
  468.             break;
  469.         goto error;
  470.         case OP_NTH:
  471.         tmp = RET_POP;
  472.         if((TOP = cmd_nth(TOP, tmp)))
  473.             break;
  474.         goto error;
  475.         case OP_NTHCDR:
  476.         tmp = RET_POP;
  477.         if((TOP = cmd_nthcdr(TOP, tmp)))
  478.             break;
  479.         goto error;
  480.         case OP_ASET:
  481.         tmp = RET_POP;
  482.         tmp2 = RET_POP;
  483.         if((TOP = cmd_aset(TOP, tmp2, tmp)))
  484.             break;
  485.         goto error;
  486.         case OP_AREF:
  487.         tmp = RET_POP;
  488.         if((TOP = cmd_aref(TOP, tmp)))
  489.             break;
  490.         goto error;
  491.         case OP_LENGTH:
  492.         if(!(tmp = cmd_length(TOP)))
  493.             goto error;
  494.         TOP = tmp;
  495.         break;
  496.         case OP_EVAL:
  497.         gcv_stackbase.gcv_N = STK_USE;
  498.         if((TOP = cmd_eval(TOP)))
  499.             break;
  500.         goto error;
  501.         case OP_PLUS_2:
  502.         tmp = RET_POP;
  503.         if(NUMBERP(tmp) && NUMBERP(TOP))
  504.         {
  505.             TOP = newnumber(VNUM(TOP) + VNUM(tmp));
  506.             break;
  507.         }
  508.         goto error;
  509.         case OP_NEGATE:
  510.         if(NUMBERP(TOP))
  511.         {
  512.             TOP = newnumber(-VNUM(TOP));
  513.             break;
  514.         }
  515.         goto error;
  516.         case OP_MINUS_2:
  517.         tmp = RET_POP;
  518.         if(NUMBERP(tmp) && NUMBERP(TOP))
  519.         {
  520.             TOP = newnumber(VNUM(TOP) - VNUM(tmp));
  521.             break;
  522.         }
  523.         goto error;
  524.         case OP_PRODUCT_2:
  525.         tmp = RET_POP;
  526.         if(NUMBERP(tmp) && NUMBERP(TOP))
  527.         {
  528.             TOP = newnumber(VNUM(TOP) * VNUM(tmp));
  529.             break;
  530.         }
  531.         goto error;
  532.         case OP_DIVIDE_2:
  533.         tmp = RET_POP;
  534.         if(NUMBERP(tmp) && NUMBERP(TOP))
  535.         {
  536.             TOP = newnumber(VNUM(TOP) / VNUM(tmp));
  537.             break;
  538.         }
  539.         goto error;
  540.         case OP_MOD_2:
  541.         tmp = RET_POP;
  542.         if(NUMBERP(tmp) && NUMBERP(TOP))
  543.         {
  544.             TOP = newnumber(VNUM(TOP) % VNUM(tmp));
  545.             break;
  546.         }
  547.         goto error;
  548.         case OP_BIT_NOT:
  549.         if(NUMBERP(TOP))
  550.         {
  551.             TOP = newnumber(~VNUM(TOP));
  552.             break;
  553.         }
  554.         goto error;
  555.         case OP_NOT:
  556.         if(TOP == sym_nil)
  557.             TOP = sym_t;
  558.         else
  559.             TOP = sym_nil;
  560.         break;
  561.         case OP_BIT_OR_2:
  562.         tmp = RET_POP;
  563.         if(NUMBERP(tmp) && NUMBERP(TOP))
  564.         {
  565.             TOP = newnumber(VNUM(TOP) | VNUM(tmp));
  566.             break;
  567.         }
  568.         goto error;
  569.         case OP_BIT_AND_2:
  570.         tmp = RET_POP;
  571.         if(NUMBERP(tmp) && NUMBERP(TOP))
  572.         {
  573.             TOP = newnumber(VNUM(TOP) & VNUM(tmp));
  574.             break;
  575.         }
  576.         goto error;
  577.         case OP_EQUAL:
  578.         tmp = RET_POP;
  579.         if(!(VALUECMP(TOP, tmp)))
  580.             TOP = sym_t;
  581.         else
  582.             TOP = sym_nil;
  583.         break;
  584.         case OP_EQ:
  585.         tmp = RET_POP;
  586.         if(TOP == tmp)
  587.             TOP = sym_t;
  588.         else
  589.             TOP = sym_nil;
  590.         break;
  591.         case OP_NUM_EQ:
  592.         tmp = RET_POP;
  593.         if((TOP = cmd_num_eq(TOP, tmp)))
  594.             break;
  595.         goto error;
  596.         case OP_NUM_NOTEQ:
  597.         tmp = RET_POP;
  598.         if((TOP = cmd_num_noteq(TOP, tmp)))
  599.             break;
  600.         goto error;
  601.         case OP_GTTHAN:
  602.         tmp = RET_POP;
  603.         if(VALUECMP(TOP, tmp) > 0)
  604.             TOP = sym_t;
  605.         else
  606.             TOP = sym_nil;
  607.         break;
  608.         case OP_GETHAN:
  609.         tmp = RET_POP;
  610.         if(VALUECMP(TOP, tmp) >= 0)
  611.             TOP = sym_t;
  612.         else
  613.             TOP = sym_nil;
  614.         break;
  615.         case OP_LTTHAN:
  616.         tmp = RET_POP;
  617.         if(VALUECMP(TOP, tmp) < 0)
  618.             TOP = sym_t;
  619.         else
  620.             TOP = sym_nil;
  621.         break;
  622.         case OP_LETHAN:
  623.         tmp = RET_POP;
  624.         if(VALUECMP(TOP, tmp) <= 0)
  625.             TOP = sym_t;
  626.         else
  627.             TOP = sym_nil;
  628.         break;
  629.         case OP_INC:
  630.         if(NUMBERP(TOP))
  631.         {
  632.             TOP = newnumber(VNUM(TOP) + 1);
  633.             break;
  634.         }
  635.         goto error;
  636.         case OP_DEC:
  637.         if(NUMBERP(TOP))
  638.         {
  639.             TOP = newnumber(VNUM(TOP) - 1);
  640.             break;
  641.         }
  642.         goto error;
  643.         case OP_LSH:
  644.         tmp = RET_POP;
  645.         if((TOP = cmd_lsh(TOP, tmp)))
  646.             break;
  647.         goto error;
  648.         case OP_ZEROP:
  649.         if(NUMBERP(TOP) && (VNUM(TOP) == 0))
  650.             TOP = sym_t;
  651.         else
  652.             TOP = sym_nil;
  653.         break;
  654.         case OP_NULL:
  655.         if(NILP(TOP))
  656.             TOP = sym_t;
  657.         else
  658.             TOP = sym_nil;
  659.         break;
  660.         case OP_ATOM:
  661.         if(!CONSP(TOP))
  662.             TOP = sym_t;
  663.         else
  664.             TOP = sym_nil;
  665.         break;
  666.         case OP_CONSP:
  667.         if(CONSP(TOP))
  668.             TOP = sym_t;
  669.         else
  670.             TOP = sym_nil;
  671.         break;
  672.         case OP_LISTP:
  673.         if(CONSP(TOP) || NILP(TOP))
  674.             TOP = sym_t;
  675.         else
  676.             TOP = sym_nil;
  677.         break;
  678.         case OP_NUMBERP:
  679.         if(NUMBERP(TOP))
  680.             TOP = sym_t;
  681.         else
  682.             TOP = sym_nil;
  683.         break;
  684.         case OP_STRINGP:
  685.         if(STRINGP(TOP))
  686.             TOP = sym_t;
  687.         else
  688.             TOP = sym_nil;
  689.         break;
  690.         case OP_VECTORP:
  691.         if(VECTORP(TOP))
  692.             TOP = sym_t;
  693.         else
  694.             TOP = sym_nil;
  695.         break;
  696.         case OP_CATCH_KLUDGE:
  697.         /* This is very crude.    */
  698.         tmp = RET_POP;
  699.         tmp = cmd_cons(tmp, cmd_cons(TOP, sym_nil));
  700.         gcv_stackbase.gcv_N = STK_USE;
  701.         if((TOP = cmd_catch(tmp)))
  702.             break;
  703.         goto error;
  704.         case OP_THROW:
  705.         tmp = RET_POP;
  706.         if(!ThrowValue)
  707.             ThrowValue = cmd_cons(TOP, tmp);
  708.         /* This isn't really an error :-)  */
  709.         goto error;
  710.         case OP_UNWIND_PRO:
  711.         tmp = RET_POP;
  712.         bindstack = cmd_cons(cmd_cons(sym_t, tmp), bindstack);
  713.         break;
  714.         case OP_UN_UNWIND_PRO:
  715.         gcv_stackbase.gcv_N = STK_USE;
  716.         /* there will only be one form (a lisp-code) */
  717.         cmd_eval(VCDR(VCAR(bindstack)));
  718.         bindstack = VCDR(bindstack);
  719.         break;
  720.  
  721.         case OP_FBOUNDP:
  722.         if((TOP = cmd_fboundp(TOP)))
  723.             break;
  724.         goto error;
  725.         case OP_BOUNDP:
  726.         if((TOP = cmd_boundp(TOP)))
  727.             break;
  728.         goto error;
  729.         case OP_SYMBOLP:
  730.         if(SYMBOLP(TOP))
  731.             TOP = sym_t;
  732.         else
  733.             TOP = sym_nil;
  734.         break;
  735.         case OP_GET:
  736.         tmp = RET_POP;
  737.         if((TOP = cmd_get(TOP, tmp)))
  738.             break;
  739.         goto error;
  740.         case OP_PUT:
  741.         tmp = RET_POP;
  742.         tmp2 = RET_POP;
  743.         if((TOP = cmd_put(TOP, tmp2, tmp)))
  744.             break;
  745.         goto error;
  746.  
  747.         case OP_ERROR_PRO:
  748.         /* bit of a kludge, this just calls the special-form, it
  749.            takes an extra argument on top of the stack - the number
  750.            of arguments that it has been given.     */
  751.         i = VNUM(RET_POP);
  752.         tmp = sym_nil;
  753.         while(i--)
  754.             tmp = cmd_cons(RET_POP, tmp);
  755.         gcv_stackbase.gcv_N = STK_USE;
  756.         tmp = cmd_error_protect(tmp);
  757.         if(tmp)
  758.         {
  759.             PUSH(tmp);
  760.             break;
  761.         }
  762.         goto error;
  763.         case OP_SIGNAL:
  764.         tmp = RET_POP;
  765.         cmd_signal(TOP, tmp);
  766.         goto error;
  767.  
  768.         case OP_SET_CURRENT_BUFFER:
  769.         tmp = RET_POP;
  770.         if((TOP = cmd_set_current_buffer(TOP, tmp)))
  771.             break;
  772.         goto error;
  773.         case OP_SWAP_BUFFER:
  774.         if(!BUFFERP(TOP))
  775.             goto error;
  776.         TOP = swapvwfilesnd(CurrVW, TOP);
  777.         break;
  778.         case OP_CURRENT_BUFFER:
  779.         if((TOP = cmd_current_buffer(TOP)))
  780.             break;
  781.         goto error;
  782.         case OP_BUFFERP:
  783.         if(BUFFERP(TOP))
  784.             TOP = sym_t;
  785.         else
  786.             TOP = sym_nil;
  787.         break;
  788.         case OP_MARK_P:
  789.         if(MARKP(TOP))
  790.             TOP = sym_t;
  791.         else
  792.             TOP = sym_nil;
  793.         break;
  794.         case OP_WINDOWP:
  795.         if(WINDOWP(TOP))
  796.             TOP = sym_t;
  797.         else
  798.             TOP = sym_nil;
  799.         break;
  800.         case OP_SWAP_WINDOW:
  801.         tmp = TOP;
  802.         if(!WINDOWP(tmp))
  803.             goto error;
  804.         TOP = CurrVW;
  805.         CurrVW = VWIN(tmp);
  806.         break;
  807.  
  808.         case OP_JMP_NIL:
  809.         if(NILP(RET_POP))
  810.             goto do_jmp;
  811.         pc += 2;
  812.         break;
  813.         case OP_JMP_T:
  814.         if(!NILP(RET_POP))
  815.             goto do_jmp;
  816.         pc += 2;
  817.         break;
  818.         case OP_JMP_NIL_ELSE_POP:
  819.         if(NILP(TOP))
  820.             goto do_jmp;
  821.         POP;
  822.         pc += 2;
  823.         break;
  824.         case OP_JMP_T_ELSE_POP:
  825.         if(NILP(TOP))
  826.         {
  827.             POP;
  828.             pc += 2;
  829.             break;
  830.         }
  831.         /* FALL THROUGH */
  832.         case OP_JMP:
  833. do_jmp:
  834.         pc = VSTR(code) + (((pc[0] & ARG_MASK) << ARG_SHIFT)
  835.                    | (pc[1] & ARG_MASK));
  836.         break;
  837.  
  838.         default:
  839.         cmd_signal(sym_error,
  840.                LIST_1(MKSTR("Unknown lisp opcode")));
  841. error:
  842.         while(CONSP(bindstack))
  843.         {
  844.             if(VCAR(VCAR(bindstack)) == sym_t)
  845.             /* an unwind-pro */
  846.             cmd_eval(VCDR(VCAR(bindstack)));
  847.             else
  848.             unbindsymbols(VCAR(bindstack));
  849.             bindstack = VCDR(bindstack);
  850.         }
  851.         TOP = NULL;
  852.         goto quit;
  853.         }
  854.     }
  855. #ifdef PARANOID
  856.     if(stackp < (stackbase - 1))
  857.     {
  858.         fprintf(stderr, "jade: stack underflow in lisp-code: aborting...\n");
  859.         abort();
  860.     }
  861.     if(stackp > (stackbase + VNUM(stkreq)))
  862.     {
  863.         fprintf(stderr, "jade: stack overflow in lisp-code: aborting...\n");
  864.         abort();
  865.     }
  866. #endif
  867.     }
  868. #ifdef PARANOID
  869.     if(stackp != stackbase)
  870.     fprintf(stderr, "jade: (stackp != stackbase) at end of lisp-code\n");
  871. #endif
  872.  
  873. quit:
  874.     /* only use this var to save declaring another */
  875.     bindstack = TOP;
  876. #ifndef HAVE_ALLOCA
  877.     mystrfree(stackbase);
  878. #endif
  879.     POPGCN; POPGC; POPGC; POPGC;
  880.     return(bindstack);
  881. }
  882.  
  883. void
  884. lispmach_init(void)
  885. {
  886.     ADD_SUBR(subr_lisp_code);
  887. }
  888.