summaryrefslogtreecommitdiffstats
path: root/mdk-stage1/slang/slang.c
diff options
context:
space:
mode:
Diffstat (limited to 'mdk-stage1/slang/slang.c')
-rw-r--r--mdk-stage1/slang/slang.c5547
1 files changed, 0 insertions, 5547 deletions
diff --git a/mdk-stage1/slang/slang.c b/mdk-stage1/slang/slang.c
deleted file mode 100644
index 6edc7df37..000000000
--- a/mdk-stage1/slang/slang.c
+++ /dev/null
@@ -1,5547 +0,0 @@
-/* -*- mode: C; mode: fold; -*- */
-/* slang.c --- guts of S-Lang interpreter */
-/* Copyright (c) 1992, 1999, 2001 John E. Davis
- * This file is part of the S-Lang library.
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Perl Artistic License.
- */
-
-#include "slinclud.h"
-
-#if SLANG_HAS_FLOAT
-# include <math.h>
-#endif
-
-#include "slang.h"
-#include "_slang.h"
-
-#define USE_COMBINED_BYTECODES 0
-
-struct _SLBlock_Type;
-
-typedef struct
-{
- struct _SLBlock_Type *body;
- unsigned int num_refs;
-}
-_SLBlock_Header_Type;
-
-typedef struct
-{
- char *name;
- SLang_Name_Type *next;
- char name_type;
-
- union
- {
- _SLBlock_Header_Type *header; /* body of function */
- char *autoload_filename;
- }
- v;
-#if _SLANG_HAS_DEBUG_CODE
- char *file;
-#endif
-#define SLANG_MAX_LOCAL_VARIABLES 254
-#define AUTOLOAD_NUM_LOCALS (SLANG_MAX_LOCAL_VARIABLES + 1)
- unsigned char nlocals; /* number of local variables */
- unsigned char nargs; /* number of arguments */
-}
-_SLang_Function_Type;
-
-typedef struct
-{
- char *name;
- SLang_Name_Type *next;
- char name_type;
-
- SLang_Object_Type obj;
-}
-SLang_Global_Var_Type;
-
-typedef struct
-{
- char *name;
- SLang_Name_Type *next;
- char name_type;
-
- int local_var_number;
-}
-SLang_Local_Var_Type;
-
-typedef struct _SLBlock_Type
-{
- unsigned char bc_main_type;
- unsigned char bc_sub_type;
- union
- {
- struct _SLBlock_Type *blk;
- int i_blk;
-
- SLang_Name_Type *nt_blk;
- SLang_App_Unary_Type *nt_unary_blk;
- SLang_Intrin_Var_Type *nt_ivar_blk;
- SLang_Intrin_Fun_Type *nt_ifun_blk;
- SLang_Global_Var_Type *nt_gvar_blk;
- SLang_IConstant_Type *iconst_blk;
- SLang_DConstant_Type *dconst_blk;
- _SLang_Function_Type *nt_fun_blk;
-
- VOID_STAR ptr_blk;
- char *s_blk;
- SLang_BString_Type *bs_blk;
-
-#if SLANG_HAS_FLOAT
- double *double_blk; /*literal double is a pointer */
-#endif
- float float_blk;
- long l_blk;
- struct _SLang_Struct_Type *struct_blk;
- int (*call_function)(void);
- }
- b;
-}
-SLBlock_Type;
-
-/* Debugging and tracing variables */
-
-void (*SLang_Enter_Function)(char *) = NULL;
-void (*SLang_Exit_Function)(char *) = NULL;
-/* If non null, these call C functions before and after a slang function. */
-
-int _SLang_Trace = 0;
-/* If _SLang_Trace = -1, do not trace intrinsics */
-static int Trace_Mode = 0;
-
-static char *Trace_Function; /* function to be traced */
-int SLang_Traceback = 0;
-/* non zero means do traceback. If less than 0, do not show local variables */
-
-/* These variables handle _NARGS processing by the parser */
-int SLang_Num_Function_Args;
-static int *Num_Args_Stack;
-static unsigned int Recursion_Depth;
-static SLang_Object_Type *Frame_Pointer;
-static int Next_Function_Num_Args;
-static unsigned int Frame_Pointer_Depth;
-static unsigned int *Frame_Pointer_Stack;
-
-static int Lang_Break_Condition = 0;
-/* true if any one below is true. This keeps us from testing 3 variables.
- * I know this can be perfomed with a bitmapped variable, but...
- */
-static int Lang_Break = 0;
-static int Lang_Return = 0;
-/* static int Lang_Continue = 0; */
-
-SLang_Object_Type *_SLRun_Stack;
-SLang_Object_Type *_SLStack_Pointer;
-static SLang_Object_Type *_SLStack_Pointer_Max;
-
-/* Might want to increase this. */
-static SLang_Object_Type Local_Variable_Stack[SLANG_MAX_LOCAL_STACK];
-static SLang_Object_Type *Local_Variable_Frame = Local_Variable_Stack;
-
-static void free_function_header (_SLBlock_Header_Type *);
-
-void (*SLang_Dump_Routine)(char *);
-
-static void call_dump_routine (char *fmt, ...)
-{
- char buf[1024];
- va_list ap;
-
- va_start (ap, fmt);
- if (SLang_Dump_Routine != NULL)
- {
- (void) _SLvsnprintf (buf, sizeof (buf), fmt, ap);
- (*SLang_Dump_Routine) (buf);
- }
- else
- {
- vfprintf (stderr, fmt, ap);
- fflush (stderr);
- }
- va_end (ap);
-}
-
-static void do_traceback (char *, unsigned int, char *);
-static int init_interpreter (void);
-
-/*{{{ push/pop/etc stack manipulation functions */
-
-/* This routine is assumed to work even in the presence of a SLang_Error. */
-_INLINE_
-int SLang_pop (SLang_Object_Type *x)
-{
- register SLang_Object_Type *y;
-
- y = _SLStack_Pointer;
- if (y == _SLRun_Stack)
- {
- if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW;
- x->data_type = 0;
- return -1;
- }
- y--;
- *x = *y;
-
- _SLStack_Pointer = y;
- return 0;
-}
-
-static int pop_ctrl_integer (int *i)
-{
- int type;
- SLang_Class_Type *cl;
-#if _SLANG_OPTIMIZE_FOR_SPEED
- register SLang_Object_Type *y;
-
- /* Most of the time, either an integer or a char will be on the stack.
- * Optimize these cases.
- */
- y = _SLStack_Pointer;
- if (y == _SLRun_Stack)
- {
- if (SLang_Error == 0) SLang_Error = SL_STACK_UNDERFLOW;
- return -1;
- }
- y--;
-
- type = y->data_type;
- if (type == SLANG_INT_TYPE)
- {
- _SLStack_Pointer = y;
- *i = y->v.int_val;
- return 0;
- }
- if (type == SLANG_CHAR_TYPE)
- {
- _SLStack_Pointer = y;
- *i = y->v.char_val;
- return 0;
- }
-#else
- if (-1 == (type = SLang_peek_at_stack ()))
- return -1;
-#endif
-
- cl = _SLclass_get_class ((unsigned char) type);
- if (cl->cl_to_bool == NULL)
- {
- SLang_verror (SL_TYPE_MISMATCH,
- "%s cannot be used in a boolean context",
- cl->cl_name);
- return -1;# dmidecode 2.8 (=> Type: laptop) SMBIOS 2.3 present. 42 structures occupying 1071 bytes. Table at 0x000D8010. Handle 0x0000, DMI type 0, 20 bytes BIOS Information Vendor: Phoenix Version: V1.09 Release Date: 10/26/2004 Address: 0xE43C0 Runtime Size: 113728 bytes ROM Size: 512 kB Characteristics: ISA is supported PCI is supported PC Card (PCMCIA) is supported PNP is supported APM is supported BIOS is upgradeable BIOS shadowing is allowed ESCD support is available USB legacy is supported Smart battery is supported BIOS boot specification is supported Handle 0x0001, DMI type 1, 25 bytes System Information Manufacturer: Acer Product Name: Aspire 1520 Version: -1 Serial Number: LXA4105039449C1C47M000 UUID: 106CE0C0-449F-11D9-BF44-EAE28FE25B4B Wake-up Type: Power Switch Handle 0x0002, DMI type 2, 8 bytes Base Board Information Manufacturer: Acer Product Name: Aspire 1520 Version: Rev.A Serial Number: LXA4105039449C1C47M000 Handle 0x0003, DMI type 3, 17 bytes Chassis Information Manufacturer: N/A Type: Other Lock: Not Present Version: N/A Serial Number: None Asset Tag: Boot-up State: Safe Power Supply State: Safe Thermal State: Safe Security Status: None OEM Information: 0x00001234 Handle 0x0004, DMI type 4, 32 bytes Processor Information Socket Designation: Socket 754 Type: Central Processor Family: Athlon 64 Manufacturer: AMD ID: 4A 0F 00 00 FF FB 8B 07 Signature: Extended Family 0, Model 4, Stepping A Flags: FPU (Floating-point unit on-chip) VME (Virtual mode extension) DE (Debugging extension) PSE (Page size extension) TSC (Time stamp counter) MSR (Model specific registers) PAE (Physical address extension) MCE (Machine check exception) CX8 (CMPXCHG8 instruction supported) APIC (On-chip APIC hardware supported) SEP (Fast system call) MTRR (Memory type range registers) PGE (Page global enable) MCA (Machine check architecture) CMOV (Conditional move instruction supported) PAT (Page attribute table) PSE-36 (36-bit page size extension) CLFSH (CLFLUSH instruction supported) MMX (MMX technology supported) FXSR (Fast floating-point save and restore) SSE (Streaming SIMD extensions) SSE2 (Streaming SIMD extensions 2) Version: C0 Voltage: 3.3 V External Clock: 800 MHz Max Speed: 2500 MHz Current Speed: 2200 MHz Status: Populated, Enabled Upgrade: Socket 754 L1 Cache Handle: 0x0008 L2 Cache Handle: 0x0009 L3 Cache Handle: Not Provided Handle 0x0005, DMI type 5, 20 bytes Memory Controller Information Error Detecting Method: 64-bit ECC Error Correcting Capabilities: Other Supported Interleave: Two-way Interleave Current Interleave: Two-way Interleave Maximum Memory Module Size: 2048 MB Maximum Total Memory Size: 4096 MB Supported Speeds: 70 ns 60 ns Supported Memory Types: Standard DIMM SDRAM Memory Module Voltage: 3.3 V Associated Memory Slots: 2 0x0001 0x0002 Enabled Error Correcting Capabilities: None Handle 0x0006, DMI type 6, 12 bytes Memory Module Information Socket Designation: DIMM 1 Bank Connections: 0 1 Current Speed: 60 ns Type: DIMM SDRAM Installed Size: 1024 MB (Double-bank Connection) Enabled Size: 1024 MB (Double-bank Connection) Error Status: OK Handle 0x0007, DMI type 6, 12 bytes Memory Module Information Socket Designation: DIMM 2 Bank Connections: 2 3 Current Speed: 60 ns Type: DIMM SDRAM Installed Size: 256 MB (Double-bank Connection) Enabled Size: 256 MB (Double-bank Connection) Error Status: OK Handle 0x0008, DMI type 7, 19 bytes Cache Information Socket Designation: L1 Cache Configuration: Enabled, Socketed, Level 1 Operational Mode: Write Back Location: Internal Installed Size: 64 KB Maximum Size: 64 KB Supported SRAM Types: Burst Pipeline Burst Asynchronous Installed SRAM Type: Asynchronous Speed: Unknown Error Correction Type: Unknown System Type: Unknown Associativity: Unknown Handle 0x0009, DMI type 7, 19 bytes Cache Information Socket Designation: L2 Cache Configuration: Enabled, Socketed, Level 2 Operational Mode: Write Through Location: External Installed Size: 1024 KB Maximum Size: 1024 KB Supported SRAM Types: Burst Pipeline Burst Synchronous Installed SRAM Type: Synchronous Speed: Unknown Error Correction Type: Unknown System Type: Unknown Associativity: Unknown Handle 0x000A, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Primary IDE Internal Connector Type: On Board IDE External Reference Designator: Not Specified External Connector Type: None Port Type: Other Handle 0x000B, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Secondary IDE Internal Connector Type: On Board IDE External Reference Designator: Not Specified External Connector Type: None Port Type: Other Handle 0x000C, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: FLOPPY Internal Connector Type: On Board Floppy External Reference Designator: Not Specified External Connector Type: None Port Type: Other Handle 0x000D, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: COM1 External Connector Type: DB-9 male Port Type: Serial Port XT/AT Compatible Handle 0x000E, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: COM2 External Connector Type: DB-9 male Port Type: Serial Port XT/AT Compatible Handle 0x000F, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: Printer External Connector Type: DB-25 female Port Type: Parallel Port ECP/EPP Handle 0x0010, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: KBD External Connector Type: PS/2 Port Type: Keyboard Port Handle 0x0011, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: Mouse External Connector Type: PS/2 Port Type: Mouse Port Handle 0x0012, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: CD_IN Internal Connector Type: On Board Sound Input From CD-ROM External Reference Designator: Not Specified External Connector Type: None Port Type: Other Handle 0x0013, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: Game Port External Connector Type: DB-15 female Port Type: Joystick Port Handle 0x0014, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: MIC_IN External Connector Type: RJ-11 Port Type: MIDI Port Handle 0x0015, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: LINE_IN External Connector Type: RJ-11 Port Type: MIDI Port Handle 0x0016, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: Not Specified Internal Connector Type: None External Reference Designator: LINE_OUT External Connector Type: RJ-11 Port Type: MIDI Port Handle 0x0017, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: FC Internal Connector Type: Other External Reference Designator: Not Specified External Connector Type: None Port Type: MIDI Port Handle 0x0018, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: USB1 Internal Connector Type: Other External Reference Designator: Not Specified External Connector Type: None Port Type: USB Handle 0x0019, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: USB2 Internal Connector Type: Other External Reference Designator: Not Specified External Connector Type: None Port Type: USB Handle 0x001A, DMI type 8, 9 bytes Port Connector Information Internal Reference Designator: USB3 Internal Connector Type: Other External Reference Designator: Not Specified External Connector Type: None Port Type: USB Handle 0x001B, DMI type 9, 13 bytes System Slot Information Designation: PCI Slot 1 Type: 32-bit PCI Current Usage: Available Length: Long ID: 1 Characteristics: 5.0 V is provided PME signal is supported Handle 0x001C, DMI type 9, 13 bytes System Slot Information Designation: PCI Slot 2 Type: 32-bit PCI Current Usage: Available Length: Long ID: 2 Characteristics: 5.0 V is provided PME signal is supported Handle 0x001D, DMI type 9, 13 bytes System Slot Information Designation: PCI Slot 3 Type: 32-bit PCI Current Usage: In Use Length: Long ID: 3 Characteristics: 5.0 V is provided PME signal is supported Handle 0x001E, DMI type 9, 13 bytes System Slot Information Designation: PCI Slot 4 Type: 32-bit PCI Current Usage: In Use Length: Long ID: 3 Characteristics: 5.0 V is provided PME signal is supported Handle 0x001F, DMI type 10, 6 bytes On Board Device Information Type: Sound Status: Disabled Description: VIA 8235 Sound Handle 0x0020, DMI type 11, 5 bytes OEM Strings String 1: VIA String 2: www.via.com.tw String 3: w3.via.com.tw Handle 0x0021, DMI type 16, 15 bytes Physical Memory Array Location: System Board Or Motherboard Use: System Memory Error Correction Type: None Maximum Capacity: 4 GB Error Information Handle: Not Provided Number Of Devices: 2 Handle 0x0022, DMI type 17, 23 bytes Memory Device Array Handle: 0x0021 Error Information Handle: No Error Total Width: 32 bits Data Width: 32 bits Size: 1024 MB Form Factor: DIMM Set: 1 Locator: S1 Bank Locator: Bank 1 Type: DRAM Type Detail: Synchronous Speed: Unknown Handle 0x0023, DMI type 17, 23 bytes Memory Device Array Handle: 0x0021 Error Information Handle: No Error Total Width: 32 bits Data Width: 32 bits Size: 256 MB Form Factor: DIMM Set: 2 Locator: S2 Bank Locator: Bank 2 Type: DRAM Type Detail: Synchronous Speed: Unknown Handle 0x0024, DMI type 19, 15 bytes Memory Array Mapped Address Starting Address: 0x00000000000 Ending Address: 0x0004FFFFFFF Range Size: 1280 MB Physical Array Handle: 0x0021 Partition Width: 0 Handle 0x0025, DMI type 20, 19 bytes Memory Device Mapped Address Starting Address: 0x00000000000 Ending Address: 0x0003FFFFFFF Range Size: 1 GB Physical Device Handle: 0x0022 Memory Array Mapped Address Handle: 0x0001 Partition Row Position: 1 Handle 0x0026, DMI type 23, 13 bytes System Reset Status: Enabled Watchdog Timer: Present Boot Option: Do Not Reboot Boot Option On Limit: Do Not Reboot Reset Count: Unknown Reset Limit: Unknown Timer Interval: Unknown Timeout: Unknown Handle 0x0027, DMI type 24, 5 bytes Hardware Security Power-On Password Status: Disabled Keyboard Password Status: Unknown Administrator Password Status: Enabled Front Panel Reset Status: Unknown Handle 0x0028, DMI type 32, 20 bytes System Boot Information Status: <OUT OF SPEC> Handle 0x0029, DMI type 127, 4 bytes End Of Table
generated by cgit v1.2.1 (git 2.21.0) at 2024-07-13 01:11:18 +0000
ass='del'>-/*}}}*/
-
-/*{{{ inner interpreter and support functions */
-
-_INLINE_
-int _SL_increment_frame_pointer (void)
-{
- if (Recursion_Depth >= SLANG_MAX_RECURSIVE_DEPTH)
- {
- SLang_verror (SL_STACK_OVERFLOW, "Num Args Stack Overflow");
- return -1;
- }
- Num_Args_Stack [Recursion_Depth] = SLang_Num_Function_Args;
-
- SLang_Num_Function_Args = Next_Function_Num_Args;
- Next_Function_Num_Args = 0;
- Recursion_Depth++;
- return 0;
-}
-
-_INLINE_
-int _SL_decrement_frame_pointer (void)
-{
- if (Recursion_Depth == 0)
- {
- SLang_verror (SL_STACK_UNDERFLOW, "Num Args Stack Underflow");
- return -1;
- }
-
- Recursion_Depth--;
- if (Recursion_Depth < SLANG_MAX_RECURSIVE_DEPTH)
- SLang_Num_Function_Args = Num_Args_Stack [Recursion_Depth];
-
- return 0;
-}
-
-_INLINE_
-int SLang_start_arg_list (void)
-{
- if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH)
- {
- Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - _SLRun_Stack);
- Frame_Pointer = _SLStack_Pointer;
- Frame_Pointer_Depth++;
- Next_Function_Num_Args = 0;
- return 0;
- }
-
- SLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow");
- return -1;
-}
-
-_INLINE_
-int SLang_end_arg_list (void)
-{
- if (Frame_Pointer_Depth == 0)
- {
- SLang_verror (SL_STACK_UNDERFLOW, "Frame Stack Underflow");
- return -1;
- }
- Frame_Pointer_Depth--;
- if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH)
- {
- Next_Function_Num_Args = (int) (_SLStack_Pointer - Frame_Pointer);
- Frame_Pointer = _SLRun_Stack + Frame_Pointer_Stack [Frame_Pointer_Depth];
- }
- return 0;
-}
-
-_INLINE_
-static int do_bc_call_direct_frame (int (*f)(void))
-{
- if ((0 == SLang_end_arg_list ())
- && (0 == _SL_increment_frame_pointer ()))
- {
- (void) (*f) ();
- _SL_decrement_frame_pointer ();
- }
- if (SLang_Error)
- return -1;
- return 0;
-}
-
-static int do_name_type_error (SLang_Name_Type *nt)
-{
- char buf[256];
- if (nt != NULL)
- {
- (void) _SLsnprintf (buf, sizeof (buf), "(Error occurred processing %s)", nt->name);
- do_traceback (buf, 0, NULL);
- }
- return -1;
-}
-
-/* local and global variable assignments */
-
-static int do_binary_ab (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
-{
- SLang_Class_Type *a_cl, *b_cl, *c_cl;
- unsigned char b_data_type, a_data_type, c_data_type;
- int (*binary_fun) (int,
- unsigned char, VOID_STAR, unsigned int,
- unsigned char, VOID_STAR, unsigned int,
- VOID_STAR);
- VOID_STAR pa;
- VOID_STAR pb;
- VOID_STAR pc;
- int ret;
-
- b_data_type = objb->data_type;
- a_data_type = obja->data_type;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (_SLarith_Is_Arith_Type[a_data_type]
- && _SLarith_Is_Arith_Type[b_data_type])
- {
- int status;
- status = _SLarith_bin_op (obja, objb, op);
- if (status != 1)
- return status;
- /* drop and try it the hard way */
- }
-#endif
-
- a_cl = _SLclass_get_class (a_data_type);
- if (a_data_type == b_data_type)
- b_cl = a_cl;
- else
- b_cl = _SLclass_get_class (b_data_type);
-
- if (NULL == (binary_fun = _SLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1)))
- return -1;
-
- c_data_type = c_cl->cl_data_type;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [a_data_type])
- pa = (VOID_STAR) &obja->v;
- else
-#endif
- pa = _SLclass_get_ptr_to_value (a_cl, obja);
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [b_data_type])
- pb = (VOID_STAR) &objb->v;
- else
-#endif
- pb = _SLclass_get_ptr_to_value (b_cl, objb);
-
- pc = c_cl->cl_transfer_buf;
-
- if (1 != (*binary_fun) (op,
- a_data_type, pa, 1,
- b_data_type, pb, 1,
- pc))
- {
- SLang_verror (SL_NOT_IMPLEMENTED,
- "Binary operation between %s and %s failed",
- a_cl->cl_name, b_cl->cl_name);
-
- return -1;
- }
-
- /* apush will create a copy, so make sure we free after the push */
- ret = (*c_cl->cl_apush)(c_data_type, pc);
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [c_data_type])
-#endif
- (*c_cl->cl_adestroy)(c_data_type, pc);
-
- return ret;
-}
-
-_INLINE_
-static void do_binary (int op)
-{
- SLang_Object_Type obja, objb;
-
- if (SLang_pop (&objb)) return;
- if (0 == SLang_pop (&obja))
- {
- (void) do_binary_ab (op, &obja, &objb);
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obja.data_type])
-#endif
- SLang_free_object (&obja);
- }
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type])
-#endif
- SLang_free_object (&objb);
-}
-
-static int do_unary_op (int op, SLang_Object_Type *obj, int unary_type)
-{
- int (*f) (int, unsigned char, VOID_STAR, unsigned int, VOID_STAR);
- VOID_STAR pa;
- VOID_STAR pb;
- SLang_Class_Type *a_cl, *b_cl;
- unsigned char a_type, b_type;
- int ret;
-
- a_type = obj->data_type;
- a_cl = _SLclass_get_class (a_type);
-
- if (NULL == (f = _SLclass_get_unary_fun (op, a_cl, &b_cl, unary_type)))
- return -1;
-
- b_type = b_cl->cl_data_type;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type [a_type])
- pa = (VOID_STAR) &obj->v;
- else
-#endif
- pa = _SLclass_get_ptr_to_value (a_cl, obj);
-
- pb = b_cl->cl_transfer_buf;
-
- if (1 != (*f) (op, a_type, pa, 1, pb))
- {
- SLang_verror (SL_NOT_IMPLEMENTED,
- "Unary operation for %s failed", a_cl->cl_name);
- return -1;
- }
-
- ret = (*b_cl->cl_apush)(b_type, pb);
- /* cl_apush creates a copy, so make sure we call cl_adestroy */
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [b_type])
-#endif
- (*b_cl->cl_adestroy)(b_type, pb);
-
- return ret;
-}
-
-_INLINE_
-static int do_unary (int op, int unary_type)
-{
- SLang_Object_Type obj;
- int ret;
-
- if (-1 == SLang_pop (&obj)) return -1;
- ret = do_unary_op (op, &obj, unary_type);
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obj.data_type])
-#endif
- SLang_free_object (&obj);
- return ret;
-}
-
-static int do_assignment_binary (int op, SLang_Object_Type *obja_ptr)
-{
- SLang_Object_Type objb;
- int ret;
-
- if (SLang_pop (&objb))
- return -1;
-
- ret = do_binary_ab (op, obja_ptr, &objb);
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [objb.data_type])
-#endif
- SLang_free_object (&objb);
- return ret;
-}
-
-/* The order of these is assumed to match the binary operators
- * defined in slang.h
- */
-static int
-map_assignment_op_to_binary (unsigned char op_type, int *op, int *is_unary)
-{
- *is_unary = 0;
- switch (op_type)
- {
- case _SLANG_BCST_PLUSEQS:
- case _SLANG_BCST_MINUSEQS:
- case _SLANG_BCST_TIMESEQS:
- case _SLANG_BCST_DIVEQS:
- *op = SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS);
- break;
-
- case _SLANG_BCST_BOREQS:
- *op = SLANG_BOR;
- break;
-
- case _SLANG_BCST_BANDEQS:
- *op = SLANG_BAND;
- break;
-
- case _SLANG_BCST_POST_MINUSMINUS:
- case _SLANG_BCST_MINUSMINUS:
- *op = SLANG_MINUS;
- *is_unary = 1;
- break;
-
- case _SLANG_BCST_PLUSPLUS:
- case _SLANG_BCST_POST_PLUSPLUS:
- *op = SLANG_PLUS;
- *is_unary = 1;
- break;
-
- default:
- SLang_verror (SL_NOT_IMPLEMENTED, "Assignment operator not implemented");
- return -1;
- }
- return 0;
-}
-
-static int
-perform_lvalue_operation (unsigned char op_type, SLang_Object_Type *obja_ptr)
-{
- switch (op_type)
- {
- case _SLANG_BCST_ASSIGN:
- break;
-
- /* The order of these is assumed to match the binary operators
- * defined in slang.h
- */
- case _SLANG_BCST_PLUSEQS:
- case _SLANG_BCST_MINUSEQS:
- case _SLANG_BCST_TIMESEQS:
- case _SLANG_BCST_DIVEQS:
- if (-1 == do_assignment_binary (SLANG_PLUS + (op_type - _SLANG_BCST_PLUSEQS), obja_ptr))
- return -1;
- break;
-
- case _SLANG_BCST_BOREQS:
- if (-1 == do_assignment_binary (SLANG_BOR, obja_ptr))
- return -1;
- break;
-
- case _SLANG_BCST_BANDEQS:
- if (-1 == do_assignment_binary (SLANG_BAND, obja_ptr))
- return -1;
- break;
-
- case _SLANG_BCST_PLUSPLUS:
- case _SLANG_BCST_POST_PLUSPLUS:
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (obja_ptr->data_type == SLANG_INT_TYPE)
- return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val + 1);
-#endif
- if (-1 == do_unary_op (SLANG_PLUSPLUS, obja_ptr, _SLANG_BC_UNARY))
- return -1;
- break;
-
- case _SLANG_BCST_MINUSMINUS:
- case _SLANG_BCST_POST_MINUSMINUS:
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (obja_ptr->data_type == SLANG_INT_TYPE)
- return SLclass_push_int_obj (SLANG_INT_TYPE, obja_ptr->v.int_val - 1);
-#endif
- if (-1 == do_unary_op (SLANG_MINUSMINUS, obja_ptr, _SLANG_BC_UNARY))
- return -1;
- break;
-
- default:
- SLang_Error = SL_INTERNAL_ERROR;
- return -1;
- }
- return 0;
-}
-
-_INLINE_
-static int
-set_lvalue_obj (unsigned char op_type, SLang_Object_Type *obja_ptr)
-{
- if (op_type != _SLANG_BCST_ASSIGN)
- {
- if (-1 == perform_lvalue_operation (op_type, obja_ptr))
- return -1;
- }
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [obja_ptr->data_type])
-#endif
- SLang_free_object (obja_ptr);
-
- return SLang_pop(obja_ptr);
-}
-
-static int
-set_struct_lvalue (SLBlock_Type *bc_blk)
-{
- int type;
- SLang_Class_Type *cl;
- char *name;
- int op;
-
- if (-1 == (type = SLang_peek_at_stack ()))
- return -1;
-
- cl = _SLclass_get_class (type);
- if ((cl->cl_sput == NULL)
- || (cl->cl_sget == NULL))
- {
- SLang_verror (SL_NOT_IMPLEMENTED,
- "%s does not support structure access",
- cl->cl_name);
- SLdo_pop_n (2); /* object plus what was to be assigned */
- return -1;
- }
- name = bc_blk->b.s_blk;
- op = bc_blk->bc_sub_type;
-
- if (op != _SLANG_BCST_ASSIGN)
- {
- /* We have something like (A.x += b) or (A.x++). In either case,
- * we need A.x.
- */
- SLang_Object_Type obj_A;
- SLang_Object_Type obj;
-
- if (-1 == SLang_pop (&obj_A))
- return -1;
-
- if ((-1 == _SLpush_slang_obj (&obj_A))
- || (-1 == cl->cl_sget ((unsigned char) type, name))
- || (-1 == SLang_pop (&obj)))
- {
- SLang_free_object (&obj_A);
- return -1;
- }
- /* Now the value of A.x is in obj. */
- if (-1 == perform_lvalue_operation (op, &obj))
- {
- SLang_free_object (&obj);
- SLang_free_object (&obj_A);
- return -1;
- }
- SLang_free_object (&obj);
- /* The result of the operation is now on the stack.
- * Perform assignment */
- if (-1 == SLang_push (&obj_A))
- {
- SLang_free_object (&obj_A);
- return -1;
- }
- }
-
- return (*cl->cl_sput) ((unsigned char) type, name);
-}
-
-static int make_unit_object (SLang_Object_Type *a, SLang_Object_Type *u)
-{
- unsigned char type;
-
- type = a->data_type;
- if (type == SLANG_ARRAY_TYPE)
- type = a->v.array_val->data_type;
-
- u->data_type = type;
- switch (type)
- {
- case SLANG_UCHAR_TYPE:
- case SLANG_CHAR_TYPE:
- u->v.char_val = 1;
- break;
-
- case SLANG_SHORT_TYPE:
- case SLANG_USHORT_TYPE:
- u->v.short_val = 1;
- break;
-
- case SLANG_LONG_TYPE:
- case SLANG_ULONG_TYPE:
- u->v.long_val = 1;
- break;
-
-#if SLANG_HAS_FLOAT
- case SLANG_FLOAT_TYPE:
- u->v.float_val = 1;
- break;
-
- case SLANG_COMPLEX_TYPE:
- u->data_type = SLANG_DOUBLE_TYPE;
- case SLANG_DOUBLE_TYPE:
- u->v.double_val = 1;
- break;
-#endif
- default:
- u->data_type = SLANG_INT_TYPE;
- u->v.int_val = 1;
- }
- return 0;
-}
-
-
-/* We want to convert 'A[i] op X' to 'A[i] = A[i] op X'. The code that
- * has been generated is: X __args i A __aput-op
- * where __aput-op represents this function. We need to generate:
- * __args i A __eargs __aget X op __args i A __eargs __aput
- * Here, __eargs implies a call to do_bc_call_direct_frame with either
- * the aput or aget function. In addition, __args represents a call to
- * SLang_start_arg_list. Of course, i represents a set of indices.
- *
- * Note: If op is an unary operation (e.g., ++ or --), then X will not
- * b present an will have to be taken to be 1.
- *
- * Implementation note: For efficiency, calls to setup the frame, start
- * arg list will be omitted and SLang_Num_Function_Args will be set.
- * This is ugly but the alternative is much less efficient rendering these
- * assignment operators useless. So, the plan is to roll the stack to get X,
- * then duplicate the next N values, call __aget followed by op X, finally
- * calling __aput. Hence, the sequence is:
- *
- * start: X i .. j A
- * dupN: X i .. j A i .. j A
- * __aget: X i .. j A Y
- * roll: i .. j A Y X
- * op: i .. j A Z
- * roll: Z i .. j A
- * __aput:
- */
-static int
-set_array_lvalue (int op)
-{
- SLang_Object_Type x, y;
- int num_args, is_unary;
-
- if (-1 == map_assignment_op_to_binary (op, &op, &is_unary))
- return -1;
-
- /* Grab the indices and the array. Do not start a new frame. */
- if (-1 == SLang_end_arg_list ())
- return -1;
- num_args = Next_Function_Num_Args;
- Next_Function_Num_Args = 0;
-
- if (-1 == SLdup_n (num_args))
- return -1;
-
- SLang_Num_Function_Args = num_args;
- if (-1 == _SLarray_aget ())
- return -1;
-
- if (-1 == SLang_pop (&y))
- return -1;
-
- if (is_unary == 0)
- {
- if ((-1 == SLroll_stack (-(num_args + 1)))
- || (-1 == SLang_pop (&x)))
- {
- SLang_free_object (&y);
- return -1;
- }
- }
- else if (-1 == make_unit_object (&y, &x))
- {
- SLang_free_object (&y);
- return -1;
- }
-
- if (-1 == do_binary_ab (op, &y, &x))
- {
- SLang_free_object (&y);
- SLang_free_object (&x);
- return -1;
- }
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [y.data_type])
-#endif
- SLang_free_object (&y);
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [x.data_type])
-#endif
- SLang_free_object (&x);
-
- if (-1 == SLroll_stack (num_args + 1))
- return -1;
-
- SLang_Num_Function_Args = num_args;
- return _SLarray_aput ();
-}
-
-
-static int
-set_intrin_lvalue (SLBlock_Type *bc_blk)
-{
- unsigned char op_type;
- SLang_Object_Type obja;
- SLang_Class_Type *cl;
- SLang_Intrin_Var_Type *ivar;
- VOID_STAR intrinsic_addr;
- unsigned char intrinsic_type;
-
- ivar = bc_blk->b.nt_ivar_blk;
-
- intrinsic_type = ivar->type;
- intrinsic_addr = ivar->addr;
-
- op_type = bc_blk->bc_sub_type;
-
- cl = _SLclass_get_class (intrinsic_type);
-
- if (op_type != _SLANG_BCST_ASSIGN)
- {
- /* We want to get the current value into obja. This is the
- * easiest way.
- */
- if ((-1 == (*cl->cl_push) (intrinsic_type, intrinsic_addr))
- || (-1 == SLang_pop (&obja)))
- return -1;
-
- (void) perform_lvalue_operation (op_type, &obja);
- SLang_free_object (&obja);
-
- if (SLang_Error)
- return -1;
- }
-
- return (*cl->cl_pop) (intrinsic_type, intrinsic_addr);
-}
-
-int _SLang_deref_assign (SLang_Ref_Type *ref)
-{
- SLang_Object_Type *objp;
- SLang_Name_Type *nt;
- SLBlock_Type blk;
-
- if (ref->is_global == 0)
- {
- objp = ref->v.local_obj;
- if (objp > Local_Variable_Frame)
- {
- SLang_verror (SL_UNDEFINED_NAME, "Local variable reference is out of scope");
- return -1;
- }
- return set_lvalue_obj (_SLANG_BCST_ASSIGN, objp);
- }
-
- nt = ref->v.nt;
- switch (nt->name_type)
- {
- case SLANG_GVARIABLE:
- case SLANG_PVARIABLE:
- if (-1 == set_lvalue_obj (_SLANG_BCST_ASSIGN,
- &((SLang_Global_Var_Type *)nt)->obj))
- {
- do_name_type_error (nt);
- return -1;
- }
- break;
-
- case SLANG_IVARIABLE:
- blk.b.nt_blk = nt;
- blk.bc_sub_type = _SLANG_BCST_ASSIGN;
- if (-1 == set_intrin_lvalue (&blk))
- {
- do_name_type_error (nt);
- return -1;
- }
- break;
-
- case SLANG_LVARIABLE:
- SLang_Error = SL_INTERNAL_ERROR;
- /* set_intrin_lvalue (&blk); */
- return -1;
-
- case SLANG_RVARIABLE:
- default:
- SLang_verror (SL_READONLY_ERROR, "deref assignment to %s not allowed", nt->name);
- return -1;
- }
-
- return 0;
-}
-
-static void set_deref_lvalue (SLBlock_Type *bc_blk)
-{
- SLang_Object_Type *objp;
- SLang_Ref_Type *ref;
-
- switch (bc_blk->bc_sub_type)
- {
- case SLANG_LVARIABLE:
- objp = (Local_Variable_Frame - bc_blk->b.i_blk);
- break;
- case SLANG_GVARIABLE:
- case SLANG_PVARIABLE:
- objp = &bc_blk->b.nt_gvar_blk->obj;
- break;
- default:
- SLang_Error = SL_INTERNAL_ERROR;
- return;
- }
-
- if (-1 == _SLpush_slang_obj (objp))
- return;
-
- if (-1 == SLang_pop_ref (&ref))
- return;
- (void) _SLang_deref_assign (ref);
- SLang_free_ref (ref);
-}
-
-static int push_struct_field (char *name)
-{
- int type;
- SLang_Class_Type *cl;
-
- if (-1 == (type = SLang_peek_at_stack ()))
- return -1;
-
- cl = _SLclass_get_class ((unsigned char) type);
- if (cl->cl_sget == NULL)
- {
- SLang_verror (SL_NOT_IMPLEMENTED,
- "%s does not permit structure access",
- cl->cl_name);
- SLdo_pop_n (2);
- return -1;
- }
-
- return (*cl->cl_sget) ((unsigned char) type, name);
-}
-
-static void trace_dump (char *format, char *name, SLang_Object_Type *objs, int n, int dir)
-{
- unsigned int len;
- char prefix [52];
-
- len = Trace_Mode - 1;
- if (len + 2 >= sizeof (prefix))
- len = sizeof (prefix) - 2;
-
- SLMEMSET (prefix, ' ', len);
- prefix[len] = 0;
-
- call_dump_routine (prefix);
- call_dump_routine (format, name, n);
-
- if (n > 0)
- {
- prefix[len] = ' ';
- len++;
- prefix[len] = 0;
-
- _SLdump_objects (prefix, objs, n, dir);
- }
-}
-
-/* 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.
- */
-static VOID_STAR pop_pointer (SLang_Object_Type *obj, unsigned char type)
-{
-#ifndef _SLANG_OPTIMIZE_FOR_SPEED
- SLang_Class_Type *cl;
-#endif
-
- SLang_Array_Type *at;
-
- /* Arrays are special. Allow scalars to automatically convert to arrays.
- */
- if (type == SLANG_ARRAY_TYPE)
- {
- if (-1 == SLang_pop_array (&at, 1))
- return NULL;
- obj->data_type = SLANG_ARRAY_TYPE;
- return obj->v.ptr_val = (VOID_STAR) at;
- }
-
- if (type == 0)
- {
- /* This happens when an intrinsic is declared without any information
- * regarding parameter types.
- */
- if (-1 == SLang_pop (obj))
- return NULL;
- type = obj->data_type;
- }
- else if (-1 == _SLang_pop_object_of_type (type, obj, 0))
- return NULL;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- type = _SLclass_Class_Type [type];
-#else
- type = _SLclass_get_class (type)->cl_class_type;
-#endif
-
- if (type == SLANG_CLASS_TYPE_SCALAR)
- return (VOID_STAR) &obj->v;
- else if (type == SLANG_CLASS_TYPE_MMT)
- return SLang_object_from_mmt (obj->v.ref);
- else
- return obj->v.ptr_val;
-}
-
-/* This is ugly. Does anyone have a advice for a cleaner way of doing
- * this??
- */
-typedef void (*VF0_Type)(void);
-typedef void (*VF1_Type)(VOID_STAR);
-typedef void (*VF2_Type)(VOID_STAR, VOID_STAR);
-typedef void (*VF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
-typedef void (*VF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef void (*VF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef void (*VF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef void (*VF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef long (*LF0_Type)(void);
-typedef long (*LF1_Type)(VOID_STAR);
-typedef long (*LF2_Type)(VOID_STAR, VOID_STAR);
-typedef long (*LF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
-typedef long (*LF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef long (*LF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef long (*LF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef long (*LF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-#if SLANG_HAS_FLOAT
-typedef double (*FF0_Type)(void);
-typedef double (*FF1_Type)(VOID_STAR);
-typedef double (*FF2_Type)(VOID_STAR, VOID_STAR);
-typedef double (*FF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
-typedef double (*FF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef double (*FF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef double (*FF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-typedef double (*FF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
-#endif
-
-static int execute_intrinsic_fun (SLang_Intrin_Fun_Type *objf)
-{
-#if SLANG_HAS_FLOAT
- double xf;
-#endif
- VOID_STAR p[SLANG_MAX_INTRIN_ARGS];
- SLang_Object_Type objs[SLANG_MAX_INTRIN_ARGS];
- long ret;
- unsigned char type;
- unsigned int argc;
- unsigned int i;
- FVOID_STAR fptr;
- unsigned char *arg_types;
- int stk_depth;
-
- fptr = objf->i_fun;
- argc = objf->num_args;
- type = objf->return_type;
- arg_types = objf->arg_types;
-
- if (argc > SLANG_MAX_INTRIN_ARGS)
- {
- SLang_verror(SL_APPLICATION_ERROR,
- "Intrinsic function %s requires too many parameters", objf->name);
- return -1;
- }
-
- if (-1 == _SL_increment_frame_pointer ())
- return -1;
-
- stk_depth = -1;
- if (Trace_Mode && (_SLang_Trace > 0))
- {
- int nargs;
-
- stk_depth = _SLstack_depth ();
-
- nargs = SLang_Num_Function_Args;
- if (nargs == 0)
- nargs = (int)argc;
-
- stk_depth -= nargs;
-
- if (stk_depth >= 0)
- trace_dump (">>%s (%d args)\n",
- objf->name,
- _SLStack_Pointer - nargs,
- nargs,
- 1);
- }
-
- i = argc;
- while (i != 0)
- {
- i--;
- if (NULL == (p[i] = pop_pointer (objs + i, arg_types[i])))
- {
- i++;
- goto free_and_return;
- }
- }
-
- ret = 0;
-#if SLANG_HAS_FLOAT
- xf = 0.0;
-#endif
-
- switch (argc)
- {
- case 0:
- if (type == SLANG_VOID_TYPE) ((VF0_Type) fptr) ();
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF0_Type) fptr)();
-#endif
- else ret = ((LF0_Type) fptr)();
- break;
-
- case 1:
- if (type == SLANG_VOID_TYPE) ((VF1_Type) fptr)(p[0]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF1_Type) fptr)(p[0]);
-#endif
- else ret = ((LF1_Type) fptr)(p[0]);
- break;
-
- case 2:
- if (type == SLANG_VOID_TYPE) ((VF2_Type) fptr)(p[0], p[1]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF2_Type) fptr)(p[0], p[1]);
-#endif
- else ret = ((LF2_Type) fptr)(p[0], p[1]);
- break;
-
- case 3:
- if (type == SLANG_VOID_TYPE) ((VF3_Type) fptr)(p[0], p[1], p[2]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF3_Type) fptr)(p[0], p[1], p[2]);
-#endif
- else ret = ((LF3_Type) fptr)(p[0], p[1], p[2]);
- break;
-
- case 4:
- if (type == SLANG_VOID_TYPE) ((VF4_Type) fptr)(p[0], p[1], p[2], p[3]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF4_Type) fptr)(p[0], p[1], p[2], p[3]);
-#endif
- else ret = ((LF4_Type) fptr)(p[0], p[1], p[2], p[3]);
- break;
-
- case 5:
- if (type == SLANG_VOID_TYPE) ((VF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
-#endif
- else ret = ((LF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
- break;
-
- case 6:
- if (type == SLANG_VOID_TYPE) ((VF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
-#endif
- else ret = ((LF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
- break;
-
- case 7:
- if (type == SLANG_VOID_TYPE) ((VF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
-#if SLANG_HAS_FLOAT
- else if (type == SLANG_DOUBLE_TYPE) xf = ((FF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
-#endif
- else ret = ((LF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
- break;
- }
-
- switch (type)
- {
- case SLANG_VOID_TYPE:
- break;
-
-#if SLANG_HAS_FLOAT
- case SLANG_DOUBLE_TYPE:
- (void) SLang_push_double (xf);
- break;
-#endif
- case SLANG_UINT_TYPE:
- case SLANG_INT_TYPE: (void) SLclass_push_int_obj (type, (int) ret);
- break;
-
- case SLANG_CHAR_TYPE:
- case SLANG_UCHAR_TYPE: (void) SLclass_push_char_obj (type, (char) ret);
- break;
-
- case SLANG_SHORT_TYPE:
- case SLANG_USHORT_TYPE: (void) SLclass_push_short_obj (type, (short) ret);
- break;
-
- case SLANG_LONG_TYPE:
- case SLANG_ULONG_TYPE: (void) SLclass_push_long_obj (type, ret);
- break;
-
- case SLANG_STRING_TYPE:
- if (NULL == (char *)ret)
- {
- if (SLang_Error == 0) SLang_Error = SL_INTRINSIC_ERROR;
- }
- else (void) SLang_push_string ((char *)ret);
- break;
-
- default:
- SLang_verror (SL_NOT_IMPLEMENTED,
- "Support for intrinsic functions returning %s is not provided",
- SLclass_get_datatype_name (type));
- }
-
- if (stk_depth >= 0)
- {
- stk_depth = _SLstack_depth () - stk_depth;
-
- trace_dump ("<<%s (returning %d values)\n",
- objf->name,
- _SLStack_Pointer - stk_depth,
- stk_depth,
- 1);
- }
-
- free_and_return:
- while (i < argc)
- {
- SLang_free_object (objs + i);
- i++;
- }
-
- return _SL_decrement_frame_pointer ();
-}
-
-static int inner_interp(register SLBlock_Type *);
-
-/* Switch_Obj_Ptr points to the NEXT available free switch object */
-static SLang_Object_Type Switch_Objects[SLANG_MAX_NESTED_SWITCH];
-static SLang_Object_Type *Switch_Obj_Ptr = Switch_Objects;
-static SLang_Object_Type *Switch_Obj_Max = Switch_Objects + SLANG_MAX_NESTED_SWITCH;
-
-static void
-lang_do_loops (unsigned char stype, SLBlock_Type *block, unsigned int num_blocks)
-{
- int i, ctrl;
- int first, last;
- SLBlock_Type *blks[4];
- char *loop_name;
- SLang_Foreach_Context_Type *foreach_context;
- SLang_Class_Type *cl;
- int type;
- unsigned int j;
-
- j = 0;
- for (i = 0; i < (int) num_blocks; i++)
- {
- if (block[i].bc_main_type != _SLANG_BC_BLOCK)
- {
- if (block[i].bc_main_type == _SLANG_BC_LINE_NUM)
- continue;
-
- SLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block");
- return;
- }
- blks[j] = block[i].b.blk;
- j++;
- }
-
- num_blocks = j;
- block = blks[0];
-
- switch (stype)
- {
- case _SLANG_BCST_FOREACH:
- loop_name = "foreach";
- if (num_blocks != 1)
- goto wrong_num_blocks_error;
-
- /* We should find Next_Function_Num_Args + 1 items on the stack.
- * The first Next_Function_Num_Args items represent the arguments to
- * to USING. The last item (deepest in stack) is the object to loop
- * over. So, roll the stack up and grab it.
- */
- if ((-1 == SLroll_stack (-(Next_Function_Num_Args + 1)))
- || (-1 == (type = SLang_peek_at_stack ())))
- goto return_error;
-
- cl = _SLclass_get_class ((unsigned char) type);
- if ((cl->cl_foreach == NULL)
- || (cl->cl_foreach_open == NULL)
- || (cl->cl_foreach_close == NULL))
- {
- SLang_verror (SL_NOT_IMPLEMENTED, "%s does not permit foreach", cl->cl_name);
- SLdo_pop_n (Next_Function_Num_Args + 1);
- goto return_error;
- }
-
- if (NULL == (foreach_context = (*cl->cl_foreach_open) ((unsigned char)type, Next_Function_Num_Args)))
- goto return_error;
-
- while (1)
- {
- int status;
-
- if (SLang_Error)
- {
- (*cl->cl_foreach_close) ((unsigned char) type, foreach_context);
- goto return_error;
- }
-
- status = (*cl->cl_foreach) ((unsigned char) type, foreach_context);
- if (status <= 0)
- {
- if (status == 0)
- break;
-
- (*cl->cl_foreach_close) ((unsigned char) type, foreach_context);
- goto return_error;
- }
-
- inner_interp (block);
- if (Lang_Break) break;
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- }
- (*cl->cl_foreach_close) ((unsigned char) type, foreach_context);
- break;
-
- case _SLANG_BCST_WHILE:
- loop_name = "while";
-
- if (num_blocks != 2)
- goto wrong_num_blocks_error;
-
- type = blks[1]->bc_main_type;
- while (1)
- {
- if (SLang_Error)
- goto return_error;
-
- inner_interp (block);
- if (Lang_Break) break;
-
- if (-1 == pop_ctrl_integer (&ctrl))
- goto return_error;
-
- if (ctrl == 0) break;
-
- if (type)
- {
- inner_interp (blks[1]);
- if (Lang_Break) break;
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- }
- }
- break;
-
- case _SLANG_BCST_DOWHILE:
- loop_name = "do...while";
-
- if (num_blocks != 2)
- goto wrong_num_blocks_error;
-
- while (1)
- {
- if (SLang_Error)
- goto return_error;
-
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- inner_interp (block);
- if (Lang_Break) break;
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- inner_interp (blks[1]);
- if (-1 == pop_ctrl_integer (&ctrl))
- goto return_error;
-
- if (ctrl == 0) break;
- }
- break;
-
- case _SLANG_BCST_CFOR:
- loop_name = "for";
-
- /* we need 4 blocks: first 3 control, the last is code */
- if (num_blocks != 4) goto wrong_num_blocks_error;
-
- inner_interp (block);
- while (1)
- {
- if (SLang_Error)
- goto return_error;
-
- inner_interp(blks[1]); /* test */
- if (-1 == pop_ctrl_integer (&ctrl))
- goto return_error;
-
- if (ctrl == 0) break;
- inner_interp(blks[3]); /* code */
- if (Lang_Break) break;
- inner_interp(blks[2]); /* bump */
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- }
- break;
-
- case _SLANG_BCST_FOR:
- loop_name = "_for";
-
- if (num_blocks != 1)
- goto wrong_num_blocks_error;
-
- /* 3 elements: first, last, step */
- if ((-1 == SLang_pop_integer (&ctrl))
- || (-1 == SLang_pop_integer (&last))
- || (-1 == SLang_pop_integer (&first)))
- goto return_error;
-
- i = first;
- while (1)
- {
- /* It is ugly to have this test here but I do not know of a
- * simple way to do this without using two while loops.
- */
- if (ctrl >= 0)
- {
- if (i > last) break;
- }
- else if (i < last) break;
-
- if (SLang_Error) goto return_error;
-
- SLclass_push_int_obj (SLANG_INT_TYPE, i);
- inner_interp (block);
- if (Lang_Break) break;
- Lang_Break_Condition = /* Lang_Continue = */ 0;
-
- i += ctrl;
- }
- break;
-
- case _SLANG_BCST_LOOP:
- loop_name = "loop";
- if (num_blocks != 1)
- goto wrong_num_blocks_error;
-
- if (-1 == SLang_pop_integer (&ctrl))
- goto return_error;
- while (ctrl > 0)
- {
- ctrl--;
-
- if (SLang_Error)
- goto return_error;
-
- inner_interp (block);
- if (Lang_Break) break;
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- }
- break;
-
- case _SLANG_BCST_FOREVER:
- loop_name = "forever";
-
- if (num_blocks != 1)
- goto wrong_num_blocks_error;
-
- while (1)
- {
- if (SLang_Error)
- goto return_error;
-
- inner_interp (block);
- if (Lang_Break) break;
- Lang_Break_Condition = /* Lang_Continue = */ 0;
- }
- break;
-
- default: SLang_verror(SL_INTERNAL_ERROR, "Unknown loop type");
- return;
- }
- Lang_Break = /* Lang_Continue = */ 0;
- Lang_Break_Condition = Lang_Return;
- return;
-
- wrong_num_blocks_error:
- SLang_verror (SL_SYNTAX_ERROR, "Wrong number of blocks for '%s' construct", loop_name);
-
- /* drop */
- return_error:
- do_traceback (loop_name, 0, NULL);
-}
-
-static void lang_do_and_orelse (unsigned char stype, SLBlock_Type *addr, SLBlock_Type *addr_max)
-{
- int test = 0;
- int is_or;
-
- is_or = (stype == _SLANG_BCST_ORELSE);
-
- while (addr <= addr_max)
- {
- if (addr->bc_main_type == _SLANG_BC_LINE_NUM)
- {
- addr++;
- continue;
- }
-
- inner_interp (addr->b.blk);
- if (SLang_Error
- || Lang_Break_Condition
- || (-1 == pop_ctrl_integer (&test)))
- return;
-
- if (is_or == (test != 0))
- break;
-
- /* if (((stype == _SLANG_BCST_ANDELSE) && (test == 0))
- * || ((stype == _SLANG_BCST_ORELSE) && test))
- * break;
- */
-
- addr++;
- }
- SLclass_push_int_obj (SLANG_INT_TYPE, test);
-}
-
-static void do_else_if (SLBlock_Type *zero_block, SLBlock_Type *non_zero_block)
-{
- int test;
-
- if (-1 == pop_ctrl_integer (&test))
- return;
-
- if (test == 0)
- non_zero_block = zero_block;
-
- if (non_zero_block != NULL)
- inner_interp (non_zero_block->b.blk);
-}
-
-int _SLang_trace_fun (char *f)
-{
- if (NULL == (f = SLang_create_slstring (f)))
- return -1;
-
- SLang_free_slstring (Trace_Function);
- Trace_Function = f;
- _SLang_Trace = 1;
- return 0;
-}
-
-int _SLdump_objects (char *prefix, SLang_Object_Type *x, unsigned int n, int dir)
-{
- char *s;
- SLang_Class_Type *cl;
-
- while (n)
- {
- cl = _SLclass_get_class (x->data_type);
-
- if (NULL == (s = _SLstringize_object (x)))
- s = "??";
-
- call_dump_routine ("%s[%s]:%s\n", prefix, cl->cl_name, s);
-
- SLang_free_slstring (s);
-
- x += dir;
- n--;
- }
- return 0;
-}
-
-static SLBlock_Type *Exit_Block_Ptr;
-static SLBlock_Type *Global_User_Block[5];
-static SLBlock_Type **User_Block_Ptr = Global_User_Block;
-char *_SLang_Current_Function_Name = NULL;
-
-static int execute_slang_fun (_SLang_Function_Type *fun)
-{
- register unsigned int i;
- register SLang_Object_Type *frame, *lvf;
- register unsigned int n_locals;
- _SLBlock_Header_Type *header;
- /* SLBlock_Type *val; */
- SLBlock_Type *exit_block_save;
- SLBlock_Type **user_block_save;
- SLBlock_Type *user_blocks[5];
- char *save_fname;
-
- exit_block_save = Exit_Block_Ptr;
- user_block_save = User_Block_Ptr;
- User_Block_Ptr = user_blocks;
- *(user_blocks) = NULL;
- *(user_blocks + 1) = NULL;
- *(user_blocks + 2) = NULL;
- *(user_blocks + 3) = NULL;
- *(user_blocks + 4) = NULL;
-
- Exit_Block_Ptr = NULL;
-
- save_fname = _SLang_Current_Function_Name;
- _SLang_Current_Function_Name = fun->name;
-
- _SL_increment_frame_pointer ();
-
- /* need loaded? */
- if (fun->nlocals == AUTOLOAD_NUM_LOCALS)
- {
- header = NULL;
- if (-1 == SLang_load_file(fun->v.autoload_filename))
- goto the_return;
-
- if (fun->nlocals == AUTOLOAD_NUM_LOCALS)
- {
- SLang_verror (SL_UNDEFINED_NAME, "%s: Function did not autoload",
- _SLang_Current_Function_Name);
- goto the_return;
- }
- }
-
- n_locals = fun->nlocals;
-
- /* let the error propagate through since it will do no harm
- and allow us to restore stack. */
-
- /* set new stack frame */
- lvf = frame = Local_Variable_Frame;
- i = n_locals;
- if ((lvf + i) > Local_Variable_Stack + SLANG_MAX_LOCAL_STACK)
- {
- SLang_verror(SL_STACK_OVERFLOW, "%s: Local Variable Stack Overflow",
- _SLang_Current_Function_Name);
- goto the_return;
- }
-
- /* Make sure we do not allow this header to get destroyed by something
- * like: define crash () { eval ("define crash ();") }
- */
- header = fun->v.header;
- header->num_refs++;
-
- while (i--)
- {
- lvf++;
- lvf->data_type = SLANG_UNDEFINED_TYPE;
- }
- Local_Variable_Frame = lvf;
-
- /* read values of function arguments */
- i = fun->nargs;
- while (i > 0)
- {
- i--;
- (void) SLang_pop (Local_Variable_Frame - i);
- }
-
- if (SLang_Enter_Function != NULL) (*SLang_Enter_Function)(_SLang_Current_Function_Name);
-
- if (_SLang_Trace)
- {
- int stack_depth;
-
- stack_depth = _SLstack_depth ();
-
- if ((Trace_Function != NULL)
- && (0 == strcmp (Trace_Function, _SLang_Current_Function_Name))
- && (Trace_Mode == 0))
- Trace_Mode = 1;
-
- if (Trace_Mode)
- {
- /* The local variable frame grows backwards */
- trace_dump (">>%s (%d args)\n",
- _SLang_Current_Function_Name,
- Local_Variable_Frame,
- (int) fun->nargs,
- -1);
- Trace_Mode++;
- }
-
- inner_interp (header->body);
- Lang_Break_Condition = Lang_Return = Lang_Break = 0;
- if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
-
- if (Trace_Mode)
- {
- Trace_Mode--;
- stack_depth = _SLstack_depth () - stack_depth;
-
- trace_dump ("<<%s (returning %d values)\n",
- _SLang_Current_Function_Name,
- _SLStack_Pointer - stack_depth,
- stack_depth,
- 1);
-
- if (Trace_Mode == 1)
- Trace_Mode = 0;
- }
- }
- else
- {
- inner_interp (header->body);
- 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)(_SLang_Current_Function_Name);
-
- if (SLang_Error)
- do_traceback(fun->name, n_locals,
-#if _SLANG_HAS_DEBUG_CODE
- fun->file
-#else
- NULL
-#endif
- );
-
- /* free local variables.... */
- lvf = Local_Variable_Frame;
- while (lvf > frame)
- {
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR != _SLclass_Class_Type [lvf->data_type])
-#endif
- SLang_free_object (lvf);
- lvf--;
- }
- Local_Variable_Frame = lvf;
-
- if (header->num_refs == 1)
- free_function_header (header);
- else
- header->num_refs--;
-
- the_return:
-
- Lang_Break_Condition = Lang_Return = Lang_Break = 0;
- Exit_Block_Ptr = exit_block_save;
- User_Block_Ptr = user_block_save;
- _SLang_Current_Function_Name = save_fname;
- _SL_decrement_frame_pointer ();
-
- if (SLang_Error)
- return -1;
-
- return 0;
-}
-
-static void do_traceback (char *name, unsigned int locals, char *file)
-{
- char *s;
- unsigned int i;
- SLang_Object_Type *objp;
- unsigned short stype;
-
- /* FIXME: Priority=low
- * I need to make this configurable!!! That is, let the
- * application decide whether or not a usage error should result in a
- * traceback.
- */
- if (SLang_Error == SL_USAGE_ERROR)
- return;
-
- if (SLang_Traceback == 0)
- return;
-
- call_dump_routine ("S-Lang Traceback: %s\n", name);
- if (SLang_Traceback < 0)
- return;
-
- if (file != NULL)
- call_dump_routine ("File: %s\n", file);
-
- if (locals == 0)
- return;
-
- call_dump_routine (" Local Variables:\n");
-
- for (i = 0; i < locals; i++)
- {
- SLang_Class_Type *cl;
- char *class_name;
-
- objp = Local_Variable_Frame - i;
- stype = objp->data_type;
-
- s = _SLstringize_object (objp);
- cl = _SLclass_get_class (stype);
- class_name = cl->cl_name;
-
- call_dump_routine ("\t$%d: Type: %s,\tValue:\t", i, class_name);
-
- if (s == NULL) call_dump_routine("??\n");
- else
- {
- char *q = "";
-#ifndef HAVE_VSNPRINTF
- char buf[256];
- if (strlen (s) >= sizeof (buf))
- {
- strncpy (buf, s, sizeof(buf));
- s = buf;
- s[sizeof(buf) - 1] = 0;
- }
-#endif
- if (SLANG_STRING_TYPE == stype) q = "\"";
- call_dump_routine ("%s%s%s\n", q, s, q);
- }
- }
-}
-
-static void do_app_unary (SLang_App_Unary_Type *nt)
-{
- if (-1 == do_unary (nt->unary_op, nt->name_type))
- do_traceback (nt->name, 0, NULL);
-}
-
-static int inner_interp_nametype (SLang_Name_Type *nt)
-{
- SLBlock_Type bc_blks[2];
-
- bc_blks[0].b.nt_blk = nt;
- bc_blks[0].bc_main_type = nt->name_type;
- bc_blks[1].bc_main_type = 0;
- return inner_interp(bc_blks);
-}
-
-int _SLang_dereference_ref (SLang_Ref_Type *ref)
-{
- if (ref == NULL)
- {
- SLang_Error = SL_INTERNAL_ERROR;
- return -1;
- }
-
- if (ref->is_global == 0)
- {
- SLang_Object_Type *obj = ref->v.local_obj;
- if (obj > Local_Variable_Frame)
- {
- SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope");
- return -1;
- }
- return _SLpush_slang_obj (ref->v.local_obj);
- }
-
- (void) inner_interp_nametype (ref->v.nt);
- return 0;
-}
-
-int _SLang_is_ref_initialized (SLang_Ref_Type *ref)
-{
- unsigned char type;
-
- if (ref == NULL)
- {
- SLang_Error = SL_INTERNAL_ERROR;
- return -1;
- }
-
- if (ref->is_global == 0)
- {
- SLang_Object_Type *obj = ref->v.local_obj;
- if (obj > Local_Variable_Frame)
- {
- SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope");
- return -1;
- }
- type = ref->v.local_obj->data_type;
- }
- else
- {
- SLang_Name_Type *nt = ref->v.nt;
- if ((nt->name_type != SLANG_GVARIABLE)
- && (nt->name_type != SLANG_PVARIABLE))
- return 1;
- type = ((SLang_Global_Var_Type *)nt)->obj.data_type;
- }
- return type != SLANG_UNDEFINED_TYPE;
-}
-
-int _SLang_uninitialize_ref (SLang_Ref_Type *ref)
-{
- SLang_Object_Type *obj;
-
- if (ref == NULL)
- {
- SLang_Error = SL_INTERNAL_ERROR;
- return -1;
- }
-
- if (ref->is_global == 0)
- {
- obj = ref->v.local_obj;
- if (obj > Local_Variable_Frame)
- {
- SLang_verror (SL_UNDEFINED_NAME, "Local variable deref is out of scope");
- return -1;
- }
- obj = ref->v.local_obj;
- }
- else
- {
- SLang_Name_Type *nt = ref->v.nt;
- if ((nt->name_type != SLANG_GVARIABLE)
- && (nt->name_type != SLANG_PVARIABLE))
- return -1;
- obj = &((SLang_Global_Var_Type *)nt)->obj;
- }
- SLang_free_object (obj);
- obj->data_type = SLANG_UNDEFINED_TYPE;
- obj->v.ptr_val = NULL;
- return 0;
-}
-
-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)();
-}
-
-int _SLpush_slang_obj (SLang_Object_Type *obj)
-{
- unsigned char subtype;
- SLang_Class_Type *cl;
-
- if (obj == NULL) return SLang_push_null ();
-
- subtype = obj->data_type;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[subtype])
- return SLang_push (obj);
-#endif
-
- cl = _SLclass_get_class (subtype);
- return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
-}
-
-_INLINE_
-static int push_local_variable (int i)
-{
- SLang_Class_Type *cl;
- SLang_Object_Type *obj;
- unsigned char subtype;
-
- obj = Local_Variable_Frame - i;
- subtype = obj->data_type;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (SLANG_CLASS_TYPE_SCALAR == _SLclass_Class_Type[subtype])
- return SLang_push (obj);
- if (subtype == SLANG_STRING_TYPE)
- return _SLang_dup_and_push_slstring (obj->v.s_val);
-#endif
-
- cl = _SLclass_get_class (subtype);
- return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
-}
-
-static int push_intrinsic_variable (SLang_Intrin_Var_Type *ivar)
-{
- SLang_Class_Type *cl;
- unsigned char stype;
-
- stype = ivar->type;
- cl = _SLclass_get_class (stype);
-
- if (-1 == (*cl->cl_push_intrinsic) (stype, ivar->addr))
- {
- do_name_type_error ((SLang_Name_Type *) ivar);
- return -1;
- }
- return 0;
-}
-
-static int dereference_object (void)
-{
- SLang_Object_Type obj;
- SLang_Class_Type *cl;
- unsigned char type;
- int ret;
-
- if (-1 == SLang_pop (&obj))
- return -1;
-
- type = obj.data_type;
-
- cl = _SLclass_get_class (type);
- ret = (*cl->cl_dereference)(type, (VOID_STAR) &obj.v);
-
- SLang_free_object (&obj);
- return ret;
-}
-
-static int case_function (void)
-{
- unsigned char type;
- SLang_Object_Type obj;
- SLang_Object_Type *swobjptr;
-
- swobjptr = Switch_Obj_Ptr - 1;
-
- if ((swobjptr < Switch_Objects)
- || (0 == (type = swobjptr->data_type)))
- {
- SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case' keyword");
- return -1;
- }
-
- if (-1 == SLang_pop (&obj))
- return -1;
-
- if (obj.data_type != type)
- {
- SLang_Class_Type *a_cl, *b_cl;
-
- a_cl = _SLclass_get_class (obj.data_type);
- b_cl = _SLclass_get_class (type);
-
- if (NULL == _SLclass_get_binary_fun (SLANG_EQ, a_cl, b_cl, &a_cl, 0))
- {
- (void) SLclass_push_int_obj (SLANG_INT_TYPE, 0);
- SLang_free_object (&obj);
- return 0;
- }
- }
-
- (void) do_binary_ab (SLANG_EQ, swobjptr, &obj);
- SLang_free_object (&obj);
- return 0;
-}
-
-static void tmp_variable_function (SLBlock_Type *addr)
-{
- SLang_Object_Type *obj;
-
- switch (addr->bc_sub_type)
- {
- case SLANG_GVARIABLE:
- case SLANG_PVARIABLE:
- obj = &addr->b.nt_gvar_blk->obj;
- break;
-
- case SLANG_LVARIABLE:
- obj = Local_Variable_Frame - addr->b.i_blk;
- break;
-
- default:
- SLang_Error = SL_INTERNAL_ERROR;
- return;
- }
-
- /* There is no need to go through higher level routines since we are
- * not creating or destroying extra copies.
- */
- if (-1 == SLang_push (obj))
- return;
-
- obj->data_type = SLANG_UNDEFINED_TYPE;
- obj->v.ptr_val = NULL;
-}
-
-
-static int
-do_inner_interp_error (SLBlock_Type *err_block,
- SLBlock_Type *addr_start,
- SLBlock_Type *addr)
-{
- int save_err, slerr;
-
- /* Someday I can use the these variable to provide extra information
- * about what went wrong.
- */
- (void) addr_start;
- (void) addr;
-
- if (err_block == NULL)
- goto return_error;
-
- if (SLang_Error < 0) /* errors less than 0 are severe */
- goto return_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)
- /* An error may have cleared the error and then caused the
- * function to return. We will allow that but let's not allow
- * 'break' nor 'continue' statements until later.
- */
- || Lang_Return)
- return 0;
-
- /* drop--- either a break or continue was called */
- }
-
- Last_Error = save_err;
- SLang_Error = slerr;
-
- return_error:
-#if _SLANG_HAS_DEBUG_CODE
- while (addr >= addr_start)
- {
- if (addr->bc_main_type == _SLANG_BC_LINE_NUM)
- {
- char buf[256];
- sprintf (buf, "(Error occurred on line %lu)", addr->b.l_blk);
- do_traceback (buf, 0, NULL);
- break;
- }
- /* Special hack for 16 bit systems to prevent pointer wrapping. */
-#if defined(__16_BIT_SYSTEM__)
- if (addr == addr_start)
- break;
-#endif
- addr--;
- }
-#endif
- return -1;
-}
-
-
-#define GATHER_STATISTICS 0
-#if GATHER_STATISTICS
-static unsigned int Bytecodes[0xFFFF];
-
-static void print_stats (void)
-{
- unsigned int i;
- unsigned long total;
- FILE *fp = fopen ("stats.txt", "w");
- if (fp == NULL)
- return;
-
- total = 0;
- for (i = 0; i < 0xFFFF; i++)
- total += Bytecodes[i];
-
- if (total == 0)
- total = 1;
-
- for (i = 0; i < 0xFFFF; i++)
- {
- if (Bytecodes[i])
- fprintf (fp, "0x%04X %9u %e\n", i, Bytecodes[i], Bytecodes[i]/(double) total);
- }
- fclose (fp);
-}
-
-static void add_to_statistics (SLBlock_Type *b)
-{
- unsigned short x, y;
-
- x = b->bc_main_type;
- if (x == 0)
- {
- Bytecodes[0] += 1;
- return;
- }
- b++;
- y = b->bc_main_type;
-
- Bytecodes[(x << 8) | y] += 1;
-}
-
-#endif
-
-/* inner interpreter */
-/* The return value from this function is only meaningful when it is used
- * to process blocks for the switch statement. If it returns 0, the calling
- * routine should pass the next block to it. Otherwise it will
- * return non-zero, with or without error.
- */
-static int inner_interp (SLBlock_Type *addr_start)
-{
- SLBlock_Type *block, *err_block, *addr;
-#if GATHER_STATISTICS
- static int inited = 0;
-
- if (inited == 0)
- {
- (void) SLang_add_cleanup_function (print_stats);
- inited = 1;
- }
-#endif
-
- /* for systems that have no real interrupt facility (e.g. go32 on dos) */
- if (SLang_Interrupt != NULL) (*SLang_Interrupt)();
-
- block = err_block = NULL;
- addr = addr_start;
-
-#if GATHER_STATISTICS
- add_to_statistics (addr);
-#endif
- while (1)
- {
- switch (addr->bc_main_type)
- {
- case 0:
- return 1;
- case _SLANG_BC_LVARIABLE:
- push_local_variable (addr->b.i_blk);
- break;
- case _SLANG_BC_GVARIABLE:
- if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj))
- do_name_type_error (addr->b.nt_blk);
- break;
-
- case _SLANG_BC_IVARIABLE:
- case _SLANG_BC_RVARIABLE:
- push_intrinsic_variable (addr->b.nt_ivar_blk);
- break;
-
- case _SLANG_BC_INTRINSIC:
- execute_intrinsic_fun (addr->b.nt_ifun_blk);
- if (SLang_Error)
- do_traceback(addr->b.nt_ifun_blk->name, 0, NULL);
- break;
-
- case _SLANG_BC_FUNCTION:
- execute_slang_fun (addr->b.nt_fun_blk);
- if (Lang_Break_Condition) goto handle_break_condition;
- break;
-
- case _SLANG_BC_MATH_UNARY:
- case _SLANG_BC_APP_UNARY:
- /* Make sure we treat these like function calls since the
- * parser took sin(x) to be a function call.
- */
- if (0 == _SL_increment_frame_pointer ())
- {
- do_app_unary (addr->b.nt_unary_blk);
- (void) _SL_decrement_frame_pointer ();
- }
- break;
-
- case _SLANG_BC_ICONST:
- SLclass_push_int_obj (SLANG_INT_TYPE, addr->b.iconst_blk->i);
- break;
-
-#if SLANG_HAS_FLOAT
- case _SLANG_BC_DCONST:
- SLang_push_double (addr->b.dconst_blk->d);
- break;
-#endif
-
- case _SLANG_BC_PVARIABLE:
- if (-1 == _SLpush_slang_obj (&addr->b.nt_gvar_blk->obj))
- do_name_type_error (addr->b.nt_blk);
- break;
-
- case _SLANG_BC_PFUNCTION:
- execute_slang_fun (addr->b.nt_fun_blk);
- if (Lang_Break_Condition) goto handle_break_condition;
- break;
-
- case _SLANG_BC_BINARY:
- do_binary (addr->b.i_blk);
- break;
-
- case _SLANG_BC_LITERAL:
-#if !_SLANG_OPTIMIZE_FOR_SPEED
- case _SLANG_BC_LITERAL_INT:
- case _SLANG_BC_LITERAL_STR:
-#endif
- {
- SLang_Class_Type *cl = _SLclass_get_class (addr->bc_sub_type);
- (*cl->cl_push_literal) (addr->bc_sub_type, (VOID_STAR) &addr->b.ptr_blk);
- }
- break;
-#if _SLANG_OPTIMIZE_FOR_SPEED
- case _SLANG_BC_LITERAL_INT:
- SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk);
- break;
-
- case _SLANG_BC_LITERAL_STR:
- _SLang_dup_and_push_slstring (addr->b.s_blk);
- break;
-#endif
- case _SLANG_BC_BLOCK:
- switch (addr->bc_sub_type)
- {
- case _SLANG_BCST_ERROR_BLOCK:
- err_block = addr;
- break;
-
- case _SLANG_BCST_EXIT_BLOCK:
- Exit_Block_Ptr = addr->b.blk;
- break;
-
- case _SLANG_BCST_USER_BLOCK0:
- case _SLANG_BCST_USER_BLOCK1:
- case _SLANG_BCST_USER_BLOCK2:
- case _SLANG_BCST_USER_BLOCK3:
- case _SLANG_BCST_USER_BLOCK4:
- User_Block_Ptr[addr->bc_sub_type - _SLANG_BCST_USER_BLOCK0] = addr->b.blk;
- break;
-
- case _SLANG_BCST_LOOP:
- case _SLANG_BCST_WHILE:
- case _SLANG_BCST_FOR:
- case _SLANG_BCST_FOREVER:
- case _SLANG_BCST_CFOR:
- case _SLANG_BCST_DOWHILE:
- case _SLANG_BCST_FOREACH:
- if (block == NULL) block = addr;
- lang_do_loops(addr->bc_sub_type, block, 1 + (unsigned int) (addr - block));
- block = NULL;
- break;
-
- case _SLANG_BCST_IFNOT:
-#if _SLANG_OPTIMIZE_FOR_SPEED
- {
- int i;
-
- if ((0 == pop_ctrl_integer (&i)) && (i == 0))
- inner_interp (addr->b.blk);
- }
-#else
- do_else_if (addr, NULL);
-#endif
- break;
-
- case _SLANG_BCST_IF:
-#if _SLANG_OPTIMIZE_FOR_SPEED
- {
- int i;
-
- if ((0 == pop_ctrl_integer (&i)) && i)
- inner_interp (addr->b.blk);
- }
-#else
- do_else_if (NULL, addr);
-#endif
- break;
-
- case _SLANG_BCST_NOTELSE:
- do_else_if (block, addr);
- block = NULL;
- break;
-
- case _SLANG_BCST_ELSE:
- do_else_if (addr, block);
- block = NULL;
- break;
-
- case _SLANG_BCST_SWITCH:
- if (Switch_Obj_Ptr == Switch_Obj_Max)
- {
- SLang_doerror("switch nesting too deep");
- break;
- }
- (void) SLang_pop (Switch_Obj_Ptr);
- Switch_Obj_Ptr++;
-
- if (block == NULL) block = addr;
- while ((SLang_Error == 0)
- && (block <= addr)
- && (Lang_Break_Condition == 0)
- && (0 == inner_interp (block->b.blk)))
- block++;
- Switch_Obj_Ptr--;
- SLang_free_object (Switch_Obj_Ptr);
- Switch_Obj_Ptr->data_type = 0;
- block = NULL;
- break;
-
- case _SLANG_BCST_ANDELSE:
- case _SLANG_BCST_ORELSE:
- if (block == NULL) block = addr;
- lang_do_and_orelse (addr->bc_sub_type, block, addr);
- block = NULL;
- break;
-
- default:
- if (block == NULL) block = addr;
- break;
- }
- if (Lang_Break_Condition) goto handle_break_condition;
- break;
-
- case _SLANG_BC_RETURN:
- Lang_Break_Condition = Lang_Return = Lang_Break = 1; return 1;
- case _SLANG_BC_BREAK:
- Lang_Break_Condition = Lang_Break = 1; return 1;
- case _SLANG_BC_CONTINUE:
- Lang_Break_Condition = /* Lang_Continue = */ 1; return 1;
-
- case _SLANG_BC_EXCH:
- (void) SLreverse_stack (2);
- break;
-
- case _SLANG_BC_LABEL:
- {
- int test;
- if ((0 == SLang_pop_integer (&test))
- && (test == 0))
- return 0;
- }
- break;
-
- case _SLANG_BC_LOBJPTR:
- (void)_SLang_push_ref (0, (VOID_STAR)(Local_Variable_Frame - addr->b.i_blk));
- break;
-
- case _SLANG_BC_GOBJPTR:
- (void)_SLang_push_ref (1, (VOID_STAR)addr->b.nt_blk);
- break;
-
- case _SLANG_BC_X_ERROR:
- if (err_block != NULL)
- {
- inner_interp(err_block->b.blk);
- if (SLang_Error) err_block = NULL;
- }
- else SLang_verror(SL_SYNTAX_ERROR, "No ERROR_BLOCK");
- if (Lang_Break_Condition) goto handle_break_condition;
- break;
-
- case _SLANG_BC_X_USER0:
- case _SLANG_BC_X_USER1:
- case _SLANG_BC_X_USER2:
- case _SLANG_BC_X_USER3:
- case _SLANG_BC_X_USER4:
- if (User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0] != NULL)
- {
- inner_interp(User_Block_Ptr[addr->bc_main_type - _SLANG_BC_X_USER0]);
- }
- else SLang_verror(SL_SYNTAX_ERROR, "No block for X_USERBLOCK");
- if (Lang_Break_Condition) goto handle_break_condition;
- break;
-
- case _SLANG_BC_CALL_DIRECT:
- (*addr->b.call_function) ();
- break;
-
- case _SLANG_BC_CALL_DIRECT_FRAME:
- do_bc_call_direct_frame (addr->b.call_function);
- break;
-
- case _SLANG_BC_UNARY:
- do_unary (addr->b.i_blk, _SLANG_BC_UNARY);
- break;
-
- case _SLANG_BC_UNARY_FUNC:
- /* Make sure we treat these like function calls since the
- * parser took abs(x) to be a function call.
- */
- if (0 == _SL_increment_frame_pointer ())
- {
- do_unary (addr->b.i_blk, _SLANG_BC_UNARY);
- (void) _SL_decrement_frame_pointer ();
- }
- break;
-
- case _SLANG_BC_DEREF_ASSIGN:
- set_deref_lvalue (addr);
- break;
- case _SLANG_BC_SET_LOCAL_LVALUE:
- set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
- break;
- case _SLANG_BC_SET_GLOBAL_LVALUE:
- if (-1 == set_lvalue_obj (addr->bc_sub_type, &addr->b.nt_gvar_blk->obj))
- do_name_type_error (addr->b.nt_blk);
- break;
- case _SLANG_BC_SET_INTRIN_LVALUE:
- set_intrin_lvalue (addr);
- break;
- case _SLANG_BC_SET_STRUCT_LVALUE:
- set_struct_lvalue (addr);
- break;
-
- case _SLANG_BC_FIELD:
- (void) push_struct_field (addr->b.s_blk);
- break;
-
- case _SLANG_BC_SET_ARRAY_LVALUE:
- set_array_lvalue (addr->bc_sub_type);
- break;
-
-#if _SLANG_HAS_DEBUG_CODE
- case _SLANG_BC_LINE_NUM:
- break;
-#endif
-
- case _SLANG_BC_TMP:
- tmp_variable_function (addr);
- break;
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
- case _SLANG_BC_LVARIABLE_AGET:
- if (0 == push_local_variable (addr->b.i_blk))
- do_bc_call_direct_frame (_SLarray_aget);
- break;
-
- case _SLANG_BC_LVARIABLE_APUT:
- if (0 == push_local_variable (addr->b.i_blk))
- do_bc_call_direct_frame (_SLarray_aput);
- break;
- case _SLANG_BC_INTEGER_PLUS:
- if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk))
- do_binary (SLANG_PLUS);
- break;
-
- case _SLANG_BC_INTEGER_MINUS:
- if (0 == SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk))
- do_binary (SLANG_MINUS);
- break;
-#endif
-#if 0
- case _SLANG_BC_ARG_LVARIABLE:
- (void) SLang_start_arg_list ();
- push_local_variable (addr->b.i_blk);
- break;
-#endif
- case _SLANG_BC_EARG_LVARIABLE:
- push_local_variable (addr->b.i_blk);
- (void) SLang_end_arg_list ();
- break;
-
-#if USE_COMBINED_BYTECODES
- case _SLANG_BC_CALL_DIRECT_INTRINSIC:
- (*addr->b.call_function) ();
- addr++;
- execute_intrinsic_fun (addr->b.nt_ifun_blk);
- if (SLang_Error)
- do_traceback(addr->b.nt_ifun_blk->name, 0, NULL);
- break;
-
- case _SLANG_BC_INTRINSIC_CALL_DIRECT:
- execute_intrinsic_fun (addr->b.nt_ifun_blk);
- if (SLang_Error)
- {
- do_traceback(addr->b.nt_ifun_blk->name, 0, NULL);
- break;
- }
- addr++;
- (*addr->b.call_function) ();
- break;
-
- case _SLANG_BC_CALL_DIRECT_LSTR:
- (*addr->b.call_function) ();
- addr++;
- _SLang_dup_and_push_slstring (addr->b.s_blk);
- break;
-
- case _SLANG_BC_CALL_DIRECT_SLFUN:
- (*addr->b.call_function) ();
- addr++;
- execute_slang_fun (addr->b.nt_fun_blk);
- if (Lang_Break_Condition) goto handle_break_condition;
- break;
-
- case _SLANG_BC_CALL_DIRECT_INTRSTOP:
- (*addr->b.call_function) ();
- addr++;
- /* drop */
- case _SLANG_BC_INTRINSIC_STOP:
- execute_intrinsic_fun (addr->b.nt_ifun_blk);
- if (SLang_Error == 0)
- return 1;
- do_traceback(addr->b.nt_ifun_blk->name, 0, NULL);
- break;
-
- case _SLANG_BC_CALL_DIRECT_EARG_LVAR:
- (*addr->b.call_function) ();
- addr++;
- push_local_variable (addr->b.i_blk);
- (void) SLang_end_arg_list ();
- break;
-
- case _SLANG_BC_CALL_DIRECT_LINT:
- (*addr->b.call_function) ();
- addr++;
- SLclass_push_int_obj (addr->bc_sub_type, (int) addr->b.l_blk);
- break;
-
- case _SLANG_BC_CALL_DIRECT_LVAR:
- (*addr->b.call_function) ();
- addr++;
- push_local_variable (addr->b.i_blk);
- break;
-#endif /* USE_COMBINED_BYTECODES */
-
- default:
- SLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
- }
-
- /* Someday I plan to add a 'signal' intrinsic function. Then when a
- * signal is caught, a variable will be set to one and that value of
- * that variable will need to be monitored here, e.g.,
- * if (Handle_Signal) handle_signal ();
- * It would be nice to check only one variable instead of Handle_Signal
- * and SLang_Error. Perhaps I should phase out SLang_Error = xxx
- * and used something like: SLang_set_error (code); Then, I could
- * use:
- * if (Handle_Condition)
- * {
- * Handle_Condition = 0;
- * if (SLang_Error) ....
- * else if (Handle_Signal) handle_signal ();
- * else....
- * }
- */
- if (SLang_Error)
- {
- if (-1 == do_inner_interp_error (err_block, addr_start, addr))
- return 1;
- if (SLang_Error)
- return 1;
-
- /* Otherwise, error cleared. Continue onto next bytecode.
- * Someday I need to add something to indicate where the
- * next statement begins since continuing on the next
- * bytecode is not really what is desired.
- */
- if (Lang_Break_Condition) goto handle_break_condition;
- }
- addr++;
- }
-
- handle_break_condition:
- /* Get here if Lang_Break_Condition != 0, which implies that either
- * Lang_Return, Lang_Break, or Lang_Continue is non zero
- */
- if (Lang_Return)
- Lang_Break = 1;
-
- return 1;
-}
-
-/*}}}*/
-
-/* The functions below this point are used to implement the parsed token
- * to byte-compiled code.
- */
-/* static SLang_Name_Type **Static_Hash_Table; */
-
-static SLang_Name_Type **Locals_Hash_Table;
-static int Local_Variable_Number;
-static unsigned int Function_Args_Number;
-int _SLang_Auto_Declare_Globals = 0;
-int (*SLang_Auto_Declare_Var_Hook) (char *);
-
-static SLang_NameSpace_Type *This_Static_NameSpace;
-static SLang_NameSpace_Type *Global_NameSpace;
-
-#if _SLANG_HAS_DEBUG_CODE
-static char *This_Compile_Filename;
-#endif
-static SLBlock_Type SLShort_Blocks[6];
-/* These are initialized in add_table below. I cannot init a Union!! */
-
-static int Lang_Defining_Function;
-static void (*Default_Variable_Mode) (_SLang_Token_Type *);
-static void (*Default_Define_Function) (char *, unsigned long);
-
-static int push_compile_context (char *);
-static int pop_compile_context (void);
-
-typedef struct
-{
- int block_type;
- SLBlock_Type *block; /* beginning of block definition */
- SLBlock_Type *block_ptr; /* current location */
- SLBlock_Type *block_max; /* end of definition */
- SLang_NameSpace_Type *static_namespace;
-}
-Block_Context_Type;
-
-static Block_Context_Type Block_Context_Stack [SLANG_MAX_BLOCK_STACK_LEN];
-static unsigned int Block_Context_Stack_Len;
-
-static SLBlock_Type *Compile_ByteCode_Ptr;
-static SLBlock_Type *This_Compile_Block;
-static SLBlock_Type *This_Compile_Block_Max;
-static int This_Compile_Block_Type;
-#define COMPILE_BLOCK_TYPE_FUNCTION 1
-#define COMPILE_BLOCK_TYPE_BLOCK 2
-#define COMPILE_BLOCK_TYPE_TOP_LEVEL 3
-
-/* If it returns 0, DO NOT FREE p */
-static int lang_free_branch (SLBlock_Type *p)
-{
- /* Note: we look at 0,2,4, since these blocks are 0 terminated */
- if ((p == SLShort_Blocks)
- || (p == SLShort_Blocks + 2)
- || (p == SLShort_Blocks + 4)
- )
- return 0;
-
- while (1)
- {
- SLang_Class_Type *cl;
-
- switch (p->bc_main_type)
- {
- case _SLANG_BC_BLOCK:
- if (lang_free_branch(p->b.blk))
- SLfree((char *)p->b.blk);
- break;
-
- case _SLANG_BC_LITERAL:
- case _SLANG_BC_LITERAL_STR:
- /* No user types should be here. */
- cl = _SLclass_get_class (p->bc_sub_type);
- (*cl->cl_byte_code_destroy) (p->bc_sub_type, (VOID_STAR) &p->b.ptr_blk);
- break;
-
- case _SLANG_BC_FIELD:
- case _SLANG_BC_SET_STRUCT_LVALUE:
- SLang_free_slstring (p->b.s_blk);
- break;
-
- default:
- break;
-
- case 0:
- return 1;
- }
- p++;
- }
-}
-
-static void free_function_header (_SLBlock_Header_Type *h)
-{
- if (h->num_refs > 1)
- {
- h->num_refs--;
- return;
- }
-
- if (h->body != NULL)
- {
- if (lang_free_branch (h->body))
- SLfree ((char *) h->body);
- }
-
- SLfree ((char *) h);
-}
-
-static int push_block_context (int type)
-{
- Block_Context_Type *c;
- unsigned int num;
- SLBlock_Type *b;
-
- if (Block_Context_Stack_Len == SLANG_MAX_BLOCK_STACK_LEN)
- {
- SLang_verror (SL_STACK_OVERFLOW, "Block stack overflow");
- return -1;
- }
-
- num = 5; /* 40 bytes */
- if (NULL == (b = (SLBlock_Type *) SLcalloc (num, sizeof (SLBlock_Type))))
- return -1;
-
- c = Block_Context_Stack + Block_Context_Stack_Len;
- c->block = This_Compile_Block;
- c->block_ptr = Compile_ByteCode_Ptr;
- c->block_max = This_Compile_Block_Max;
- c->block_type = This_Compile_Block_Type;
- c->static_namespace = This_Static_NameSpace;
-
- Compile_ByteCode_Ptr = This_Compile_Block = b;
- This_Compile_Block_Max = b + num;
- This_Compile_Block_Type = type;
-
- Block_Context_Stack_Len += 1;
- return 0;
-}
-
-static int pop_block_context (void)
-{
- Block_Context_Type *c;
-
- if (Block_Context_Stack_Len == 0)
- return -1;
-
- Block_Context_Stack_Len -= 1;
- c = Block_Context_Stack + Block_Context_Stack_Len;
-
- This_Compile_Block = c->block;
- This_Compile_Block_Max = c->block_max;
- This_Compile_Block_Type = c->block_type;
- Compile_ByteCode_Ptr = c->block_ptr;
- This_Static_NameSpace = c->static_namespace;
-
- return 0;
-}
-
-int _SLcompile_push_context (SLang_Load_Type *load_object)
-{
- if (-1 == push_compile_context (load_object->name))
- return -1;
-
- if (NULL == (This_Static_NameSpace = _SLns_allocate_namespace (load_object->name, SLSTATIC_HASH_TABLE_SIZE)))
- {
- pop_compile_context ();
- return -1;
- }
-
- if (-1 == push_block_context (COMPILE_BLOCK_TYPE_TOP_LEVEL))
- {
- pop_compile_context ();
- return -1;
- }
-
- return 0;
-}
-
-int _SLcompile_pop_context (void)
-{
- if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL)
- {
- Compile_ByteCode_Ptr->bc_main_type = 0;
- if (lang_free_branch (This_Compile_Block))
- SLfree ((char *) This_Compile_Block);
- }
-
- (void) pop_block_context ();
- (void) pop_compile_context ();
-
- if (This_Compile_Block == NULL)
- return 0;
-
-#if 0
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
- {
- SLang_verror (SL_INTERNAL_ERROR, "Not at top-level");
- return -1;
- }
-#endif
-
- return 0;
-}
-
-/*{{{ Hash and Name Table Functions */
-
-static SLang_Name_Type *locate_name_in_table (char *name, unsigned long hash,
- SLang_Name_Type **table, unsigned int table_size)
-{
- SLang_Name_Type *t;
- char ch;
-
- t = table [(unsigned int) (hash % table_size)];
- ch = *name++;
-
- while (t != NULL)
- {
- if ((ch == t->name[0])
- && (0 == strcmp (t->name + 1, name)))
- break;
-
- t = t->next;
- }
-
- return t;
-}
-
-static SLang_Name_Type *locate_namespace_encoded_name (char *name, int err_on_bad_ns)
-{
- char *ns, *ns1;
- SLang_NameSpace_Type *table;
- SLang_Name_Type *nt;
-
- ns = name;
- name = strchr (name, '-');
- if ((name == NULL) || (name [1] != '>'))
- name = ns;
-
- ns1 = SLang_create_nslstring (ns, (unsigned int) (name - ns));
- if (ns1 == NULL)
- return NULL;
- if (ns != name)
- name += 2;
- ns = ns1;
-
- if (*ns == 0)
- {
- /* Use Global Namespace */
- SLang_free_slstring (ns);
- return locate_name_in_table (name, _SLcompute_string_hash (name),
- Global_NameSpace->table, Global_NameSpace->table_size);
- }
-
- if (NULL == (table = _SLns_find_namespace (ns)))
- {
- if (err_on_bad_ns)
- SLang_verror (SL_SYNTAX_ERROR, "Unable to find namespace called %s", ns);
- SLang_free_slstring (ns);
- return NULL;
- }
- SLang_free_slstring (ns);
-
- /* FIXME: the hash table size should be stored in the hash table itself */
- nt = locate_name_in_table (name, _SLcompute_string_hash (name),
- table->table, table->table_size);
- if (nt == NULL)
- return NULL;
-
- switch (nt->name_type)
- {
- /* These are private and cannot be accessed through the namespace. */
- case SLANG_PVARIABLE:
- case SLANG_PFUNCTION:
- return NULL;
- }
- return nt;
-}
-
-static SLang_Name_Type *locate_hashed_name (char *name, unsigned long hash)
-{
- SLang_Name_Type *t;
-
- if (Lang_Defining_Function)
- {
- t = locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE);
- if (t != NULL)
- return t;
- }
-
- if ((This_Static_NameSpace != NULL)
- && (NULL != (t = locate_name_in_table (name, hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size))))
- return t;
-
- t = locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size);
- if (NULL != t)
- return t;
-
- return locate_namespace_encoded_name (name, 1);
-}
-
-SLang_Name_Type *_SLlocate_name (char *name)
-{
- return locate_hashed_name (name, _SLcompute_string_hash (name));
-}
-
-static SLang_Name_Type *
-add_name_to_hash_table (char *name, unsigned long hash,
- unsigned int sizeof_obj, unsigned char name_type,
- SLang_Name_Type **table, unsigned int table_size,
- int check_existing)
-{
- SLang_Name_Type *t;
-
- if (check_existing)
- {
- t = locate_name_in_table (name, hash, table, table_size);
- if (t != NULL)
- return t;
- }
-
- if (-1 == _SLcheck_identifier_syntax (name))
- return NULL;
-
- t = (SLang_Name_Type *) SLmalloc (sizeof_obj);
- if (t == NULL)
- return t;
-
- memset ((char *) t, 0, sizeof_obj);
- if (NULL == (t->name = _SLstring_dup_hashed_string (name, hash)))
- {
- SLfree ((char *) t);
- return NULL;
- }
- t->name_type = name_type;
-
- hash = hash % table_size;
- t->next = table [(unsigned int)hash];
- table [(unsigned int) hash] = t;
-
- return t;
-}
-
-static SLang_Name_Type *
-add_global_name (char *name, unsigned long hash,
- unsigned char name_type, unsigned int sizeof_obj,
- SLang_NameSpace_Type *ns)
-{
- SLang_Name_Type *nt;
- SLang_Name_Type **table;
- unsigned int table_size;
-
- table = ns->table;
- table_size = ns->table_size;
-
- nt = locate_name_in_table (name, hash, table, table_size);
- if (nt != NULL)
- {
- if (nt->name_type == name_type)
- return nt;
-
- SLang_verror (SL_DUPLICATE_DEFINITION, "%s cannot be re-defined", name);
- return NULL;
- }
-
- return add_name_to_hash_table (name, hash, sizeof_obj, name_type,
- table, table_size, 0);
-}
-
-static int add_intrinsic_function (SLang_NameSpace_Type *ns,
- char *name, FVOID_STAR addr, unsigned char ret_type,
- unsigned int nargs, va_list ap)
-{
- SLang_Intrin_Fun_Type *f;
- unsigned int i;
-
- if (-1 == init_interpreter ())
- return -1;
-
- if (ns == NULL) ns = Global_NameSpace;
-
- if (nargs > SLANG_MAX_INTRIN_ARGS)
- {
- SLang_verror (SL_APPLICATION_ERROR, "Function %s requires too many arguments", name);
- return -1;
- }
-
- if (ret_type == SLANG_FLOAT_TYPE)
- {
- SLang_verror (SL_NOT_IMPLEMENTED, "Function %s is not permitted to return float", name);
- return -1;
- }
-
- f = (SLang_Intrin_Fun_Type *) add_global_name (name, _SLcompute_string_hash (name),
- SLANG_INTRINSIC, sizeof (SLang_Intrin_Fun_Type),
- ns);
-
- if (f == NULL)
- return -1;
-
- f->i_fun = addr;
- f->num_args = nargs;
- f->return_type = ret_type;
-
- for (i = 0; i < nargs; i++)
- f->arg_types [i] = va_arg (ap, unsigned int);
-
- return 0;
-}
-
-int SLadd_intrinsic_function (char *name, FVOID_STAR addr, unsigned char ret_type,
- unsigned int nargs, ...)
-{
- va_list ap;
- int status;
-
- va_start (ap, nargs);
- status = add_intrinsic_function (NULL, name, addr, ret_type, nargs, ap);
- va_end (ap);
-
- return status;
-}
-
-int SLns_add_intrinsic_function (SLang_NameSpace_Type *ns,
- char *name, FVOID_STAR addr, unsigned char ret_type,
- unsigned int nargs, ...)
-{
- va_list ap;
- int status;
-
- va_start (ap, nargs);
- status = add_intrinsic_function (ns, name, addr, ret_type, nargs, ap);
- va_end (ap);
-
- return status;
-}
-
-int SLns_add_intrinsic_variable (SLang_NameSpace_Type *ns,
- char *name, VOID_STAR addr, unsigned char data_type, int ro)
-{
- SLang_Intrin_Var_Type *v;
-
- if (-1 == init_interpreter ())
- return -1;
-
- if (ns == NULL) ns = Global_NameSpace;
-
- v = (SLang_Intrin_Var_Type *)add_global_name (name,
- _SLcompute_string_hash (name),
- (ro ? SLANG_RVARIABLE : SLANG_IVARIABLE),
- sizeof (SLang_Intrin_Var_Type),
- ns);
- if (v == NULL)
- return -1;
-
- v->addr = addr;
- v->type = data_type;
- return 0;
-}
-
-int SLadd_intrinsic_variable (char *name, VOID_STAR addr, unsigned char data_type, int ro)
-{
- return SLns_add_intrinsic_variable (NULL, name, addr, data_type, ro);
-}
-
-static int
-add_slang_function (char *name, unsigned char type, unsigned long hash,
- unsigned int num_args, unsigned int num_locals,
-#if _SLANG_HAS_DEBUG_CODE
- char *file,
-#endif
- _SLBlock_Header_Type *h,
- SLang_NameSpace_Type *ns)
-{
- _SLang_Function_Type *f;
-
-#if _SLANG_HAS_DEBUG_CODE
- if ((file != NULL)
- && (NULL == (file = SLang_create_slstring (file))))
- return -1;
-#endif
-
- f = (_SLang_Function_Type *)add_global_name (name, hash,
- type,
- sizeof (_SLang_Function_Type),
- ns);
- if (f == NULL)
- {
-#if _SLANG_HAS_DEBUG_CODE
- SLang_free_slstring (file); /* NULL ok */
-#endif
- return -1;
- }
-
- if (f->v.header != NULL)
- {
- if (f->nlocals == AUTOLOAD_NUM_LOCALS)
- SLang_free_slstring ((char *)f->v.autoload_filename); /* autoloaded filename */
- else
- free_function_header (f->v.header);
- }
-
-#if _SLANG_HAS_DEBUG_CODE
- if (f->file != NULL) SLang_free_slstring (f->file);
- f->file = file;
-#endif
- f->v.header = h;
- f->nlocals = num_locals;
- f->nargs = num_args;
-
- return 0;
-}
-
-int SLang_autoload (char *name, char *file)
-{
- _SLang_Function_Type *f;
- unsigned long hash;
-
- hash = _SLcompute_string_hash (name);
- f = (_SLang_Function_Type *)locate_name_in_table (name, hash, Global_NameSpace->table, Global_NameSpace->table_size);
-
- if ((f != NULL)
- && (f->name_type == SLANG_FUNCTION)
- && (f->v.header != NULL)
- && (f->nlocals != AUTOLOAD_NUM_LOCALS))
- {
- /* already loaded */
- return 0;
- }
-
- file = SLang_create_slstring (file);
- if (-1 == add_slang_function (name, SLANG_FUNCTION, hash, 0, AUTOLOAD_NUM_LOCALS,
-#if _SLANG_HAS_DEBUG_CODE
- file,
-#endif
- (_SLBlock_Header_Type *) file,
- Global_NameSpace))
- {
- SLang_free_slstring (file);
- return -1;
- }
-
- return 0;
-}
-
-SLang_Name_Type *_SLlocate_global_name (char *name)
-{
- unsigned long hash;
-
- hash = _SLcompute_string_hash (name);
- return locate_name_in_table (name, hash, Global_NameSpace->table,
- Global_NameSpace->table_size);
-}
-
-/*}}}*/
-
-static void free_local_variable_table (void)
-{
- unsigned int i;
- SLang_Name_Type *t, *t1;
-
- for (i = 0; i < SLLOCALS_HASH_TABLE_SIZE; i++)
- {
- t = Locals_Hash_Table [i];
- while (t != NULL)
- {
- SLang_free_slstring (t->name);
- t1 = t->next;
- SLfree ((char *) t);
- t = t1;
- }
- Locals_Hash_Table [i] = NULL;
- }
- Local_Variable_Number = 0;
-}
-
-/* call inner interpreter or return for more */
-static void lang_try_now(void)
-{
- Compile_ByteCode_Ptr++;
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
- return;
-
- Compile_ByteCode_Ptr->bc_main_type = 0; /* so next command stops after this */
-
- /* now do it */
- inner_interp (This_Compile_Block);
- (void) lang_free_branch (This_Compile_Block);
- Compile_ByteCode_Ptr = This_Compile_Block;
-}
-
-SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *ref)
-{
- if (ref->is_global)
- {
- SLang_Name_Type *nt = ref->v.nt;
-
- switch (nt->name_type)
- {
- case SLANG_PFUNCTION:
- case SLANG_FUNCTION:
- case SLANG_INTRINSIC:
- case SLANG_MATH_UNARY:
- case SLANG_APP_UNARY:
- return nt;
- }
- SLang_verror (SL_TYPE_MISMATCH,
- "Reference to a function expected. Found &%s",
- nt->name);
- }
-
- SLang_verror (SL_TYPE_MISMATCH,
- "Reference to a function expected");
- return NULL;
-}
-
-int SLexecute_function (SLang_Name_Type *nt)
-{
- unsigned char type;
- char *name;
-
- if (SLang_Error)
- return -1;
-
- type = nt->name_type;
- name = nt->name;
-
- switch (type)
- {
- case SLANG_PFUNCTION:
- case SLANG_FUNCTION:
- execute_slang_fun ((_SLang_Function_Type *) nt);
- break;
-
- case SLANG_INTRINSIC:
- execute_intrinsic_fun ((SLang_Intrin_Fun_Type *) nt);
- break;
-
- case SLANG_MATH_UNARY:
- case SLANG_APP_UNARY:
- inner_interp_nametype (nt);
- break;
-
- default:
- SLang_verror (SL_TYPE_MISMATCH, "%s is not a function", name);
- return -1;
- }
-
- if (SLang_Error)
- {
- SLang_verror (SLang_Error, "Error while executing %s", name);
- return -1;
- }
-
- return 1;
-}
-
-int SLang_execute_function (char *name)
-{
- SLang_Name_Type *entry;
-
- if (NULL == (entry = SLang_get_function (name)))
- return 0;
-
- return SLexecute_function (entry);
-}
-
-/* return S-Lang function or NULL */
-SLang_Name_Type *SLang_get_function (char *name)
-{
- SLang_Name_Type *entry;
-
- if (NULL == (entry = locate_namespace_encoded_name (name, 0)))
- return NULL;
-
- if ((entry->name_type == SLANG_FUNCTION)
- || (entry->name_type == SLANG_INTRINSIC))
- return entry;
-
- return NULL;
-}
-
-static void lang_begin_function (void)
-{
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
- {
- SLang_verror (SL_SYNTAX_ERROR, "Function nesting is illegal");
- return;
- }
- Lang_Defining_Function = 1;
- (void) push_block_context (COMPILE_BLOCK_TYPE_FUNCTION);
-}
-
-#if USE_COMBINED_BYTECODES
-static void optimize_block (SLBlock_Type *b)
-{
- while (1)
- {
- switch (b->bc_main_type)
- {
- case 0:
- return;
-
- default:
- b++;
- break;
-
- case _SLANG_BC_CALL_DIRECT:
- b++;
- switch (b->bc_main_type)
- {
- case 0:
- return;
- case _SLANG_BC_INTRINSIC:
- if ((b+1)->bc_main_type == 0)
- {
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRSTOP;
- return;
- }
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_INTRINSIC;
- b++;
- break;
- case _SLANG_BC_LITERAL_STR:
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LSTR;
- b++;
- break;
- case _SLANG_BC_FUNCTION:
- case _SLANG_BC_PFUNCTION:
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_SLFUN;
- b++;
- break;
- case _SLANG_BC_EARG_LVARIABLE:
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_EARG_LVAR;
- b++;
- break;
- case _SLANG_BC_LITERAL_INT:
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LINT;
- b++;
- break;
- case _SLANG_BC_LVARIABLE:
- (b-1)->bc_main_type = _SLANG_BC_CALL_DIRECT_LVAR;
- b++;
- break;
- }
- break;
-
- case _SLANG_BC_INTRINSIC:
- b++;
- switch (b->bc_main_type)
- {
- case _SLANG_BC_CALL_DIRECT:
- (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_CALL_DIRECT;
- b++;
- break;
-#if 0
- case _SLANG_BC_BLOCK:
- (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_BLOCK;
- b++;
- break;
-#endif
-
- case 0:
- (b-1)->bc_main_type = _SLANG_BC_INTRINSIC_STOP;
- return;
- }
- break;
- }
- }
-}
-
-#endif
-
-
-/* name will be NULL if the object is to simply terminate the function
- * definition. See SLang_restart.
- */
-static int lang_define_function (char *name, unsigned char type, unsigned long hash,
- SLang_NameSpace_Type *ns)
-{
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_FUNCTION)
- {
- SLang_verror (SL_SYNTAX_ERROR, "Premature end of function");
- return -1;
- }
-
- /* terminate function */
- Compile_ByteCode_Ptr->bc_main_type = 0;
-
- if (name != NULL)
- {
- _SLBlock_Header_Type *h;
-
- h = (_SLBlock_Header_Type *)SLmalloc (sizeof (_SLBlock_Header_Type));
- if (h != NULL)
- {
- h->num_refs = 1;
- h->body = This_Compile_Block;
-
-#if USE_COMBINED_BYTECODES
- optimize_block (h->body);
-#endif
-
- if (-1 == add_slang_function (name, type, hash,
- Function_Args_Number,
- Local_Variable_Number,
-#if _SLANG_HAS_DEBUG_CODE
- This_Compile_Filename,
-#endif
- h, ns))
- SLfree ((char *) h);
- }
- /* Drop through for clean-up */
- }
-
- free_local_variable_table ();
-
- Function_Args_Number = 0;
- Lang_Defining_Function = 0;
-
- if (SLang_Error) return -1;
- /* SLang_restart will finish this if there is a slang error. */
-
- pop_block_context ();
-
- /* A function is only defined at top-level */
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
- {
- SLang_verror (SL_INTERNAL_ERROR, "Not at top-level");
- return -1;
- }
- Compile_ByteCode_Ptr = This_Compile_Block;
- return 0;
-}
-
-static void define_static_function (char *name, unsigned long hash)
-{
- (void) lang_define_function (name, SLANG_FUNCTION, hash, This_Static_NameSpace);
-}
-
-static void define_private_function (char *name, unsigned long hash)
-{
- (void) lang_define_function (name, SLANG_PFUNCTION, hash, This_Static_NameSpace);
-}
-
-static void define_public_function (char *name, unsigned long hash)
-{
- (void) lang_define_function (name, SLANG_FUNCTION, hash, Global_NameSpace);
-}
-
-static void lang_end_block (void)
-{
- SLBlock_Type *node, *branch;
- unsigned char mtype;
-
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK)
- {
- SLang_verror (SL_SYNTAX_ERROR, "Not defining a block");
- return;
- }
-
- /* terminate the block */
- Compile_ByteCode_Ptr->bc_main_type = 0;
- branch = This_Compile_Block;
-
- /* Try to save some space by using the cached blocks. */
- if (Compile_ByteCode_Ptr == branch + 1)
- {
- mtype = branch->bc_main_type;
- if (((mtype == _SLANG_BC_BREAK)
- || (mtype == _SLANG_BC_CONTINUE)
- || (mtype == _SLANG_BC_RETURN))
- && (SLang_Error == 0))
- {
- SLfree ((char *)branch);
- branch = SLShort_Blocks + 2 * (int) (mtype - _SLANG_BC_RETURN);
- }
- }
-
-#if USE_COMBINED_BYTECODES
- optimize_block (branch);
-#endif
-
- pop_block_context ();
- node = Compile_ByteCode_Ptr++;
-
- node->bc_main_type = _SLANG_BC_BLOCK;
- node->bc_sub_type = 0;
- node->b.blk = branch;
-}
-
-static int lang_begin_block (void)
-{
- return push_block_context (COMPILE_BLOCK_TYPE_BLOCK);
-}
-
-static int lang_check_space (void)
-{
- unsigned int n;
- SLBlock_Type *p;
-
- if (NULL == (p = This_Compile_Block))
- {
- SLang_verror (SL_INTERNAL_ERROR, "Top-level block not present");
- return -1;
- }
-
- /* Allow 1 extra for terminator */
- if (Compile_ByteCode_Ptr + 1 < This_Compile_Block_Max)
- return 0;
-
- n = (unsigned int) (This_Compile_Block_Max - p);
-
- /* enlarge the space by 2 objects */
- n += 2;
-
- if (NULL == (p = (SLBlock_Type *) SLrealloc((char *)p, n * sizeof(SLBlock_Type))))
- return -1;
-
- This_Compile_Block_Max = p + n;
- n = (unsigned int) (Compile_ByteCode_Ptr - This_Compile_Block);
- This_Compile_Block = p;
- Compile_ByteCode_Ptr = p + n;
-
- return 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;
-
- if (-1 == init_interpreter ())
- return -1;
-
- t = locate_namespace_encoded_name (name, 0);
- if (t == NULL)
- return 0;
-
- switch (t->name_type)
- {
- case SLANG_FUNCTION:
- /* case SLANG_PFUNCTION: */
- return 2;
- case SLANG_GVARIABLE:
- /* case SLANG_PVARIABLE: */
- return -2;
-
- case SLANG_ICONSTANT:
- case SLANG_DCONSTANT:
- case SLANG_RVARIABLE:
- case SLANG_IVARIABLE:
- return -1;
-
- case SLANG_INTRINSIC:
- default:
- return 1;
- }
-}
-
-static int add_global_variable (char *name, char name_type, unsigned long hash,
- SLang_NameSpace_Type *ns)
-{
- SLang_Name_Type *g;
-
- /* 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;"); }
- */
- /* hash = _SLcompute_string_hash (name); */
- g = locate_name_in_table (name, hash, ns->table, ns->table_size);
-
- if (g != NULL)
- {
- if (g->name_type == name_type)
- return 0;
- }
-
- if (NULL == add_global_name (name, hash, name_type,
- sizeof (SLang_Global_Var_Type), ns))
- return -1;
-
- return 0;
-}
-
-int SLadd_global_variable (char *name)
-{
- if (-1 == init_interpreter ())
- return -1;
-
- return add_global_variable (name, SLANG_GVARIABLE,
- _SLcompute_string_hash (name),
- Global_NameSpace);
-}
-
-static int add_local_variable (char *name, unsigned long hash)
-{
- SLang_Local_Var_Type *t;
-
- /* local variable */
- if (Local_Variable_Number >= SLANG_MAX_LOCAL_VARIABLES)
- {
- SLang_verror (SL_SYNTAX_ERROR, "Too many local variables");
- return -1;
- }
-
- if (NULL != locate_name_in_table (name, hash, Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE))
- {
- SLang_verror (SL_SYNTAX_ERROR, "Local variable %s has already been defined", name);
- return -1;
- }
-
- t = (SLang_Local_Var_Type *)
- add_name_to_hash_table (name, hash,
- sizeof (SLang_Local_Var_Type), SLANG_LVARIABLE,
- Locals_Hash_Table, SLLOCALS_HASH_TABLE_SIZE, 0);
- if (t == NULL)
- return -1;
-
- t->local_var_number = Local_Variable_Number;
- Local_Variable_Number++;
- return 0;
-}
-
-static void (*Compile_Mode_Function) (_SLang_Token_Type *);
-static void compile_basic_token_mode (_SLang_Token_Type *);
-
-/* if an error occurs, discard current object, block, function, etc... */
-void SLang_restart (int localv)
-{
- int save = SLang_Error;
-
- SLang_Error = SL_UNKNOWN_ERROR;
-
- _SLcompile_ptr = _SLcompile;
- Compile_Mode_Function = compile_basic_token_mode;
-
- Lang_Break = /* Lang_Continue = */ Lang_Return = 0;
- Trace_Mode = 0;
-
- while (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK)
- lang_end_block();
-
- if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_FUNCTION)
- {
- /* Terminate function definition and free variables */
- lang_define_function (NULL, SLANG_FUNCTION, 0, Global_NameSpace);
- if (lang_free_branch (This_Compile_Block))
- SLfree((char *)This_Compile_Block);
- }
- Lang_Defining_Function = 0;
-
- SLang_Error = save;
-
- if (SLang_Error == SL_STACK_OVERFLOW)
- {
- /* This loop guarantees that the stack is properly cleaned. */
- while (_SLStack_Pointer != _SLRun_Stack)
- {
- SLdo_pop ();
- }
- }
-
- while ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
- && (0 == pop_block_context ()))
- ;
-
- if (localv)
- {
- Next_Function_Num_Args = SLang_Num_Function_Args = 0;
- Local_Variable_Frame = Local_Variable_Stack;
- Recursion_Depth = 0;
- Frame_Pointer = _SLStack_Pointer;
- Frame_Pointer_Depth = 0;
- Switch_Obj_Ptr = Switch_Objects;
- while (Switch_Obj_Ptr < Switch_Obj_Max)
- {
- SLang_free_object (Switch_Obj_Ptr);
- Switch_Obj_Ptr++;
- }
- Switch_Obj_Ptr = Switch_Objects;
- }
-}
-
-static void compile_directive (unsigned char sub_type)
-{
- /* This function is called only from compile_directive_mode which is
- * only possible when a block is available.
- */
-
- /* use BLOCK */
- Compile_ByteCode_Ptr--;
- Compile_ByteCode_Ptr->bc_sub_type = sub_type;
-
- lang_try_now ();
-}
-
-static void compile_unary (int op, unsigned char mt)
-{
- Compile_ByteCode_Ptr->bc_main_type = mt;
- Compile_ByteCode_Ptr->b.i_blk = op;
- Compile_ByteCode_Ptr->bc_sub_type = 0;
-
- lang_try_now ();
-}
-
-
-static void compile_binary (int op)
-{
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_BINARY;
- Compile_ByteCode_Ptr->b.i_blk = op;
- Compile_ByteCode_Ptr->bc_sub_type = 0;
-
- lang_try_now ();
-}
-
-#if _SLANG_OPTIMIZE_FOR_SPEED
-static int try_compressed_bytecode (unsigned char last_bc, unsigned char bc)
-{
- if (Compile_ByteCode_Ptr != This_Compile_Block)
- {
- SLBlock_Type *b;
- b = Compile_ByteCode_Ptr - 1;
- if (b->bc_main_type == last_bc)
- {
- Compile_ByteCode_Ptr = b;
- b->bc_main_type = bc;
- lang_try_now ();
- return 0;
- }
- }
- return -1;
-}
-#endif
-
-static void compile_fast_binary (int op, unsigned char bc)
-{
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (0 == try_compressed_bytecode (_SLANG_BC_LITERAL_INT, bc))
- return;
-#else
- (void) bc;
-#endif
- compile_binary (op);
-}
-
-/* This is a hack */
-typedef struct _Special_NameTable_Type
-{
- char *name;
- int (*fun) (struct _Special_NameTable_Type *, _SLang_Token_Type *);
- VOID_STAR blk_data;
- unsigned char main_type;
-}
-Special_NameTable_Type;
-
-static int handle_special (Special_NameTable_Type *nt, _SLang_Token_Type *tok)
-{
- (void) tok;
- Compile_ByteCode_Ptr->bc_main_type = nt->main_type;
- Compile_ByteCode_Ptr->b.ptr_blk = nt->blk_data;
- return 0;
-}
-
-static int handle_special_file (Special_NameTable_Type *nt, _SLang_Token_Type *tok)
-{
- char *name;
-
- (void) nt; (void) tok;
-
- if (This_Static_NameSpace == NULL) name = "***Unknown***";
- else
- name = This_Static_NameSpace->name;
-
- name = SLang_create_slstring (name);
- if (name == NULL)
- return -1;
-
- Compile_ByteCode_Ptr->b.s_blk = name;
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR;
- Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE;
- return 0;
-}
-
-static int handle_special_line (Special_NameTable_Type *nt, _SLang_Token_Type *tok)
-{
- (void) nt;
-
-#if _SLANG_HAS_DEBUG_CODE
- Compile_ByteCode_Ptr->b.l_blk = (long) tok->line_number;
-#endif
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL;
- Compile_ByteCode_Ptr->bc_sub_type = SLANG_UINT_TYPE;
-
- return 0;
-}
-
-static Special_NameTable_Type Special_Name_Table [] =
-{
- {"EXECUTE_ERROR_BLOCK", handle_special, NULL, _SLANG_BC_X_ERROR},
- {"X_USER_BLOCK0", handle_special, NULL, _SLANG_BC_X_USER0},
- {"X_USER_BLOCK1", handle_special, NULL, _SLANG_BC_X_USER1},
- {"X_USER_BLOCK2", handle_special, NULL, _SLANG_BC_X_USER2},
- {"X_USER_BLOCK3", handle_special, NULL, _SLANG_BC_X_USER3},
- {"X_USER_BLOCK4", handle_special, NULL, _SLANG_BC_X_USER4},
- {"__FILE__", handle_special_file, NULL, 0},
- {"__LINE__", handle_special_line, NULL, 0},
-#if 0
- {"__NAMESPACE__", handle_special_namespace, NULL, 0},
-#endif
- {NULL, NULL, NULL, 0}
-};
-
-static void compile_hashed_identifier (char *name, unsigned long hash, _SLang_Token_Type *tok)
-{
- SLang_Name_Type *entry;
- unsigned char name_type;
-
- entry = locate_hashed_name (name, hash);
-
- if (entry == NULL)
- {
- Special_NameTable_Type *nt = Special_Name_Table;
-
- while (nt->name != NULL)
- {
- if (strcmp (name, nt->name))
- {
- nt++;
- continue;
- }
-
- if (0 == (*nt->fun)(nt, tok))
- lang_try_now ();
- return;
- }
-
- SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
- return;
- }
-
- name_type = entry->name_type;
- Compile_ByteCode_Ptr->bc_main_type = name_type;
-
- if (name_type == SLANG_LVARIABLE)
- Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number;
- else
- Compile_ByteCode_Ptr->b.nt_blk = entry;
-
- lang_try_now ();
-}
-
-static void compile_tmp_variable (char *name, unsigned long hash)
-{
- SLang_Name_Type *entry;
- unsigned char name_type;
-
- if (NULL == (entry = locate_hashed_name (name, hash)))
- {
- SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
- return;
- }
-
- name_type = entry->name_type;
- switch (name_type)
- {
- case SLANG_LVARIABLE:
- Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number;
- break;
-
- case SLANG_GVARIABLE:
- case SLANG_PVARIABLE:
- Compile_ByteCode_Ptr->b.nt_blk = entry;
- break;
-
- default:
- SLang_verror (SL_SYNTAX_ERROR, "__tmp(%s) does not specifiy a variable", name);
- return;
- }
-
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_TMP;
- Compile_ByteCode_Ptr->bc_sub_type = name_type;
-
- lang_try_now ();
-}
-
-static void compile_simple (unsigned char main_type)
-{
- Compile_ByteCode_Ptr->bc_main_type = main_type;
- Compile_ByteCode_Ptr->bc_sub_type = 0;
- Compile_ByteCode_Ptr->b.blk = NULL;
- lang_try_now ();
-}
-
-static void compile_identifier (char *name, _SLang_Token_Type *tok)
-{
- compile_hashed_identifier (name, _SLcompute_string_hash (name), tok);
-}
-
-static void compile_call_direct (int (*f) (void), unsigned char byte_code)
-{
- Compile_ByteCode_Ptr->b.call_function = f;
- Compile_ByteCode_Ptr->bc_main_type = byte_code;
- Compile_ByteCode_Ptr->bc_sub_type = 0;
- lang_try_now ();
-}
-
-static void compile_lvar_call_direct (int (*f)(void), unsigned char bc,
- unsigned char frame_op)
-{
-#if _SLANG_OPTIMIZE_FOR_SPEED
- if (0 == try_compressed_bytecode (_SLANG_BC_LVARIABLE, bc))
- return;
-#else
- (void) bc;
-#endif
-
- compile_call_direct (f, frame_op);
-}
-
-static void compile_integer (long i, unsigned char bc_main_type, unsigned char bc_sub_type)
-{
- Compile_ByteCode_Ptr->b.l_blk = i;
- Compile_ByteCode_Ptr->bc_main_type = bc_main_type;
- Compile_ByteCode_Ptr->bc_sub_type = bc_sub_type;
-
- lang_try_now ();
-}
-
-#if SLANG_HAS_FLOAT
-static void compile_double (char *str, unsigned char type)
-{
- double d;
- unsigned int factor = 1;
- double *ptr;
-
-#if 1
- d = _SLang_atof (str);
-#else
- if (1 != sscanf (str, "%lf", &d))
- {
- SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to double", str);
- return;
- }
-#endif
-
-#if SLANG_HAS_COMPLEX
- if (type == SLANG_COMPLEX_TYPE) factor = 2;
-#endif
- if (NULL == (ptr = (double *) SLmalloc(factor * sizeof(double))))
- return;
-
- Compile_ByteCode_Ptr->b.double_blk = ptr;
-#if SLANG_HAS_COMPLEX
- if (type == SLANG_COMPLEX_TYPE)
- *ptr++ = 0;
-#endif
- *ptr = d;
-
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL;
- Compile_ByteCode_Ptr->bc_sub_type = type;
- lang_try_now ();
-}
-
-static void compile_float (char *s)
-{
- float x;
-
-#if 1
- x = (float) _SLang_atof (s);
-#else
- if (1 != sscanf (s, "%f", &x))
- {
- SLang_verror (SL_SYNTAX_ERROR, "Unable to convert %s to float", s);
- return;
- }
-#endif
- Compile_ByteCode_Ptr->b.float_blk = x;
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL;
- Compile_ByteCode_Ptr->bc_sub_type = SLANG_FLOAT_TYPE;
- lang_try_now ();
-}
-
-#endif
-
-static void compile_string (char *s, unsigned long hash)
-{
- if (NULL == (Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (s, hash)))
- return;
-
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL_STR;
- Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE;
-
- lang_try_now ();
-}
-
-static void compile_bstring (SLang_BString_Type *s)
-{
- if (NULL == (Compile_ByteCode_Ptr->b.bs_blk = SLbstring_dup (s)))
- return;
-
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LITERAL;
- Compile_ByteCode_Ptr->bc_sub_type = SLANG_BSTRING_TYPE;
-
- lang_try_now ();
-}
-
-/* assign_type is one of _SLANG_BCST_ASSIGN, ... values */
-static void compile_assign (unsigned char assign_type,
- char *name, unsigned long hash)
-{
- SLang_Name_Type *v;
- unsigned char main_type;
- SLang_Class_Type *cl;
-
- v = locate_hashed_name (name, hash);
- if (v == NULL)
- {
- if ((_SLang_Auto_Declare_Globals == 0)
- || (NULL != strchr (name, '-')) /* namespace->name form */
- || Lang_Defining_Function
- || (assign_type != _SLANG_BCST_ASSIGN)
- || (This_Static_NameSpace == NULL))
- {
- SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
- return;
- }
- /* Note that function local variables are not at top level */
-
- /* Variables that are automatically declared are given static
- * scope.
- */
- if ((NULL != SLang_Auto_Declare_Var_Hook)
- && (-1 == (*SLang_Auto_Declare_Var_Hook) (name)))
- return;
-
- if ((-1 == add_global_variable (name, SLANG_GVARIABLE, hash, This_Static_NameSpace))
- || (NULL == (v = locate_hashed_name (name, hash))))
- return;
- }
-
- switch (v->name_type)
- {
- case SLANG_LVARIABLE:
- main_type = _SLANG_BC_SET_LOCAL_LVALUE;
- Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number;
- break;
-
- case SLANG_GVARIABLE:
- case SLANG_PVARIABLE:
- main_type = _SLANG_BC_SET_GLOBAL_LVALUE;
- Compile_ByteCode_Ptr->b.nt_blk = v;
- break;
-
- case SLANG_IVARIABLE:
- cl = _SLclass_get_class (((SLang_Intrin_Var_Type *)v)->type);
- if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR)
- {
- SLang_verror (SL_SYNTAX_ERROR, "Assignment to %s is not allowed", name);
- return;
- }
- main_type = _SLANG_BC_SET_INTRIN_LVALUE;
- Compile_ByteCode_Ptr->b.nt_blk = v;
- break;
-
- case SLANG_RVARIABLE:
- SLang_verror (SL_READONLY_ERROR, "%s is read-only", name);
- return;
-
- default:
- SLang_verror (SL_DUPLICATE_DEFINITION, "%s may not be used as an lvalue", name);
- return;
- }
-
- Compile_ByteCode_Ptr->bc_sub_type = assign_type;
- Compile_ByteCode_Ptr->bc_main_type = main_type;
-
- lang_try_now ();
-}
-
-static void compile_deref_assign (char *name, unsigned long hash)
-{
- SLang_Name_Type *v;
-
- v = locate_hashed_name (name, hash);
-
- if (v == NULL)
- {
- SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
- return;
- }
-
- switch (v->name_type)
- {
- case SLANG_LVARIABLE:
- Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number;
- break;
-
- case SLANG_GVARIABLE:
- case SLANG_PVARIABLE:
- Compile_ByteCode_Ptr->b.nt_blk = v;
- break;
-
- default:
- /* FIXME: Priority=low
- * This could be made to work. It is not a priority because
- * I cannot imagine application intrinsics which are references.
- */
- SLang_verror (SL_NOT_IMPLEMENTED, "Deref assignment to %s is not allowed", name);
- return;
- }
-
- Compile_ByteCode_Ptr->bc_sub_type = v->name_type;
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_DEREF_ASSIGN;
-
- lang_try_now ();
-}
-
-static void
-compile_struct_assign (_SLang_Token_Type *t)
-{
- Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _STRUCT_ASSIGN_TOKEN);
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_STRUCT_LVALUE;
- Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string (t->v.s_val, t->hash);
- lang_try_now ();
-}
-
-static void
-compile_array_assign (_SLang_Token_Type *t)
-{
- Compile_ByteCode_Ptr->bc_sub_type = _SLANG_BCST_ASSIGN + (t->type - _ARRAY_ASSIGN_TOKEN);
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_SET_ARRAY_LVALUE;
- Compile_ByteCode_Ptr->b.s_blk = NULL;
- lang_try_now ();
-}
-
-static void compile_dot(_SLang_Token_Type *t)
-{
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_FIELD;
- Compile_ByteCode_Ptr->b.s_blk = _SLstring_dup_hashed_string(t->v.s_val, t->hash);
- lang_try_now ();
-}
-
-static void compile_ref (char *name, unsigned long hash)
-{
- SLang_Name_Type *entry;
- unsigned char main_type;
-
- if (NULL == (entry = locate_hashed_name (name, hash)))
- {
- SLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
- return;
- }
-
- main_type = entry->name_type;
-
- if (main_type == SLANG_LVARIABLE)
- {
- main_type = _SLANG_BC_LOBJPTR;
- Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *)entry)->local_var_number;
- }
- else
- {
- main_type = _SLANG_BC_GOBJPTR;
- Compile_ByteCode_Ptr->b.nt_blk = entry;
- }
-
- Compile_ByteCode_Ptr->bc_main_type = main_type;
- lang_try_now ();
-}
-
-static void compile_break (unsigned char break_type,
- int requires_block, int requires_fun,
- char *str)
-{
- if ((requires_fun
- && (Lang_Defining_Function == 0))
- || (requires_block
- && (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK)))
- {
- SLang_verror (SL_SYNTAX_ERROR, "misplaced %s", str);
- return;
- }
-
- Compile_ByteCode_Ptr->bc_main_type = break_type;
- Compile_ByteCode_Ptr->bc_sub_type = 0;
-
- lang_try_now ();
-}
-
-static void compile_public_variable_mode (_SLang_Token_Type *t)
-{
- if (t->type == IDENT_TOKEN)
- {
- /* If the variable is already defined in the static hash table,
- * generate an error.
- */
- if ((This_Static_NameSpace != NULL)
- && (NULL != locate_name_in_table (t->v.s_val, t->hash, This_Static_NameSpace->table, This_Static_NameSpace->table_size)))
- {
- SLang_verror (SL_DUPLICATE_DEFINITION,
- "%s already has static or private linkage in this unit",
- t->v.s_val);
- return;
- }
- add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, Global_NameSpace);
- }
- else if (t->type == CBRACKET_TOKEN)
- Compile_Mode_Function = compile_basic_token_mode;
- else
- SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
-}
-
-static void compile_local_variable_mode (_SLang_Token_Type *t)
-{
- if (t->type == IDENT_TOKEN)
- add_local_variable (t->v.s_val, t->hash);
- else if (t->type == CBRACKET_TOKEN)
- Compile_Mode_Function = compile_basic_token_mode;
- else
- SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
-}
-
-static void compile_static_variable_mode (_SLang_Token_Type *t)
-{
- if (t->type == IDENT_TOKEN)
- add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, This_Static_NameSpace);
- else if (t->type == CBRACKET_TOKEN)
- Compile_Mode_Function = compile_basic_token_mode;
- else
- SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
-}
-
-static void compile_private_variable_mode (_SLang_Token_Type *t)
-{
- if (t->type == IDENT_TOKEN)
- add_global_variable (t->v.s_val, SLANG_PVARIABLE, t->hash, This_Static_NameSpace);
- else if (t->type == CBRACKET_TOKEN)
- Compile_Mode_Function = compile_basic_token_mode;
- else
- SLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
-}
-
-static void compile_function_mode (_SLang_Token_Type *t)
-{
- if (-1 == lang_check_space ())
- return;
-
- if (t->type != IDENT_TOKEN)
- SLang_verror (SL_SYNTAX_ERROR, "Expecting function name");
- else
- lang_define_function (t->v.s_val, SLANG_FUNCTION, t->hash, Global_NameSpace);
-
- Compile_Mode_Function = compile_basic_token_mode;
-}
-
-/* An error block is not permitted to contain continue or break statements.
- * This restriction may be removed later but for now reject them.
- */
-static int check_error_block (void)
-{
- SLBlock_Type *p;
- unsigned char t;
-
- /* Back up to the block and then scan it. */
- p = (Compile_ByteCode_Ptr - 1)->b.blk;
-
- while (0 != (t = p->bc_main_type))
- {
- if ((t == _SLANG_BC_BREAK)
- || (t == _SLANG_BC_CONTINUE))
- {
- SLang_verror (SL_SYNTAX_ERROR,
- "An ERROR_BLOCK is not permitted to contain continue or break statements");
- return -1;
- }
- p++;
- }
- return 0;
-}
-
-/* The only allowed tokens are the directives and another block start.
- * The mode is only active if a block is available. The inner_interp routine
- * expects such safety checks.
- */
-static void compile_directive_mode (_SLang_Token_Type *t)
-{
- int bc_sub_type;
-
- if (-1 == lang_check_space ())
- return;
-
- bc_sub_type = -1;
-
- switch (t->type)
- {
- case FOREVER_TOKEN:
- bc_sub_type = _SLANG_BCST_FOREVER;
- break;
-
- case IFNOT_TOKEN:
- bc_sub_type = _SLANG_BCST_IFNOT;
- break;
-
- case IF_TOKEN:
- bc_sub_type = _SLANG_BCST_IF;
- break;
-
- case ANDELSE_TOKEN:
- bc_sub_type = _SLANG_BCST_ANDELSE;
- break;
-
- case SWITCH_TOKEN:
- bc_sub_type = _SLANG_BCST_SWITCH;
- break;
-
- case EXITBLK_TOKEN:
- if (Lang_Defining_Function == 0)
- {
- SLang_verror (SL_SYNTAX_ERROR, "misplaced EXIT_BLOCK");
- break;
- }
- bc_sub_type = _SLANG_BCST_EXIT_BLOCK;
- break;
-
- case ERRBLK_TOKEN:
- if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL)
- {
- SLang_verror (SL_SYNTAX_ERROR, "misplaced ERROR_BLOCK");
- break;
- }
- if (0 == check_error_block ())
- bc_sub_type = _SLANG_BCST_ERROR_BLOCK;
- break;
-
- case USRBLK0_TOKEN:
- case USRBLK1_TOKEN:
- case USRBLK2_TOKEN:
- case USRBLK3_TOKEN:
- case USRBLK4_TOKEN:
- if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL)
- {
- SLang_verror (SL_SYNTAX_ERROR, "misplaced USER_BLOCK");
- break;
- }
- bc_sub_type = _SLANG_BCST_USER_BLOCK0 + (t->type - USRBLK0_TOKEN);
- break;
-
- case NOTELSE_TOKEN:
- bc_sub_type = _SLANG_BCST_NOTELSE;
- break;
-
- case ELSE_TOKEN:
- bc_sub_type = _SLANG_BCST_ELSE;
- break;
-
- case LOOP_TOKEN:
- bc_sub_type = _SLANG_BCST_LOOP;
- break;
-
- case DOWHILE_TOKEN:
- bc_sub_type = _SLANG_BCST_DOWHILE;
- break;
-
- case WHILE_TOKEN:
- bc_sub_type = _SLANG_BCST_WHILE;
- break;
-
- case ORELSE_TOKEN:
- bc_sub_type = _SLANG_BCST_ORELSE;
- break;
-
- case _FOR_TOKEN:
- bc_sub_type = _SLANG_BCST_FOR;
- break;
-
- case FOR_TOKEN:
- bc_sub_type = _SLANG_BCST_CFOR;
- break;
-
- case FOREACH_TOKEN:
- bc_sub_type = _SLANG_BCST_FOREACH;
- break;
-
- case OBRACE_TOKEN:
- lang_begin_block ();
- break;
-
- default:
- SLang_verror (SL_SYNTAX_ERROR, "Expecting directive token. Found 0x%X", t->type);
- break;
- }
-
- /* Reset this pointer first because compile_directive may cause a
- * file to be loaded.
- */
- Compile_Mode_Function = compile_basic_token_mode;
-
- if (bc_sub_type != -1)
- compile_directive (bc_sub_type);
-}
-
-static unsigned int Assign_Mode_Type;
-static void compile_assign_mode (_SLang_Token_Type *t)
-{
- if (t->type != IDENT_TOKEN)
- {
- SLang_verror (SL_SYNTAX_ERROR, "Expecting identifier for assignment");
- return;
- }
-
- compile_assign (Assign_Mode_Type, t->v.s_val, t->hash);
- Compile_Mode_Function = compile_basic_token_mode;
-}
-
-static void compile_basic_token_mode (_SLang_Token_Type *t)
-{
- if (-1 == lang_check_space ())
- return;
-
- switch (t->type)
- {
- case PUSH_TOKEN:
- case NOP_TOKEN:
- case EOF_TOKEN:
- case READONLY_TOKEN:
- case DO_TOKEN:
- case VARIABLE_TOKEN:
- case SEMICOLON_TOKEN:
- default:
- SLang_verror (SL_SYNTAX_ERROR, "Unknown or unsupported token type 0x%X", t->type);
- break;
-
- case DEREF_TOKEN:
- compile_call_direct (dereference_object, _SLANG_BC_CALL_DIRECT);
- break;
-
- case STRUCT_TOKEN:
- compile_call_direct (_SLstruct_define_struct, _SLANG_BC_CALL_DIRECT);
- break;
-
- case TYPEDEF_TOKEN:
- compile_call_direct (_SLstruct_define_typedef, _SLANG_BC_CALL_DIRECT);
- break;
-
- case TMP_TOKEN:
- compile_tmp_variable (t->v.s_val, t->hash);
- break;
-
- case DOT_TOKEN: /* X . field */
- compile_dot (t);
- break;
-
- case COMMA_TOKEN:
- break; /* do nothing */
-
- case IDENT_TOKEN:
- compile_hashed_identifier (t->v.s_val, t->hash, t);
- break;
-
- case _REF_TOKEN:
- compile_ref (t->v.s_val, t->hash);
- break;
-
- case ARG_TOKEN:
- compile_call_direct (SLang_start_arg_list, _SLANG_BC_CALL_DIRECT);
- break;
-
- case EARG_TOKEN:
- compile_lvar_call_direct (SLang_end_arg_list, _SLANG_BC_EARG_LVARIABLE, _SLANG_BC_CALL_DIRECT);
- break;
-
- case COLON_TOKEN:
- if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK)
- compile_simple (_SLANG_BC_LABEL);
- else SLang_Error = SL_SYNTAX_ERROR;
- break;
-
- case POP_TOKEN:
- compile_call_direct (SLdo_pop, _SLANG_BC_CALL_DIRECT);
- break;
-
- case CASE_TOKEN:
- if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK)
- SLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case'");
- else
- compile_call_direct (case_function, _SLANG_BC_CALL_DIRECT);
- break;
-
- case CHAR_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_CHAR_TYPE);
- break;
- case SHORT_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_SHORT_TYPE);
- break;
- case INT_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_INT_TYPE);
- break;
- case UCHAR_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_UCHAR_TYPE);
- break;
- case USHORT_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_USHORT_TYPE);
- break;
- case UINT_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL_INT, SLANG_UINT_TYPE);
- break;
- case LONG_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_LONG_TYPE);
- break;
- case ULONG_TOKEN:
- compile_integer (t->v.long_val, _SLANG_BC_LITERAL, SLANG_ULONG_TYPE);
- break;
-
-#if SLANG_HAS_FLOAT
- case FLOAT_TOKEN:
- compile_float (t->v.s_val);
- break;
-
- case DOUBLE_TOKEN:
- compile_double (t->v.s_val, SLANG_DOUBLE_TYPE);
- break;
-#endif
-#if SLANG_HAS_COMPLEX
- case COMPLEX_TOKEN:
- compile_double (t->v.s_val, SLANG_COMPLEX_TYPE);
- break;
-#endif
-
- case STRING_TOKEN:
- compile_string (t->v.s_val, t->hash);
- break;
-
- case _BSTRING_TOKEN:
- compile_bstring (SLbstring_create ((unsigned char *)t->v.s_val, (unsigned int) t->hash));
- break;
-
- case BSTRING_TOKEN:
- compile_bstring (t->v.b_val);
- break;
-
- case _NULL_TOKEN:
- compile_identifier ("NULL", t);
- break;
-
- case _INLINE_WILDCARD_ARRAY_TOKEN:
- compile_call_direct (_SLarray_wildcard_array, _SLANG_BC_CALL_DIRECT);
- break;
-
- case _INLINE_ARRAY_TOKEN:
- compile_call_direct (_SLarray_inline_array, _SLANG_BC_CALL_DIRECT_FRAME);
- break;
-
- case _INLINE_IMPLICIT_ARRAY_TOKEN:
- compile_call_direct (_SLarray_inline_implicit_array, _SLANG_BC_CALL_DIRECT_FRAME);
- break;
-
- case ARRAY_TOKEN:
- compile_lvar_call_direct (_SLarray_aget, _SLANG_BC_LVARIABLE_AGET, _SLANG_BC_CALL_DIRECT_FRAME);
- break;
-
- /* Note: I need to add the other _ARRAY assign tokens. */
- case _ARRAY_PLUSEQS_TOKEN:
- case _ARRAY_MINUSEQS_TOKEN:
- case _ARRAY_TIMESEQS_TOKEN:
- case _ARRAY_DIVEQS_TOKEN:
- case _ARRAY_BOREQS_TOKEN:
- case _ARRAY_BANDEQS_TOKEN:
- case _ARRAY_POST_MINUSMINUS_TOKEN:
- case _ARRAY_MINUSMINUS_TOKEN:
- case _ARRAY_POST_PLUSPLUS_TOKEN:
- case _ARRAY_PLUSPLUS_TOKEN:
- compile_array_assign (t);
- break;
-
- case _ARRAY_ASSIGN_TOKEN:
- compile_lvar_call_direct (_SLarray_aput, _SLANG_BC_LVARIABLE_APUT, _SLANG_BC_CALL_DIRECT_FRAME);
- break;
-
- case _STRUCT_ASSIGN_TOKEN:
- case _STRUCT_PLUSEQS_TOKEN:
- case _STRUCT_MINUSEQS_TOKEN:
- case _STRUCT_TIMESEQS_TOKEN:
- case _STRUCT_DIVEQS_TOKEN:
- case _STRUCT_BOREQS_TOKEN:
- case _STRUCT_BANDEQS_TOKEN:
- case _STRUCT_POST_MINUSMINUS_TOKEN:
- case _STRUCT_MINUSMINUS_TOKEN:
- case _STRUCT_POST_PLUSPLUS_TOKEN:
- case _STRUCT_PLUSPLUS_TOKEN:
- compile_struct_assign (t);
- break;
-
- case _SCALAR_ASSIGN_TOKEN:
- case _SCALAR_PLUSEQS_TOKEN:
- case _SCALAR_MINUSEQS_TOKEN:
- case _SCALAR_TIMESEQS_TOKEN:
- case _SCALAR_DIVEQS_TOKEN:
- case _SCALAR_BOREQS_TOKEN:
- case _SCALAR_BANDEQS_TOKEN:
- case _SCALAR_POST_MINUSMINUS_TOKEN:
- case _SCALAR_MINUSMINUS_TOKEN:
- case _SCALAR_POST_PLUSPLUS_TOKEN:
- case _SCALAR_PLUSPLUS_TOKEN:
- compile_assign (_SLANG_BCST_ASSIGN + (t->type - _SCALAR_ASSIGN_TOKEN),
- t->v.s_val, t->hash);
- break;
-
- case _DEREF_ASSIGN_TOKEN:
- compile_deref_assign (t->v.s_val, t->hash);
- break;
-
- /* For processing RPN tokens */
- case ASSIGN_TOKEN:
- case PLUSEQS_TOKEN:
- case MINUSEQS_TOKEN:
- case TIMESEQS_TOKEN:
- case DIVEQS_TOKEN:
- case BOREQS_TOKEN:
- case BANDEQS_TOKEN:
- case POST_MINUSMINUS_TOKEN:
- case MINUSMINUS_TOKEN:
- case POST_PLUSPLUS_TOKEN:
- case PLUSPLUS_TOKEN:
- Compile_Mode_Function = compile_assign_mode;
- Assign_Mode_Type = _SLANG_BCST_ASSIGN + (t->type - ASSIGN_TOKEN);
- break;
-
- case LT_TOKEN:
- compile_binary (SLANG_LT);
- break;
-
- case LE_TOKEN:
- compile_binary (SLANG_LE);
- break;
-
- case GT_TOKEN:
- compile_binary (SLANG_GT);
- break;
-
- case GE_TOKEN:
- compile_binary (SLANG_GE);
- break;
-
- case EQ_TOKEN:
- compile_binary (SLANG_EQ);
- break;
-
- case NE_TOKEN:
- compile_binary (SLANG_NE);
- break;
-
- case AND_TOKEN:
- compile_binary (SLANG_AND);
- break;
-
- case ADD_TOKEN:
- compile_fast_binary (SLANG_PLUS, _SLANG_BC_INTEGER_PLUS);
- break;
-
- case SUB_TOKEN:
- compile_fast_binary (SLANG_MINUS, _SLANG_BC_INTEGER_MINUS);
- break;
-
- case TIMES_TOKEN:
- compile_binary (SLANG_TIMES);
- break;
-
- case DIV_TOKEN:
- compile_binary (SLANG_DIVIDE);
- break;
-
- case POW_TOKEN:
- compile_binary (SLANG_POW);
- break;
-
- case BXOR_TOKEN:
- compile_binary (SLANG_BXOR);
- break;
-
- case BAND_TOKEN:
- compile_binary (SLANG_BAND);
- break;
-
- case BOR_TOKEN:
- compile_binary (SLANG_BOR);
- break;
-
- case SHR_TOKEN:
- compile_binary (SLANG_SHR);
- break;
-
- case SHL_TOKEN:
- compile_binary (SLANG_SHL);
- break;
-
- case MOD_TOKEN:
- compile_binary (SLANG_MOD);
- break;
-
- case OR_TOKEN:
- compile_binary (SLANG_OR);
- break;
-
- case NOT_TOKEN:
- compile_unary (SLANG_NOT, _SLANG_BC_UNARY);
- break;
-
- case BNOT_TOKEN:
- compile_unary (SLANG_BNOT, _SLANG_BC_UNARY);
- break;
-
- case MUL2_TOKEN:
- compile_unary (SLANG_MUL2, _SLANG_BC_UNARY_FUNC);
- break;
-
- case CHS_TOKEN:
- compile_unary (SLANG_CHS, _SLANG_BC_UNARY_FUNC);
- break;
-
- case ABS_TOKEN:
- compile_unary (SLANG_ABS, _SLANG_BC_UNARY_FUNC);
- break;
-
- case SQR_TOKEN:
- compile_unary (SLANG_SQR, _SLANG_BC_UNARY_FUNC);
- break;
-
- case SIGN_TOKEN:
- compile_unary (SLANG_SIGN, _SLANG_BC_UNARY_FUNC);
- break;
-
- case BREAK_TOKEN:
- compile_break (_SLANG_BC_BREAK, 1, 0, "break");
- break;
-
- case RETURN_TOKEN:
- compile_break (_SLANG_BC_RETURN, 0, 1, "return");
- break;
-
- case CONT_TOKEN:
- compile_break (_SLANG_BC_CONTINUE, 1, 0, "continue");
- break;
-
- case EXCH_TOKEN:
- compile_break (_SLANG_BC_EXCH, 0, 0, ""); /* FIXME: Priority=low */
- break;
-
- case STATIC_TOKEN:
- if (Lang_Defining_Function == 0)
- Compile_Mode_Function = compile_static_variable_mode;
- else
- SLang_verror (SL_NOT_IMPLEMENTED, "static variables not permitted in functions");
- break;
-
- case PRIVATE_TOKEN:
- if (Lang_Defining_Function == 0)
- Compile_Mode_Function = compile_private_variable_mode;
- else
- SLang_verror (SL_NOT_IMPLEMENTED, "private variables not permitted in functions");
- break;
-
- case PUBLIC_TOKEN:
- if (Lang_Defining_Function == 0)
- Compile_Mode_Function = compile_public_variable_mode;
- else
- SLang_verror (SL_NOT_IMPLEMENTED, "public variables not permitted in functions");
- break;
-
- case OBRACKET_TOKEN:
- if (Lang_Defining_Function == 0)
- Compile_Mode_Function = Default_Variable_Mode;
- else
- Compile_Mode_Function = compile_local_variable_mode;
- break;
-
- case OPAREN_TOKEN:
- lang_begin_function ();
- break;
-
- case DEFINE_STATIC_TOKEN:
- if (Lang_Defining_Function)
- define_static_function (t->v.s_val, t->hash);
- else SLang_Error = SL_SYNTAX_ERROR;
- break;
-
- case DEFINE_PRIVATE_TOKEN:
- if (Lang_Defining_Function)
- define_private_function (t->v.s_val, t->hash);
- else SLang_Error = SL_SYNTAX_ERROR;
- break;
-
- case DEFINE_PUBLIC_TOKEN:
- if (Lang_Defining_Function)
- define_public_function (t->v.s_val, t->hash);
- else SLang_Error = SL_SYNTAX_ERROR;
- break;
-
- case DEFINE_TOKEN:
- if (Lang_Defining_Function)
- (*Default_Define_Function) (t->v.s_val, t->hash);
- else
- SLang_Error = SL_SYNTAX_ERROR;
- break;
-
- case CPAREN_TOKEN:
- if (Lang_Defining_Function)
- Compile_Mode_Function = compile_function_mode;
- else SLang_Error = SL_SYNTAX_ERROR;
- break;
-
- case CBRACE_TOKEN:
- lang_end_block ();
- Compile_Mode_Function = compile_directive_mode;
- break;
-
- case OBRACE_TOKEN:
- lang_begin_block ();
- break;
-
- case FARG_TOKEN:
- Function_Args_Number = Local_Variable_Number;
- break;
-
-#if _SLANG_HAS_DEBUG_CODE
- case LINE_NUM_TOKEN:
- Compile_ByteCode_Ptr->bc_main_type = _SLANG_BC_LINE_NUM;
- Compile_ByteCode_Ptr->b.l_blk = t->v.long_val;
- lang_try_now ();
- break;
-#endif
- case POUND_TOKEN:
- compile_call_direct (_SLarray_matrix_multiply, _SLANG_BC_CALL_DIRECT);
- break;
- }
-}
-
-void _SLcompile (_SLang_Token_Type *t)
-{
- if (SLang_Error == 0)
- {
- if (Compile_Mode_Function != compile_basic_token_mode)
- {
- if (Compile_Mode_Function == NULL)
- Compile_Mode_Function = compile_basic_token_mode;
-#if _SLANG_HAS_DEBUG_CODE
- if (t->type == LINE_NUM_TOKEN)
- {
- compile_basic_token_mode (t);
- return;
- }
-#endif
- }
-
- (*Compile_Mode_Function) (t);
- }
-
- if (SLang_Error)
- {
- Compile_Mode_Function = compile_basic_token_mode;
- SLang_restart (0);
- }
-}
-
-void (*_SLcompile_ptr)(_SLang_Token_Type *) = _SLcompile;
-
-typedef struct _Compile_Context_Type
-{
- struct _Compile_Context_Type *next;
- SLang_NameSpace_Type *static_namespace;
- void (*compile_variable_mode) (_SLang_Token_Type *);
- void (*define_function) (char *, unsigned long);
- int lang_defining_function;
- int local_variable_number;
- unsigned int function_args_number;
- SLang_Name_Type **locals_hash_table;
- void (*compile_mode_function)(_SLang_Token_Type *);
-#if _SLANG_HAS_DEBUG_CODE
- char *compile_filename;
-#endif
-}
-Compile_Context_Type;
-
-static Compile_Context_Type *Compile_Context_Stack;
-
-/* The only way the push/pop_context functions can get called is via
- * an eval type function. That can only happen when executed from a
- * top level block. This means that Compile_ByteCode_Ptr can always be
- * rest back to the beginning of a block.
- */
-
-static int pop_compile_context (void)
-{
- Compile_Context_Type *cc;
-
- if (NULL == (cc = Compile_Context_Stack))
- return -1;
-
- This_Static_NameSpace = cc->static_namespace;
- Compile_Context_Stack = cc->next;
- Default_Variable_Mode = cc->compile_variable_mode;
- Default_Define_Function = cc->define_function;
- Compile_Mode_Function = cc->compile_mode_function;
-
- Lang_Defining_Function = cc->lang_defining_function;
- Local_Variable_Number = cc->local_variable_number;
- Function_Args_Number = cc->function_args_number;
-
-#if _SLANG_HAS_DEBUG_CODE
- SLang_free_slstring (This_Compile_Filename);
- This_Compile_Filename = cc->compile_filename;
-#endif
-
- SLfree ((char *) Locals_Hash_Table);
- Locals_Hash_Table = cc->locals_hash_table;
-
- SLfree ((char *) cc);
-
- return 0;
-}
-
-static int push_compile_context (char *name)
-{
- Compile_Context_Type *cc;
- SLang_Name_Type **lns;
-
- cc = (Compile_Context_Type *)SLmalloc (sizeof (Compile_Context_Type));
- if (cc == NULL)
- return -1;
- memset ((char *) cc, 0, sizeof (Compile_Context_Type));
-
- lns = (SLang_Name_Type **) SLcalloc (sizeof (SLang_Name_Type *), SLLOCALS_HASH_TABLE_SIZE);
- if (lns == NULL)
- {
- SLfree ((char *) cc);
- return -1;
- }
-
-#if _SLANG_HAS_DEBUG_CODE
- if ((name != NULL)
- && (NULL == (name = SLang_create_slstring (name))))
- {
- SLfree ((char *) cc);
- SLfree ((char *) lns);
- return -1;
- }
-
- cc->compile_filename = This_Compile_Filename;
- This_Compile_Filename = name;
-#endif
-
- cc->static_namespace = This_Static_NameSpace;
- cc->compile_variable_mode = Default_Variable_Mode;
- cc->define_function = Default_Define_Function;
- cc->locals_hash_table = Locals_Hash_Table;
-
- cc->lang_defining_function = Lang_Defining_Function;
- cc->local_variable_number = Local_Variable_Number;
- cc->function_args_number = Function_Args_Number;
- cc->locals_hash_table = Locals_Hash_Table;
- cc->compile_mode_function = Compile_Mode_Function;
-
- cc->next = Compile_Context_Stack;
- Compile_Context_Stack = cc;
-
- Compile_Mode_Function = compile_basic_token_mode;
- Default_Variable_Mode = compile_public_variable_mode;
- Default_Define_Function = define_public_function;
- Lang_Defining_Function = 0;
- Local_Variable_Number = 0;
- Function_Args_Number = 0;
- Locals_Hash_Table = lns;
- return 0;
-}
-
-static int init_interpreter (void)
-{
- SLang_NameSpace_Type *ns;
-
- if (Global_NameSpace != NULL)
- return 0;
-
- if (NULL == (ns = _SLns_allocate_namespace ("***GLOBAL***", SLGLOBALS_HASH_TABLE_SIZE)))
- return -1;
- if (-1 == _SLns_set_namespace_name (ns, "Global"))
- return -1;
- Global_NameSpace = ns;
-
- _SLRun_Stack = (SLang_Object_Type *) SLcalloc (SLANG_MAX_STACK_LEN,
- sizeof (SLang_Object_Type));
- if (_SLRun_Stack == NULL)
- return -1;
-
- _SLStack_Pointer = _SLRun_Stack;
- _SLStack_Pointer_Max = _SLRun_Stack + SLANG_MAX_STACK_LEN;
-
- SLShort_Blocks[0].bc_main_type = _SLANG_BC_RETURN;
- SLShort_Blocks[2].bc_main_type = _SLANG_BC_BREAK;
- SLShort_Blocks[4].bc_main_type = _SLANG_BC_CONTINUE;
-
- Num_Args_Stack = (int *) SLmalloc (sizeof (int) * SLANG_MAX_RECURSIVE_DEPTH);
- if (Num_Args_Stack == NULL)
- {
- SLfree ((char *) _SLRun_Stack);
- return -1;
- }
- Recursion_Depth = 0;
- Frame_Pointer_Stack = (unsigned int *) SLmalloc (sizeof (unsigned int) * SLANG_MAX_RECURSIVE_DEPTH);
- if (Frame_Pointer_Stack == NULL)
- {
- SLfree ((char *) _SLRun_Stack);
- SLfree ((char *)Num_Args_Stack);
- return -1;
- }
- Frame_Pointer_Depth = 0;
- Frame_Pointer = _SLRun_Stack;
-
- Default_Variable_Mode = compile_public_variable_mode;
- Default_Define_Function = define_public_function;
- return 0;
-}
-
-static int add_generic_table (SLang_NameSpace_Type *ns,
- SLang_Name_Type *table, char *pp_name,
- unsigned int entry_len)
-{
- SLang_Name_Type *t, **ns_table;
- char *name;
- unsigned int table_size;
-
- if (-1 == init_interpreter ())
- return -1;
-
- if (ns == NULL)
- ns = Global_NameSpace;
-
- ns_table = ns->table;
- table_size = ns->table_size;
-
- if ((pp_name != NULL)
- && (-1 == SLdefine_for_ifdef (pp_name)))
- return -1;
-
- t = table;
- while (NULL != (name = t->name))
- {
- unsigned long hash;
-
- /* Backward compatibility: '.' WAS used as hash marker */
- if (*name == '.')
- {
- name++;
- t->name = name;
- }
-
- if (NULL == (name = SLang_create_slstring (name)))
- return -1;
-
- t->name = name;
-
- hash = _SLcompute_string_hash (name);
- hash = hash % table_size;
-
- t->next = ns_table [(unsigned int) hash];
- ns_table [(unsigned int) hash] = t;
-
- t = (SLang_Name_Type *) ((char *)t + entry_len);
- }
-
- return 0;
-}
-
-int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *tbl, char *pp)
-{
- return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type));
-}
-
-int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, char *pp)
-{
- return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type));
-}
-
-int SLadd_app_unary_table (SLang_App_Unary_Type *tbl, char *pp)
-{
- return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type));
-}
-
-int SLadd_math_unary_table (SLang_Math_Unary_Type *tbl, char *pp)
-{
- return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type));
-}
-
-int SLadd_iconstant_table (SLang_IConstant_Type *tbl, char *pp)
-{
- return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type));
-}
-
-#if SLANG_HAS_FLOAT
-int SLadd_dconstant_table (SLang_DConstant_Type *tbl, char *pp)
-{
- return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type));
-}
-#endif
-
-/* ----------- */
-int SLns_add_intrin_fun_table (SLang_NameSpace_Type *ns, SLang_Intrin_Fun_Type *tbl, char *pp)
-{
- return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type));
-}
-
-int SLns_add_intrin_var_table (SLang_NameSpace_Type *ns, SLang_Intrin_Var_Type *tbl, char *pp)
-{
- return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type));
-}
-
-int SLns_add_app_unary_table (SLang_NameSpace_Type *ns, SLang_App_Unary_Type *tbl, char *pp)
-{
- return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type));
-}
-
-int SLns_add_math_unary_table (SLang_NameSpace_Type *ns, SLang_Math_Unary_Type *tbl, char *pp)
-{
- return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type));
-}
-
-int SLns_add_iconstant_table (SLang_NameSpace_Type *ns, SLang_IConstant_Type *tbl, char *pp)
-{
- return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type));
-}
-
-#if SLANG_HAS_FLOAT
-int SLns_add_dconstant_table (SLang_NameSpace_Type *ns, SLang_DConstant_Type *tbl, char *pp)
-{
- return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type));
-}
-#endif
-
-/* what is a bitmapped value:
- * 1 intrin fun
- * 2 user fun
- * 4 intrin var
- * 8 user defined var
- */
-SLang_Array_Type *_SLang_apropos (char *namespace_name, char *pat, unsigned int what)
-{
- SLang_NameSpace_Type *ns;
-
- if (namespace_name == NULL)
- namespace_name = "Global";
-
- if (*namespace_name == 0)
- ns = This_Static_NameSpace;
- else ns = _SLns_find_namespace (namespace_name);
-
- return _SLnspace_apropos (ns, pat, what);
-}
-
-void _SLang_implements_intrinsic (char *name)
-{
- if (This_Static_NameSpace == NULL)
- {
- SLang_verror (SL_INTRINSIC_ERROR, "No namespace available");
- return;
- }
-
- (void) _SLns_set_namespace_name (This_Static_NameSpace, name);
-
- Default_Define_Function = define_static_function;
- Default_Variable_Mode = compile_static_variable_mode;
-}
-
-void _SLang_use_namespace_intrinsic (char *name)
-{
- SLang_NameSpace_Type *ns;
-
- if (NULL == (ns = _SLns_find_namespace (name)))
- {
- SLang_verror (SL_INTRINSIC_ERROR, "Namespace %s does not exist", name);
- return;
- }
- This_Static_NameSpace = ns;
- if (Global_NameSpace == ns)
- {
- Default_Define_Function = define_public_function;
- Default_Variable_Mode = compile_public_variable_mode;
- }
- else
- {
- Default_Define_Function = define_static_function;
- Default_Variable_Mode = compile_static_variable_mode;
- }
-}
-
-
-char *_SLang_cur_namespace_intrinsic (void)
-{
- if (This_Static_NameSpace == NULL)
- return "Global";
-
- if (This_Static_NameSpace->namespace_name == NULL)
- return "";
-
- return This_Static_NameSpace->namespace_name;
-}
generated by cgit v1.2.1 (git 2.21.0) at 2024-07-13 01:11:18 +0000