/* slang.c --- guts of S-Lang interpreter */ /* * Copyright (c) 1992, 1994 John E. Davis * All rights reserved. * * Permission is hereby granted, without written agreement and without * license or royalty fees, to use, copy, and distribute this * software and its documentation for any purpose, provided that the * above copyright notice and the following two paragraphs appear in * all copies of this software. Permission is not granted to modify this * software for any purpose without written agreement from John E. Davis. * * IN NO EVENT SHALL JOHN E. DAVIS BE LIABLE TO ANY PARTY FOR DIRECT, * INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF * THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF JOHN E. DAVIS * HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. * * JOHN E. DAVIS SPECIFICALLY DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A * PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" * BASIS, AND JOHN E. DAVIS HAS NO OBLIGATION TO PROVIDE MAINTENANCE, * SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS. */ #include #ifdef FLOAT_TYPE char SLang_Version[] = "F0.99.5"; #include #else char SLang_Version[] = "0.99.5"; #endif /* not ready yet */ #define SL_BYTE_COMPILING #include "slang.h" #include "_slang.h" /* If non null, these call C functions before and after a slang function. */ void (*SLang_Enter_Function)(char *) = NULL; void (*SLang_Exit_Function)(char *) = NULL; int SLang_Trace = 0; char SLang_Trace_Function[32]; SLang_Name_Type SLang_Name_Table[LANG_MAX_SYMBOLS]; static int SLang_Name_Table_Ofs[256]; SLName_Table *SLName_Table_Root; static SLang_Name_Type *Lang_Local_Variable_Table; int Local_Variable_Number; #define MAX_LOCAL_VARIABLES 50 static int Lang_Break_Condition = 0; /* true if any one below is true */ static int Lang_Break = 0; static int Lang_Return = 0; static int Lang_Continue = 0; /* this stack is used by the inner interpreter to execute top level * interpreter commands which by definition are immediate so stack is * only of maximum 10; sorry... */ #define SLANG_MAX_TOP_STACK 10 static SLBlock_Type Lang_Interp_Stack_Static[SLANG_MAX_TOP_STACK]; static SLBlock_Type *Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static; static SLBlock_Type *Lang_Interp_Stack = Lang_Interp_Stack_Static; SLang_Object_Type SLRun_Stack[LANG_MAX_STACK_LEN]; SLang_Object_Type *SLStack_Pointer = SLRun_Stack; static SLang_Object_Type *SLStack_Pointer_Max = SLRun_Stack + LANG_MAX_STACK_LEN; /* Might want to increase this. */ #define MAX_LOCAL_STACK 200 static SLang_Object_Type Local_Variable_Stack[MAX_LOCAL_STACK]; static SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack; int SLang_Traceback = 0; /* non zero means do traceback */ static int inner_interp(register SLBlock_Type *); static int Lang_Defining_Function = 0; /* true if defining a function */ static SLBlock_Type *Lang_Function_Body; static SLBlock_Type *Lang_FBody_Ptr; static int Lang_FBody_Size = 0; #define LANG_MAX_BLOCKS 30 /* max number of nested blocks--- was 10 but I once exceeded it! */ typedef struct Lang_Block_Type { int size; /* current nuber of objects malloced */ SLBlock_Type *body; /* beginning of body definition */ SLBlock_Type *ptr; /* current location */ } Lang_Block_Type; static int Lang_Defining_Block = 0; /* true if defining a block */ static Lang_Block_Type Lang_Block_Stack[LANG_MAX_BLOCKS]; static SLBlock_Type *Lang_Block_Body; static int Lang_BBody_Size; static int Lang_Block_Depth = -1; static SLBlock_Type *Lang_Object_Ptr = Lang_Interp_Stack_Static; /* next location for compiled obj -- points to interpreter stack initially */ /* type MUST come back 0 if there is a stack underflow !!! */ int SLang_pop(SLang_Object_Type *x) { register SLang_Object_Type *y; y = SLStack_Pointer; if (y == SLRun_Stack) { x->type = 0; if (SLang_Error == 0) SLang_Error = STACK_UNDERFLOW; SLStack_Pointer = SLRun_Stack; return 1; } y--; *x = *y; SLStack_Pointer = y; return(0); } void SLang_push(SLang_Object_Type *x) { register SLang_Object_Type *y; y = SLStack_Pointer; /* if there is a SLang_Error, probably not much harm will be done if it is ignored here */ /* if (SLang_Error) return; */ /* flag it now */ if (y >= SLStack_Pointer_Max) { if (!SLang_Error) SLang_Error = STACK_OVERFLOW; return; } *y = *x; SLStack_Pointer = y + 1; } /* If it returns 0, DO NOT FREE p */ static int lang_free_branch(SLBlock_Type *p) { short type; type = p->type; /* These guys were not all allocated. See end_block for details */ if ((type == LANG_RETURN) || (type == LANG_BREAK) || (type == LANG_CONTINUE)) return 0; while(1) { type = (p->type); if ((type & 0xFF) == LANG_BLOCK) { if (lang_free_branch(p->b.blk)) FREE(p->b.blk); } #ifdef FLOAT_TYPE else if (type == (LANG_LITERAL | (FLOAT_TYPE << 8))) { FREE (p->b.f_blk); } #endif /* else if (type == string_type) FREE(p->value); This fails because objects may be attached to these strings */ else if (type == 0) break; p++; } return 1; } int SLang_pop_integer(int *i) { SLang_Object_Type obj; (void) SLang_pop(&obj); if ((obj.type >> 8) != INT_TYPE) { if (!SLang_Error) SLang_Error = TYPE_MISMATCH; return(1); } *i = obj.v.i_val; return(0); } #ifdef FLOAT_TYPE int SLang_pop_float(FLOAT *x, int *convert, int *ip) { SLang_Object_Type obj; register unsigned char stype; if (SLang_pop(&obj)) return(1); stype = obj.type >> 8; if (stype == FLOAT_TYPE) { *x = obj.v.f_val; *convert = 0; } else if (stype == INT_TYPE) { *ip = obj.v.i_val; *x = (FLOAT) obj.v.i_val; *convert = 1; } else { SLang_Error = TYPE_MISMATCH; return(1); } return(0); } void SLang_push_float(FLOAT x) { SLang_Object_Type obj; obj.type = LANG_DATA | (FLOAT_TYPE << 8); obj.v.f_val = x; SLang_push (&obj); } #endif /* if *data = 1, string should be freed upon use. If it is -1, do not free but if you use it, malloc a new one. */ int SLang_pop_string(char **s, int *data) { SLang_Object_Type obj; if (SLang_pop(&obj) || ((obj.type >> 8) != STRING_TYPE)) { if (!SLang_Error) SLang_Error = TYPE_MISMATCH; return(1); } *s = obj.v.s_val; /* return whether or not this should be freed after its use. */ if ((obj.type & 0xFF) == LANG_DATA) *data = 1; else *data = 0; return(0); } void SLang_push_integer(int i) { SLang_Object_Type obj; obj.type = LANG_DATA | (INT_TYPE << 8); obj.v.i_val = i; SLang_push (&obj); } char *SLmake_nstring (char *str, int n) { char *ptr; if (NULL == (ptr = (char *) MALLOC(n + 1))) { SLang_Error = SL_MALLOC_ERROR; return(NULL); } MEMCPY (ptr, str, n); ptr[n] = 0; return(ptr); } char *SLmake_string(char *str) { return SLmake_nstring(str, strlen (str)); } void SLang_push_string(char *t) { SLang_Object_Type obj; if (NULL == (obj.v.s_val = SLmake_string(t))) return; obj.type = LANG_DATA | (STRING_TYPE << 8); SLang_push(&obj); } void SLang_push_malloced_string(char *c) { SLang_Object_Type obj; obj.type = LANG_DATA | (STRING_TYPE << 8); obj.v.s_val = c; SLang_push(&obj); } int SLatoi (unsigned char *s) { register unsigned char ch; register unsigned int i, ich; register int base; if (*s != '0') return atoi((char *) s); /* look for 'x' which indicates hex */ s++; if (*s == 'x') { base = 4; s++; } else base = 3; i = 0; while ((ch = *s++) != 0) { if (ch > 64) ich = ch - 55; else ich = ch - 48; i = (i << base) | ich; } return (int) i; } static void call_funptr(SLang_Name_Type *); /* This is a global variable */ void SLang_push_variable(SLang_Object_Type *obj) { register unsigned char subtype; subtype = obj->type >> 8; if (subtype == STRING_TYPE) { SLang_push_string(obj->v.s_val); return; } else if (subtype == LANG_OBJ_TYPE) { call_funptr(obj->v.n_val); return; } SLang_push(obj); } /* This routine pops an integer off the stack. It then adds dn to the * value producing n. The it reverses the * next n items on the stack. Some functions may require this. * This returns a pointer to the last item. */ SLang_Object_Type *SLreverse_stack(int *dn) { int n; SLang_Object_Type *otop, *obot, tmp; if (SLang_pop_integer(&n)) return(NULL); n += *dn; otop = SLStack_Pointer; if ((n > otop - SLRun_Stack) || (n < 0)) { SLang_Error = STACK_UNDERFLOW; return (NULL); } obot = otop - n; otop--; while (otop > obot) { tmp = *obot; *obot = *otop; *otop = tmp; otop--; obot++; } return (SLStack_Pointer - n); } /* local and global variable assignments */ /* Pop a data item from the stack and return a pointer to it. * Strings are not freed from stack so use another routine to do it. * * In addition, I need to make this work with the array types. * see pop string for discussion of do_free */ long *SLang_pop_pointer(unsigned short *type, int *do_free) { SLang_Object_Type obj; register SLang_Object_Type *p; long *val; if (SLang_pop(&obj)) return(NULL); p = SLStack_Pointer; /* use this because the stack is static but obj is not. do not even try to make it static either. See the intrinsic routine for details */ *type = p->type; *do_free = 0; switch (*type >> 8) { #ifdef FLOAT_TYPE case FLOAT_TYPE: val = (long *) &(p->v.f_val); break; #endif case INT_TYPE: val = (long *) &(p->v.i_val); break; case STRING_TYPE: if ((*type & 0xFF) == LANG_DATA) *do_free = 1; /* drop */ default: val = (long *) p->v.s_val; } return (val); } static void lang_do_eqs(SLBlock_Type *obj) { int y; #ifdef FLOAT_TYPE int ifloat, float_convert; #endif register unsigned char type; register SLang_Object_Type *addr; register long val; unsigned short stype; type = obj->type >> 8; /* calculate address */ if (type <= LANG_LMM) { /* local */ val = 0; addr = Local_Variable_Frame - obj->b.i_blk; stype = addr->type; } else if (type <= LANG_GMM) /* global */ { addr = (SLang_Object_Type *) obj->b.n_blk->addr; val = 0; stype = addr->type; } else /* intrinsic */ { addr = NULL; val = obj->b.n_blk->addr; stype = obj->b.n_blk->type; } if ((type == LANG_LEQS) || (type == LANG_GEQS)) { if (IS_DATA_STRING(*addr)) FREE(addr->v.s_val); SLang_pop(addr); return; } /* everything else applies to integers -- later I will extend to float */ if (INT_TYPE != (stype >> 8)) { #ifdef FLOAT_TYPE /* A quick hack for float */ if ((FLOAT_TYPE == (stype >> 8)) && (type == LANG_IEQS)) { SLang_pop_float ((FLOAT *) val, &float_convert, &ifloat); return; } #endif if (INTP_TYPE != (stype >> 8)) { SLang_Error = TYPE_MISMATCH; return; } /* AT this point, val is int **. Below, we assume that val is * an int *. Note that this type is only defined for intrinsics. */ val = (long) *(int **) val; } /* make this fast for local variables avoiding switch bottleneck */ if (type == LANG_LPP) { addr->v.i_val += 1; return; } else if (type == LANG_LMM) { addr->v.i_val -= 1; return; } y = 1; switch (type) { case LANG_LPEQS: case LANG_GPEQS: if (SLang_pop_integer(&y)) return; /* drop */ case LANG_GPP: addr->v.i_val += y; break; case LANG_GMEQS: case LANG_LMEQS: if (SLang_pop_integer(&y)) return; /* drop */ case LANG_GMM: addr->v.i_val -= y; break; case LANG_IEQS: if (SLang_pop_integer(&y)) return; *(int *) val = y; break; case LANG_IPEQS: if (SLang_pop_integer(&y)) return; /* drop */ case LANG_IPP: *(int *) val += y; break; case LANG_IMEQS: if (SLang_pop_integer(&y)) return; /* drop */ case LANG_IMM: *(int *) val -= y; break; default: SLang_Error = UNKNOWN_ERROR; } } /* lower 4 bits represent the return type, e.g., void, int, etc... The next 4 bits represent the number of parameters, 0 -> 15 */ #define LANG_INTRINSIC_ARGC(f) ((f).type >> 12) #define LANG_INTRINSIC_TYPE(f) (((f).type & 0x0F00) >> 8) static void lang_do_intrinsic(SLang_Name_Type *objf) { typedef void (*VF0_Type)(void); typedef void (*VF1_Type)(char *); typedef void (*VF2_Type)(char *, char *); typedef void (*VF3_Type)(char *, char *, char *); typedef void (*VF4_Type)(char *, char *, char *, char *); typedef void (*VF5_Type)(char *, char *, char *, char *, char *); typedef void (*VF6_Type)(char *, char *, char *, char *, char *, char *); typedef void (*VF7_Type)(char *, char *, char *, char *, char *, char *, char *); typedef long (*LF0_Type)(void); typedef long (*LF1_Type)(char *); typedef long (*LF2_Type)(char *, char *); typedef long (*LF3_Type)(char *, char *, char *); typedef long (*LF4_Type)(char *, char *, char *, char *); typedef long (*LF5_Type)(char *, char *, char *, char *, char *); typedef long (*LF6_Type)(char *, char *, char *, char *, char *, char *); typedef long (*LF7_Type)(char *, char *, char *, char *, char *, char *, char *); #ifdef FLOAT_TYPE typedef FLOAT (*FF0_Type)(void); typedef FLOAT (*FF1_Type)(char *); typedef FLOAT (*FF2_Type)(char *, char *); typedef FLOAT (*FF3_Type)(char *, char *, char *); typedef FLOAT (*FF4_Type)(char *, char *, char *, char *); typedef FLOAT (*FF5_Type)(char *, char *, char *, char *, char *); typedef FLOAT (*FF6_Type)(char *, char *, char *, char *, char *, char *); typedef FLOAT (*FF7_Type)(char *, char *, char *, char *, char *, char *, char *); #endif long ret, fptr; char *p1, *p2, *p3, *p4, *p5, *p6, *p7; unsigned short tmp; int free_p5 = 0, free_p4 = 0, free_p3 = 0, free_p2 = 0, free_p1 = 0; int free_p7 = 0, free_p6 = 0; unsigned char type; int argc; #ifdef FLOAT_TYPE FLOAT xf; #endif fptr = objf->addr; argc = LANG_INTRINSIC_ARGC(*objf); type = LANG_INTRINSIC_TYPE(*objf); p7 = p6 = p5 = p4 = p3 = p2 = p1 = NULL; /* shuts up gcc, NOT needed */ switch (argc) { case 7: p7 = (char *) SLang_pop_pointer(&tmp, &free_p7); case 6: p6 = (char *) SLang_pop_pointer(&tmp, &free_p6); case 5: p5 = (char *) SLang_pop_pointer(&tmp, &free_p5); case 4: p4 = (char *) SLang_pop_pointer(&tmp, &free_p4); case 3: p3 = (char *) SLang_pop_pointer(&tmp, &free_p3); case 2: p2 = (char *) SLang_pop_pointer(&tmp, &free_p2); case 1: p1 = (char *) SLang_pop_pointer(&tmp, &free_p1); } (void) tmp; /* I need to put a setjmp here so to catch any long jmps that occur in the user program */ if (!SLang_Error) switch (argc) { case 0: if (type == VOID_TYPE) ((VF0_Type) fptr) (); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF0_Type) fptr)(); #endif else ret = ((LF0_Type) fptr)(); break; case 1: if (type == VOID_TYPE) ((VF1_Type) fptr)(p1); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF1_Type) fptr)(p1); #endif else ret = ((LF1_Type) fptr)(p1); break; case 2: if (type == VOID_TYPE) ((VF2_Type) fptr)(p1, p2); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF2_Type) fptr)(p1, p2); #endif else ret = ((LF2_Type) fptr)(p1, p2); break; case 3: if (type == VOID_TYPE) ((VF3_Type) fptr)(p1, p2, p3); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF3_Type) fptr)(p1, p2, p3); #endif else ret = ((LF3_Type) fptr)(p1, p2, p3); break; case 4: if (type == VOID_TYPE) ((VF4_Type) fptr)(p1, p2, p3, p4); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF4_Type) fptr)(p1, p2, p3, p4); #endif else ret = ((LF4_Type) fptr)(p1, p2, p3, p4); break; case 5: if (type == VOID_TYPE) ((VF5_Type) fptr)(p1, p2, p3, p4, p5); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF5_Type) fptr)(p1, p2, p3, p4, p5); #endif else ret = ((LF5_Type) fptr)(p1, p2, p3, p4, p5); break; case 6: if (type == VOID_TYPE) ((VF6_Type) fptr)(p1, p2, p3, p4, p5, p6); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF6_Type) fptr)(p1, p2, p3, p4, p5, p6); #endif else ret = ((LF6_Type) fptr)(p1, p2, p3, p4, p5, p6); break; case 7: if (type == VOID_TYPE) ((VF7_Type) fptr)(p1, p2, p3, p4, p5, p6, p7); #ifdef FLOAT_TYPE else if (type == FLOAT_TYPE) xf = ((FF7_Type) fptr)(p1, p2, p3, p4, p5, p6, p7); #endif else ret = ((LF7_Type) fptr)(p1, p2, p3, p4, p5, p6, p7); break; default: SLang_doerror("Function requires too many parameters"); SLang_Error = UNKNOWN_ERROR; break; } switch(type) { case STRING_TYPE: if (NULL == (char *) ret) { if (!SLang_Error) SLang_Error = INTRINSIC_ERROR; } else SLang_push_string((char *) ret); break; case INT_TYPE: /* For msdos, longs are 4 bytes and ints are two. Take this approach: */ SLang_push_integer(*(int*) &ret); break; case VOID_TYPE: break; #ifdef FLOAT_TYPE case FLOAT_TYPE: SLang_push_float(* (FLOAT *) &xf); break; #endif default: SLang_Error = TYPE_MISMATCH; } /* I free afterword because functions that return char * may point to this space. */ switch (argc) { case 7: if (free_p7 == 1) FREE(p7); case 6: if (free_p6 == 1) FREE(p6); case 5: if (free_p5 == 1) FREE(p5); case 4: if (free_p4 == 1) FREE(p4); case 3: if (free_p3 == 1) FREE(p3); case 2: if (free_p2 == 1) FREE(p2); case 1: if (free_p1 == 1) FREE(p1); } } static void lang_do_loops(unsigned char type, SLBlock_Type *block) { register int i, ctrl = 0; int ctrl1; int first, last, one = 0; register SLBlock_Type *obj1, *obj2, *obj3; obj1 = block->b.blk; switch (type) { case LANG_WHILE: case LANG_DOWHILE: /* we need 2 blocks: first is the control, the second is code */ block++; if ((block->type) != LANG_BLOCK) { SLang_doerror("Block needed for while."); return; } obj2 = block->b.blk; if (type == LANG_WHILE) { while(!SLang_Error) { inner_interp(obj1); if (Lang_Break) break; if (SLang_pop_integer(&ctrl1)) return; if (!ctrl1) break; inner_interp(obj2); if (Lang_Break) break; Lang_Break_Condition = Lang_Continue = 0; } } else while(!SLang_Error) { Lang_Break_Condition = Lang_Continue = 0; inner_interp(obj1); if (Lang_Break) break; inner_interp(obj2); if (SLang_pop_integer(&ctrl1)) return; if (!ctrl1) break; } break; case LANG_CFOR: /* we need 4 blocks: first 3 control, the last is code */ inner_interp(obj1); block++; if ((block->type) != LANG_BLOCK) goto cfor_err; obj1 = block->b.blk; block++; if ((block->type) != LANG_BLOCK) goto cfor_err; obj2 = block->b.blk; block++; if ((block->type) != LANG_BLOCK) goto cfor_err; obj3 = block->b.blk; while(!SLang_Error) { inner_interp(obj1); /* test */ if (SLang_pop_integer(&ctrl1)) return; if (!ctrl1) break; inner_interp(obj3); /* code */ if (Lang_Break) break; inner_interp(obj2); /* bump */ Lang_Break_Condition = Lang_Continue = 0; } break; cfor_err: SLang_doerror("Block needed for for."); return; case LANG_FOR: /* 3 elements: first, last, step */ if (SLang_pop_integer(&ctrl1)) return; if (SLang_pop_integer(&last)) return; if (SLang_pop_integer(&first)) return; ctrl = ctrl1; if (ctrl >= 0) { for (i = first; i <= last; i += ctrl) { if (SLang_Error) return; SLang_push_integer(i); inner_interp(obj1); if (Lang_Break) break; Lang_Break_Condition = Lang_Continue = 0; } } else { for (i = first; i >= last; i += ctrl) { if (SLang_Error) return; SLang_push_integer(i); inner_interp(obj1); if (Lang_Break) break; Lang_Break_Condition = Lang_Continue = 0; } } break; case LANG_LOOP: if (SLang_pop_integer(&ctrl1)) return; ctrl = ctrl1; case LANG_FOREVER: if (type == LANG_FOREVER) one = 1; while (one || (ctrl-- > 0)) { if (SLang_Error) break; inner_interp(obj1); if (Lang_Break) break; Lang_Break_Condition = Lang_Continue = 0; } break; default: SLang_doerror("Unknown loop type."); } Lang_Break = Lang_Continue = 0; Lang_Break_Condition = Lang_Return; } static void lang_do_ifs(register SLBlock_Type *addr) { register unsigned char type; int test; type = addr->type >> 8; if (SLang_pop_integer(&test)) return; if (type == LANG_IF) { if (!test) return; } else if (type == LANG_IFNOT) { if (test) return; } else if (test) addr--; /* LANG_ELSE */ addr--; if (addr->type != LANG_BLOCK) /* was & 0xFF as well */ { SLang_doerror("Block needed."); return; } inner_interp(addr->b.blk); } static void lang_do_else(unsigned char type, SLBlock_Type *addr) { int test, status; char *str = NULL; SLang_Object_Type cobj; if (type == LANG_SWITCH) { if (SLang_pop(&cobj)) return; if (IS_DATA_STRING(cobj)) str = cobj.v.s_val; } while((addr->type == LANG_BLOCK) != 0) { if (type == LANG_SWITCH) { if (str == NULL) SLang_push(&cobj); else SLang_push_string(str); } status = inner_interp(addr->b.blk); if (SLang_Error || Lang_Break_Condition) return; if (type == LANG_SWITCH) { if (status) break; } else if (SLang_pop_integer(&test)) return; if (((type == LANG_ANDELSE) && (test == 0)) || ((type == LANG_ORELSE) && test)) { break; } addr++; } if (type != LANG_SWITCH) SLang_push_integer(test); else if (str != NULL) FREE(str); return; } static void lang_dump(char *s) { fputs(s, stderr); } void (*SLang_Dump_Routine)(char *) = lang_dump; static void do_traceback(SLang_Name_Type *nt, int locals); static SLBlock_Type *Exit_Block_Ptr; static SLBlock_Type *Global_User_Block[5]; static SLBlock_Type **User_Block_Ptr = Global_User_Block; void SLexecute_function(SLang_Name_Type *entry1) { register int i; register SLang_Object_Type *frame, *lvf; register int n_locals; register SLang_Name_Type *entry = entry1; SLBlock_Type *val; static char buf[96]; int trace_max, j; static int trace = 0; SLBlock_Type *exit_block_save; SLBlock_Type **user_block_save; SLBlock_Type *user_blocks[5]; n_locals = (entry->type) >> 8; exit_block_save = Exit_Block_Ptr; user_block_save = User_Block_Ptr; User_Block_Ptr = user_blocks; for (j = 0; j < 5; j++) user_blocks[j] = NULL; Exit_Block_Ptr = NULL; /* need loaded? */ if (n_locals == 255) { if (!SLang_load_file((char *) entry->addr)) goto the_return; n_locals = (entry->type) >> 8; if (n_locals == 255) { SLang_doerror("Function did not autoload!"); goto the_return; } } /* let the lang error propagate through since it will do no harm and allow us to restore stack. */ val = (SLBlock_Type *) entry->addr; /* set new stack frame */ lvf = frame = Local_Variable_Frame; i = n_locals; if ((lvf + i) > Local_Variable_Stack + MAX_LOCAL_STACK) { SLang_doerror("Local Variable Stack Overflow!"); goto the_return; } while(i--) { lvf++; lvf->type = 0; } Local_Variable_Frame = lvf; if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(entry->name + 1); if (SLang_Trace) { if ((*SLang_Trace_Function == *entry->name) && !strcmp(SLang_Trace_Function, entry->name)) trace = 1; trace_max = (trace > 50) ? 50 : trace - 1; if (trace) { for (j = 0; j < trace_max; j++) buf[j] = ' '; sprintf(buf + trace_max, ">>%s\n", entry->name + 1); (*SLang_Dump_Routine)(buf); trace++; } inner_interp(val); Lang_Break_Condition = Lang_Return = Lang_Break = 0; if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); if (trace) { sprintf(buf + trace_max, "<<%s\n", entry->name + 1); (*SLang_Dump_Routine)(buf); trace--; if (trace == 1) trace = 0; } } else { inner_interp(val); Lang_Break_Condition = Lang_Return = Lang_Break = 0; if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr); } if (SLang_Exit_Function != NULL) (*SLang_Exit_Function)(entry->name + 1); if (SLang_Error && SLang_Traceback) { do_traceback(entry, n_locals); } /* free local variables.... */ lvf = Local_Variable_Frame; while(lvf > frame) { if (IS_DATA_STRING(*lvf)) FREE (lvf->v.s_val); lvf--; } Local_Variable_Frame = lvf; the_return: Lang_Break_Condition = Lang_Return = Lang_Break = 0; Exit_Block_Ptr = exit_block_save; User_Block_Ptr = user_block_save; } static void do_traceback(SLang_Name_Type *nt, int locals) { char buf[80]; int i; SLang_Object_Type *objp; unsigned short stype; sprintf(buf, "S-Lang Traceback: %s\n",nt->name + 1); (*SLang_Dump_Routine)(buf); if (!locals) return; (*SLang_Dump_Routine)(" Local Variables:\n"); for (i = 0; i < locals; i++) { objp = Local_Variable_Frame - i; stype = objp->type >> 8; if (STRING_TYPE == stype) { sprintf(buf, "\t$%d: \"", i); (*SLang_Dump_Routine)(buf); (*SLang_Dump_Routine)(objp->v.s_val); (*SLang_Dump_Routine)("\"\n"); continue; } else if (INT_TYPE == stype) { sprintf(buf, "\t$%d: %d\n", i, objp->v.i_val); } #ifdef FLOAT_TYPE else if (stype == FLOAT_TYPE) { sprintf(buf,"\t$%d: %g\n", i, objp->v.f_val); } #endif else sprintf(buf, "\t$%d: ??\n", i); (*SLang_Dump_Routine)(buf); } } static void call_funptr(SLang_Name_Type *optr) { SLBlock_Type objs[2]; if (optr == NULL) { SLang_doerror("Object Ptr is Nil!"); return; } objs[0].b.n_blk = optr; objs[0].type = optr->type; objs[1].type = 0; inner_interp(objs); } #ifdef SLANG_STATS static unsigned long stat_counts[256]; #endif void (*SLang_Interrupt)(void); static int Last_Error; void (*SLang_User_Clear_Error)(void); void SLang_clear_error (void) { if (Last_Error <= 0) { Last_Error = 0; return; } Last_Error--; if (SLang_User_Clear_Error != NULL) (*SLang_User_Clear_Error)(); } /* inner interpreter */ static int inner_interp(SLBlock_Type *addr1) { register int bc = 0; register SLang_Object_Type *val; register SLBlock_Type *addr; SLang_Object_Type obj1, obj2, *objp; register unsigned short type; register unsigned char stype; int x, y, z; SLBlock_Type *block = NULL; SLBlock_Type *err_block = NULL; int save_err, slerr; #ifdef FLOAT_TYPE FLOAT xf, yf, zf; int xc, yc; #endif /* for systems that have no real interrupt facility (e.g. go32 on dos) */ if (SLang_Interrupt != NULL) (*SLang_Interrupt)(); addr = addr1; if (addr == NULL) { SLang_Error = UNKNOWN_ERROR; } while (SLang_Error == 0) { if (bc) { if (SLang_Error) break; if (Lang_Return || Lang_Break) { Lang_Break = 1; return(1); } if (Lang_Continue) return(1); } #ifdef SLANG_STATS stat_counts[(unsigned char) (type & 0xFF)] += 1; #endif switch (addr->type & 0xFF) { case 0: goto end_of_switch; case LANG_INTEGER_BINARY: case LANG_INTEGER_CMP: y = addr->b.i_blk; #ifdef FLOAT_TYPE yc = 1; yf = (FLOAT) y; #endif goto binary_begin; case LANG_LOCAL_BINARY: case LANG_LOCAL_CMP: case LANG_LVARIABLE: /* make val point to local stack */ val = (Local_Variable_Frame - addr->b.i_blk); /* inline push_variable here -- save function call */ type = val -> type; stype = type >> 8; if (stype == STRING_TYPE) { SLang_push_string(val->v.s_val); } else if (stype == LANG_OBJ_TYPE) call_funptr(val->v.n_val); else { SLang_push(val); } if ((addr->type & 0xFF) == LANG_LVARIABLE) break; /* drop if we have local_binary and local_cmp */ case LANG_CMP: case LANG_BINARY: #ifndef FLOAT_TYPE if (SLang_pop_integer(&y)) return 0; /* Start here when we already have y */ binary_begin: if (SLang_pop_integer(&x)) return 0; z = 0; #else if (SLang_pop_float(&yf, &yc, &y)) return 0; /* Start here when we already have y */ binary_begin: if (SLang_pop_float(&xf, &xc, &x)) return 0; z = 0; if (yc && xc) { #endif switch (addr->type >> 8) { case LANG_EQ: if (x == y) z = 1; break; case LANG_NE: if (x != y) z = 1; break; case LANG_GT: if (x > y) z = 1; break; case LANG_GE: if (x >= y) z = 1; break; case LANG_LT: if (x < y) z = 1; break; case LANG_LE: if (x <= y) z = 1; break; case LANG_OR: if (x || y) z = 1; break; case LANG_AND: if (x && y) z = 1; break; case LANG_BAND: z = x & y; break; case LANG_BXOR: z = x ^ y; break; case LANG_MOD: z = x % y; break; case LANG_BOR: z = x | y; break; case LANG_PLUS: z = x + y; break; case LANG_MINUS: z = x - y; break; case LANG_TIMES: z = x * y; break; case LANG_DIVIDE: if (y == 0) { SLang_Error = DIVIDE_ERROR; return(0); } z = x / y; break; /* y == 0? */ case LANG_SHL: z = x << y; break; case LANG_SHR: z = x >> y; break; default: SLang_Error = INTERNAL_ERROR; return(0); } SLang_push_integer(z); /* binary */ #ifdef FLOAT_TYPE } else { switch (addr->type >> 8) { case LANG_SHR: case LANG_SHL: SLang_Error = TYPE_MISMATCH; return(0); case LANG_EQ: if (xf == yf) z = 1; break; case LANG_NE: if (xf != yf) z = 1; break; case LANG_GT: if (xf > yf) z = 1; break; case LANG_GE: if (xf >= yf) z = 1; break; case LANG_LT: if (xf < yf) z = 1; break; case LANG_LE: if (xf <= yf) z = 1; break; case LANG_OR: if (xf || yf) z = 1; break; case LANG_AND: if (xf && yf) z = 1; break; case LANG_PLUS: zf = xf + yf; break; case LANG_MINUS: zf = xf - yf; break; case LANG_TIMES: zf = xf * yf; break; case LANG_DIVIDE: if (yf == 0.0) { SLang_Error = DIVIDE_ERROR; return(0); } zf = xf / yf; break; /* y == 0? */ default: SLang_Error = INTERNAL_ERROR; return(0); } if (((addr->type & 0xFF) == LANG_CMP) || ((addr->type & 0xFF) == LANG_INTEGER_CMP) || ((addr->type & 0xFF) == LANG_LOCAL_CMP)) SLang_push_integer(z); else SLang_push_float(zf); } /* binary */ #endif /* FLOAT */ break; case LANG_LINTRINSIC: case LANG_LFUNCTION: /* make val point to local stack */ val = (Local_Variable_Frame - (addr->type >> 8)); /* inline push_variable here -- save function call */ type = val -> type; stype = type >> 8; if (stype == STRING_TYPE) { SLang_push_string(val->v.s_val); } else if (stype == LANG_OBJ_TYPE) call_funptr(val->v.n_val); else { SLang_push(val); } if ((addr->type & 0xFF) == LANG_LFUNCTION) goto lang_function_label; /* drop */ case LANG_INTRINSIC: lang_do_intrinsic(addr->b.n_blk); if (SLang_Error && SLang_Traceback) { do_traceback(addr->b.n_blk, 0); } break; case LANG_FUNCTION: lang_function_label: SLexecute_function(addr->b.n_blk); bc = Lang_Break_Condition; break; case LANG_LITERAL: /* a constant */ obj1.type = addr->type; stype = obj1.type >> 8; #ifdef FLOAT_TYPE /* The value is a pointer to the float */ if (stype == FLOAT_TYPE) { obj1.v.f_val = *addr->b.f_blk; } else #endif obj1.v.l_val = addr->b.l_blk; SLang_push(&obj1); break; case LANG_BLOCK: stype = addr->type >> 8; if (stype == ERROR_BLOCK) err_block = addr; else if (stype == EXIT_BLOCK) Exit_Block_Ptr = addr->b.blk; else if ((stype >= USER_BLOCK0) && (stype <= USER_BLOCK4)) User_Block_Ptr[stype - USER_BLOCK0] = addr->b.blk; else if (block == NULL) block = addr; break; case LANG_DIRECTIVE: if (addr->type & (LANG_EQS_MASK << 8)) { lang_do_eqs(addr); break; } type = addr->type; if (!block) SLang_doerror("No Blocks!"); else if (type & (LANG_IF_MASK << 8)) lang_do_ifs(addr); else if (type & (LANG_ELSE_MASK << 8)) lang_do_else(type >> 8, block); else if (type & (LANG_LOOP_MASK << 8)) lang_do_loops(type >> 8, block); /* else SLang_doerror("Unknown directive!"); */ block = 0; bc = Lang_Break_Condition; break; case LANG_UNARY: stype = addr->type >> 8; #ifndef FLOAT_TYPE if (SLang_pop_integer(&z)) return(0); switch (stype) { case LANG_SQR: z = z * z; break; case LANG_MUL2: z = z * 2; break; case LANG_NOT: z = !z; break; case LANG_BNOT: z = ~z; break; case LANG_CHS: z = -z; break; case LANG_ABS: z = abs(z); break; case LANG_SIGN: z = (z >= 0) ? 1 : -1; break; default: SLang_Error = INTERNAL_ERROR; return(0); } SLang_push_integer(z); #else if (stype == LANG_CHS) { if (SLang_pop_float(&zf, &xc, &z)) return(0); if (xc) SLang_push_integer(-z); else SLang_push_float(-zf); } else if (stype == LANG_SQR) { if (SLang_pop_float(&zf, &xc, &z)) return(0); if (xc) SLang_push_integer(z * z); else SLang_push_float(zf * zf); } else if (stype == LANG_MUL2) { if (SLang_pop_float(&zf, &xc, &z)) return(0); if (xc) SLang_push_integer(z << 1); else SLang_push_float(2.0 * zf); } else if (stype == LANG_ABS) { if (SLang_pop_float(&zf, &xc, &z)) return(0); if (xc) SLang_push_integer(abs(z)); else SLang_push_float((FLOAT) fabs((double) zf)); } else { if (SLang_pop_integer(&z)) return(0); if (stype == LANG_NOT) z = !z; else if (stype == LANG_BNOT) z = ~z; else { SLang_Error = INTERNAL_ERROR; return(0); } SLang_push_integer(z); } #endif break; case LANG_GVARIABLE: SLang_push_variable((SLang_Object_Type *) addr->b.n_blk->addr); break; case LANG_IVARIABLE: case LANG_RVARIABLE: switch(addr->type >> 8) { case ARRAY_TYPE: obj1.type = addr->type; obj1.v.i_val = (int) addr->b.n_blk->addr; SLang_push (&obj1); break; case STRING_TYPE: SLang_push_string((char *) addr->b.n_blk->addr); break; case INT_TYPE: SLang_push_integer(*(int *) addr->b.n_blk->addr); break; case INTP_TYPE: SLang_push_integer(**(int **) addr->b.n_blk->addr); break; #ifdef FLOAT_TYPE case FLOAT_TYPE: SLang_push_float(*(FLOAT *) addr->b.n_blk->addr); break; #endif default: SLang_doerror("Unsupported Type!"); } break; case LANG_RETURN: Lang_Break_Condition = Lang_Return = Lang_Break = 1; return(1); case LANG_BREAK: Lang_Break_Condition = Lang_Break = 1; return(1); case LANG_CONTINUE: Lang_Break_Condition = Lang_Continue = 1; return(1); case LANG_EXCH: if (SLang_pop(&obj1) || SLang_pop(&obj2)) return(1); SLang_push(&obj1); SLang_push(&obj2); break; case LANG_LABEL: if (SLang_pop_integer(&z) || !z) return(0); break; case LANG_LOBJPTR: objp = (Local_Variable_Frame - addr->b.i_blk); if (objp->type == 0) { SLang_doerror("Local variable pointer not initialized."); break; } obj1.v.n_val = objp->v.n_val; obj1.type = LANG_DATA | (LANG_OBJ_TYPE << 8); SLang_push(&obj1); break; case LANG_GOBJPTR: obj1.v.n_val = addr->b.n_blk; obj1.type = LANG_DATA | (LANG_OBJ_TYPE << 8); SLang_push(&obj1); break; case LANG_X_USER0: case LANG_X_USER1: case LANG_X_USER2: case LANG_X_USER3: case LANG_X_USER4: if (User_Block_Ptr[(addr->type & 0xFF) - LANG_X_USER0] != NULL) { inner_interp(User_Block_Ptr[(addr->type & 0xFF) - LANG_X_USER0]); } else SLang_doerror("No User Block"); bc = Lang_Break_Condition; break; case LANG_X_ERROR: if (err_block != NULL) { inner_interp(err_block->b.blk); if (SLang_Error) err_block = NULL; } else SLang_doerror("No Error Block"); bc = Lang_Break_Condition; break; /* default : SLang_doerror("Run time error."); */ } addr++; } end_of_switch: if ((SLang_Error) && (err_block != NULL) && ((SLang_Error == USER_BREAK) || (SLang_Error == INTRINSIC_ERROR))) { save_err = Last_Error++; slerr = SLang_Error; SLang_Error = 0; inner_interp(err_block->b.blk); if (Last_Error <= save_err) { /* Caught error and cleared it */ Last_Error = save_err; if (Lang_Break_Condition == 0) inner_interp(addr); } else { Last_Error = save_err; SLang_Error = slerr; } } return(1); } /* Hash value of current item to search in table */ static unsigned char Hash; static unsigned char compute_hash(unsigned char *s) { register unsigned char *ss = s; register unsigned int h = 0; while (*ss) h += (unsigned int) *ss++ + (h << 2); if (0 == (Hash = (unsigned char) h)) { Hash = (unsigned char) (h >> 8); if (!Hash) Hash = *s; } return(Hash); } SLang_Name_Type *SLang_locate_name_in_table(char *name, SLang_Name_Type *table, SLang_Name_Type *t0, int max) { register SLang_Name_Type *t = t0, *tmax = table + max; register char h = Hash, h1; /* while(t != tmax) && (nm = t->name, (h1 = *nm) != 0)) */ while(t != tmax) { h1 = *t->name; /* h is never 0 */ if ((h1 == h) && !strcmp(t->name + 1,name)) { #ifdef SLANG_STATS t->n++; #endif return(t); } else if (h1 == 0) break; t++; } if (t == tmax) return(NULL); return(t); } void SLang_trace_fun(char *f) { SLang_Trace = 1; compute_hash((unsigned char *) f); *SLang_Trace_Function = Hash; strcpy((char *) SLang_Trace_Function + 1, f); } #ifdef SLANG_STATS int SLang_dump_stats(char *file) { SLang_Name_Type *t = Lang_Intrinsic_Name_Table; int i; FILE *fp; if ((fp = fopen(file, "w")) == NULL) return(0); while (*t->name != 0) { fprintf(fp, "%3d\t%3d\t%s\n", t->n, (int) (unsigned char) *t->name, t->name + 1); t++; } for (i = 0; i < 256; i++) fprintf(fp, "Count %d: %lu\n", i, stat_counts[i]); fclose(fp); return(1); } #endif /* before calling this routine, make sure that Hash is up to date */ SLang_Name_Type *SLang_locate_global_name(char *name) { SLName_Table *nt; SLang_Name_Type *t; int ofs; nt = SLName_Table_Root; while (nt != NULL) { t = nt->table; if ((ofs = nt->ofs[Hash]) != -1) { t = SLang_locate_name_in_table(name, t, t + ofs, nt->n); if ((t != NULL) && (*t->name != 0)) return(t); } nt = nt->next; } ofs = SLang_Name_Table_Ofs [Hash]; if (ofs == -1) ofs = SLang_Name_Table_Ofs [0]; return SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table + ofs, LANG_MAX_SYMBOLS); } SLang_Name_Type *SLang_locate_name(char *name) { SLang_Name_Type *t; (void) compute_hash((unsigned char *) name); t = Lang_Local_Variable_Table; if (t != NULL) { t = SLang_locate_name_in_table(name, t, t, Local_Variable_Number); /* MAX_LOCAL_VARIABLES */ } if ((t == NULL) || (*t->name == 0)) t = SLang_locate_global_name(name); return(t); } /* check syntax. Allowed chars are: $!_?AB..Zab..z0-9 */ static int lang_check_name(char *name) { register char *p, ch; char *err = "Name Syntax"; p = name; while ((ch = *p++) != 0) { if ((ch >= 'a') && (ch <= 'z')) continue; if ((ch >= 'A') && (ch <= 'Z')) continue; if ((ch >= '0') && (ch <= '9')) continue; if ((ch == '_') || (ch == '$') || (ch == '!') || (ch == '?')) continue; SLang_doerror(err); return(0); } p--; if ((int) (p - name) > LANG_MAX_NAME_LEN) { SLang_doerror("Name too long."); return(0); } return (1); } void SLadd_name(char *name, long addr, unsigned short type) { SLang_Name_Type *entry; unsigned char stype; int ofs, this_ofs; if (!lang_check_name(name)) return; if (NULL == (entry = SLang_locate_name(name))) { SLang_doerror("Table size exceeded!"); return; /* table full */ } stype = entry->type & 0xFF; if ((stype == LANG_INTRINSIC) || (stype == LANG_IVARIABLE) || (stype == LANG_RVARIABLE)) { /* Allow application to change what the binding of a given object * is but do not allow a user function to have same name as something * intrinsic. It must be the same base type though. */ if ((type & 0xFF) != stype) { SLang_Error = DUPLICATE_DEFINITION; return; } } if (*entry->name != 0) { /* 255 denotes that the function needs autoloaded. */ if (stype == LANG_FUNCTION) { if ((entry->type >> 8) != 255) { if (lang_free_branch((SLBlock_Type *) entry->addr)) FREE(entry->addr); } else FREE(entry->addr); } } else { strcpy(entry->name + 1, name); *entry->name = (char) Hash; ofs = SLang_Name_Table_Ofs [Hash]; this_ofs = (int) (entry - SLang_Name_Table); if (ofs == -1) /* unused */ { SLang_Name_Table_Ofs [Hash] = this_ofs; SLang_Name_Table_Ofs [0] = this_ofs; } } entry->addr = (long) addr; entry->type = type; } void SLang_autoload(char *name, char *file) { unsigned short type; long f; type = LANG_FUNCTION | (255 << 8); f = (long) SLmake_string(file); SLadd_name(name, f, type); } /* These are initialized in add_table below. I cannot init a Union!! */ static SLBlock_Type SLShort_Blocks[3]; static void lang_define_function(char *name) { long addr; unsigned short type; /* terminate function */ Lang_Object_Ptr->type = 0; if (Lang_Function_Body + 1 == Lang_Object_Ptr) { if (Lang_Function_Body -> type == LANG_RETURN) { FREE (Lang_Function_Body); Lang_Function_Body = SLShort_Blocks; } } addr = (long) Lang_Function_Body; type = LANG_FUNCTION | (Local_Variable_Number << 8); if (name != NULL) { SLadd_name(name, addr, type); } if (SLang_Error) return; Lang_Defining_Function = 0; if (Lang_Local_Variable_Table != NULL) FREE(Lang_Local_Variable_Table); Lang_Local_Variable_Table = NULL; Local_Variable_Number = 0; Lang_Object_Ptr = Lang_Interp_Stack_Ptr; /* restore pointer */ } /* call inner interpreter or return for more */ static void lang_try_now(void) { SLBlock_Type *old_stack, *old_stack_ptr, *old_int_stack_ptr; SLBlock_Type new_stack[SLANG_MAX_TOP_STACK]; int i; if (Lang_Defining_Function || Lang_Defining_Block) { Lang_Object_Ptr++; return; } /* This is the entry point into the inner interpreter. As a result, it is also the exit point of the inner interpreter. So it is necessary to clean up if there was an error. */ (Lang_Object_Ptr + 1)->type = 0; /* so next command stops after this */ /* now before entering the inner interpreter, we make a new stack so that we are able to be reentrant */ for (i = 1; i < 4; i++) { new_stack[i].type = 0; new_stack[i].b.blk = NULL; } /* remember these values */ old_int_stack_ptr = Lang_Interp_Stack_Ptr; old_stack_ptr = Lang_Object_Ptr; old_stack = Lang_Interp_Stack; /* new values for reentrancy */ Lang_Interp_Stack_Ptr = Lang_Object_Ptr = Lang_Interp_Stack = new_stack; /* now do it */ inner_interp(old_stack); /* we are back so restore old pointers */ Lang_Interp_Stack_Ptr = old_int_stack_ptr; Lang_Object_Ptr = old_stack_ptr; Lang_Interp_Stack = old_stack; /* now free blocks from the current interp_stack. There can only be blocks since they are only objects not evaluated immediately */ while (Lang_Object_Ptr != Lang_Interp_Stack) { /* note that top object is not freed since it was not malloced */ Lang_Object_Ptr--; (void) lang_free_branch(Lang_Object_Ptr->b.blk); } /* now free up the callocd stack. FREE(new_stack); */ } #define eqs(a,b) ((*(a) == *(b)) && !strcmp(a,b)) int SLang_execute_function(char *name) { unsigned char type; SLang_Name_Type *entry; if ((NULL == (entry = SLang_locate_name(name))) || (*entry->name == 0)) return(0); type = entry->type & 0xFF; if (type == LANG_FUNCTION) SLexecute_function(entry); else if (type == LANG_INTRINSIC) lang_do_intrinsic(entry); else return(0); if (SLang_Error) SLang_doerror(NULL); return(1); } /* return S-Lang function or NULL */ SLang_Name_Type *SLang_get_function (char *name) { SLang_Name_Type *entry; if ((NULL == (entry = SLang_locate_name(name))) || (*entry->name == 0)) return NULL; if ((entry->type & 0xFF) == LANG_FUNCTION) { return entry; } return NULL; } /* Look for name ONLY in local or global slang tables */ static SLang_Name_Type *SLang_locate_slang_name (char *name) { SLang_Name_Type *entry; int ofs; compute_hash ((unsigned char *) name); /* try local table first */ entry = Lang_Local_Variable_Table; if (entry != NULL) { entry = SLang_locate_name_in_table(name, entry, entry, Local_Variable_Number); } if ((entry == NULL) || (*entry->name == 0)) { ofs = SLang_Name_Table_Ofs [Hash]; if (ofs == -1) ofs = SLang_Name_Table_Ofs [0]; entry = SLang_locate_name_in_table(name, SLang_Name_Table, SLang_Name_Table + ofs, LANG_MAX_SYMBOLS); } return entry; } #if 0 static void make_name_ptr(char *name) { SLang_Name_Type *n; SLang_Object_Type obj; n = SLang_locate_name(name); if ((n == NULL) || (*n->name == 0)) { SLang_doerror("Object is undefined."); return; } obj.type = LANG_DATA | (LANG_OBJ_TYPE << 8); if ((n->obj.type >> 8) == LANG_OBJ_TYPE) obj.value = n->obj.value; else obj.value = (long) n; SLang_push (&obj); } #endif static int lang_exec(char *name, int all) { SLang_Name_Type *entry; short type; int ptr_type = 0; int i = 0; if (all && (eqs(name, "EXECUTE_ERROR_BLOCK") || ((*name == 'X') && !strncmp ("X_USER_BLOCK", name, 12) && ((i = name[12]) < '5') && (i >= '0') && (name[13] == 0)))) { if (*name == 'X') { Lang_Object_Ptr->type = LANG_X_USER0 + (i - '0'); } else Lang_Object_Ptr->type = LANG_X_ERROR; Lang_Object_Ptr->b.blk = NULL; lang_try_now (); return 1; } if (*name == '&') { name++; ptr_type = 1; } if (all) entry = SLang_locate_name(name); else entry = SLang_locate_slang_name (name); if ((entry == NULL) || (*entry->name == 0)) return(0); type = entry->type; if (ptr_type) { Lang_Object_Ptr->type = type == LANG_LVARIABLE ? LANG_LOBJPTR : LANG_GOBJPTR; } else { Lang_Object_Ptr->type = type; } if (type == LANG_LVARIABLE) { Lang_Object_Ptr->b.i_blk = (int) entry->addr; } else { if ((((type & 0xFF) == LANG_INTRINSIC) || ((type & 0xFF) == LANG_FUNCTION)) && (Lang_Object_Ptr != Lang_Interp_Stack) && ((Lang_Object_Ptr - 1)->type == LANG_LVARIABLE) && (ptr_type == 0)) { Lang_Object_Ptr--; /* hi byte is local number */ if ((type & 0xFF) == LANG_INTRINSIC) Lang_Object_Ptr->type = LANG_LINTRINSIC | (Lang_Object_Ptr->b.i_blk << 8); else Lang_Object_Ptr->type = LANG_LFUNCTION | (Lang_Object_Ptr->b.i_blk << 8); } Lang_Object_Ptr->b.n_blk = entry; } lang_try_now(); return(1); } static int lang_try_binary(char *t) { int ssub; unsigned char sub, type; ssub = 0; if (0 == (ssub = slang_eqs_name(t, SL_Binary_Ops))) return(0); if (ssub < 0) { ssub = -ssub; type = LANG_BINARY; } else type = LANG_CMP; sub = (unsigned char) ssub; if (Lang_Object_Ptr != Lang_Interp_Stack) { if (((Lang_Object_Ptr - 1) ->type) == LANG_LVARIABLE) { if (type == LANG_BINARY) type = LANG_LOCAL_BINARY; else type = LANG_LOCAL_CMP; Lang_Object_Ptr--; } else if (((Lang_Object_Ptr - 1)->type) == ((INT_TYPE << 8) | LANG_LITERAL)) { if (type == LANG_BINARY) type = LANG_INTEGER_BINARY; else type = LANG_INTEGER_CMP; Lang_Object_Ptr--; } else Lang_Object_Ptr->b.blk = NULL; /* not used */ } else Lang_Object_Ptr->b.blk = NULL; /* not used */ Lang_Object_Ptr->type = type | (sub << 8); lang_try_now(); return(1); } static int lang_try_unary(char *t) { unsigned char ssub, type; if (eqs(t, "~")) ssub = LANG_BNOT; else if (eqs(t, "not")) ssub = LANG_NOT; else if (eqs(t, "chs")) ssub = LANG_CHS; else if (eqs(t, "sign")) ssub = LANG_SIGN; else if (eqs(t, "abs")) ssub = LANG_ABS; else if (eqs(t, "sqr")) ssub = LANG_SQR; else if (eqs(t, "mul2")) ssub = LANG_MUL2; else return(0); type = LANG_UNARY; Lang_Object_Ptr->type = type | (ssub << 8); Lang_Object_Ptr->b.blk = NULL; /* not used */ lang_try_now(); return(1); } static void lang_begin_function(void) { if (Lang_Defining_Function || Lang_Defining_Block) { SLang_doerror("Function nesting illegal."); return; } Lang_Defining_Function = 1; /* make initial size for 3 things */ Lang_FBody_Size = 3; if (NULL == (Lang_Function_Body = (SLBlock_Type *) CALLOC(Lang_FBody_Size, sizeof(SLBlock_Type)))) { SLang_doerror("Calloc error defining function."); return; } /* function definitions should be done only at top level so it should be safe to do this: */ Lang_Interp_Stack_Ptr = Lang_Object_Ptr; Lang_Object_Ptr = Lang_FBody_Ptr = Lang_Function_Body; return; } static void lang_end_block(void) { SLBlock_Type *node, *branch; unsigned short type; Lang_Block_Depth--; /* terminate the block */ Lang_Object_Ptr->type = 0; branch = Lang_Block_Body; if (Lang_Object_Ptr == Lang_Block_Body + 1) { type = (Lang_Object_Ptr - 1)->type; if ((type == LANG_BREAK) || (type == LANG_CONTINUE) || (type == LANG_RETURN)) { FREE (branch); branch = SLShort_Blocks + (int) (type - LANG_RETURN); } } if (Lang_Block_Depth == -1) /* done */ { if (Lang_Defining_Function) { node = Lang_FBody_Ptr++; } else node = Lang_Interp_Stack_Ptr; /* on small stack */ } else /* pop previous block */ { Lang_BBody_Size = Lang_Block_Stack[Lang_Block_Depth].size; Lang_Block_Body = Lang_Block_Stack[Lang_Block_Depth].body; node = Lang_Block_Stack[Lang_Block_Depth].ptr; } node->type = LANG_BLOCK; node->b.blk = branch; Lang_Object_Ptr = node + 1; Lang_Defining_Block--; } static void lang_begin_block(void) { if (Lang_Block_Depth == LANG_MAX_BLOCKS - 1) { SLang_doerror("Block Nesting too deep."); SLang_Error = UNKNOWN_ERROR; return; } /* push the current block onto the stack */ if (Lang_Block_Depth > -1) { Lang_Block_Stack[Lang_Block_Depth].size = Lang_BBody_Size; Lang_Block_Stack[Lang_Block_Depth].body = Lang_Block_Body; Lang_Block_Stack[Lang_Block_Depth].ptr = Lang_Object_Ptr; } /* otherwise this is first block so save function pointer */ else if (Lang_Defining_Function) Lang_FBody_Ptr = Lang_Object_Ptr; else Lang_Interp_Stack_Ptr = Lang_Object_Ptr; Lang_BBody_Size = 5; /* 40 bytes */ if (NULL == (Lang_Block_Body = (SLBlock_Type *) CALLOC(Lang_BBody_Size, sizeof(SLBlock_Type)))) { SLang_Error = SL_MALLOC_ERROR; /* SLang_doerror("Malloc error defining block."); */ return; } Lang_Block_Depth++; Lang_Defining_Block++; Lang_Object_Ptr = Lang_Block_Body; return; } /* see if token is a directive, and add it to current block/function */ static Lang_Name2_Type Lang_Directives[] = { {"!if", LANG_IFNOT}, {"if", LANG_IF}, {"else", LANG_ELSE}, {"forever", LANG_FOREVER}, {"while", LANG_WHILE}, {"for", LANG_CFOR}, {"_for", LANG_FOR}, {"loop", LANG_LOOP}, {"switch", LANG_SWITCH}, {"do_while", LANG_DOWHILE}, {"andelse", LANG_ANDELSE}, {"orelse", LANG_ORELSE}, {(char *) NULL, (int) NULL} }; static int try_directive(char *t, int *flag) { unsigned char sub = 0; unsigned short type = LANG_DIRECTIVE; SLBlock_Type *lop; int flag_save; if ((sub = (unsigned char) slang_eqs_name(t, Lang_Directives)) != 0); /* null */ else if (*flag && ((*t == 'E') || (*t == 'U'))) { int b, i; lop = Lang_Object_Ptr - 1; if (eqs(t, "ERROR_BLOCK")) b = LANG_BLOCK | (ERROR_BLOCK << 8); else if (eqs(t, "EXIT_BLOCK")) b = LANG_BLOCK | (EXIT_BLOCK << 8); else if ((*t == 'U') && !strncmp(t, "USER_BLOCK", 10) && ((i = t[10]) < '5') && (i >= '0') && (t[11] == 0)) { b = LANG_BLOCK | ((USER_BLOCK0 + (i - '0')) << 8); } else return 0; if (lop->type != LANG_BLOCK) SLang_doerror("Internal Error with block!"); else lop->type = b; return(1); } /* rest valid only if flag is zero */ else if (*flag) return(0); else { if (Lang_Defining_Block && eqs(t, "continue")) type = LANG_CONTINUE; else if (Lang_Defining_Block && eqs(t, "break")) type = LANG_BREAK; else if (Lang_Defining_Function && eqs(t, "return")) type = LANG_RETURN; /* why is exch here? */ else if (eqs(t, "exch")) type = LANG_EXCH; else return(0); *flag = 1; } Lang_Object_Ptr->type = type | (sub << 8); Lang_Object_Ptr->b.blk = 0; /* not used */ flag_save = *flag; *flag = 0; lang_try_now(); *flag = flag_save; return(1); } static SLang_Object_Type *lang_make_object(void) { SLang_Object_Type *obj; obj = (SLang_Object_Type *) MALLOC(sizeof(SLang_Object_Type)); if (NULL == obj) { SLang_Error = SL_MALLOC_ERROR; /* SLang_doerror("Lang: malloc error."); */ return(0); } obj->type = 0; obj->v.l_val = 0; return obj; } static int interp_variable_eqs(char *name) { SLang_Name_Type *v; SLBlock_Type obj; unsigned short type; unsigned char stype; char ch; long value; int offset; int eq, pe, me, pp, mm; eq = LANG_GEQS - LANG_GEQS; pe = LANG_GPEQS - LANG_GEQS; me = LANG_GMEQS - LANG_GEQS; pp = LANG_GPP - LANG_GEQS; mm = LANG_GMM - LANG_GEQS; /* Name must be prefixed by one of: =, ++, --, +=, -= all of which have ascii codes less than or equal to 61 ('=') */ offset = -1; ch = *name++; switch (ch) { case '=': offset = eq; break; case '+': ch = *name++; if (ch == '+') offset = pp; else if (ch == '=') offset = pe; break; case '-': ch = *name++; if (ch == '-') offset = mm; else if (ch == '=') offset = me; break; } if (offset == -1) return 0; v = SLang_locate_name(name); if ((v == NULL) || *(v->name) == 0) { SLang_Error = UNDEFINED_NAME; SLang_doerror(name); return(1); } type = (v->type) & 0xFF; if (type == LANG_RVARIABLE) { SLang_Error = READONLY_ERROR; return(1); } if ((type != LANG_GVARIABLE) && (type != LANG_LVARIABLE) && (type != LANG_IVARIABLE)) { SLang_Error = DUPLICATE_DEFINITION; return(1); } /* its value is location of object in name table unless it is local */ value = (long) v; if (type == LANG_IVARIABLE) { if ((v->type >> 8) == STRING_TYPE) { SLang_Error = READONLY_ERROR; return(1); } stype = LANG_IEQS; } else if (type == LANG_GVARIABLE) stype = LANG_GEQS; else { stype = LANG_LEQS; value = (int) v->addr; } stype += offset; if (Lang_Defining_Function || Lang_Defining_Block) { Lang_Object_Ptr->type = LANG_DIRECTIVE | (stype << 8); Lang_Object_Ptr->b.l_blk = value; Lang_Object_Ptr++; return (1); } /* create an object with the required properties for next call */ obj.type = LANG_DIRECTIVE | (stype << 8); obj.b.l_blk = value; lang_do_eqs(&obj); return(1); } /* a literal */ static int interp_push_number(char *t) { int i = 0; unsigned char stype; long value = 0; #ifdef FLOAT_TYPE FLOAT x = 0.0; #endif stype = slang_guess_type(t); if (stype == STRING_TYPE) return(0); if (stype == INT_TYPE) { i = SLatoi((unsigned char *) t); value = (long) i; } #ifdef FLOAT_TYPE else if (stype == FLOAT_TYPE) { x = atof(t); } #endif if (!Lang_Defining_Block && !Lang_Defining_Function) { #ifdef FLOAT_TYPE if (stype == INT_TYPE) { #endif SLang_push_integer(i); #ifdef FLOAT_TYPE } else SLang_push_float(x); #endif return(1); } /* a literal */ #ifdef FLOAT_TYPE if (stype == FLOAT_TYPE) { if (NULL == (Lang_Object_Ptr->b.f_blk = (FLOAT *) MALLOC(sizeof(FLOAT)))) { SLang_Error = SL_MALLOC_ERROR; return 1; } *Lang_Object_Ptr->b.f_blk = x; } else #endif Lang_Object_Ptr->b.l_blk = value; Lang_Object_Ptr->type = LANG_LITERAL | (stype << 8); Lang_Object_Ptr++; return(1); } /* only supports non negative integers, use 'chs' to make negative number */ void lang_check_space(void) { int n; SLBlock_Type *p; if (Lang_Interp_Stack_Ptr - Lang_Interp_Stack >= 9) { SLang_doerror("Interpret stack overflow."); return; } if (Lang_Defining_Block) { n = (int) (Lang_Object_Ptr - Lang_Block_Body); if (n + 1 < Lang_BBody_Size) return; /* extra for terminator */ p = Lang_Block_Body; } else if (Lang_Defining_Function) { n = (int) (Lang_Object_Ptr - Lang_Function_Body); if (n + 1 < Lang_FBody_Size) return; p = Lang_Function_Body; } else return; /* enlarge the space by 2 objects */ n += 2; if (NULL == (p = (SLBlock_Type *) REALLOC(p, n * sizeof(SLBlock_Type)))) { SLang_Error = SL_MALLOC_ERROR; return; } if (Lang_Defining_Block) { Lang_BBody_Size = n; n = (int) (Lang_Object_Ptr - Lang_Block_Body); Lang_Block_Body = p; Lang_Object_Ptr = p + n; } else { Lang_FBody_Size = n; n = (int) (Lang_Object_Ptr - Lang_Function_Body); Lang_Function_Body = p; Lang_Object_Ptr = p + n; } } int Lang_Defining_Variables = 0; /* returns positive number if name is a function or negative number if it is a variable. If it is intrinsic, it returns magnitude of 1, else 2 */ int SLang_is_defined(char *name) { SLang_Name_Type *t; unsigned char stype; (void) compute_hash((unsigned char *) name); t = SLang_locate_global_name(name); if ((t == NULL) || (*t->name == 0)) return 0; stype = t->type & 0xFF; switch (stype) { case LANG_FUNCTION: return(2); case LANG_INTRINSIC: return(1); case LANG_GVARIABLE: return (-2); default: return(-1); } } char *SLang_find_name(char *name) { SLang_Name_Type *n; compute_hash((unsigned char *) name); n = SLang_locate_global_name(name); if ((n != NULL) && (*n->name != 0)) { return(n->name); } return(NULL); } void SLadd_variable(char *name) { SLang_Name_Type *table; long value; if (!lang_check_name(name)) return; if (Lang_Defining_Function) /* local variable */ { compute_hash((unsigned char *) name); table = Lang_Local_Variable_Table; if (!Local_Variable_Number) { table = (SLang_Name_Type *) CALLOC(MAX_LOCAL_VARIABLES, sizeof(SLang_Name_Type)); if (NULL == table) { SLang_doerror("Lang: calloc error."); return; } Lang_Local_Variable_Table = table; } strcpy(table[Local_Variable_Number].name + 1, name); *table[Local_Variable_Number].name = (char) Hash; table[Local_Variable_Number].type = LANG_LVARIABLE; table[Local_Variable_Number].addr = (long) Local_Variable_Number; Local_Variable_Number++; } /* Note the importance of checking if it is already defined or not. For example, * suppose X is defined as an intrinsic variable. Then S-Lang code like: * !if (is_defined("X")) { variable X; } * will not result in a global variable X. On the other hand, this would * not be an issue if 'variable' statements always were not processed * immediately. That is, as it is now, 'if (0) {variable ZZZZ;}' will result * in the variable ZZZZ being defined because of the immediate processing. * The current solution is to do: if (0) { eval("variable ZZZZ;"); } */ else if (!SLang_is_defined(name)) { if (0 == (value = (long) lang_make_object())) return; SLadd_name(name, value, LANG_GVARIABLE); } } static void interp_push_string(char *t) { int len; /* strings come in with the quotes attached-- knock em off */ if (*t == '"') { len = strlen(t) - 1; if (*(t + len) == '"') *(t + len) = 0; t++; } if (!Lang_Defining_Block && !Lang_Defining_Function) { SLang_push_string(t); return; } if (NULL == (Lang_Object_Ptr->b.s_blk = SLmake_string(t))) return; /* a literal --- not to be freed. * It would be nice if there were some way to avoid this for blocks outside * a function definition. Perhaps by setting this to LANG_DATA if not * defining a function is what I really want. */ Lang_Object_Ptr->type = LANG_LITERAL | (STRING_TYPE << 8); Lang_Object_Ptr++; } /* if an error occurs, discard current object, block, function, etc... */ void SLang_restart(int localv) { int save = SLang_Error; SLang_Error = UNKNOWN_ERROR; SLcompile_ptr = SLcompile; Lang_Break = Lang_Continue = Lang_Return = 0; while(Lang_Defining_Block) { lang_end_block(); } /* I need to free blocks on the interp stack even when not defining a * function. This is not done here--- future work. */ if (Lang_Defining_Function) { if (Lang_Function_Body != NULL) { lang_define_function(NULL); if (lang_free_branch(Lang_Function_Body)) FREE(Lang_Function_Body); } if (Local_Variable_Number) { FREE(Lang_Local_Variable_Table); Local_Variable_Number = 0; Lang_Local_Variable_Table = NULL; } Lang_Defining_Function = 0; } SLang_Error = save; /* --- warning--- I need to free things on the stack--- left to future! */ if (SLang_Error == STACK_OVERFLOW) SLStack_Pointer = SLRun_Stack; Lang_Interp_Stack = Lang_Object_Ptr = Lang_Interp_Stack_Ptr = Lang_Interp_Stack_Static; /* This should be handled automatically */ if (localv) Local_Variable_Frame = Local_Variable_Stack; Lang_Defining_Variables = 0; } #ifdef SL_BYTE_COMPILING static int try_byte_compiled(register unsigned char *s) { SLName_Table *nt; SLang_Name_Type *entry; register ofs; int n; if ((*s++ != '#') || ((n = (int) (*s++ - '0')) < 0)) { SLang_doerror("Illegal name."); return 1; } if (n == 0) { try_directive ((char *) s, &n); /* note that n is a dummy now */ return 1; } if (n == 1) { lang_try_binary((char *) s); return 1; } if (n == 2) { /* global or local, try it. */ if (Lang_Defining_Function == -1) return 0; return lang_exec ((char *) s, 0); } n -= 3; /* 3 digit base 26 number */ ofs = (*s++ - 'A'); ofs = 26 * ofs + (*s++ - 'A'); ofs = 26 * ofs + (*s++ - 'A'); nt = SLName_Table_Root; while (n--) { nt = nt->next; /* find the correct table */ if (nt == NULL) { SLang_doerror("Illegal name."); return 1; } } entry = &(nt->table[ofs]); /* table = Lang_Local_Variable_Table; */ Lang_Object_Ptr->type = entry->type; Lang_Object_Ptr->b.n_blk = entry; lang_try_now(); return 1; } #endif int SLPreprocess_Only = 0; char *SLbyte_compile_name(char *name) { static char code[36]; SLang_Name_Type *t; SLName_Table *nt; int ofs, n; if (SLPreprocess_Only || (*name == 0)) return name; if (slang_eqs_name(name, Lang_Directives)) { *code = '@'; code[1] = '#'; code[2] = '0'; strcpy (code + 3, name); return code; } if (slang_eqs_name(name, SL_Binary_Ops)) { *code = '@'; code[1] = '#'; code[2] = '1'; strcpy (code + 3, name); return code; } (void) compute_hash((unsigned char *) name); /* see if it is in local table */ t = Lang_Local_Variable_Table; if (t != NULL) { t = SLang_locate_name_in_table(name, t, t, Local_Variable_Number); } if ((t == NULL) || (t->name == 0)) { /* It must be global. Check intrinsics first */ nt = SLName_Table_Root; n = 3; while (nt != NULL) { t = nt->table; if ((ofs = nt->ofs[Hash]) != -1) { t = SLang_locate_name_in_table(name, t, t + ofs, nt->n); if ((t != NULL) && (*t->name != 0)) { ofs = (int) (t - nt->table); *code = '@'; *(code + 1) = '#'; *(code + 2) = n + '0'; *(code + 5) = (ofs % 26) + 'A'; ofs = ofs / 26; *(code + 4) = (ofs % 26) + 'A'; ofs = ofs / 26; *(code + 3) = (ofs % 26) + 'A'; *(code + 6) = 0; return code; } } nt = nt->next; n++; } /* Now try global */ t = SLang_locate_slang_name (name); if ((t == NULL) || (*t->name == 0)) return name; } *code = '@'; code [1] = '#'; code [2] = '2'; strcpy (code + 3, name); return code; } void SLcompile(char *t) { static int flag = 0; int d = 0; char ch = *t; if (ch == 0) return; lang_check_space(); /* make sure there is space for this */ if (!SLang_Error #ifdef SL_BYTE_COMPILING && (ch != '@') #endif && (ch != '"')) { if (ch == '{') { lang_begin_block(); d = 1; } else { /* The purpose of this convoluted mess is to flag errors such as '{block} statement' where 'statement' is not somthing like 'if', '!if', 'while', ... That is, something which is not supposed to follow a block. */ d = try_directive(t, &flag); if ((!flag && d) || (flag && !d)) SLang_Error = SYNTAX_ERROR; } flag = 0; } #ifdef SL_BYTE_COMPILING if (ch == '@') { flag = 0; d = 0; if (0 == try_byte_compiled((unsigned char *) (t + 1))) { /* failure ONLY for slang functions/variables. */ t += 3; ch = *t; } } #endif if ((ch == '@') || SLang_Error || d); /* null... */ else if (Lang_Defining_Variables) { if (ch == ']') Lang_Defining_Variables = 0; else SLadd_variable(t); } else if (Lang_Defining_Function == -1) lang_define_function(t); else if (ch == '"') interp_push_string(t); else if ((ch == ':') && (Lang_Defining_Block)) { Lang_Object_Ptr->type = LANG_LABEL; Lang_Object_Ptr->b.blk = NULL; Lang_Object_Ptr++; } else if ((ch == ')') && (Lang_Defining_Function == 1)) { if (Lang_Defining_Block) SLang_doerror("Function nesting illegal."); else Lang_Defining_Function = -1; } else if (ch == '{') { lang_begin_block(); flag = 0; } else if ((ch == '}') && Lang_Defining_Block) { lang_end_block(); flag = 1; } else if (ch == '(') lang_begin_function(); else if (ch == '[') Lang_Defining_Variables = 1; else if (lang_try_binary(t)); else if (lang_try_unary(t)); /* note that order here is important */ else if ((ch <= '9') && interp_push_number(t)); else if ((ch <= '=') && interp_variable_eqs(t)); else if (lang_exec(t, 1)); else { SLang_Error = UNDEFINED_NAME; } if (SLang_Error) { SLang_restart(0); flag = 0; } } int SLstack_depth() { return (int) (SLStack_Pointer - SLRun_Stack); } /* #define STRCHR(x, y) ((y >= 'a') && (y <= 'z') ? NULL : ((y) == 32) || strchr(x, y)) */ Lang_Name2_Type SL_Binary_Ops[] = { {"+", -LANG_PLUS}, {"-", -LANG_MINUS}, {"*", -LANG_TIMES}, {"/", -LANG_DIVIDE}, {"<", LANG_LT}, {"<=", LANG_LE}, {"==", LANG_EQ}, {">", LANG_GT}, {">=", LANG_GE}, {"!=", LANG_NE}, {"and", LANG_AND}, {"or", LANG_OR}, {"mod", LANG_MOD}, {"&", LANG_BAND}, {"shl", LANG_SHL}, {"shr", LANG_SHR}, {"xor", LANG_BXOR}, {"|", LANG_BOR}, {(char *) NULL, (int) NULL} }; static char Really_Stupid_Hash[256]; void SLstupid_hash() { register unsigned char *p; register Lang_Name2_Type *d; d = SL_Binary_Ops; while ((p = (unsigned char *) (d->name)) != NULL) { Really_Stupid_Hash[*(p + 1)] = 1; d++; } d = Lang_Directives; while ((p = (unsigned char *) (d->name)) != NULL) { Really_Stupid_Hash[*(p + 1)] = 1; d++; } } int slang_eqs_name(char *t, Lang_Name2_Type *d_parm) { register char *p; register char ch; register Lang_Name2_Type *d; ch = *t++; if (Really_Stupid_Hash[(unsigned char) *t] == 0) return(0); d = d_parm; while ((p = d->name) != NULL) { if ((ch == *p) && !strcmp(t, p + 1)) return(d->type); d++; } return(0); } void (*SLcompile_ptr)(char *) = SLcompile; int SLang_add_table(SLang_Name_Type *table, char *table_name) { register int i; SLang_Name_Type *t; SLName_Table *nt; int *ofs; unsigned char h; char *name; static init = 0; if (init == 0) { init = 1; for (i = 1; i < 256; i++) SLang_Name_Table_Ofs[i] = -1; SLang_Name_Table_Ofs[0] = 0; SLShort_Blocks[0].type = LANG_RETURN; SLShort_Blocks[1].type = LANG_BREAK; SLShort_Blocks[2].type = LANG_CONTINUE; } if ((nt = (SLName_Table *) MALLOC(sizeof(SLName_Table))) == NULL) return(0); nt->table = table; nt->next = SLName_Table_Root; strcpy(nt->name, table_name); SLName_Table_Root = nt; ofs = nt->ofs; for (i = 0; i < 256; i++) ofs[i] = -1; /* compute hash for table */ t = table; while (((name = t->name) != NULL) && (*name != 0)) { h = compute_hash((unsigned char *) (name + 1)); *name = (char) h; if (ofs[h] == -1) { ofs[h] = (int) (t - table); } t++; } nt->n = (int) (t - table); return(1); } extern char *SLang_extract_list_element(char *, int *, int *);