home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fresh Fish 8
/
FreshFishVol8-CD1.bin
/
new
/
util
/
edit
/
jade
/
src
/
lispmach.c
< prev
next >
Wrap
C/C++ Source or Header
|
1994-10-06
|
21KB
|
1,049 lines
/* lispmach.c -- Interpreter for compiled Lisp forms
Copyright (C) 1993, 1994 John Harper <jsh@ukc.ac.uk>
This file is part of Jade.
Jade is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
Jade is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Jade; see the file COPYING. If not, write to
the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "jade.h"
#include "jade_protos.h"
#ifdef HAVE_ALLOCA
# include <alloca.h>
#endif
_PR void lispmach_init(void);
#define OP_CALL 0x08
#define OP_PUSH 0x10
#define OP_VREFC 0x18
#define OP_VSETC 0x20
#define OP_LIST 0x28
#define OP_BIND 0x30
#define OP_LAST_WITH_ARGS 0x38
#define OP_VREF 0x40
#define OP_VSET 0x41
#define OP_FREF 0x42
#define OP_FSET 0x43
#define OP_INIT_BIND 0x44
#define OP_UNBIND 0x45
#define OP_DUP 0x46
#define OP_SWAP 0x47
#define OP_POP 0x48
#define OP_NIL 0x49
#define OP_T 0x4a
#define OP_CONS 0x4b
#define OP_CAR 0x4c
#define OP_CDR 0x4d
#define OP_RPLACA 0x4e
#define OP_RPLACD 0x4f
#define OP_NTH 0x50
#define OP_NTHCDR 0x51
#define OP_ASET 0x52
#define OP_AREF 0x53
#define OP_LENGTH 0x54
#define OP_EVAL 0x55
#define OP_PLUS_2 0x56
#define OP_NEGATE 0x57
#define OP_MINUS_2 0x58
#define OP_PRODUCT_2 0x59
#define OP_DIVIDE_2 0x5a
#define OP_MOD_2 0x5b
#define OP_LOGNOT 0x5c
#define OP_NOT 0x5d
#define OP_LOGIOR_2 0x5e
#define OP_LOGAND_2 0x5f
#define OP_EQUAL 0x60
#define OP_EQ 0x61
#define OP_NUM_EQ 0x62
#define OP_NUM_NOTEQ 0x63
#define OP_GTTHAN 0x64
#define OP_GETHAN 0x65
#define OP_LTTHAN 0x66
#define OP_LETHAN 0x67
#define OP_INC 0x68
#define OP_DEC 0x69
#define OP_LSH 0x6a
#define OP_ZEROP 0x6b
#define OP_NULL 0x6c
#define OP_ATOM 0x6d
#define OP_CONSP 0x6e
#define OP_LISTP 0x6f
#define OP_NUMBERP 0x70
#define OP_STRINGP 0x71
#define OP_VECTORP 0x72
#define OP_CATCH_KLUDGE 0x73
#define OP_THROW 0x74
#define OP_UNWIND_PRO 0x75
#define OP_UN_UNWIND_PRO 0x76
#define OP_FBOUNDP 0x77
#define OP_BOUNDP 0x78
#define OP_SYMBOLP 0x79
#define OP_GET 0x7a
#define OP_PUT 0x7b
#define OP_ERROR_PRO 0x7c
#define OP_SIGNAL 0x7d
#define OP_RETURN 0x7e
#define OP_REVERSE 0x7f /* new 12/7/94 */
#define OP_NREVERSE 0x80
#define OP_ASSOC 0x81
#define OP_ASSQ 0x82
#define OP_RASSOC 0x83
#define OP_RASSQ 0x84
#define OP_LAST 0x85
#define OP_MAPCAR 0x86
#define OP_MAPC 0x87
#define OP_MEMBER 0x88
#define OP_MEMQ 0x89
#define OP_DELETE 0x8a
#define OP_DELQ 0x8b
#define OP_DELETE_IF 0x8c
#define OP_DELETE_IF_NOT 0x8d
#define OP_COPY_SEQUENCE 0x8e
#define OP_SEQUENCEP 0x8f
#define OP_FUNCTIONP 0x90
#define OP_SPECIAL_FORM_P 0x91
#define OP_SUBRP 0x92
#define OP_EQL 0x93
#define OP_LOGXOR_2 0x94 /* new 23-8-94 */
#define OP_SET_CURRENT_BUFFER 0xb0
#define OP_SWAP_BUFFER 0xb1
#define OP_CURRENT_BUFFER 0xb2
#define OP_BUFFERP 0xb3
#define OP_MARKP 0xb4
#define OP_WINDOWP 0xb5
#define OP_SWAP_WINDOW 0xb6
#define OP_LAST_BEFORE_JMPS 0xfa
#define OP_JMP 0xfb
#define OP_JN 0xfc
#define OP_JT 0xfd
#define OP_JNP 0xfe
#define OP_JTP 0xff
#define TOP (*stackp)
#define RET_POP (*stackp--)
#define POP (stackp--)
#define POPN(n) (stackp -= n)
#define PUSH(v) (*(++stackp) = (v))
#define STK_USE (stackp - (stackbase - 1))
#define ARG_SHIFT 8
#define OP_ARG_MASK 0x07
#define OP_OP_MASK 0xf8
#define OP_ARG_1BYTE 6
#define OP_ARG_2BYTE 7
/* These macros pop as many args as required then call the specified
function properly. */
#define CALL_1(cmd) \
if((TOP = cmd (TOP))) \
break; \
goto error
#define CALL_2(cmd) \
tmp = RET_POP; \
if((TOP = cmd (TOP, tmp))) \
break; \
goto error
#define CALL_3(cmd) \
tmp = RET_POP; \
tmp2 = RET_POP; \
if((TOP = cmd (TOP, tmp2, tmp))) \
break; \
goto error
_PR VALUE cmd_jade_byte_code(VALUE code, VALUE consts, VALUE stkreq);
DEFUN("jade-byte-code", cmd_jade_byte_code, subr_jade_byte_code, (VALUE code, VALUE consts, VALUE stkreq), V_Subr3, DOC_jade_byte_code) /*
::doc:jade_byte_code::
jade-byte-code CODE-STRING CONST-VEC MAX-STACK
Evaluates the string of byte codes CODE-STRING, the constants that it
references are contained in the vector CONST-VEC. MAX-STACK is a number
defining how much stack space is required to evaluate the code.
Do *not* attempt to call this function manually, the lisp file `compiler.jl'
contains a simple compiler which translates files of lisp forms into files
of byte code. See the functions `compile-file', `compile-directory' and
`compile-lisp-lib' for more details.
::end:: */
{
VALUE *stackbase;
register VALUE *stackp;
/* This holds a list of sets of bindings, it can also hold the form of
an unwind-protect that always gets eval'd (when the car is t). */
VALUE bindstack = sym_nil;
register u_char *pc;
u_char c;
GCVAL gcv_code, gcv_consts, gcv_bindstack;
/* The `gcv_N' field is only filled in with the stack-size when there's
a chance of gc. */
GCVALN gcv_stackbase;
DECLARE1(code, STRINGP);
DECLARE2(consts, VECTORP);
DECLARE3(stkreq, NUMBERP);
#ifdef HAVE_ALLOCA
stackbase = alloca(sizeof(VALUE) * VNUM(stkreq));
#else
if(!(stackbase = str_alloc(sizeof(VALUE) * VNUM(stkreq))))
return(NULL);
#endif
stackp = stackbase - 1;
PUSHGC(gcv_code, code);
PUSHGC(gcv_consts, consts);
PUSHGC(gcv_bindstack, bindstack);
PUSHGCN(gcv_stackbase, stackbase, 0);
pc = VSTR(code);
while((c = *pc++) != 0)
{
if(c < OP_LAST_WITH_ARGS)
{
register short arg;
switch(c & OP_ARG_MASK)
{
case OP_ARG_1BYTE:
arg = *pc++;
break;
case OP_ARG_2BYTE:
arg = (pc[0] << ARG_SHIFT) | pc[1];
pc += 2;
break;
default:
arg = c & OP_ARG_MASK;
}
switch(c & OP_OP_MASK)
{
register VALUE tmp;
VALUE tmp2;
case OP_CALL:
#ifdef MINSTACK
if(STK_SIZE <= MINSTACK)
{
STK_WARN("lisp-code");
TOP = cmd_signal(sym_stack_error, sym_nil);
goto quit;
}
#endif
/* args are still available above the top of the stack,
this just makes things a bit easier. */
POPN(arg);
tmp = TOP;
if(SYMBOLP(tmp))
{
if(VSYM(tmp)->sym_Flags & SF_DEBUG)
single_step_flag = TRUE;
if(!(tmp = cmd_symbol_function(tmp, sym_nil)))
goto error;
}
gcv_stackbase.gcv_N = STK_USE;
switch(VTYPE(tmp))
{
case V_Subr0:
TOP = VSUBR0FUN(tmp)();
break;
case V_Subr1:
TOP = VSUBR1FUN(tmp)(arg >= 1 ? stackp[1] : sym_nil);
break;
case V_Subr2:
switch(arg)
{
case 0:
TOP = VSUBR2FUN(tmp)(sym_nil, sym_nil);
break;
case 1:
TOP = VSUBR2FUN(tmp)(stackp[1], sym_nil);
break;
default:
TOP = VSUBR2FUN(tmp)(stackp[1], stackp[2]);
break;
}
break;
case V_Subr3:
switch(arg)
{
case 0:
TOP = VSUBR3FUN(tmp)(sym_nil, sym_nil, sym_nil);
break;
case 1:
TOP = VSUBR3FUN(tmp)(stackp[1], sym_nil, sym_nil);
break;
case 2:
TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], sym_nil);
break;
default:
TOP = VSUBR3FUN(tmp)(stackp[1], stackp[2], stackp[3]);
break;
}
break;
case V_Subr4:
switch(arg)
{
case 0:
TOP = VSUBR4FUN(tmp)(sym_nil, sym_nil,
sym_nil, sym_nil);
break;
case 1:
TOP = VSUBR4FUN(tmp)(stackp[1], sym_nil,
sym_nil, sym_nil);
break;
case 2:
TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
sym_nil, sym_nil);
break;
case 3:
TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
stackp[3], sym_nil);
break;
default:
TOP = VSUBR4FUN(tmp)(stackp[1], stackp[2],
stackp[3], stackp[4]);
break;
}
break;
case V_Subr5:
switch(arg)
{
case 0:
TOP = VSUBR5FUN(tmp)(sym_nil, sym_nil, sym_ni