1 /* -*- mode: C; mode: fold; -*- */
2 /* slang.c --- guts of S-Lang interpreter */
3 /*
4 Copyright (C) 2004-2017,2018 John E. Davis
5
6 This file is part of the S-Lang Library.
7
8 The S-Lang Library is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public License as
10 published by the Free Software Foundation; either version 2 of the
11 License, or (at your option) any later version.
12
13 The S-Lang Library is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with this library; if not, write to the Free Software
20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
21 USA.
22 */
23
24 #include "slinclud.h"
25
26 #if SLANG_HAS_FLOAT
27 # include <math.h>
28 #endif
29
30 #include "slang.h"
31 #include "_slang.h"
32
33 #if SLANG_OPTIMIZE_FOR_SPEED
34 # define USE_COMBINED_BYTECODES 1
35 #else
36 # define USE_COMBINED_BYTECODES 0
37 #endif
38
39 #define USE_UNUSED_BYCODES_IN_SWITCH 1
40
41 struct _pSLBlock_Type;
42
43 typedef struct
44 {
45 struct _pSLBlock_Type *body;
46 unsigned int num_refs;
47
48 SLFUTURE_CONST char *file;
49 #define SLANG_MAX_LOCAL_VARIABLES 255
50 unsigned char nlocals; /* number of local variables */
51 unsigned char nargs; /* number of arguments */
52 char **local_variables;
53 SLang_NameSpace_Type *static_ns; /* namespace containing this function */
54 SLang_NameSpace_Type *private_ns; /* private namespace where this function was declared */
55 #if SLANG_HAS_BOSEOS
56 int issue_bofeof_info;
57 #endif
58 }
59 Function_Header_Type;
60
61 typedef struct
62 {
63 SLFUTURE_CONST char *name;
64 SLang_Name_Type *next;
65 char name_type;
66
67 /* If header is NULL, then the autoload_file field will be used. The file
68 * is to be loaded into the ns namespace.
69 */
70 Function_Header_Type *header; /* body of function */
71 SLFUTURE_CONST char *autoload_file;
72 SLang_NameSpace_Type *autoload_ns;
73 }
74 _pSLang_Function_Type;
75 static char *Local_Variable_Names[SLANG_MAX_LOCAL_VARIABLES];
76
77 typedef struct
78 {
79 char *name;
80 SLang_Name_Type *next;
81 char name_type;
82
83 int local_var_number;
84 }
85 SLang_Local_Var_Type;
86
87 #if SLANG_HAS_DEBUG_CODE
88 typedef struct
89 {
90 int linenum;
91 char *filename;
92 }
93 Linenum_Info_Type;
94 #endif
95
96 typedef struct _pSLBlock_Type
97 {
98 _pSLang_BC_Type bc_main_type;
99 unsigned char bc_sub_type; /* no types greater than 255 allowed here */
100 unsigned char bc_flags;
101 #define BC_LITERAL_MASK 0x1 /* if object is a literal */
102
103 unsigned short linenum;
104 union
105 {
106 struct _pSLBlock_Type *blk;
107 int i_blk;
108
109 SLang_Name_Type *nt_blk;
110 SLang_App_Unary_Type *nt_unary_blk;
111 SLang_Arith_Binary_Type *nt_binary_blk;
112 SLang_Intrin_Var_Type *nt_ivar_blk;
113 SLang_Intrin_Fun_Type *nt_ifun_blk;
114 SLang_Global_Var_Type *nt_gvar_blk;
115 SLang_HConstant_Type *hconst_blk;
116 SLang_IConstant_Type *iconst_blk;
117 SLang_LConstant_Type *lconst_blk;
118 SLang_FConstant_Type *fconst_blk;
119 SLang_DConstant_Type *dconst_blk;
120 #ifdef HAVE_LONG_LONG
121 _pSLang_LLConstant_Type *llconst_blk;
122 #endif
123 _pSLang_Function_Type *nt_fun_blk;
124
125 VOID_STAR ptr_blk;
126 SLFUTURE_CONST char *s_blk;
127 SLang_BString_Type *bs_blk;
128
129 #if SLANG_HAS_FLOAT
130 double *double_blk; /*literal double is a pointer */
131 #endif
132 #ifdef HAVE_LONG_LONG
133 long long *llong_blk;
134 #endif
135 float float_blk;
136 long l_blk;
137 struct _pSLang_Struct_Type *struct_blk;
138 int (*call_function)(void);
139 #if SLANG_HAS_DEBUG_CODE
140 Linenum_Info_Type *line_info;
141 #endif
142 }
143 b;
144 }
145 SLBlock_Type;
146
147 /* Debugging and tracing variables */
148
149 void (*SLang_Enter_Function)(SLFUTURE_CONST char *) = NULL;
150 void (*SLang_Exit_Function)(SLFUTURE_CONST char *) = NULL;
151 /* If non null, these call C functions before and after a slang function. */
152
153 int _pSLang_Trace = 0;
154 /* If _pSLang_Trace = -1, do not trace intrinsics */
155 static int Trace_Mode = 0;
156
157 static SLFUTURE_CONST char *Trace_Function; /* function to be traced */
158
159 int SLang_Traceback = SL_TB_PARTIAL;
160
161 #if SLANG_HAS_BOSEOS
162 static int BOS_Stack_Depth;
163 #endif
164
165 static SLFUTURE_CONST char *This_Compile_Filename;
166 static unsigned int This_Compile_Linenum;
167
168 /* These variables handle _NARGS processing by the parser */
169 int SLang_Num_Function_Args = 0;
170 static int *Num_Args_Stack;
171 static unsigned int Recursion_Depth;
172 static SLang_Object_Type *Frame_Pointer;
173 static int Next_Function_Num_Args;
174
175 static unsigned int Frame_Pointer_Depth;
176 static unsigned int *Frame_Pointer_Stack;
177
178 #if SLANG_HAS_QUALIFIERS
179 static SLang_Struct_Type *Next_Function_Qualifiers;
180 static SLang_Struct_Type *Function_Qualifiers;
181 static SLang_Struct_Type **Function_Qualifiers_Stack;
182 #endif
183
184 static _pSLang_Function_Type *Current_Function = NULL;
185 static Function_Header_Type *Current_Function_Header;
186
187 typedef struct
188 {
189 _pSLang_Function_Type *function;
190 Function_Header_Type *header; /* could be different from function->header */
191 SLang_Object_Type *local_variable_frame;
192 SLang_NameSpace_Type *static_ns;
193 SLang_NameSpace_Type *private_ns;
194 /* file and line where function call occurs, 0 if no-info */
195 SLCONST char *file;
196 unsigned int line;
197 }
198 Function_Stack_Type;
199 static Function_Stack_Type *Function_Stack;
200 static Function_Stack_Type *Function_Stack_Ptr;
201 /* static Function_Stack_Type *Function_Stack_Ptr_Max; */
202
203 static SLang_NameSpace_Type *This_Private_NameSpace;
204 static SLang_NameSpace_Type *This_Static_NameSpace;
205 static SLang_NameSpace_Type *Global_NameSpace;
206 static SLang_NameSpace_Type *Locals_NameSpace;
207
208 static SLang_Name_Type *
209 find_global_hashed_name (SLCONST char *, unsigned long,
210 SLang_NameSpace_Type *, SLang_NameSpace_Type *,
211 SLang_NameSpace_Type *, int);
212
213 static int Lang_Break_Condition = 0;
214 /* true if any one below is true. This keeps us from testing 3 variables.
215 * I know this can be perfomed with a bitmapped variable, but...
216 *
217 * Note that Lang_Break is positive when handling the break statements,
218 * and is negative when handling continue-N forms. The reason this variable
219 * is involved is that continue-N is equivalent to break, break,...,continue.
220 */
221 static int Lang_Break = 0;
222 static int Lang_Return = 0;
223 /* static int Lang_Continue = 0; */
224
225 static SLang_Object_Type *Run_Stack;
226 static SLang_Object_Type *Stack_Pointer;
227 static SLang_Object_Type *Stack_Pointer_Max;
228
229 static SLang_Object_Type *Local_Variable_Stack;
230 static SLang_Object_Type *Local_Variable_Stack_Max;
231 static SLang_Object_Type *Local_Variable_Frame; /* points into Local_Variable_Stack */
232
233 #define INTERRUPT_ERROR 0x01
234 #define INTERRUPT_SIGNAL 0x02
235 static volatile int Handle_Interrupt; /* bitmapped value */
236 #define IS_SLANG_ERROR (Handle_Interrupt & INTERRUPT_ERROR)
237
238 static void free_function_header (Function_Header_Type *);
239
240 #if SLANG_HAS_SIGNALS
241 static int check_signals (void);
242 #endif
243
244 #if SLANG_OPTIMIZE_FOR_SPEED
245 # define NUM_CLASSES 512 /* must be large enough for built-ins */
246 static SLclass_Type The_Class_Types [NUM_CLASSES];
247 static SLang_Class_Type *The_Classes[NUM_CLASSES];
248
249 # define GET_CLASS_TYPE(x) \
250 (((x) < NUM_CLASSES) ? The_Class_Types[(x)] : _pSLang_get_class_type(x))
251
_pSLang_set_class_info(SLtype t,SLang_Class_Type * cl)252 void _pSLang_set_class_info (SLtype t, SLang_Class_Type *cl)
253 {
254 if (t < NUM_CLASSES)
255 {
256 The_Class_Types[t] = cl->cl_class_type;
257 The_Classes [t] = cl;
258 }
259 }
260 # define GET_CLASS(cl,t) \
261 if (((t)>=NUM_CLASSES) || (NULL == (cl = The_Classes[(t)]))) \
262 cl = _pSLclass_get_class(t)
263 # define GET_BUILTIN_CLASS(cl,t) \
264 if (NULL == (cl = The_Classes[(t)])) \
265 cl = _pSLclass_get_class(t)
266 #else
267 # define GET_CLASS(cl,t) cl = _pSLclass_get_class(t)
268 # define GET_BUILTIN_CLASS(cl,t) cl = _pSLclass_get_class(t)
269 # define GET_CLASS_TYPE(t) _pSLclass_get_class(t)->cl_class_type
270 #endif
271
272 #if SLANG_OPTIMIZE_FOR_SPEED
_pSLang_get_class_type(SLtype t)273 SLclass_Type _pSLang_get_class_type (SLtype t)
274 {
275 SLang_Class_Type *cl;
276 #if SLANG_OPTIMIZE_FOR_SPEED
277 if (t < NUM_CLASSES)
278 return The_Class_Types[t];
279 #endif
280 cl = _pSLclass_get_class (t);
281 return cl->cl_class_type;
282 }
283 #endif
284
285 /* If 0, not an arith type. Otherwise it is. Also, value implies precedence
286 * See slarith.c for how this is used.
287 */
288 static int Is_Arith_Type_Array [256];
289 #define IS_ARITH_TYPE(t) \
290 (((t) < 256) ? Is_Arith_Type_Array[t] : 0)
291
292 static void do_traceback (SLCONST char *);
293 static void do_function_traceback (Function_Header_Type *, unsigned int);
294
295 static int init_interpreter (void);
296
297 /*{{{ push/pop/etc stack manipulation functions */
298
299 /* These routines are assumed to work even in the presence of a SLang_Error. */
300
pop_object(SLang_Object_Type * x)301 _INLINE_ static int pop_object (SLang_Object_Type *x)
302 {
303 register SLang_Object_Type *y;
304
305 y = Stack_Pointer;
306 IF_UNLIKELY(y == Run_Stack)
307 {
308 (void) SLang_set_error (SL_STACK_UNDERFLOW);
309 x->o_data_type = 0;
310 return -1;
311 }
312 y--;
313 *x = *y;
314
315 Stack_Pointer = y;
316 return 0;
317 }
318
SLang_pop(SLang_Object_Type * x)319 int SLang_pop (SLang_Object_Type *x)
320 {
321 return pop_object (x);
322 }
323
324 #if 0
325 static int pop_2_objs (SLang_Object_Type *a, SLang_Object_Type *b)
326 {
327 register SLang_Object_Type *y;
328
329 y = Stack_Pointer;
330
331 if (Run_Stack + 2 > y)
332 {
333 (void) SLang_set_error (SL_STACK_UNDERFLOW);
334 a->o_data_type = 0;
335 b->o_data_type = 0;
336 SLdo_pop_n (y - Run_Stack);
337 return -1;
338 }
339 *b = *(--y);
340 *a = *(--y);
341 Stack_Pointer = y;
342 return 0;
343 }
344 #endif
345
346 /* This function pops the top of the stack to x[0], next to x[1], etc... This is
347 * backwards from what might be expected but this corresponds to the order of the local
348 * variable stack.
349 */
350 _INLINE_
pop_n_objs_reverse(SLang_Object_Type * x,unsigned int n)351 static int pop_n_objs_reverse (SLang_Object_Type *x, unsigned int n)
352 {
353 register SLang_Object_Type *y;
354 unsigned int i;
355
356 y = Stack_Pointer;
357
358 if (Run_Stack + n > y)
359 {
360 (void) SLang_set_error (SL_STACK_UNDERFLOW);
361 for (i = 0; i < n; i++)
362 x[i].o_data_type = 0;
363 (void) SLdo_pop_n ((unsigned int) (y - Run_Stack));
364 return -1;
365 }
366
367 for (i = 0; i < n; i++)
368 {
369 y--;
370 x[i] = *y;
371 }
372 Stack_Pointer = y;
373 return 0;
374 }
375
376 _INLINE_
peek_at_stack(void)377 static int peek_at_stack (void)
378 {
379 IF_UNLIKELY(Stack_Pointer == Run_Stack)
380 {
381 (void) SLang_set_error (SL_STACK_UNDERFLOW);
382 return -1;
383 }
384
385 return (int) (Stack_Pointer - 1)->o_data_type;
386 }
387
SLang_peek_at_stack(void)388 int SLang_peek_at_stack (void)
389 {
390 return peek_at_stack ();
391 }
392
_pSLang_peek_at_stack2(SLtype * _typep)393 int _pSLang_peek_at_stack2 (SLtype *_typep)
394 {
395 SLtype type;
396 if (Stack_Pointer == Run_Stack)
397 {
398 (void) SLang_set_error (SL_STACK_UNDERFLOW);
399 return -1;
400 }
401
402 type = (Stack_Pointer - 1)->o_data_type;
403 if (type == SLANG_ARRAY_TYPE)
404 *_typep = (Stack_Pointer - 1)->v.array_val->data_type;
405 else
406 *_typep = type;
407 return (int) type;
408 }
409
SLang_peek_at_stack_n(unsigned int n)410 int SLang_peek_at_stack_n (unsigned int n)
411 {
412 unsigned int stklen = (unsigned int)(Stack_Pointer - Run_Stack);
413
414 if (n >= stklen)
415 {
416 (void) SLang_set_error (SL_STACK_UNDERFLOW);
417 return -1;
418 }
419 return (int) (Stack_Pointer - (n+1))->o_data_type;
420 }
421
pop_ctrl_integer(int * i)422 static int pop_ctrl_integer (int *i)
423 {
424 int type;
425 SLang_Class_Type *cl;
426 #if SLANG_OPTIMIZE_FOR_SPEED
427 register SLang_Object_Type *y;
428
429 /* Most of the time, either an integer or a char will be on the stack.
430 * Optimize these cases.
431 */
432 y = Stack_Pointer;
433 IF_UNLIKELY(y == Run_Stack)
434 {
435 (void) SLang_set_error (SL_STACK_UNDERFLOW);
436 return -1;
437 }
438 y--;
439
440 type = (int) y->o_data_type;
441 if (type == SLANG_INT_TYPE)
442 {
443 Stack_Pointer = y;
444 *i = y->v.int_val;
445 return 0;
446 }
447 if (type == SLANG_CHAR_TYPE)
448 {
449 Stack_Pointer = y;
450 *i = y->v.char_val;
451 return 0;
452 }
453 #else
454 if (-1 == (type = peek_at_stack ()))
455 return -1;
456 #endif
457
458 GET_CLASS(cl,type);
459 if (cl->cl_to_bool == NULL)
460 {
461 _pSLang_verror (SL_TYPE_MISMATCH,
462 "%s cannot be used in a boolean context",
463 cl->cl_name);
464 return -1;
465 }
466 return cl->cl_to_bool ((unsigned char) type, i);
467 }
468
SLang_peek_at_stack1_n(unsigned int n)469 int SLang_peek_at_stack1_n (unsigned int n)
470 {
471 int type;
472
473 type = SLang_peek_at_stack_n (n);
474 if (type == SLANG_ARRAY_TYPE)
475 type = (Stack_Pointer - (n+1))->v.array_val->data_type;
476
477 return type;
478 }
479
SLang_peek_at_stack1(void)480 int SLang_peek_at_stack1 (void)
481 {
482 return SLang_peek_at_stack1_n (0);
483 }
484
485 /* _INLINE_ */
free_object(SLang_Object_Type * obj,SLang_Class_Type * cl)486 static void free_object (SLang_Object_Type *obj, SLang_Class_Type *cl)
487 {
488 if ((obj == NULL)
489 || (cl->cl_class_type == SLANG_CLASS_TYPE_SCALAR))
490 return;
491
492 #if SLANG_OPTIMIZE_FOR_SPEED
493 if (obj->o_data_type == SLANG_STRING_TYPE)
494 {
495 _pSLang_free_slstring (obj->v.s_val);
496 return;
497 }
498 #endif
499 (*cl->cl_destroy) (obj->o_data_type, (VOID_STAR) &obj->v);
500 }
501
SLang_free_object(SLang_Object_Type * obj)502 void SLang_free_object (SLang_Object_Type *obj)
503 {
504 SLtype data_type;
505 SLang_Class_Type *cl;
506
507 if (obj == NULL) return;
508 data_type = obj->o_data_type;
509 GET_CLASS(cl,data_type);
510 free_object (obj, cl);
511 }
512
push_object(SLang_Object_Type * x)513 _INLINE_ static int push_object (SLang_Object_Type *x)
514 {
515 register SLang_Object_Type *y;
516 y = Stack_Pointer;
517
518 /* if there is a SLang_Error, probably not much harm will be done
519 if it is ignored here */
520 /* if (SLang_Error) return; */
521
522 /* flag it now */
523 IF_UNLIKELY(y >= Stack_Pointer_Max)
524 {
525 (void) SLang_set_error (SL_STACK_OVERFLOW);
526 return -1;
527 }
528
529 *y = *x;
530 Stack_Pointer = y + 1;
531 return 0;
532 }
533
SLang_push(SLang_Object_Type * x)534 int SLang_push (SLang_Object_Type *x)
535 {
536 return push_object (x);
537 }
538
539 /* _INLINE_ */
SLclass_push_ptr_obj(SLtype type,VOID_STAR pval)540 int SLclass_push_ptr_obj (SLtype type, VOID_STAR pval)
541 {
542 register SLang_Object_Type *y;
543 y = Stack_Pointer;
544
545 IF_UNLIKELY(y >= Stack_Pointer_Max)
546 {
547 (void) SLang_set_error (SL_STACK_OVERFLOW);
548 return -1;
549 }
550
551 y->o_data_type = type;
552 y->v.ptr_val = pval;
553
554 Stack_Pointer = y + 1;
555 return 0;
556 }
557
push_int_object(SLtype type,int x)558 _INLINE_ static int push_int_object (SLtype type, int x)
559 {
560 register SLang_Object_Type *y;
561 y = Stack_Pointer;
562
563 IF_UNLIKELY(y >= Stack_Pointer_Max)
564 {
565 (void) SLang_set_error (SL_STACK_OVERFLOW);
566 return -1;
567 }
568
569 y->o_data_type = type;
570 y->v.int_val = x;
571
572 Stack_Pointer = y + 1;
573 return 0;
574 }
575
576 #if (SLANG_ARRAY_INDEX_TYPE == SLANG_INT_TYPE)
577 # define push_array_index push_int_object
578 #else
push_array_index(SLtype type,SLindex_Type x)579 _INLINE_ static int push_array_index (SLtype type, SLindex_Type x)
580 {
581 register SLang_Object_Type *y;
582 y = Stack_Pointer;
583
584 IF_UNLIKELY(y >= Stack_Pointer_Max)
585 {
586 (void) SLang_set_error (SL_STACK_OVERFLOW);
587 return -1;
588 }
589
590 y->o_data_type = type;
591 y->v.index_val = x;
592
593 Stack_Pointer = y + 1;
594 return 0;
595 }
596 #endif
597
SLclass_push_int_obj(SLtype type,int x)598 int SLclass_push_int_obj (SLtype type, int x)
599 {
600 return push_int_object (type, x);
601 }
602
_pSLang_push_array(SLang_Array_Type * at,int free_array)603 int _pSLang_push_array (SLang_Array_Type *at, int free_array)
604 {
605 register SLang_Object_Type *y;
606
607 y = Stack_Pointer;
608
609 IF_UNLIKELY(y >= Stack_Pointer_Max)
610 {
611 (void) SLang_set_error (SL_STACK_OVERFLOW);
612 if (free_array) SLang_free_array (at);
613 return -1;
614 }
615
616 if (free_array == 0) at->num_refs++;
617 y->o_data_type = SLANG_ARRAY_TYPE;
618 y->v.ptr_val = (VOID_STAR)at;
619
620 Stack_Pointer = y + 1;
621 return 0;
622 }
623
624 #if SLANG_HAS_FLOAT
push_double_object(SLtype type,double x)625 _INLINE_ static int push_double_object (SLtype type, double x)
626 {
627 register SLang_Object_Type *y;
628 y = Stack_Pointer;
629
630 IF_UNLIKELY(y >= Stack_Pointer_Max)
631 {
632 (void) SLang_set_error (SL_STACK_OVERFLOW);
633 return -1;
634 }
635
636 y->o_data_type = type;
637 y->v.double_val = x;
638
639 Stack_Pointer = y + 1;
640 return 0;
641 }
642
SLclass_push_double_obj(SLtype type,double x)643 int SLclass_push_double_obj (SLtype type, double x)
644 {
645 return push_double_object (type, x);
646 }
647 #endif
648
push_char_object(SLtype type,char x)649 _INLINE_ static int push_char_object (SLtype type, char x)
650 {
651 register SLang_Object_Type *y;
652 y = Stack_Pointer;
653
654 IF_UNLIKELY(y >= Stack_Pointer_Max)
655 {
656 (void) SLang_set_error (SL_STACK_OVERFLOW);
657 return -1;
658 }
659
660 y->o_data_type = type;
661 y->v.char_val = x;
662
663 Stack_Pointer = y + 1;
664 return 0;
665 }
666
SLclass_push_char_obj(SLtype type,char x)667 int SLclass_push_char_obj (SLtype type, char x)
668 {
669 return push_char_object (type, x);
670 }
671
672 /* This function is "fragile". It is a helper routine and assumes that y is on the stack */
_typecast_object_to_type(SLang_Object_Type * y,SLang_Object_Type * obj,SLtype type,int allow_arrays)673 static int _typecast_object_to_type (SLang_Object_Type *y, SLang_Object_Type *obj, SLtype type, int allow_arrays)
674 {
675 #if SLANG_OPTIMIZE_FOR_SPEED
676 /* This is an implicit typecast. We do not want to typecast
677 * floats to ints implicitly.
678 */
679 if (IS_ARITH_TYPE(type)
680 && IS_ARITH_TYPE(y->o_data_type)
681 && (type >= y->o_data_type))
682 {
683 /* This should not fail */
684 (void) _pSLarith_typecast (y->o_data_type, (VOID_STAR)&y->v, 1,
685 type, (VOID_STAR)&obj->v);
686 obj->o_data_type = type;
687 return 0;
688 }
689 #endif
690 if ((allow_arrays == 0)
691 || (y->o_data_type != SLANG_ARRAY_TYPE)
692 || (y->v.array_val->data_type != type))
693 {
694 if (-1 == SLclass_typecast (type, 1, 0))
695 return -1;
696 }
697
698 /* Here, *y has been replaced by the object of the specified type */
699 *obj = *y;
700 return 0;
701 }
702
703 _INLINE_
pop_int(int * i)704 static int pop_int (int *i)
705 {
706 SLang_Object_Type *y;
707 SLang_Object_Type obj;
708
709 y = Stack_Pointer;
710 IF_UNLIKELY(y == Run_Stack)
711 return SLang_pop(&obj); /* let it fail */
712 y--;
713 if (y->o_data_type == SLANG_INT_TYPE)
714 {
715 *i = y->v.int_val;
716 Stack_Pointer = y;
717 return 0;
718 }
719 if (-1 == _typecast_object_to_type (y, &obj, SLANG_INT_TYPE, 0))
720 {
721 /* Stack_Pointer = y; */
722 return -1;
723 }
724 *i = obj.v.int_val;
725 Stack_Pointer = y;
726 return 0;
727 }
728
SLang_pop_int(int * i)729 int SLang_pop_int (int *i)
730 {
731 return pop_int (i);
732 }
733
SLang_pop_array_index(SLindex_Type * i)734 int SLang_pop_array_index (SLindex_Type *i)
735 {
736 SLang_Object_Type *y;
737 SLang_Object_Type obj;
738
739 y = Stack_Pointer;
740 if (y == Run_Stack)
741 return SLang_pop (&obj); /* let it fail */
742 y--;
743 if (y->o_data_type == SLANG_ARRAY_INDEX_TYPE)
744 {
745 *i = y->v.index_val;
746 Stack_Pointer = y;
747 return 0;
748 }
749 if (-1 == _typecast_object_to_type (y, &obj, SLANG_ARRAY_INDEX_TYPE, 0))
750 {
751 /* Stack_Pointer = y; */
752 return -1;
753 }
754 *i = obj.v.index_val;
755 Stack_Pointer = y;
756 return 0;
757 }
758
SLang_push_array_index(SLindex_Type i)759 int SLang_push_array_index (SLindex_Type i)
760 {
761 return push_array_index (SLANG_ARRAY_INDEX_TYPE, i);
762 }
763
pop_object_of_type(SLtype type,SLang_Object_Type * obj,int allow_arrays)764 _INLINE_ static int pop_object_of_type (SLtype type, SLang_Object_Type *obj,
765 int allow_arrays)
766 {
767 register SLang_Object_Type *y;
768
769 y = Stack_Pointer;
770 IF_UNLIKELY(y == Run_Stack)
771 return SLang_pop(obj); /* let it fail */
772 y--;
773 if (y->o_data_type == type)
774 {
775 *obj = *y;
776 Stack_Pointer = y;
777 return 0;
778 }
779 if (-1 == _typecast_object_to_type (y, obj, type, allow_arrays))
780 {
781 /* Stack_Pointer = y; */
782 return -1;
783 }
784 Stack_Pointer = y;
785 return 0;
786 }
787
SLclass_pop_ptr_obj(SLtype type,VOID_STAR * s)788 int SLclass_pop_ptr_obj (SLtype type, VOID_STAR *s)
789 {
790 SLang_Object_Type obj;
791
792 if (-1 == pop_object_of_type (type, &obj, 0))
793 {
794 *s = (VOID_STAR) NULL;
795 return -1;
796 }
797 *s = obj.v.ptr_val;
798 return 0;
799 }
800
_pSLang_pop_object_of_type(SLtype type,SLang_Object_Type * obj,int allow_arrays)801 int _pSLang_pop_object_of_type (SLtype type, SLang_Object_Type *obj,
802 int allow_arrays)
803 {
804 return pop_object_of_type (type, obj, allow_arrays);
805 }
806
807 /* This function reverses the top n items on the stack and returns a
808 * an offset from the start of the stack to the last item.
809 */
SLreverse_stack(int n)810 int SLreverse_stack (int n)
811 {
812 SLang_Object_Type *otop, *obot, tmp;
813
814 otop = Stack_Pointer;
815 if ((n > otop - Run_Stack) || (n < 0))
816 {
817 (void) SLang_set_error (SL_STACK_UNDERFLOW);
818 return -1;
819 }
820 obot = otop - n;
821 otop--;
822 while (otop > obot)
823 {
824 tmp = *obot;
825 *obot = *otop;
826 *otop = tmp;
827 otop--;
828 obot++;
829 }
830 return (int) ((Stack_Pointer - n) - Run_Stack);
831 }
832
833 /* _INLINE_ */
roll_stack(int np)834 static int roll_stack (int np)
835 {
836 int n, i;
837 SLang_Object_Type *otop, *obot, tmp;
838
839 if ((n = abs(np)) <= 1) return 0; /* identity */
840
841 obot = otop = Stack_Pointer;
842 i = n;
843 while (i != 0)
844 {
845 if (obot <= Run_Stack)
846 {
847 (void) SLang_set_error (SL_STACK_UNDERFLOW);
848 return -1;
849 }
850 obot--;
851 i--;
852 }
853 otop--;
854
855 if (np > 0)
856 {
857 /* Put top on bottom and roll rest up. */
858 tmp = *otop;
859 while (otop > obot)
860 {
861 *otop = *(otop - 1);
862 otop--;
863 }
864 *otop = tmp;
865 }
866 else
867 {
868 /* Put bottom on top and roll rest down. */
869 tmp = *obot;
870 while (obot < otop)
871 {
872 *obot = *(obot + 1);
873 obot++;
874 }
875 *obot = tmp;
876 }
877 return 0;
878 }
879
SLroll_stack(int np)880 int SLroll_stack (int np)
881 {
882 return roll_stack (np);
883 }
884
SLstack_exch(unsigned int a,unsigned int b)885 int SLstack_exch (unsigned int a, unsigned int b)
886 {
887 SLang_Object_Type *ap, *bp;
888 SLang_Object_Type tmp;
889 unsigned int stklen = (unsigned int)(Stack_Pointer - Run_Stack);
890
891 if ((a >= stklen) || (b >= stklen))
892 {
893 (void) SLang_set_error (SL_STACK_UNDERFLOW);
894 return -1;
895 }
896 ap = Stack_Pointer - (a+1);
897 bp = Stack_Pointer - (b+1);
898
899 tmp = *ap;
900 *ap = *bp;
901 *bp = tmp;
902
903 return 0;
904 }
905
SLstack_depth(void)906 int SLstack_depth (void)
907 {
908 return (int) (Stack_Pointer - Run_Stack);
909 }
910
SLdup_n(int n)911 int SLdup_n (int n)
912 {
913 SLang_Object_Type *bot, *top;
914
915 if (n <= 0)
916 return 0;
917
918 top = Stack_Pointer;
919 if (top < Run_Stack + n)
920 {
921 (void) SLang_set_error (SL_STACK_UNDERFLOW);
922 return -1;
923 }
924 if (top + n > Stack_Pointer_Max)
925 {
926 (void) SLang_set_error (SL_STACK_OVERFLOW);
927 return -1;
928 }
929 bot = top - n;
930
931 while (bot < top)
932 {
933 SLang_Class_Type *cl;
934 SLtype data_type = bot->o_data_type;
935
936 #if SLANG_OPTIMIZE_FOR_SPEED
937 if (SLANG_CLASS_TYPE_SCALAR == GET_CLASS_TYPE(data_type))
938 {
939 *Stack_Pointer++ = *bot++;
940 continue;
941 }
942 #endif
943 GET_CLASS(cl,data_type);
944 if (-1 == (*cl->cl_push) (data_type, (VOID_STAR) &bot->v))
945 return -1;
946 bot++;
947 }
948 return 0;
949 }
950
951 /*}}}*/
952
953 /*{{{ inner interpreter and support functions */
954
955 _INLINE_
_pSL_increment_frame_pointer(void)956 int _pSL_increment_frame_pointer (void)
957 {
958 IF_UNLIKELY(Recursion_Depth >= SLANG_MAX_RECURSIVE_DEPTH)
959 {
960 #if SLANG_HAS_QUALIFIERS
961 if (Next_Function_Qualifiers != NULL)
962 {
963 SLang_free_struct (Next_Function_Qualifiers);
964 Next_Function_Qualifiers = NULL;
965 }
966 #endif
967 _pSLang_verror (SL_STACK_OVERFLOW, "Num Args Stack Overflow");
968 return -1;
969 }
970 Num_Args_Stack [Recursion_Depth] = SLang_Num_Function_Args;
971 SLang_Num_Function_Args = Next_Function_Num_Args;
972 Next_Function_Num_Args = 0;
973 #if SLANG_HAS_QUALIFIERS
974 Function_Qualifiers_Stack[Recursion_Depth] = Function_Qualifiers;
975 Function_Qualifiers = Next_Function_Qualifiers;
976 Next_Function_Qualifiers = NULL;
977 #endif
978 Recursion_Depth++;
979 return 0;
980 }
981
982 _INLINE_
_pSL_decrement_frame_pointer(void)983 int _pSL_decrement_frame_pointer (void)
984 {
985 #if SLANG_HAS_QUALIFIERS
986 if (Function_Qualifiers != NULL)
987 {
988 SLang_free_struct (Function_Qualifiers);
989 Function_Qualifiers = NULL;
990 }
991 #endif
992 IF_UNLIKELY(Recursion_Depth == 0)
993 {
994 _pSLang_verror (SL_STACK_UNDERFLOW, "Num Args Stack Underflow");
995 return -1;
996 }
997
998 Recursion_Depth--;
999 if (Recursion_Depth < SLANG_MAX_RECURSIVE_DEPTH)
1000 {
1001 SLang_Num_Function_Args = Num_Args_Stack [Recursion_Depth];
1002 #if SLANG_HAS_QUALIFIERS
1003 Function_Qualifiers = Function_Qualifiers_Stack[Recursion_Depth];
1004 #endif
1005 }
1006 return 0;
1007 }
1008
decrement_slang_frame_pointer(void)1009 static int decrement_slang_frame_pointer (void)
1010 {
1011 Function_Stack_Type *s;
1012
1013 if (-1 == _pSL_decrement_frame_pointer ())
1014 return -1;
1015
1016 Function_Stack_Ptr--;
1017 s = Function_Stack_Ptr;
1018 Current_Function = s->function;
1019 Current_Function_Header = s->header;
1020 This_Compile_Linenum = s->line;
1021 return 0;
1022 }
1023
increment_slang_frame_pointer(_pSLang_Function_Type * fun,unsigned int linenum)1024 static int increment_slang_frame_pointer (_pSLang_Function_Type *fun, unsigned int linenum)
1025 {
1026 Function_Stack_Type *s;
1027
1028 if (-1 == _pSL_increment_frame_pointer ())
1029 return -1;
1030
1031 /* No need to check for stack underflow/overflow errors here since
1032 * this stack is the same size as the "frame pointer stack".
1033 */
1034 s = Function_Stack_Ptr++;
1035 s->function = Current_Function;
1036 s->header = Current_Function_Header;
1037 s->local_variable_frame = Local_Variable_Frame;
1038 s->line = linenum;
1039 if (Current_Function_Header != NULL)
1040 {
1041 s->file = Current_Function_Header->file;
1042 s->static_ns = Current_Function_Header->static_ns;
1043 s->private_ns = Current_Function_Header->private_ns;
1044 }
1045 else
1046 {
1047 s->file = This_Compile_Filename;
1048 s->static_ns = This_Static_NameSpace;
1049 s->private_ns = This_Private_NameSpace;
1050 }
1051 if (fun == NULL)
1052 return 0; /* called from SLexecute_function */
1053
1054 if (fun->header == NULL)
1055 {
1056 if (fun->autoload_ns == NULL)
1057 {
1058 if (-1 == SLang_load_file(fun->autoload_file))
1059 {
1060 (void) decrement_slang_frame_pointer ();
1061 return -1;
1062 }
1063 }
1064 else if (-1 == SLns_load_file (fun->autoload_file, fun->autoload_ns->namespace_name))
1065 {
1066 (void) decrement_slang_frame_pointer ();
1067 return -1;
1068 }
1069
1070 if (NULL == fun->header)
1071 {
1072 _pSLang_verror (SL_UNDEFINED_NAME, "%s: Function did not autoload",
1073 fun->name);
1074 (void) decrement_slang_frame_pointer ();
1075 return -1;
1076 }
1077 }
1078 Current_Function = fun;
1079 Current_Function_Header = fun->header;
1080 return 0;
1081 }
1082
1083 #if SLANG_HAS_QUALIFIERS
set_qualifier(void)1084 static int set_qualifier (void)
1085 {
1086 if (SLANG_NULL_TYPE == peek_at_stack ())
1087 {
1088 Next_Function_Qualifiers = NULL;
1089 return SLang_pop_null ();
1090 }
1091 return SLang_pop_struct (&Next_Function_Qualifiers);
1092 }
1093
1094 /* This function is called from slang code */
_pSLang_get_qualifiers_intrin(SLang_Struct_Type ** qp)1095 int _pSLang_get_qualifiers_intrin (SLang_Struct_Type **qp)
1096 {
1097 /* The assumption is that this is being called from a function one level up.
1098 * Grab the qualifiers from the previous frame stack.
1099 */
1100 if (Recursion_Depth > 1)
1101 *qp = Function_Qualifiers_Stack[Recursion_Depth-1];
1102 else
1103 *qp = NULL;
1104
1105 return 0;
1106 }
1107
1108 /* This may be called from intrinsic functions */
SLang_qualifier_exists(SLCONST char * name)1109 int SLang_qualifier_exists (SLCONST char *name)
1110 {
1111 if (Function_Qualifiers == NULL)
1112 return 0;
1113
1114 return (NULL != _pSLstruct_get_field_value (Function_Qualifiers, name));
1115 }
1116
1117 /* returns -1 upon error, 0 if qualifier does not exist,
1118 * 1 if qualifier exists and has correct type,
1119 * 2 if qualifier had to be converted to requested type.
1120 * If 1, then use the first object pointer but do not free it.
1121 * If 2, then use the second object pointer and free it.
1122 */
check_qualifier(SLCONST char * name,SLtype t,SLang_Object_Type ** op,SLang_Object_Type * o)1123 static int check_qualifier (SLCONST char *name, SLtype t,
1124 SLang_Object_Type **op, SLang_Object_Type *o)
1125 {
1126 SLang_Object_Type *objp;
1127
1128 if ((Function_Qualifiers == NULL)
1129 || (NULL == (objp = _pSLstruct_get_field_value (Function_Qualifiers, name)))
1130 || (objp->o_data_type == SLANG_NULL_TYPE)
1131 )
1132 {
1133 *op = NULL;
1134 return 0;
1135 }
1136
1137 if (objp->o_data_type == t)
1138 {
1139 *op = objp;
1140 return 1;
1141 }
1142
1143 if (-1 == _pSLpush_slang_obj (objp))
1144 return -1;
1145
1146 if (-1 == pop_object_of_type (t, o, 0))
1147 {
1148 SLang_verror (0, "Expecting '%s' qualifier to be %s",
1149 name, SLclass_get_datatype_name (t));
1150 return -1;
1151 }
1152 return 2;
1153 }
1154
SLang_get_int_qualifier(SLCONST char * name,int * p,int def)1155 int SLang_get_int_qualifier (SLCONST char *name, int *p, int def)
1156 {
1157 SLang_Object_Type *objp;
1158 SLang_Object_Type obj;
1159 int status;
1160
1161 status = check_qualifier (name, SLANG_INT_TYPE, &objp, &obj);
1162 if (status <= 0)
1163 {
1164 *p = def;
1165 return status;
1166 }
1167 if (status == 1)
1168 {
1169 *p = objp->v.int_val;
1170 return 0;
1171 }
1172 *p = obj.v.int_val;
1173 /* SLang_free_object (&obj); not necessary for scalars */
1174 return 0;
1175 }
1176
SLang_get_long_qualifier(SLCONST char * name,long * p,long def)1177 int SLang_get_long_qualifier (SLCONST char *name, long *p, long def)
1178 {
1179 SLang_Object_Type *objp;
1180 SLang_Object_Type obj;
1181 int status;
1182
1183 status = check_qualifier (name, SLANG_LONG_TYPE, &objp, &obj);
1184 if (status <= 0)
1185 {
1186 *p = def;
1187 return status;
1188 }
1189 if (status == 1)
1190 {
1191 *p = objp->v.long_val;
1192 return 0;
1193 }
1194 *p = obj.v.long_val;
1195 /* SLang_free_object (&obj); not necessary for scalars */
1196 return 0;
1197 }
1198
1199 #if SLANG_HAS_FLOAT
SLang_get_double_qualifier(SLCONST char * name,double * p,double def)1200 int SLang_get_double_qualifier (SLCONST char *name, double *p, double def)
1201 {
1202 SLang_Object_Type *objp;
1203 SLang_Object_Type obj;
1204 int status;
1205
1206 status = check_qualifier (name, SLANG_DOUBLE_TYPE, &objp, &obj);
1207 if (status <= 0)
1208 {
1209 *p = def;
1210 return status;
1211 }
1212 if (status == 1)
1213 {
1214 *p = objp->v.double_val;
1215 return 0;
1216 }
1217 *p = obj.v.double_val;
1218 /* SLang_free_object (&obj); not necessary for scalars */
1219 return 0;
1220 }
1221 #endif
1222
SLang_get_string_qualifier(SLCONST char * name,char ** p,SLFUTURE_CONST char * def)1223 int SLang_get_string_qualifier (SLCONST char *name, char **p, SLFUTURE_CONST char *def)
1224 {
1225 SLang_Object_Type *objp;
1226 SLang_Object_Type obj;
1227 int status;
1228
1229 status = check_qualifier (name, SLANG_STRING_TYPE, &objp, &obj);
1230 if (status <= 0)
1231 {
1232 if (status == 0)
1233 {
1234 if ((def != NULL)
1235 && (NULL == (def = SLang_create_slstring (def))))
1236 status = -1;
1237 else *p = (char *)def;
1238 }
1239 return status;
1240 }
1241
1242 if (status == 1)
1243 {
1244 if (NULL == (*p = SLang_create_slstring (objp->v.s_val)))
1245 return -1;
1246 return 0;
1247 }
1248
1249 *p = obj.v.s_val;
1250 /* SLang_free_object (&obj); not necessary, since we own v.s_val */
1251 return 0;
1252 }
1253 #endif
1254
1255 _INLINE_
start_arg_list(void)1256 static int start_arg_list (void)
1257 {
1258 IF_LIKELY(Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH)
1259 {
1260 Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - Run_Stack);
1261 Frame_Pointer = Stack_Pointer;
1262 Frame_Pointer_Depth++;
1263 Next_Function_Num_Args = 0;
1264 return 0;
1265 }
1266
1267 _pSLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow");
1268 return -1;
1269 }
1270
SLang_start_arg_list(void)1271 int SLang_start_arg_list (void)
1272 {
1273 return start_arg_list ();
1274 }
1275
_pSLang_restart_arg_list(int nargs)1276 int _pSLang_restart_arg_list (int nargs)
1277 {
1278 if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH)
1279 {
1280 if ((nargs < 0) || (Run_Stack + nargs > Stack_Pointer))
1281 {
1282 _pSLang_verror (SL_Internal_Error, "restart_arg_list: stack underflow");
1283 return -1;
1284 }
1285 Frame_Pointer_Stack [Frame_Pointer_Depth] = (unsigned int) (Frame_Pointer - Run_Stack);
1286 Frame_Pointer = Stack_Pointer - nargs;
1287 Frame_Pointer_Depth++;
1288 Next_Function_Num_Args = 0;
1289 return 0;
1290 }
1291
1292 _pSLang_verror (SL_STACK_OVERFLOW, "Frame Stack Overflow");
1293 return -1;
1294 }
1295
end_arg_list(void)1296 _INLINE_ static int end_arg_list (void)
1297 {
1298 IF_UNLIKELY(Frame_Pointer_Depth == 0)
1299 {
1300 _pSLang_verror (SL_STACK_UNDERFLOW, "Frame Stack Underflow");
1301 return -1;
1302 }
1303 Frame_Pointer_Depth--;
1304 if (Frame_Pointer_Depth < SLANG_MAX_RECURSIVE_DEPTH)
1305 {
1306 Next_Function_Num_Args = (int) (Stack_Pointer - Frame_Pointer);
1307 Frame_Pointer = Run_Stack + Frame_Pointer_Stack [Frame_Pointer_Depth];
1308 }
1309 return 0;
1310 }
1311
SLang_end_arg_list(void)1312 int SLang_end_arg_list (void)
1313 {
1314 return end_arg_list ();
1315 }
1316
1317 _INLINE_
do_bc_call_direct_frame(int (* f)(void))1318 static int do_bc_call_direct_frame (int (*f)(void))
1319 {
1320 if ((0 == end_arg_list ())
1321 && (0 == _pSL_increment_frame_pointer ()))
1322 {
1323 (void) (*f) ();
1324 _pSL_decrement_frame_pointer ();
1325 }
1326 if (IS_SLANG_ERROR)
1327 return -1;
1328 return 0;
1329 }
1330
1331 _INLINE_
do_bc_call_direct_nargs(int (* f)(void))1332 static int do_bc_call_direct_nargs (int (*f)(void))
1333 {
1334 if (0 == end_arg_list ())
1335 {
1336 int nargs = SLang_Num_Function_Args;
1337
1338 SLang_Num_Function_Args = Next_Function_Num_Args;
1339 Next_Function_Num_Args = 0;
1340 (void) (*f) ();
1341 SLang_Num_Function_Args = nargs;
1342 }
1343 if (IS_SLANG_ERROR)
1344 return -1;
1345 return 0;
1346 }
1347
do_name_type_error(SLang_Name_Type * nt)1348 static int do_name_type_error (SLang_Name_Type *nt)
1349 {
1350 if (nt != NULL)
1351 {
1352 char buf[256];
1353 (void) _pSLsnprintf (buf, sizeof (buf), "(Error occurred processing %s)", nt->name);
1354 do_traceback (buf);
1355 }
1356 return -1;
1357 }
1358
1359 /* local and global variable assignments */
1360
do_binary_ab(int op,SLang_Object_Type * obja,SLang_Object_Type * objb)1361 static int do_binary_ab (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
1362 {
1363 SLang_Class_Type *a_cl, *b_cl, *c_cl;
1364 SLtype b_data_type, a_data_type, c_data_type;
1365 int (*binary_fun) (int,
1366 SLtype, VOID_STAR, SLuindex_Type,
1367 SLtype, VOID_STAR, SLuindex_Type,
1368 VOID_STAR);
1369 VOID_STAR pa;
1370 VOID_STAR pb;
1371 VOID_STAR pc;
1372 int ret;
1373
1374 b_data_type = objb->o_data_type;
1375 a_data_type = obja->o_data_type;
1376
1377 #if SLANG_OPTIMIZE_FOR_SPEED
1378 if (IS_ARITH_TYPE(a_data_type)
1379 && IS_ARITH_TYPE(b_data_type))
1380 {
1381 int status;
1382 status = _pSLarith_bin_op (obja, objb, op);
1383 if (status != 1)
1384 return status;
1385 /* drop and try it the hard way */
1386 }
1387
1388 if (a_data_type == b_data_type)
1389 {
1390 if (a_data_type == SLANG_ARRAY_TYPE)
1391 return _pSLarray_bin_op (obja, objb, op);
1392
1393 if ((a_data_type == SLANG_STRING_TYPE)
1394 && (op == SLANG_PLUS))
1395 {
1396 char *stra = obja->v.s_val, *strb = objb->v.s_val, *strc;
1397
1398 strc = SLang_concat_slstrings (stra, strb);
1399 if (strc == NULL)
1400 return -1;
1401
1402 return _pSLang_push_slstring (strc); /* frees strc */
1403 }
1404 }
1405 #endif
1406
1407 GET_CLASS(a_cl,a_data_type);
1408 if (a_data_type == b_data_type)
1409 b_cl = a_cl;
1410 else
1411 GET_CLASS(b_cl, b_data_type);
1412
1413 if (NULL == (binary_fun = _pSLclass_get_binary_fun (op, a_cl, b_cl, &c_cl, 1)))
1414 return -1;
1415
1416 c_data_type = c_cl->cl_data_type;
1417
1418 #if SLANG_OPTIMIZE_FOR_SPEED
1419 if (SLANG_CLASS_TYPE_VECTOR == a_cl->cl_class_type)
1420 pa = (VOID_STAR) obja->v.ptr_val;
1421 else
1422 pa = (VOID_STAR) &obja->v;
1423 #else
1424 pa = _pSLclass_get_ptr_to_value (a_cl, obja);
1425 #endif
1426
1427 #if SLANG_OPTIMIZE_FOR_SPEED
1428 if (SLANG_CLASS_TYPE_VECTOR == b_cl->cl_class_type)
1429 pb = (VOID_STAR) objb->v.ptr_val;
1430 else
1431 pb = (VOID_STAR) &objb->v;
1432 #else
1433 pb = _pSLclass_get_ptr_to_value (b_cl, objb);
1434 #endif
1435
1436 pc = c_cl->cl_transfer_buf;
1437
1438 if (1 != (*binary_fun) (op,
1439 a_data_type, pa, 1,
1440 b_data_type, pb, 1,
1441 pc))
1442 {
1443 _pSLang_verror (SL_NOT_IMPLEMENTED,
1444 "Binary operation between %s and %s failed",
1445 a_cl->cl_name, b_cl->cl_name);
1446
1447 return -1;
1448 }
1449
1450 /* apush will create a copy, so make sure we free after the push */
1451 ret = (*c_cl->cl_apush)(c_data_type, pc);
1452 #if SLANG_OPTIMIZE_FOR_SPEED
1453 if ((SLANG_CLASS_TYPE_SCALAR != c_cl->cl_class_type)
1454 && (SLANG_CLASS_TYPE_VECTOR != c_cl->cl_class_type))
1455 #endif
1456 (*c_cl->cl_adestroy)(c_data_type, pc);
1457
1458 return ret;
1459 }
1460
1461 #if SLANG_OPTIMIZE_FOR_SPEED
int_int_binary_result(int op,SLang_Object_Type * obja,SLang_Object_Type * objb,SLang_Object_Type * objc)1462 static int int_int_binary_result (int op, SLang_Object_Type *obja, SLang_Object_Type *objb, SLang_Object_Type *objc)
1463 {
1464 int a, b;
1465
1466 a = obja->v.int_val; b = objb->v.int_val;
1467 switch (op)
1468 {
1469 case SLANG_PLUS:
1470 objc->v.int_val = a + b; objc->o_data_type = SLANG_INT_TYPE;
1471 return 0;
1472 case SLANG_MINUS:
1473 objc->v.int_val = a - b; objc->o_data_type = SLANG_INT_TYPE;
1474 return 0;
1475 case SLANG_TIMES:
1476 objc->v.int_val = a * b; objc->o_data_type = SLANG_INT_TYPE;
1477 return 0;
1478 case SLANG_DIVIDE:
1479 if (b == 0)
1480 {
1481 SLang_set_error (SL_DIVIDE_ERROR);
1482 return -1;
1483 }
1484 objc->v.int_val = a/b; objc->o_data_type = SLANG_INT_TYPE;
1485 return 0;
1486 case SLANG_MOD:
1487 if (b == 0)
1488 {
1489 SLang_set_error (SL_DIVIDE_ERROR);
1490 return -1;
1491 }
1492 objc->v.int_val = a % b; objc->o_data_type = SLANG_INT_TYPE;
1493 return 0;
1494
1495 case SLANG_BAND:
1496 objc->v.int_val = (a & b); objc->o_data_type = SLANG_INT_TYPE;
1497 return 0;
1498 case SLANG_BXOR:
1499 objc->v.int_val = (a ^ b); objc->o_data_type = SLANG_INT_TYPE;
1500 return 0;
1501 case SLANG_BOR:
1502 objc->v.int_val = (a | b); objc->o_data_type = SLANG_INT_TYPE;
1503 return 0;
1504 case SLANG_SHL:
1505 objc->v.int_val = (a << b); objc->o_data_type = SLANG_INT_TYPE;
1506 return 0;
1507 case SLANG_SHR:
1508 objc->v.int_val = (a >> b); objc->o_data_type = SLANG_INT_TYPE;
1509 return 0;
1510
1511 case SLANG_EQ:
1512 objc->v.char_val = (a == b); objc->o_data_type = SLANG_CHAR_TYPE;
1513 return 0;
1514 case SLANG_NE:
1515 objc->v.char_val = (a != b); objc->o_data_type = SLANG_CHAR_TYPE;
1516 return 0;
1517 case SLANG_GT:
1518 objc->v.char_val = (a > b); objc->o_data_type = SLANG_CHAR_TYPE;
1519 return 0;
1520 case SLANG_GE:
1521 objc->v.char_val = (a >= b); objc->o_data_type = SLANG_CHAR_TYPE;
1522 return 0;
1523 case SLANG_LT:
1524 objc->v.char_val = (a < b); objc->o_data_type = SLANG_CHAR_TYPE;
1525 return 0;
1526 case SLANG_LE:
1527 objc->v.char_val = (a <= b); objc->o_data_type = SLANG_CHAR_TYPE;
1528 return 0;
1529 }
1530 if (-1 == do_binary_ab (op, obja, objb))
1531 return -1;
1532
1533 return pop_object (objc);
1534 }
1535
int_int_binary(int op,SLang_Object_Type * obja,SLang_Object_Type * objb)1536 static int int_int_binary (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
1537 {
1538 int a = obja->v.int_val;
1539 int b = objb->v.int_val;
1540
1541 switch (op)
1542 {
1543 case SLANG_PLUS:
1544 return push_int_object (SLANG_INT_TYPE, a + b);
1545 case SLANG_MINUS:
1546 return push_int_object (SLANG_INT_TYPE, a - b);
1547 case SLANG_TIMES:
1548 return push_int_object (SLANG_INT_TYPE, a * b);
1549 case SLANG_DIVIDE:
1550 if (b == 0)
1551 {
1552 SLang_set_error (SL_DIVIDE_ERROR);
1553 return -1;
1554 }
1555 return push_int_object (SLANG_INT_TYPE, a/b);
1556 case SLANG_MOD:
1557 if (b == 0)
1558 {
1559 SLang_set_error (SL_DIVIDE_ERROR);
1560 return -1;
1561 }
1562 return push_int_object (SLANG_INT_TYPE, a%b);
1563
1564 case SLANG_BAND:
1565 return push_int_object (SLANG_INT_TYPE, a&b);
1566 case SLANG_BXOR:
1567 return push_int_object (SLANG_INT_TYPE, a^b);
1568 case SLANG_BOR:
1569 return push_int_object (SLANG_INT_TYPE, a|b);
1570 case SLANG_SHL:
1571 return push_int_object (SLANG_INT_TYPE, a<<b);
1572 case SLANG_SHR:
1573 return push_int_object (SLANG_INT_TYPE, a>>b);
1574
1575 case SLANG_EQ:
1576 return push_char_object (SLANG_CHAR_TYPE, a == b);
1577 case SLANG_NE:
1578 return push_char_object (SLANG_CHAR_TYPE, a != b);
1579 case SLANG_GT:
1580 return push_char_object (SLANG_CHAR_TYPE, a > b);
1581 case SLANG_GE:
1582 return push_char_object (SLANG_CHAR_TYPE, a >= b);
1583 case SLANG_LT:
1584 return push_char_object (SLANG_CHAR_TYPE, a < b);
1585 case SLANG_LE:
1586 return push_char_object (SLANG_CHAR_TYPE, a <= b);
1587 }
1588 return do_binary_ab (op, obja, objb);
1589 }
1590
1591 #if SLANG_HAS_FLOAT
dbl_dbl_binary(int op,SLang_Object_Type * obja,SLang_Object_Type * objb)1592 static int dbl_dbl_binary (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
1593 {
1594 switch (op)
1595 {
1596 case SLANG_PLUS:
1597 return push_double_object (SLANG_DOUBLE_TYPE, obja->v.double_val + objb->v.double_val);
1598 case SLANG_MINUS:
1599 return push_double_object (SLANG_DOUBLE_TYPE, obja->v.double_val - objb->v.double_val);
1600 case SLANG_TIMES:
1601 return push_double_object (SLANG_DOUBLE_TYPE, obja->v.double_val * objb->v.double_val);
1602 case SLANG_DIVIDE:
1603 return push_double_object (SLANG_DOUBLE_TYPE, obja->v.double_val / objb->v.double_val);
1604 case SLANG_EQ:
1605 return push_char_object (SLANG_CHAR_TYPE, obja->v.double_val == objb->v.double_val);
1606 case SLANG_NE:
1607 return push_char_object (SLANG_CHAR_TYPE, obja->v.double_val != objb->v.double_val);
1608 case SLANG_GT:
1609 return push_char_object (SLANG_CHAR_TYPE, obja->v.double_val > objb->v.double_val);
1610 case SLANG_GE:
1611 return push_char_object (SLANG_CHAR_TYPE, obja->v.double_val >= objb->v.double_val);
1612 case SLANG_LT:
1613 return push_char_object (SLANG_CHAR_TYPE, obja->v.double_val < objb->v.double_val);
1614 case SLANG_LE:
1615 return push_char_object (SLANG_CHAR_TYPE, obja->v.double_val <= objb->v.double_val);
1616 case SLANG_POW:
1617 return push_double_object (SLANG_DOUBLE_TYPE, pow(obja->v.double_val, objb->v.double_val));
1618 }
1619 return do_binary_ab (op, obja, objb);
1620 }
1621
int_dbl_binary_result(int op,SLang_Object_Type * obja,SLang_Object_Type * objb,SLang_Object_Type * objc)1622 static int int_dbl_binary_result (int op, SLang_Object_Type *obja, SLang_Object_Type *objb, SLang_Object_Type *objc)
1623 {
1624 int a = obja->v.int_val;
1625 double b = objb->v.double_val;
1626
1627 switch (op)
1628 {
1629 case SLANG_PLUS:
1630 objc->v.double_val = a + b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1631 return 0;
1632 case SLANG_MINUS:
1633 objc->v.double_val = a - b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1634 return 0;
1635 case SLANG_TIMES:
1636 objc->v.double_val = a * b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1637 return 0;
1638 case SLANG_DIVIDE:
1639 objc->v.double_val = a / b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1640 return 0;
1641 case SLANG_EQ:
1642 objc->v.char_val = (a == b); objc->o_data_type = SLANG_CHAR_TYPE;
1643 return 0;
1644 case SLANG_NE:
1645 objc->v.char_val = (a != b); objc->o_data_type = SLANG_CHAR_TYPE;
1646 return 0;
1647 case SLANG_GT:
1648 objc->v.char_val = (a > b); objc->o_data_type = SLANG_CHAR_TYPE;
1649 return 0;
1650 case SLANG_GE:
1651 objc->v.char_val = (a >= b); objc->o_data_type = SLANG_CHAR_TYPE;
1652 return 0;
1653 case SLANG_LT:
1654 objc->v.char_val = (a < b); objc->o_data_type = SLANG_CHAR_TYPE;
1655 return 0;
1656 case SLANG_LE:
1657 objc->v.char_val = (a <= b); objc->o_data_type = SLANG_CHAR_TYPE;
1658 return 0;
1659 case SLANG_POW:
1660 objc->v.double_val = pow(a,b); objc->o_data_type = SLANG_DOUBLE_TYPE;
1661 return 0;
1662 }
1663 if (-1 == do_binary_ab (op, obja, objb))
1664 return -1;
1665
1666 return pop_object (objc);
1667 }
1668
dbl_int_binary_result(int op,SLang_Object_Type * obja,SLang_Object_Type * objb,SLang_Object_Type * objc)1669 static int dbl_int_binary_result (int op, SLang_Object_Type *obja, SLang_Object_Type *objb, SLang_Object_Type *objc)
1670 {
1671 double a = obja->v.double_val;
1672 int b = objb->v.int_val;
1673
1674 switch (op)
1675 {
1676 case SLANG_PLUS:
1677 objc->v.double_val = a + b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1678 return 0;
1679 case SLANG_MINUS:
1680 objc->v.double_val = a - b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1681 return 0;
1682 case SLANG_TIMES:
1683 objc->v.double_val = a * b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1684 return 0;
1685 case SLANG_DIVIDE:
1686 objc->v.double_val = a / b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1687 return 0;
1688 case SLANG_EQ:
1689 objc->v.char_val = (a == b); objc->o_data_type = SLANG_CHAR_TYPE;
1690 return 0;
1691 case SLANG_NE:
1692 objc->v.char_val = (a != b); objc->o_data_type = SLANG_CHAR_TYPE;
1693 return 0;
1694 case SLANG_GT:
1695 objc->v.char_val = (a > b); objc->o_data_type = SLANG_CHAR_TYPE;
1696 return 0;
1697 case SLANG_GE:
1698 objc->v.char_val = (a >= b); objc->o_data_type = SLANG_CHAR_TYPE;
1699 return 0;
1700 case SLANG_LT:
1701 objc->v.char_val = (a < b); objc->o_data_type = SLANG_CHAR_TYPE;
1702 return 0;
1703 case SLANG_LE:
1704 objc->v.char_val = (a <= b); objc->o_data_type = SLANG_CHAR_TYPE;
1705 return 0;
1706 case SLANG_POW:
1707 objc->v.double_val = pow(a,b); objc->o_data_type = SLANG_DOUBLE_TYPE;
1708 return 0;
1709 }
1710 if (-1 == do_binary_ab (op, obja, objb))
1711 return -1;
1712
1713 return pop_object (objc);
1714 }
1715
dbl_dbl_binary_result(int op,SLang_Object_Type * obja,SLang_Object_Type * objb,SLang_Object_Type * objc)1716 static int dbl_dbl_binary_result (int op, SLang_Object_Type *obja, SLang_Object_Type *objb, SLang_Object_Type *objc)
1717 {
1718 double a = obja->v.double_val;
1719 double b = objb->v.double_val;
1720
1721 switch (op)
1722 {
1723 case SLANG_PLUS:
1724 objc->v.double_val = a + b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1725 return 0;
1726 case SLANG_MINUS:
1727 objc->v.double_val = a - b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1728 return 0;
1729 case SLANG_TIMES:
1730 objc->v.double_val = a * b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1731 return 0;
1732 case SLANG_DIVIDE:
1733 objc->v.double_val = a / b; objc->o_data_type = SLANG_DOUBLE_TYPE;
1734 return 0;
1735 case SLANG_EQ:
1736 objc->v.char_val = (a == b); objc->o_data_type = SLANG_CHAR_TYPE;
1737 return 0;
1738 case SLANG_NE:
1739 objc->v.char_val = (a != b); objc->o_data_type = SLANG_CHAR_TYPE;
1740 return 0;
1741 case SLANG_GT:
1742 objc->v.char_val = (a > b); objc->o_data_type = SLANG_CHAR_TYPE;
1743 return 0;
1744 case SLANG_GE:
1745 objc->v.char_val = (a >= b); objc->o_data_type = SLANG_CHAR_TYPE;
1746 return 0;
1747 case SLANG_LT:
1748 objc->v.char_val = (a < b); objc->o_data_type = SLANG_CHAR_TYPE;
1749 return 0;
1750 case SLANG_LE:
1751 objc->v.char_val = (a <= b); objc->o_data_type = SLANG_CHAR_TYPE;
1752 return 0;
1753 case SLANG_POW:
1754 objc->v.double_val = pow(a,b); objc->o_data_type = SLANG_DOUBLE_TYPE;
1755 return 0;
1756 }
1757 if (-1 == do_binary_ab (op, obja, objb))
1758 return -1;
1759
1760 return pop_object (objc);
1761 }
1762 #endif /* SLANG_HAS_FLOAT */
1763 #endif /* SLANG_OPTIMIZE_FOR_SPEED */
1764
_pSLang_do_binary_ab(int op,SLang_Object_Type * obja,SLang_Object_Type * objb)1765 int _pSLang_do_binary_ab (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
1766 {
1767 #if SLANG_OPTIMIZE_FOR_SPEED
1768 if (obja->o_data_type == objb->o_data_type)
1769 {
1770 if (obja->o_data_type == SLANG_INT_TYPE)
1771 return int_int_binary (op, obja, objb);
1772 #if SLANG_HAS_FLOAT
1773 if (obja->o_data_type == SLANG_DOUBLE_TYPE)
1774 return dbl_dbl_binary (op, obja, objb);
1775 #endif
1776 }
1777 #endif
1778 return do_binary_ab (op, obja, objb);
1779 }
1780
1781 #define INC_REF(cl,type,addr,dr) \
1782 if (cl->cl_inc_ref != NULL) (*cl->cl_inc_ref)(type,addr,dr)
1783
1784 /* _INLINE_ */
do_binary_ab_inc_ref(int op,SLang_Object_Type * obja,SLang_Object_Type * objb)1785 static int do_binary_ab_inc_ref (int op, SLang_Object_Type *obja, SLang_Object_Type *objb)
1786 {
1787 int ret;
1788 SLang_Class_Type *cl_a, *cl_b;
1789 SLtype atype = obja->o_data_type;
1790 SLtype btype = objb->o_data_type;
1791
1792 if (atype == SLANG_INT_TYPE)
1793 {
1794 if (btype == SLANG_INT_TYPE)
1795 {
1796 int a, b;
1797
1798 a = obja->v.int_val; b = objb->v.int_val;
1799 switch (op)
1800 {
1801 case SLANG_PLUS:
1802 return push_int_object (SLANG_INT_TYPE, a+b);
1803 case SLANG_MINUS:
1804 return push_int_object (SLANG_INT_TYPE, a-b);
1805 case SLANG_TIMES:
1806 return push_int_object (SLANG_INT_TYPE, a*b);
1807 case SLANG_DIVIDE:
1808 if (b == 0)
1809 {
1810 SLang_set_error (SL_DIVIDE_ERROR);
1811 return -1;
1812 }
1813 return push_int_object (SLANG_INT_TYPE, a/b);
1814 case SLANG_MOD:
1815 if (b == 0)
1816 {
1817 SLang_set_error (SL_DIVIDE_ERROR);
1818 return -1;
1819 }
1820 return push_int_object (SLANG_INT_TYPE, a%b);
1821
1822 case SLANG_BAND:
1823 return push_int_object (SLANG_INT_TYPE, a&b);
1824 case SLANG_BXOR:
1825 return push_int_object (SLANG_INT_TYPE, a^b);
1826 case SLANG_BOR:
1827 return push_int_object (SLANG_INT_TYPE, a|b);
1828 case SLANG_SHL:
1829 return push_int_object (SLANG_INT_TYPE, a<<b);
1830 case SLANG_SHR:
1831 return push_int_object (SLANG_INT_TYPE, a>>b);
1832
1833 case SLANG_EQ:
1834 return push_char_object (SLANG_CHAR_TYPE, a==b);
1835 case SLANG_NE:
1836 return push_char_object (SLANG_CHAR_TYPE, a!=b);
1837 case SLANG_GT:
1838 return push_char_object (SLANG_CHAR_TYPE, a>b);
1839 case SLANG_GE:
1840 return push_char_object (SLANG_CHAR_TYPE, a>=b);
1841 case SLANG_LT:
1842 return push_char_object (SLANG_CHAR_TYPE, a<b);
1843 case SLANG_LE:
1844 return push_char_object (SLANG_CHAR_TYPE, a<=b);
1845 }
1846 return do_binary_ab (op, obja, objb);
1847 }
1848 #if SLANG_HAS_FLOAT
1849 if (btype == SLANG_DOUBLE_TYPE)
1850 {
1851 int a;
1852 double b;
1853
1854 a = obja->v.int_val; b = objb->v.double_val;
1855 switch (op)
1856 {
1857 case SLANG_PLUS:
1858 return push_double_object (SLANG_DOUBLE_TYPE, a+b);
1859 case SLANG_MINUS:
1860 return push_double_object (SLANG_DOUBLE_TYPE, a-b);
1861 case SLANG_TIMES:
1862 return push_double_object (SLANG_DOUBLE_TYPE, a*b);
1863 case SLANG_DIVIDE:
1864 return push_double_object (SLANG_DOUBLE_TYPE, a/b);
1865 case SLANG_EQ:
1866 return push_char_object (SLANG_CHAR_TYPE, a==b);
1867 case SLANG_NE:
1868 return push_char_object (SLANG_CHAR_TYPE, a!=b);
1869 case SLANG_GT:
1870 return push_char_object (SLANG_CHAR_TYPE, a>b);
1871 case SLANG_GE:
1872 return push_char_object (SLANG_CHAR_TYPE, a>=b);
1873 case SLANG_LT:
1874 return push_char_object (SLANG_CHAR_TYPE, a<b);
1875 case SLANG_LE:
1876 return push_char_object (SLANG_CHAR_TYPE, a<=b);
1877 case SLANG_POW:
1878 return push_double_object (SLANG_DOUBLE_TYPE, pow(a, b));
1879 }
1880 return do_binary_ab (op, obja, objb);
1881 }
1882 #endif /* SLANG_HAS_FLOAT */
1883 }
1884 #if SLANG_HAS_FLOAT
1885 else if (atype == SLANG_DOUBLE_TYPE)
1886 {
1887 double a, b;
1888
1889 if (btype == SLANG_DOUBLE_TYPE)
1890 b = objb->v.double_val;
1891 else if (btype == SLANG_INT_TYPE)
1892 b = (double) objb->v.int_val;
1893 else
1894 goto the_hard_way;
1895
1896 a = obja->v.double_val;
1897 switch (op)
1898 {
1899 case SLANG_PLUS:
1900 return push_double_object (SLANG_DOUBLE_TYPE, a+b);
1901 case SLANG_MINUS:
1902 return push_double_object (SLANG_DOUBLE_TYPE, a-b);
1903 case SLANG_TIMES:
1904 return push_double_object (SLANG_DOUBLE_TYPE, a*b);
1905 case SLANG_DIVIDE:
1906 return push_double_object (SLANG_DOUBLE_TYPE, a/b);
1907 case SLANG_EQ:
1908 return push_char_object (SLANG_CHAR_TYPE, a==b);
1909 case SLANG_NE:
1910 return push_char_object (SLANG_CHAR_TYPE, a!=b);
1911 case SLANG_GT:
1912 return push_char_object (SLANG_CHAR_TYPE, a>b);
1913 case SLANG_GE:
1914 return push_char_object (SLANG_CHAR_TYPE, a>=b);
1915 case SLANG_LT:
1916 return push_char_object (SLANG_CHAR_TYPE, a<b);
1917 case SLANG_LE:
1918 return push_char_object (SLANG_CHAR_TYPE, a<=b);
1919 case SLANG_POW:
1920 return push_double_object (SLANG_DOUBLE_TYPE, pow(a, b));
1921 }
1922 return do_binary_ab (op, obja, objb);
1923 }
1924 #endif /* SLANG_HAS_FLOAT */
1925
1926 the_hard_way:
1927
1928 GET_CLASS(cl_a, atype);
1929 GET_CLASS(cl_b, btype);
1930 INC_REF(cl_a, atype, &obja->v, 1);
1931 INC_REF(cl_b, btype, &objb->v, 1);
1932 ret = do_binary_ab (op, obja, objb);
1933 INC_REF(cl_a, atype, &obja->v, -1);
1934 INC_REF(cl_b, btype, &objb->v, -1);
1935
1936 return ret;
1937 }
1938
1939 #if SLANG_OPTIMIZE_FOR_SPEED
1940 /* Only for SLANG_BCST_ASSIGN */
1941 /* _INLINE_ */
do_binary_ab_inc_ref_assign(int op,SLang_Object_Type * obja,SLang_Object_Type * objb,SLang_Object_Type * objc)1942 static int do_binary_ab_inc_ref_assign (int op, SLang_Object_Type *obja, SLang_Object_Type *objb, SLang_Object_Type *objc)
1943 {
1944 int ret;
1945 SLang_Class_Type *cl, *cl_a, *cl_b;
1946 int c_needs_freed;
1947 SLtype atype, btype;
1948
1949 GET_CLASS(cl, objc->o_data_type);
1950 c_needs_freed = (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type);
1951
1952 atype = obja->o_data_type;
1953 btype = objb->o_data_type;
1954
1955 if (atype == SLANG_INT_TYPE)
1956 {
1957 if (btype == SLANG_INT_TYPE)
1958 {
1959 if (c_needs_freed)
1960 {
1961 ret = int_int_binary (op, obja, objb);
1962 goto the_return;
1963 }
1964 return int_int_binary_result (op, obja, objb, objc);
1965 }
1966 #if SLANG_HAS_FLOAT
1967 if (btype == SLANG_DOUBLE_TYPE)
1968 {
1969 if (c_needs_freed)
1970 {
1971 ret = do_binary_ab (op, obja, objb);
1972 goto the_return;
1973 }
1974 return int_dbl_binary_result (op, obja, objb, objc);
1975 }
1976 #endif /* SLANG_HAS_FLOAT */
1977 }
1978 #if SLANG_HAS_FLOAT
1979 else if (atype == SLANG_DOUBLE_TYPE)
1980 {
1981 if (btype == SLANG_DOUBLE_TYPE)
1982 {
1983 if (c_needs_freed)
1984 {
1985 ret = dbl_dbl_binary (op, obja, objb);
1986 goto the_return;
1987 }
1988 return dbl_dbl_binary_result (op, obja, objb, objc);
1989 }
1990
1991 if (btype == SLANG_INT_TYPE)
1992 {
1993 if (c_needs_freed)
1994 {
1995 ret = do_binary_ab (op, obja, objb);
1996 goto the_return;
1997 }
1998
1999 return dbl_int_binary_result (op, obja, objb, objc);
2000 }
2001 }
2002 #endif /* SLANG_HAS_FLOAT */
2003
2004 GET_CLASS(cl_a, atype);
2005 GET_CLASS(cl_b, btype);
2006 INC_REF(cl_a, atype, &obja->v, 1);
2007 INC_REF(cl_b, btype, &objb->v, 1);
2008 ret = do_binary_ab (op, obja, objb);
2009 INC_REF(cl_b, btype, &objb->v, -1);
2010 INC_REF(cl_a, atype, &obja->v, -1);
2011
2012 the_return:
2013
2014 if (ret != 0)
2015 return ret;
2016
2017 if (c_needs_freed)
2018 free_object (objc, cl);
2019
2020 return pop_object(objc);
2021 }
2022 #endif
2023
2024 /* _INLINE_ */
do_binary(int op)2025 static int do_binary (int op)
2026 {
2027 SLang_Object_Type obja, objb, *objap, *objbp;
2028 #if SLANG_OPTIMIZE_FOR_SPEED
2029 SLang_Class_Type *cl;
2030 #endif
2031 int ret;
2032
2033 objbp = Stack_Pointer;
2034 if (Run_Stack + 2 > objbp)
2035 {
2036 (void) SLang_set_error (SL_STACK_UNDERFLOW);
2037 SLdo_pop_n (objbp - Run_Stack);
2038 return -1;
2039 }
2040 objbp--;
2041 objap = objbp-1;
2042
2043 Stack_Pointer = objap;
2044 #if SLANG_OPTIMIZE_FOR_SPEED
2045 if (objbp->o_data_type == objap->o_data_type)
2046 {
2047 if (objbp->o_data_type == SLANG_INT_TYPE)
2048 return int_int_binary (op, objap, objbp);
2049 #if SLANG_HAS_FLOAT
2050 if (objbp->o_data_type == SLANG_DOUBLE_TYPE)
2051 return dbl_dbl_binary (op, objap, objbp);
2052 #endif
2053 }
2054 #endif
2055
2056 obja = *objap;
2057 objb = *objbp;
2058
2059 ret = do_binary_ab (op, &obja, &objb);
2060 #if SLANG_OPTIMIZE_FOR_SPEED
2061 GET_CLASS(cl, obja.o_data_type);
2062 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2063 free_object (&obja, cl);
2064 #else
2065 SLang_free_object (&obja);
2066 #endif
2067
2068 #if SLANG_OPTIMIZE_FOR_SPEED
2069 if (obja.o_data_type != objb.o_data_type)
2070 {
2071 GET_CLASS(cl, objb.o_data_type);
2072 }
2073 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2074 free_object (&objb, cl);
2075 #else
2076 SLang_free_object (&objb);
2077 #endif
2078
2079 return ret;
2080 }
2081
2082 _INLINE_
do_binary_b(int op,SLang_Object_Type * bp)2083 static int do_binary_b (int op, SLang_Object_Type *bp)
2084 {
2085 SLang_Object_Type a;
2086 #if SLANG_OPTIMIZE_FOR_SPEED
2087 SLang_Class_Type *cl;
2088 #endif
2089 int ret;
2090
2091 if (pop_object(&a)) return -1;
2092 #if SLANG_OPTIMIZE_FOR_SPEED
2093 if (a.o_data_type == bp->o_data_type)
2094 {
2095 if (a.o_data_type == SLANG_INT_TYPE)
2096 return int_int_binary (op, &a, bp);
2097
2098 #if SLANG_HAS_FLOAT
2099 if (a.o_data_type == SLANG_DOUBLE_TYPE)
2100 return dbl_dbl_binary (op, &a, bp);
2101 #endif
2102 }
2103 #endif
2104 ret = do_binary_ab (op, &a, bp);
2105 #if SLANG_OPTIMIZE_FOR_SPEED
2106 GET_CLASS(cl, a.o_data_type);
2107 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2108 free_object (&a, cl);
2109 #else
2110 SLang_free_object (&a);
2111 #endif
2112 return ret;
2113 }
2114
2115 #if SLANG_OPTIMIZE_FOR_SPEED
2116 /* _INLINE_ */
do_binary_b_inc_ref(int op,SLang_Object_Type * objbp)2117 static void do_binary_b_inc_ref (int op, SLang_Object_Type *objbp)
2118 {
2119 SLang_Object_Type obja;
2120 SLang_Class_Type *cl_a, *cl_b;
2121 SLang_Object_Type *objap;
2122 SLtype atype, btype;
2123
2124 btype = objbp->o_data_type;
2125
2126 if (btype == SLANG_INT_TYPE)
2127 {
2128 if (Stack_Pointer == Run_Stack)
2129 {
2130 (void) SLang_set_error (SL_STACK_UNDERFLOW);
2131 return;
2132 }
2133 objap = (Stack_Pointer-1);
2134 atype = objap->o_data_type;
2135
2136 if (atype == SLANG_INT_TYPE)
2137 {
2138 int a, b;
2139
2140 a = objap->v.int_val; b = objbp->v.int_val;
2141 switch (op)
2142 {
2143 case SLANG_PLUS:
2144 objap->v.int_val = a + b; return;
2145 case SLANG_MINUS:
2146 objap->v.int_val = a - b; return;
2147 case SLANG_TIMES:
2148 objap->v.int_val = a * b; return;
2149 case SLANG_EQ:
2150 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a == b); return;
2151 case SLANG_NE:
2152 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a != b); return;
2153 case SLANG_GT:
2154 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a > b); return;
2155 case SLANG_GE:
2156 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a >= b); return;
2157 case SLANG_LT:
2158 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a < b); return;
2159 case SLANG_LE:
2160 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a <= b); return;
2161 }
2162 (void) pop_object (&obja);
2163 do_binary_ab (op, &obja, objbp);
2164 return;
2165 }
2166 #if SLANG_HAS_FLOAT
2167 if (atype == SLANG_DOUBLE_TYPE)
2168 {
2169 double a;
2170 int b;
2171
2172 a = objap->v.double_val; b = objbp->v.int_val;
2173 switch (op)
2174 {
2175 case SLANG_PLUS:
2176 objap->v.double_val = a + b; return;
2177 case SLANG_MINUS:
2178 objap->v.double_val = a - b; return;
2179 case SLANG_TIMES:
2180 objap->v.double_val = a * b; return;
2181 case SLANG_DIVIDE:
2182 objap->v.double_val = a / b; return;
2183 case SLANG_EQ:
2184 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a == b); return;
2185 case SLANG_NE:
2186 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a != b); return;
2187 case SLANG_GT:
2188 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a > b); return;
2189 case SLANG_GE:
2190 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a >= b); return;
2191 case SLANG_LT:
2192 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a < b); return;
2193 case SLANG_LE:
2194 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a <= b); return;
2195 case SLANG_POW:
2196 objap->v.double_val = pow(a,b); return;
2197 }
2198 (void) pop_object (&obja);
2199 do_binary_ab (op, &obja, objbp);
2200 return;
2201 }
2202 #endif /* SLANG_HAS_FLOAT */
2203 }
2204 #if SLANG_HAS_FLOAT
2205 else if (btype == SLANG_DOUBLE_TYPE)
2206 {
2207 double a, b;
2208
2209 if (Stack_Pointer == Run_Stack)
2210 {
2211 (void) SLang_set_error (SL_STACK_UNDERFLOW);
2212 return;
2213 }
2214 objap = (Stack_Pointer-1);
2215 atype = objap->o_data_type;
2216
2217 if (atype == SLANG_DOUBLE_TYPE)
2218 a = objap->v.double_val;
2219 else if (atype == SLANG_INT_TYPE)
2220 a = (double) objap->v.int_val;
2221 else
2222 goto the_hard_way;
2223
2224 b = objbp->v.double_val;
2225 switch (op)
2226 {
2227 case SLANG_PLUS:
2228 objap->o_data_type = SLANG_DOUBLE_TYPE; objap->v.double_val = a + b; return;
2229 case SLANG_MINUS:
2230 objap->o_data_type = SLANG_DOUBLE_TYPE; objap->v.double_val = a - b; return;
2231 case SLANG_TIMES:
2232 objap->o_data_type = SLANG_DOUBLE_TYPE; objap->v.double_val = a * b; return;
2233 case SLANG_DIVIDE:
2234 objap->o_data_type = SLANG_DOUBLE_TYPE; objap->v.double_val = a / b; return;
2235 case SLANG_EQ:
2236 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a == b); return;
2237 case SLANG_NE:
2238 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a != b); return;
2239 case SLANG_GT:
2240 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a > b); return;
2241 case SLANG_GE:
2242 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a >= b); return;
2243 case SLANG_LT:
2244 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a < b); return;
2245 case SLANG_LE:
2246 objap->o_data_type = SLANG_CHAR_TYPE; objap->v.char_val = (a <= b); return;
2247 case SLANG_POW:
2248 objap->o_data_type = SLANG_DOUBLE_TYPE; objap->v.double_val = pow(a,b); return;
2249 }
2250 (void) pop_object (&obja);
2251 do_binary_ab (op, &obja, objbp);
2252 return;
2253 }
2254 #endif /* SLANG_HAS_FLOAT */
2255
2256 the_hard_way:
2257
2258 if (-1 == pop_object (&obja))
2259 return;
2260
2261 GET_CLASS(cl_a, obja.o_data_type);
2262 GET_CLASS(cl_b, btype);
2263
2264 INC_REF(cl_b, btype, &objbp->v, 1);
2265 (void) do_binary_ab (op, &obja, objbp);
2266 INC_REF(cl_b, btype, &objbp->v, -1);
2267
2268 if (SLANG_CLASS_TYPE_SCALAR != cl_a->cl_class_type)
2269 free_object (&obja, cl_a);
2270 }
2271 #endif
2272
do_unary_op(int op,SLang_Object_Type * obj,int unary_type)2273 static int do_unary_op (int op, SLang_Object_Type *obj, int unary_type)
2274 {
2275 int (*f) (int, SLtype, VOID_STAR, SLuindex_Type, VOID_STAR);
2276 VOID_STAR pa;
2277 VOID_STAR pb;
2278 SLang_Class_Type *a_cl, *b_cl;
2279 SLtype a_type, b_type;
2280 int ret;
2281
2282 a_type = obj->o_data_type;
2283 GET_CLASS (a_cl, a_type);
2284
2285 if (NULL == (f = _pSLclass_get_unary_fun (op, a_cl, &b_cl, unary_type)))
2286 return -1;
2287
2288 b_type = b_cl->cl_data_type;
2289
2290 #if SLANG_OPTIMIZE_FOR_SPEED
2291 if (SLANG_CLASS_TYPE_VECTOR == a_cl->cl_class_type)
2292 pa = (VOID_STAR) obj->v.ptr_val;
2293 else
2294 pa = (VOID_STAR) &obj->v;
2295 #else
2296 pa = _pSLclass_get_ptr_to_value (a_cl, obj);
2297 #endif
2298 pb = b_cl->cl_transfer_buf;
2299
2300 if (1 != (*f) (op, a_type, pa, 1, pb))
2301 {
2302 _pSLang_verror (SL_NOT_IMPLEMENTED,
2303 "Unary operation/function for %s failed", a_cl->cl_name);
2304 return -1;
2305 }
2306
2307 ret = (*b_cl->cl_apush)(b_type, pb);
2308 /* cl_apush creates a copy, so make sure we call cl_adestroy */
2309 #if SLANG_OPTIMIZE_FOR_SPEED
2310 if ((SLANG_CLASS_TYPE_SCALAR != b_cl->cl_class_type)
2311 && (SLANG_CLASS_TYPE_VECTOR != b_cl->cl_class_type))
2312 #endif
2313 (*b_cl->cl_adestroy)(b_type, pb);
2314
2315 return ret;
2316 }
2317
2318 _INLINE_
do_unary(int op,int unary_type)2319 static int do_unary (int op, int unary_type)
2320 {
2321 SLang_Object_Type obj;
2322 #if SLANG_OPTIMIZE_FOR_SPEED
2323 SLang_Class_Type *cl;
2324 #endif
2325 int ret;
2326
2327 if (-1 == pop_object(&obj)) return -1;
2328 ret = do_unary_op (op, &obj, unary_type);
2329 #if SLANG_OPTIMIZE_FOR_SPEED
2330 GET_CLASS(cl, obj.o_data_type);
2331 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_data_type)
2332 free_object (&obj, cl);
2333 #else
2334 SLang_free_object (&obj);
2335 #endif
2336 return ret;
2337 }
2338
do_assignment_binary(int op,SLang_Object_Type * obja_ptr)2339 static int do_assignment_binary (int op, SLang_Object_Type *obja_ptr)
2340 {
2341 SLang_Object_Type objb;
2342 #if SLANG_OPTIMIZE_FOR_SPEED
2343 SLtype btype;
2344 SLang_Class_Type *cl;
2345 #endif
2346 int ret;
2347
2348 if (pop_object(&objb))
2349 return -1;
2350 #if SLANG_OPTIMIZE_FOR_SPEED
2351 btype = objb.o_data_type;
2352 #endif
2353
2354 #if 0 && SLANG_OPTIMIZE_FOR_SPEED
2355 if (op == SLANG_PLUS)
2356 {
2357 if (obja_ptr->o_data_type == SLANG_BSTRING_TYPE)
2358 {
2359 if (btype == SLANG_BSTRING_TYPE)
2360 {
2361 ret = _pSLbstring_concat_bstr (obja_ptr, (SLang_BString_Type*)objb.v.ptr_val);
2362 SLbstring_free ((SLang_BString_Type *) objb.v.ptr_val);
2363 return ret;
2364 }
2365 if (btype == SLANG_STRING_TYPE)
2366 {
2367 ret = _pSLbstring_concat_str (obja_ptr, objb.v.s_val);
2368 _pSLang_free_slstring (objb.v.s_val);
2369 return ret;
2370 }
2371 }
2372 }
2373 #endif
2374
2375 ret = do_binary_ab (op, obja_ptr, &objb);
2376 #if SLANG_OPTIMIZE_FOR_SPEED
2377 GET_CLASS(cl, btype);
2378 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2379 free_object (&objb, cl);
2380 #else
2381 SLang_free_object (&objb);
2382 #endif
2383 return ret;
2384 }
2385
2386 /* The order of these is assumed to match the binary operators
2387 * defined in slang.h
2388 */
2389 static int
map_assignment_op_to_binary(int op_type,int * op,int * is_unary)2390 map_assignment_op_to_binary (int op_type, int *op, int *is_unary)
2391 {
2392 *is_unary = 0;
2393 switch (op_type)
2394 {
2395 case SLANG_BCST_PLUSEQS:
2396 case SLANG_BCST_MINUSEQS:
2397 case SLANG_BCST_TIMESEQS:
2398 case SLANG_BCST_DIVEQS:
2399 *op = SLANG_PLUS + (op_type - SLANG_BCST_PLUSEQS);
2400 break;
2401
2402 case SLANG_BCST_BOREQS:
2403 *op = SLANG_BOR;
2404 break;
2405
2406 case SLANG_BCST_BANDEQS:
2407 *op = SLANG_BAND;
2408 break;
2409
2410 case SLANG_BCST_POST_MINUSMINUS:
2411 case SLANG_BCST_MINUSMINUS:
2412 *op = SLANG_MINUS;
2413 *is_unary = 1;
2414 break;
2415
2416 case SLANG_BCST_PLUSPLUS:
2417 case SLANG_BCST_POST_PLUSPLUS:
2418 *op = SLANG_PLUS;
2419 *is_unary = 1;
2420 break;
2421
2422 default:
2423 _pSLang_verror (SL_NOT_IMPLEMENTED, "Assignment operator not implemented");
2424 return -1;
2425 }
2426 return 0;
2427 }
2428
2429 static int
perform_lvalue_operation(int op_type,SLang_Object_Type * obja_ptr)2430 perform_lvalue_operation (int op_type, SLang_Object_Type *obja_ptr)
2431 {
2432 switch (op_type)
2433 {
2434 case SLANG_BCST_ASSIGN:
2435 break;
2436
2437 /* The order of these is assumed to match the binary operators
2438 * defined in slang.h
2439 */
2440 case SLANG_BCST_PLUSEQS:
2441 case SLANG_BCST_MINUSEQS:
2442 case SLANG_BCST_TIMESEQS:
2443 case SLANG_BCST_DIVEQS:
2444 if (-1 == do_assignment_binary (SLANG_PLUS + (op_type - SLANG_BCST_PLUSEQS), obja_ptr))
2445 return -1;
2446 break;
2447
2448 case SLANG_BCST_BOREQS:
2449 if (-1 == do_assignment_binary (SLANG_BOR, obja_ptr))
2450 return -1;
2451 break;
2452
2453 case SLANG_BCST_BANDEQS:
2454 if (-1 == do_assignment_binary (SLANG_BAND, obja_ptr))
2455 return -1;
2456 break;
2457
2458 case SLANG_BCST_PLUSPLUS:
2459 case SLANG_BCST_POST_PLUSPLUS:
2460 #if SLANG_OPTIMIZE_FOR_SPEED
2461 if (obja_ptr->o_data_type == SLANG_INT_TYPE)
2462 return push_int_object (SLANG_INT_TYPE, obja_ptr->v.int_val + 1);
2463 #endif
2464 if (-1 == do_unary_op (SLANG_PLUSPLUS, obja_ptr, SLANG_BC_UNARY))
2465 return -1;
2466 break;
2467
2468 case SLANG_BCST_MINUSMINUS:
2469 case SLANG_BCST_POST_MINUSMINUS:
2470 #if SLANG_OPTIMIZE_FOR_SPEED
2471 if (obja_ptr->o_data_type == SLANG_INT_TYPE)
2472 return push_int_object (SLANG_INT_TYPE, obja_ptr->v.int_val - 1);
2473 #endif
2474 if (-1 == do_unary_op (SLANG_MINUSMINUS, obja_ptr, SLANG_BC_UNARY))
2475 return -1;
2476 break;
2477
2478 default:
2479 (void) SLang_set_error (SL_INTERNAL_ERROR);
2480 return -1;
2481 }
2482 return 0;
2483 }
2484
2485 _INLINE_
2486 static int
set_lvalue_obj(int op_type,SLang_Object_Type * obja_ptr)2487 set_lvalue_obj (int op_type, SLang_Object_Type *obja_ptr)
2488 {
2489 #if SLANG_OPTIMIZE_FOR_SPEED
2490 SLang_Class_Type *cl;
2491 #endif
2492 if (op_type != SLANG_BCST_ASSIGN)
2493 {
2494 if (-1 == perform_lvalue_operation (op_type, obja_ptr))
2495 return -1;
2496 }
2497 #if SLANG_OPTIMIZE_FOR_SPEED
2498 GET_CLASS(cl, obja_ptr->o_data_type);
2499 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2500 free_object (obja_ptr, cl);
2501 #else
2502 SLang_free_object (obja_ptr);
2503 #endif
2504
2505 return pop_object(obja_ptr);
2506 }
2507
2508 /* a = b; a += b; ... */
2509 _INLINE_
2510 static int
set_lvalue_obj_with_obj(int op_type,SLang_Object_Type * obja_ptr,SLang_Object_Type * objb_ptr)2511 set_lvalue_obj_with_obj (int op_type, SLang_Object_Type *obja_ptr, SLang_Object_Type *objb_ptr)
2512 {
2513 SLang_Class_Type *cl;
2514
2515 if (op_type != SLANG_BCST_ASSIGN)
2516 {
2517 if (-1 == _pSLpush_slang_obj (objb_ptr))
2518 return -1;
2519 if (-1 == perform_lvalue_operation (op_type, obja_ptr))
2520 return -1;
2521
2522 goto pop_method;
2523 }
2524
2525 if (SLANG_CLASS_TYPE_SCALAR == GET_CLASS_TYPE(objb_ptr->o_data_type))
2526 {
2527 /* We can copy b to a */
2528 #if SLANG_OPTIMIZE_FOR_SPEED
2529 GET_CLASS(cl, obja_ptr->o_data_type);
2530 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2531 free_object (obja_ptr, cl);
2532 #else
2533 SLang_free_object (obja_ptr);
2534 #endif
2535 *obja_ptr = *objb_ptr;
2536 return 0;
2537 }
2538
2539 /* a and b could refer to the same object. So push b first before freeing a */
2540
2541 GET_CLASS(cl, objb_ptr->o_data_type);
2542 if (-1 == (*cl->cl_push)(objb_ptr->o_data_type, (VOID_STAR)&objb_ptr->v))
2543 return -1;
2544
2545 pop_method:
2546
2547 #if SLANG_OPTIMIZE_FOR_SPEED
2548 GET_CLASS(cl, obja_ptr->o_data_type);
2549 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
2550 free_object (obja_ptr, cl);
2551 #else
2552 SLang_free_object (obja_ptr);
2553 #endif
2554
2555 return pop_object(obja_ptr);
2556 }
2557
2558 /* A.x = stackobj; A.x += stackobj, etc... */
2559 static int
set_struct_obj_lvalue(SLBlock_Type * bc_blk,SLang_Object_Type * objA,int do_free)2560 set_struct_obj_lvalue (SLBlock_Type *bc_blk, SLang_Object_Type *objA, int do_free)
2561 {
2562 SLtype type;
2563 SLang_Class_Type *cl;
2564 SLFUTURE_CONST char *name;
2565 int op, ret;
2566
2567 type = objA->o_data_type;
2568
2569 GET_CLASS(cl,type);
2570 if ((cl->cl_sput == NULL)
2571 || (cl->cl_sget == NULL))
2572 {
2573 _pSLang_verror (SL_NOT_IMPLEMENTED,
2574 "%s does not support structure access",
2575 cl->cl_name);
2576 if (do_free)
2577 free_object (objA, cl);
2578 return -1;
2579 }
2580 name = bc_blk->b.s_blk;
2581 op = bc_blk->bc_sub_type;
2582
2583 if (op != SLANG_BCST_ASSIGN)
2584 {
2585 /* We have something like (A.x += b) or (A.x++). In either case,
2586 * we need A.x.
2587 */
2588 SLang_Object_Type obj;
2589 #if SLANG_USE_TMP_OPTIMIZATION
2590 SLang_Class_Type *cl_obj;
2591 #endif
2592 if (cl->is_struct)
2593 {
2594 if ((-1 == _pSLstruct_push_field (objA->v.struct_val, name, 0))
2595 || (-1 == pop_object(&obj)))
2596 {
2597 if (do_free) free_object (objA, cl);
2598 return -1;
2599 }
2600 }
2601 else if ((-1 == _pSLpush_slang_obj (objA))
2602 || (-1 == cl->cl_sget ((SLtype) type, name))
2603 || (-1 == pop_object(&obj)))
2604 {
2605 if (do_free) free_object (objA, cl);
2606 return -1;
2607 }
2608
2609 /* Now the value of A.x is in obj. */
2610 #if SLANG_USE_TMP_OPTIMIZATION
2611 /*
2612 * It has at least 2 references: A.x and obj. Decrement its reference
2613 * to allow for the possibility of __tmp optimization.
2614 */
2615 GET_CLASS(cl_obj,obj.o_data_type);
2616 INC_REF(cl_obj, obj.o_data_type, &obj.v, -1);
2617 #endif
2618 ret = perform_lvalue_operation (op, &obj);
2619 #if SLANG_USE_TMP_OPTIMIZATION
2620 INC_REF(cl_obj, obj.o_data_type, &obj.v, 1);
2621 #endif
2622 if (ret == -1)
2623 {
2624 SLang_free_object (&obj);
2625 if (do_free) free_object (objA, cl);
2626 return -1;
2627 }
2628 #if SLANG_USE_TMP_OPTIMIZATION
2629 free_object (&obj, cl_obj);
2630 #endif
2631 }
2632
2633 /* The result of the operation is now on the stack.
2634 * Perform assignment
2635 */
2636 if (cl->is_struct)
2637 {
2638 ret = _pSLstruct_pop_field (objA->v.struct_val, name, 0);
2639 if (do_free) free_object (objA, cl);
2640 return ret;
2641 }
2642
2643 if (-1 == _pSLpush_slang_obj (objA))
2644 {
2645 if (do_free) free_object (objA, cl);
2646 return -1;
2647 }
2648
2649 ret = (*cl->cl_sput) ((SLtype) type, name);
2650 if (do_free) free_object (objA, cl);
2651 return ret;
2652 }
2653
2654 /* A.x = stack, A.x += stack, ... A is also on the stack. */
set_struct_lvalue(SLBlock_Type * bc_blk)2655 static int set_struct_lvalue (SLBlock_Type *bc_blk)
2656 {
2657 SLang_Object_Type objA;
2658
2659 if (-1 == pop_object (&objA))
2660 return -1;
2661
2662 return set_struct_obj_lvalue (bc_blk, &objA, 1);
2663 }
2664
2665 /* handle: @x op y
2666 * @x++, @x--
2667 */
set_deref_lvalue(int op)2668 static int set_deref_lvalue (int op)
2669 {
2670 int ret;
2671 SLang_Object_Type x;
2672 SLang_Ref_Type *ref;
2673
2674 if (-1 == SLang_pop_ref (&ref))
2675 return -1;
2676
2677 if (op == SLANG_BCST_ASSIGN)
2678 {
2679 ret = _pSLang_deref_assign (ref);
2680 SLang_free_ref (ref);
2681 return ret;
2682 }
2683
2684 ret = -1;
2685 if ((0 == _pSLang_dereference_ref (ref))
2686 && (0 == pop_object(&x)))
2687 {
2688 if (0 == perform_lvalue_operation (op, &x))
2689 ret = _pSLang_deref_assign (ref);
2690
2691 SLang_free_object (&x);
2692 }
2693
2694 SLang_free_ref (ref);
2695 return ret;
2696 }
2697
make_unit_object(SLang_Object_Type * a,SLang_Object_Type * u)2698 static int make_unit_object (SLang_Object_Type *a, SLang_Object_Type *u)
2699 {
2700 SLtype type;
2701
2702 type = a->o_data_type;
2703 if (type == SLANG_ARRAY_TYPE)
2704 type = a->v.array_val->data_type;
2705
2706 u->o_data_type = type;
2707 switch (type)
2708 {
2709 case SLANG_UCHAR_TYPE:
2710 case SLANG_CHAR_TYPE:
2711 u->v.char_val = 1;
2712 break;
2713
2714 case SLANG_SHORT_TYPE:
2715 case SLANG_USHORT_TYPE:
2716 u->v.short_val = 1;
2717 break;
2718
2719 case SLANG_LONG_TYPE:
2720 case SLANG_ULONG_TYPE:
2721 u->v.long_val = 1;
2722 break;
2723
2724 #if SLANG_HAS_FLOAT
2725 case SLANG_FLOAT_TYPE:
2726 u->v.float_val = 1;
2727 break;
2728
2729 case SLANG_COMPLEX_TYPE:
2730 u->o_data_type = SLANG_DOUBLE_TYPE;
2731 case SLANG_DOUBLE_TYPE:
2732 u->v.double_val = 1;
2733 break;
2734 #endif
2735 default:
2736 u->o_data_type = SLANG_INT_TYPE;
2737 u->v.int_val = 1;
2738 }
2739 return 0;
2740 }
2741
2742 /* We want to convert 'A[i] op X' to 'A[i] = A[i] op X'. The code that
2743 * has been generated is: X __args i A __aput-op
2744 * where __aput-op represents this function. We need to generate:
2745 * __args i A __eargs __aget X op __args i A __eargs __aput
2746 * Here, __eargs implies a call to do_bc_call_direct_nargs with either
2747 * the aput or aget function. In addition, __args represents a call to
2748 * start_arg_list. Of course, i represents a set of indices.
2749 *
2750 * Note: If op is an unary operation (e.g., ++ or --), then X will not
2751 * be present an will have to be taken to be 1.
2752 *
2753 * Implementation note: For efficiency, calls to setup the frame, start
2754 * arg list will be omitted and SLang_Num_Function_Args will be set.
2755 * This is ugly but the alternative is much less efficient rendering these
2756 * assignment operators useless. So, the plan is to roll the stack to get X,
2757 * then duplicate the next N values, call __aget followed by op X, finally
2758 * calling __aput. Hence, the sequence is:
2759 *
2760 * start: X i .. j A
2761 * dupN: X i .. j A i .. j A
2762 * __aget: X i .. j A Y
2763 * roll: i .. j A Y X
2764 * op: i .. j A Z
2765 * roll: Z i .. j A
2766 * __aput:
2767 */
2768 static int
set_array_lvalue(int op)2769 set_array_lvalue (int op)
2770 {
2771 SLang_Object_Type x, y;
2772 int is_unary;
2773 int status;
2774 #if SLANG_OPTIMIZE_FOR_SPEED
2775 int class_type;
2776 SLang_Class_Type *cl;
2777 #endif
2778 int num_args;
2779
2780 if (-1 == map_assignment_op_to_binary (op, &op, &is_unary))
2781 return -1;
2782
2783 /* Grab the indices and the array. Do not start a new frame. */
2784 if (-1 == end_arg_list ())
2785 return -1;
2786 if ((num_args = Next_Function_Num_Args) <= 0)
2787 {
2788 SLang_verror (SL_INTERNAL_ERROR, "set_array_lvalue: Next_Function_Num_Args<=0");
2789 return -1;
2790 }
2791 Next_Function_Num_Args = 0;
2792
2793 if (is_unary) /* PLUSPLUS, MINUSMINUS */
2794 {
2795 int type = peek_at_stack ();
2796 if (type == SLANG_ASSOC_TYPE)
2797 {
2798 return _pSLassoc_inc_value (num_args-1,
2799 (op == SLANG_PLUS) ? +1 : -1);
2800 }
2801 }
2802
2803 if (-1 == SLdup_n (num_args))
2804 return -1;
2805
2806 if (-1 == _pSLarray_aget1 (num_args-1))
2807 return -1;
2808
2809 if (-1 == pop_object(&y))
2810 return -1;
2811
2812 if (is_unary == 0)
2813 {
2814 if ((-1 == roll_stack (-(num_args + 1)))
2815 || (-1 == pop_object(&x)))
2816 {
2817 SLang_free_object (&y);
2818 return -1;
2819 }
2820 }
2821 else if (-1 == make_unit_object (&y, &x))
2822 {
2823 SLang_free_object (&y);
2824 return -1;
2825 }
2826 #if SLANG_OPTIMIZE_FOR_SPEED
2827 if (x.o_data_type == y.o_data_type)
2828 {
2829 if (x.o_data_type == SLANG_INT_TYPE)
2830 status = int_int_binary (op, &y, &x);
2831 #if SLANG_HAS_FLOAT
2832 else if (x.o_data_type == SLANG_DOUBLE_TYPE)
2833 status = dbl_dbl_binary (op, &y, &x);
2834 #endif
2835 else status = do_binary_ab (op, &y, &x);
2836 }
2837 else
2838 #endif
2839 status = do_binary_ab (op, &y, &x);
2840
2841 if (status != 0)
2842 {
2843 SLang_free_object (&y);
2844 SLang_free_object (&x);
2845 return -1;
2846 }
2847
2848 #if SLANG_OPTIMIZE_FOR_SPEED
2849 GET_CLASS(cl, y.o_data_type);
2850 class_type = cl->cl_class_type;
2851 if (SLANG_CLASS_TYPE_SCALAR != class_type)
2852 free_object (&y, cl);
2853 #else
2854 SLang_free_object (&y);
2855 #endif
2856
2857 #if SLANG_OPTIMIZE_FOR_SPEED
2858 if (cl->cl_data_type != x.o_data_type)
2859 {
2860 GET_CLASS(cl, x.o_data_type);
2861 class_type = cl->cl_class_type;
2862 }
2863 if (SLANG_CLASS_TYPE_SCALAR != class_type)
2864 free_object (&x, cl);
2865 #else
2866 SLang_free_object (&x);
2867 #endif
2868
2869 if (-1 == roll_stack (num_args + 1))
2870 return -1;
2871
2872 return _pSLarray_aput1 (num_args-1);
2873 }
2874
2875 static int
set_intrin_lvalue(SLBlock_Type * bc_blk)2876 set_intrin_lvalue (SLBlock_Type *bc_blk)
2877 {
2878 int op_type;
2879 SLang_Object_Type obja;
2880 SLang_Class_Type *cl;
2881 SLang_Intrin_Var_Type *ivar;
2882 VOID_STAR intrinsic_addr;
2883 SLtype intrinsic_type;
2884
2885 ivar = bc_blk->b.nt_ivar_blk;
2886
2887 intrinsic_type = ivar->type;
2888 intrinsic_addr = ivar->addr;
2889
2890 op_type = bc_blk->bc_sub_type;
2891
2892 GET_CLASS(cl, intrinsic_type);
2893
2894 if (op_type != SLANG_BCST_ASSIGN)
2895 {
2896 /* We want to get the current value into obja. This is the
2897 * easiest way.
2898 */
2899 if ((-1 == (*cl->cl_push) (intrinsic_type, intrinsic_addr))
2900 || (-1 == pop_object(&obja)))
2901 return -1;
2902
2903 (void) perform_lvalue_operation (op_type, &obja);
2904 SLang_free_object (&obja);
2905
2906 if (IS_SLANG_ERROR)
2907 return -1;
2908 }
2909
2910 return (*cl->cl_pop) (intrinsic_type, intrinsic_addr);
2911 }
2912
push_intrinsic_variable(SLang_Intrin_Var_Type * ivar)2913 static int push_intrinsic_variable (SLang_Intrin_Var_Type *ivar)
2914 {
2915 SLang_Class_Type *cl;
2916 SLtype stype;
2917
2918 stype = ivar->type;
2919 GET_CLASS(cl,stype);
2920
2921 if (-1 == (*cl->cl_push_intrinsic) (stype, ivar->addr))
2922 {
2923 do_name_type_error ((SLang_Name_Type *) ivar);
2924 return -1;
2925 }
2926 return 0;
2927 }
2928
push_nametype_variable(SLang_Name_Type * nt)2929 static int push_nametype_variable (SLang_Name_Type *nt)
2930 {
2931 switch (nt->name_type)
2932 {
2933 case SLANG_PVARIABLE:
2934 case SLANG_GVARIABLE:
2935 return _pSLpush_slang_obj (&((SLang_Global_Var_Type *)nt)->obj);
2936
2937 case SLANG_IVARIABLE:
2938 case SLANG_RVARIABLE:
2939 return push_intrinsic_variable ((SLang_Intrin_Var_Type *)nt);
2940
2941 case SLANG_HCONSTANT:
2942 return SLclass_push_short_obj (((SLang_HConstant_Type *)nt)->data_type, ((SLang_HConstant_Type*)nt)->value);
2943 case SLANG_ICONSTANT:
2944 return push_int_object (((SLang_IConstant_Type *)nt)->data_type, ((SLang_IConstant_Type*)nt)->value);
2945 case SLANG_LCONSTANT:
2946 return SLclass_push_long_obj (((SLang_LConstant_Type *)nt)->data_type, ((SLang_LConstant_Type*)nt)->value);
2947
2948 #if SLANG_HAS_FLOAT
2949 case SLANG_DCONSTANT:
2950 return push_double_object (SLANG_DOUBLE_TYPE, ((SLang_DConstant_Type*)nt)->d);
2951 case SLANG_FCONSTANT:
2952 return SLclass_push_float_obj (SLANG_FLOAT_TYPE, ((SLang_FConstant_Type*)nt)->f);
2953 #endif
2954 #ifdef HAVE_LONG_LONG
2955 case SLANG_LLCONSTANT:
2956 return SLclass_push_llong_obj (SLANG_LLONG_TYPE, ((SLang_LLConstant_Type*)nt)->ll);
2957 #endif
2958 }
2959 _pSLang_verror (SL_TYPE_MISMATCH, "Symbol %s is not a variable", nt->name);
2960 return -1;
2961 }
2962
set_nametype_variable(SLang_Name_Type * nt)2963 static int set_nametype_variable (SLang_Name_Type *nt)
2964 {
2965 SLBlock_Type blk;
2966
2967 switch (nt->name_type)
2968 {
2969 case SLANG_GVARIABLE:
2970 case SLANG_PVARIABLE:
2971 if (-1 == set_lvalue_obj (SLANG_BCST_ASSIGN,
2972 &((SLang_Global_Var_Type *)nt)->obj))
2973 {
2974 do_name_type_error (nt);
2975 return -1;
2976 }
2977 break;
2978
2979 case SLANG_IVARIABLE:
2980 blk.b.nt_blk = nt;
2981 blk.bc_sub_type = SLANG_BCST_ASSIGN;
2982 if (-1 == set_intrin_lvalue (&blk))
2983 {
2984 do_name_type_error (nt);
2985 return -1;
2986 }
2987 break;
2988
2989 case SLANG_LVARIABLE:
2990 (void) SLang_set_error (SL_INTERNAL_ERROR);
2991 return -1;
2992
2993 case SLANG_RVARIABLE:
2994 default:
2995 _pSLang_verror (SL_READONLY_ERROR, "%s is read-only", nt->name);
2996 return -1;
2997 }
2998
2999 return 0;
3000 }
3001
3002 /* References to Nametype objects */
nt_ref_string(VOID_STAR vdata)3003 static char *nt_ref_string (VOID_STAR vdata)
3004 {
3005 SLang_NameSpace_Type *ns;
3006 SLang_Name_Type *nt = *(SLang_Name_Type **)vdata;
3007 SLCONST char *name;
3008 SLstrlen_Type len;
3009 char *s;
3010
3011 ns = _pSLns_find_object_namespace (nt);
3012 if (ns == NULL)
3013 return NULL;
3014
3015 name = nt->name;
3016 len = strlen (name);
3017
3018 if ((ns->namespace_name != NULL)
3019 && (0 != strcmp (ns->namespace_name, "Global")))
3020 {
3021 SLstrlen_Type dlen = strlen (ns->namespace_name);
3022 s = (char *)SLmalloc (len + dlen + 4);
3023 if (s == NULL)
3024 return NULL;
3025 (void) sprintf (s, "&%s->%s", ns->namespace_name, name);
3026 return s;
3027 }
3028
3029 if (NULL == (s = (char *)SLmalloc (len + 2)))
3030 return NULL;
3031
3032 *s = '&';
3033 strcpy (s + 1, name);
3034 return s;
3035 }
3036
nt_ref_destroy(VOID_STAR vdata)3037 static void nt_ref_destroy (VOID_STAR vdata)
3038 {
3039 /* SLang_free_function ((SLang_Name_Type *)nt) -- someday */
3040 (void) vdata;
3041 }
3042
nt_ref_deref_assign(VOID_STAR vdata)3043 static int nt_ref_deref_assign (VOID_STAR vdata)
3044 {
3045 return set_nametype_variable (*(SLang_Name_Type **) vdata);
3046 }
3047
3048 static int inner_interp_nametype (SLang_Name_Type *, int);
nt_ref_deref(VOID_STAR vdata)3049 static int nt_ref_deref (VOID_STAR vdata)
3050 {
3051 (void) inner_interp_nametype (*(SLang_Name_Type **)vdata, 0);
3052 return 0;
3053 }
3054
nt_ref_is_initialized(VOID_STAR v)3055 static int nt_ref_is_initialized (VOID_STAR v)
3056 {
3057 SLang_Name_Type *nt = *(SLang_Name_Type **)v;
3058
3059 if ((nt->name_type != SLANG_GVARIABLE)
3060 && (nt->name_type != SLANG_PVARIABLE))
3061 return 1;
3062
3063 return ((SLang_Global_Var_Type *)nt)->obj.o_data_type != SLANG_UNDEFINED_TYPE;
3064 }
3065
nt_ref_uninitialize(VOID_STAR v)3066 static int nt_ref_uninitialize (VOID_STAR v)
3067 {
3068 SLang_Name_Type *nt = *(SLang_Name_Type **)v;
3069 SLang_Object_Type *obj;
3070
3071 if ((nt->name_type != SLANG_GVARIABLE)
3072 && (nt->name_type != SLANG_PVARIABLE))
3073 return -1;
3074
3075 obj = &((SLang_Global_Var_Type *)nt)->obj;
3076 SLang_free_object (obj);
3077 obj->o_data_type = SLANG_UNDEFINED_TYPE;
3078 obj->v.ptr_val = NULL;
3079 return 0;
3080 }
3081
create_ref_to_nametype(SLang_Name_Type * nt)3082 static SLang_Ref_Type *create_ref_to_nametype (SLang_Name_Type *nt)
3083 {
3084 SLang_Ref_Type *ref;
3085
3086 if (NULL == (ref = _pSLang_new_ref (sizeof (SLang_Name_Type *))))
3087 return NULL;
3088
3089 ref->data_is_nametype = 1;
3090 *(SLang_Name_Type **)ref->data = nt;
3091 ref->destroy = nt_ref_destroy;
3092 ref->string = nt_ref_string;
3093 ref->deref = nt_ref_deref;
3094 ref->deref_assign = nt_ref_deref_assign;
3095 ref->is_initialized = nt_ref_is_initialized;
3096 ref->uninitialize = nt_ref_uninitialize;
3097 return ref;
3098 }
3099
SLang_assign_nametype_to_ref(SLang_Ref_Type * ref,SLang_Name_Type * nt)3100 int SLang_assign_nametype_to_ref (SLang_Ref_Type *ref, SLang_Name_Type *nt)
3101 {
3102 SLang_Ref_Type *r;
3103
3104 if ((nt == NULL) || (ref == NULL))
3105 return -1;
3106
3107 if (NULL == (r = create_ref_to_nametype (nt)))
3108 return -1;
3109
3110 if (-1 == SLang_assign_to_ref (ref, SLANG_REF_TYPE, (VOID_STAR) &r))
3111 {
3112 SLang_free_ref (r);
3113 return -1;
3114 }
3115 SLang_free_ref (r);
3116 return 0;
3117 }
3118
3119 /* Note: This is ok if nt is NULL. Some routines rely on this behavior */
_pSLang_push_nt_as_ref(SLang_Name_Type * nt)3120 int _pSLang_push_nt_as_ref (SLang_Name_Type *nt)
3121 {
3122 SLang_Ref_Type *r;
3123 int ret;
3124
3125 if (nt == NULL)
3126 return SLang_push_null ();
3127
3128 r = create_ref_to_nametype (nt);
3129 if (r == NULL) return -1;
3130
3131 ret = SLang_push_ref (r);
3132 SLang_free_ref (r);
3133 return ret;
3134 }
3135
3136 /* Local variable references */
lv_ref_check_object(VOID_STAR vdata)3137 static SLang_Object_Type *lv_ref_check_object (VOID_STAR vdata)
3138 {
3139 SLang_Object_Type *obj = *(SLang_Object_Type **)vdata;
3140
3141 if (obj > Local_Variable_Frame)
3142 {
3143 _pSLang_verror (SL_UNDEFINED_NAME, "Local variable reference is out of scope");
3144 return NULL;
3145 }
3146 return obj;
3147 }
3148
lv_ref_deref(VOID_STAR vdata)3149 static int lv_ref_deref (VOID_STAR vdata)
3150 {
3151 SLang_Object_Type *obj = lv_ref_check_object (vdata);
3152 if (obj == NULL)
3153 return -1;
3154 return _pSLpush_slang_obj (obj);
3155 }
3156
lv_ref_deref_assign(VOID_STAR vdata)3157 static int lv_ref_deref_assign (VOID_STAR vdata)
3158 {
3159 SLang_Object_Type *objp = lv_ref_check_object (vdata);
3160 if (objp == NULL)
3161 return -1;
3162 return set_lvalue_obj (SLANG_BCST_ASSIGN, objp);
3163 }
3164
lv_ref_destroy(VOID_STAR vdata)3165 static void lv_ref_destroy (VOID_STAR vdata)
3166 {
3167 (void)vdata;
3168 }
3169
lv_ref_string(VOID_STAR vdata)3170 static char *lv_ref_string (VOID_STAR vdata)
3171 {
3172 (void) vdata;
3173 return SLmake_string ("Local variable reference");
3174 }
3175
lv_ref_is_initialized(VOID_STAR v)3176 static int lv_ref_is_initialized (VOID_STAR v)
3177 {
3178 SLang_Object_Type *objp = lv_ref_check_object (v);
3179 if (objp == NULL)
3180 return -1;
3181
3182 return objp->o_data_type != SLANG_UNDEFINED_TYPE;
3183 }
3184
lv_ref_uninitialize(VOID_STAR v)3185 static int lv_ref_uninitialize (VOID_STAR v)
3186 {
3187 SLang_Object_Type *obj = lv_ref_check_object (v);
3188 if (obj == NULL)
3189 return -1;
3190
3191 SLang_free_object (obj);
3192 obj->o_data_type = SLANG_UNDEFINED_TYPE;
3193 obj->v.ptr_val = NULL;
3194 return 0;
3195 }
3196
lv_new_ref(SLang_Object_Type * objp)3197 static SLang_Ref_Type *lv_new_ref (SLang_Object_Type *objp)
3198 {
3199 SLang_Ref_Type *ref;
3200
3201 if (NULL == (ref = _pSLang_new_ref (sizeof (SLang_Object_Type *))))
3202 return NULL;
3203 *(SLang_Object_Type **)ref->data = objp;
3204 ref->destroy = lv_ref_destroy;
3205 ref->string = lv_ref_string;
3206 ref->deref = lv_ref_deref;
3207 ref->deref_assign = lv_ref_deref_assign;
3208 ref->is_initialized = lv_ref_is_initialized;
3209 ref->uninitialize = lv_ref_uninitialize;
3210 return ref;
3211 }
3212
push_lv_as_ref(SLang_Object_Type * objp)3213 static int push_lv_as_ref (SLang_Object_Type *objp)
3214 {
3215 int ret;
3216 SLang_Ref_Type *ref = lv_new_ref (objp);
3217
3218 if (ref == NULL)
3219 return -1;
3220
3221 ret = SLang_push_ref (ref);
3222 SLang_free_ref (ref);
3223 return ret;
3224 }
3225
3226 #if 0
3227 static void set_deref_lvalue (SLBlock_Type *bc_blk)
3228 {
3229 SLang_Object_Type *objp;
3230 SLang_Ref_Type *ref;
3231
3232 switch (bc_blk->bc_sub_type)
3233 {
3234 case SLANG_LVARIABLE:
3235 objp = (Local_Variable_Frame - bc_blk->b.i_blk);
3236 break;
3237 case SLANG_GVARIABLE:
3238 case SLANG_PVARIABLE:
3239 objp = &bc_blk->b.nt_gvar_blk->obj;
3240 break;
3241 default:
3242 (void) SLang_set_error (SL_INTERNAL_ERROR);
3243 return;
3244 }
3245
3246 if (-1 == _pSLpush_slang_obj (objp))
3247 return;
3248
3249 if (-1 == SLang_pop_ref (&ref))
3250 return;
3251 (void) _pSLang_deref_assign (ref);
3252 SLang_free_ref (ref);
3253 }
3254 #endif
3255
push_struct_field(SLFUTURE_CONST char * name)3256 static int push_struct_field (SLFUTURE_CONST char *name)
3257 {
3258 SLang_Class_Type *cl;
3259 SLang_Object_Type obj;
3260 SLtype type;
3261
3262 if (-1 == pop_object (&obj))
3263 return -1;
3264
3265 if (SLANG_STRUCT_TYPE == (type = obj.o_data_type))
3266 return _pSLstruct_push_field (obj.v.struct_val, name, 1);
3267
3268 GET_CLASS(cl, (SLtype) type);
3269
3270 if (cl->is_struct)
3271 return _pSLstruct_push_field (obj.v.struct_val, name, 1);
3272
3273 if (cl->cl_sget == NULL)
3274 {
3275 _pSLang_verror (SL_NOT_IMPLEMENTED,
3276 "%s does not permit structure access",
3277 cl->cl_name);
3278 free_object (&obj, cl);
3279 return -1;
3280 }
3281 if (-1 == push_object (&obj))
3282 {
3283 free_object (&obj, cl);
3284 return -1;
3285 }
3286 return (*cl->cl_sget) ((SLtype) type, name);
3287 }
3288
is_nametype_callable(SLang_Name_Type * nt)3289 static int is_nametype_callable (SLang_Name_Type *nt)
3290 {
3291 switch (nt->name_type)
3292 {
3293 case SLANG_PFUNCTION:
3294 case SLANG_FUNCTION:
3295 case SLANG_INTRINSIC:
3296 case SLANG_ARITH_UNARY:
3297 case SLANG_MATH_UNARY:
3298 case SLANG_APP_UNARY:
3299 case SLANG_ARITH_BINARY:
3300 return 1;
3301 }
3302 return 0;
3303 }
3304
_pSLang_ref_is_callable(SLang_Ref_Type * ref)3305 int _pSLang_ref_is_callable (SLang_Ref_Type *ref)
3306 {
3307 if (ref->data_is_nametype == 0)
3308 return 0;
3309
3310 return is_nametype_callable (*(SLang_Name_Type **)ref->data);
3311 }
3312
3313 static int inner_interp(register SLBlock_Type *);
inner_interp_nametype(SLang_Name_Type * nt,int linenum)3314 static int inner_interp_nametype (SLang_Name_Type *nt, int linenum)
3315 {
3316 SLBlock_Type bc_blks[2];
3317
3318 bc_blks[0].b.nt_blk = nt;
3319 bc_blks[0].bc_main_type = (_pSLang_BC_Type)nt->name_type;
3320 bc_blks[0].bc_sub_type = 0;
3321 bc_blks[0].linenum = linenum;
3322 bc_blks[1].bc_main_type = SLANG_BC_LAST_BLOCK;
3323
3324 return inner_interp(bc_blks);
3325 }
3326
3327 /* This function also frees the object */
deref_call_object(SLang_Object_Type * obj,int linenum)3328 static int deref_call_object (SLang_Object_Type *obj, int linenum)
3329 {
3330 if (obj->o_data_type == SLANG_REF_TYPE)
3331 {
3332 SLang_Ref_Type *ref = (SLang_Ref_Type *)obj->v.ref;
3333 if ((ref != NULL) && ref->data_is_nametype
3334 && is_nametype_callable (*(SLang_Name_Type **)ref->data))
3335 {
3336 int ret = inner_interp_nametype (*(SLang_Name_Type**)ref->data, linenum);
3337 SLang_free_ref (ref);
3338 return ret;
3339 }
3340 }
3341 _pSLang_verror (SL_TYPE_MISMATCH, "Expected a reference to a function");
3342 SLang_free_object (obj);
3343 return -1;
3344 }
3345
3346 /* This arises from code such as a.f(x,y) with the following on the stack:
3347 *
3348 * __args x y a
3349 *
3350 * This function turns this into
3351 *
3352 * __args a x y _eargs (@a.field)
3353 *
3354 */
do_struct_method(SLFUTURE_CONST char * name,int linenum)3355 static int do_struct_method (SLFUTURE_CONST char *name, int linenum)
3356 {
3357 SLang_Object_Type obj;
3358
3359 if (-1 == SLdup_n (1))
3360 return -1; /* stack: __args x y a a */
3361
3362 if (-1 == push_struct_field (name))
3363 return -1; /* stack: __args x y a a.name */
3364
3365 if (-1 == pop_object(&obj))
3366 return -1;
3367
3368 if (-1 == end_arg_list ())
3369 {
3370 SLang_free_object (&obj);
3371 return -1;
3372 }
3373 /* stack: __args x y a __eargs */
3374 if (-1 == roll_stack (Next_Function_Num_Args))
3375 {
3376 SLang_free_object (&obj);
3377 return -1;
3378 }
3379 return deref_call_object (&obj, linenum); /* frees obj */
3380 }
3381
3382 #if defined(__GNUC__)
3383 # pragma GCC diagnostic ignored "-Wformat-nonliteral"
3384 #endif
trace_dump(SLFUTURE_CONST char * format,char * name,SLang_Object_Type * objs,int n,int dir)3385 static void trace_dump (SLFUTURE_CONST char *format, char *name, SLang_Object_Type *objs, int n, int dir)
3386 {
3387 unsigned int len;
3388 char prefix [52];
3389
3390 len = Trace_Mode - 1;
3391 if (len + 2 >= sizeof (prefix))
3392 len = sizeof (prefix) - 2;
3393
3394 SLMEMSET (prefix, ' ', len);
3395 prefix[len] = 0;
3396
3397 _pSLerr_dump_msg ("%s", prefix);
3398 _pSLerr_dump_msg (format, name, n);
3399
3400 if (n > 0)
3401 {
3402 prefix[len] = ' ';
3403 len++;
3404 prefix[len] = 0;
3405
3406 _pSLerr_dump_msg (prefix, objs, n, dir);
3407 }
3408 }
3409 #if defined(__GNUC__)
3410 # pragma GCC diagnostic warning "-Wformat-nonliteral"
3411 #endif
3412
3413 /* Pop a data item from the stack and return a pointer to it.
3414 * Strings are not freed from stack so use another routine to do it.
3415 */
pop_pointer(SLang_Object_Type * obj,SLtype type)3416 static VOID_STAR pop_pointer (SLang_Object_Type *obj, SLtype type)
3417 {
3418 #ifndef SLANG_OPTIMIZE_FOR_SPEED
3419 SLang_Class_Type *cl;
3420 #endif
3421
3422 SLang_Array_Type *at;
3423
3424 /* Arrays are special. Allow scalars to automatically convert to arrays.
3425 */
3426 if (type == SLANG_ARRAY_TYPE)
3427 {
3428 if (-1 == SLang_pop_array (&at, 1))
3429 return NULL;
3430 obj->o_data_type = SLANG_ARRAY_TYPE;
3431 return obj->v.ptr_val = (VOID_STAR) at;
3432 }
3433
3434 if (type == 0)
3435 {
3436 /* This happens when an intrinsic is declared without any information
3437 * regarding parameter types.
3438 */
3439 if (-1 == pop_object(obj))
3440 return NULL;
3441 type = obj->o_data_type;
3442 }
3443 else if (-1 == pop_object_of_type (type, obj, 0))
3444 return NULL;
3445
3446 type = GET_CLASS_TYPE(type);
3447
3448 if (type == SLANG_CLASS_TYPE_SCALAR)
3449 return (VOID_STAR) &obj->v;
3450 else if (type == SLANG_CLASS_TYPE_MMT)
3451 return SLang_object_from_mmt (obj->v.ref);
3452 else
3453 return obj->v.ptr_val;
3454 }
3455
3456 /* This is ugly. Does anyone have a advice for a cleaner way of doing
3457 * this??
3458 */
3459 typedef void (*VF0_Type)(void);
3460 typedef void (*VF1_Type)(VOID_STAR);
3461 typedef void (*VF2_Type)(VOID_STAR, VOID_STAR);
3462 typedef void (*VF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
3463 typedef void (*VF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3464 typedef void (*VF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3465 typedef void (*VF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3466 typedef void (*VF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3467 typedef long (*LF0_Type)(void);
3468 typedef long (*LF1_Type)(VOID_STAR);
3469 typedef long (*LF2_Type)(VOID_STAR, VOID_STAR);
3470 typedef long (*LF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
3471 typedef long (*LF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3472 typedef long (*LF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3473 typedef long (*LF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3474 typedef long (*LF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3475 #if SLANG_HAS_FLOAT
3476 typedef double (*FF0_Type)(void);
3477 typedef double (*FF1_Type)(VOID_STAR);
3478 typedef double (*FF2_Type)(VOID_STAR, VOID_STAR);
3479 typedef double (*FF3_Type)(VOID_STAR, VOID_STAR, VOID_STAR);
3480 typedef double (*FF4_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3481 typedef double (*FF5_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3482 typedef double (*FF6_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3483 typedef double (*FF7_Type)(VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR, VOID_STAR);
3484 #endif
3485
execute_intrinsic_fun(SLang_Intrin_Fun_Type * objf)3486 static int execute_intrinsic_fun (SLang_Intrin_Fun_Type *objf)
3487 {
3488 #if SLANG_HAS_FLOAT
3489 double xf;
3490 #endif
3491 VOID_STAR p[SLANG_MAX_INTRIN_ARGS];
3492 SLang_Object_Type objs[SLANG_MAX_INTRIN_ARGS];
3493 ptrdiff_t ret;
3494 SLtype ret_type;
3495 unsigned int argc;
3496 unsigned int i;
3497 FVOID_STAR fptr;
3498 SLtype *arg_types;
3499 int stk_depth;
3500 int num_args;
3501
3502 fptr = objf->i_fun;
3503 argc = objf->num_args;
3504 ret_type = objf->return_type;
3505 arg_types = objf->arg_types;
3506
3507 if (argc > SLANG_MAX_INTRIN_ARGS)
3508 {
3509 _pSLang_verror(SL_APPLICATION_ERROR,
3510 "Intrinsic function %s requires too many parameters", objf->name);
3511 return -1;
3512 }
3513
3514 if (-1 == _pSL_increment_frame_pointer ())
3515 return -1;
3516 num_args = SLang_Num_Function_Args;
3517
3518 stk_depth = -1;
3519 if (Trace_Mode && (_pSLang_Trace > 0))
3520 {
3521 int nargs;
3522
3523 stk_depth = SLstack_depth ();
3524
3525 nargs = SLang_Num_Function_Args;
3526 if (nargs == 0)
3527 nargs = (int)argc;
3528
3529 stk_depth -= nargs;
3530
3531 if (stk_depth >= 0)
3532 trace_dump (">>%s (%d args)\n",
3533 (char *) objf->name,
3534 Stack_Pointer - nargs,
3535 nargs,
3536 1);
3537 }
3538
3539 i = argc;
3540 while (i != 0)
3541 {
3542 i--;
3543 if (NULL == (p[i] = pop_pointer (objs + i, arg_types[i])))
3544 {
3545 i++;
3546 goto free_and_return;
3547 }
3548 }
3549
3550 ret = 0;
3551 #if SLANG_HAS_FLOAT
3552 xf = 0.0;
3553 #endif
3554
3555 switch (argc)
3556 {
3557 case 0:
3558 if (ret_type == SLANG_VOID_TYPE) ((VF0_Type) fptr) ();
3559 #if SLANG_HAS_FLOAT
3560 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF0_Type) fptr)();
3561 #endif
3562 else ret = ((LF0_Type) fptr)();
3563 break;
3564
3565 case 1:
3566 if (ret_type == SLANG_VOID_TYPE) ((VF1_Type) fptr)(p[0]);
3567 #if SLANG_HAS_FLOAT
3568 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF1_Type) fptr)(p[0]);
3569 #endif
3570 else ret = ((LF1_Type) fptr)(p[0]);
3571 break;
3572
3573 case 2:
3574 if (ret_type == SLANG_VOID_TYPE) ((VF2_Type) fptr)(p[0], p[1]);
3575 #if SLANG_HAS_FLOAT
3576 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF2_Type) fptr)(p[0], p[1]);
3577 #endif
3578 else ret = ((LF2_Type) fptr)(p[0], p[1]);
3579 break;
3580
3581 case 3:
3582 if (ret_type == SLANG_VOID_TYPE) ((VF3_Type) fptr)(p[0], p[1], p[2]);
3583 #if SLANG_HAS_FLOAT
3584 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF3_Type) fptr)(p[0], p[1], p[2]);
3585 #endif
3586 else ret = ((LF3_Type) fptr)(p[0], p[1], p[2]);
3587 break;
3588
3589 case 4:
3590 if (ret_type == SLANG_VOID_TYPE) ((VF4_Type) fptr)(p[0], p[1], p[2], p[3]);
3591 #if SLANG_HAS_FLOAT
3592 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF4_Type) fptr)(p[0], p[1], p[2], p[3]);
3593 #endif
3594 else ret = ((LF4_Type) fptr)(p[0], p[1], p[2], p[3]);
3595 break;
3596
3597 case 5:
3598 if (ret_type == SLANG_VOID_TYPE) ((VF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
3599 #if SLANG_HAS_FLOAT
3600 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
3601 #endif
3602 else ret = ((LF5_Type) fptr)(p[0], p[1], p[2], p[3], p[4]);
3603 break;
3604
3605 case 6:
3606 if (ret_type == SLANG_VOID_TYPE) ((VF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
3607 #if SLANG_HAS_FLOAT
3608 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
3609 #endif
3610 else ret = ((LF6_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5]);
3611 break;
3612
3613 case 7:
3614 if (ret_type == SLANG_VOID_TYPE) ((VF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
3615 #if SLANG_HAS_FLOAT
3616 else if (ret_type == SLANG_DOUBLE_TYPE) xf = ((FF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
3617 #endif
3618 else ret = ((LF7_Type) fptr)(p[0], p[1], p[2], p[3], p[4], p[5], p[6]);
3619 break;
3620 }
3621
3622 switch (ret_type)
3623 {
3624 case SLANG_VOID_TYPE:
3625 break;
3626
3627 #if SLANG_HAS_FLOAT
3628 case SLANG_DOUBLE_TYPE:
3629 (void) push_double_object (SLANG_DOUBLE_TYPE, xf);
3630 break;
3631 #endif
3632 case SLANG_UINT_TYPE:
3633 case SLANG_INT_TYPE: (void) push_int_object (ret_type, (int) ret);
3634 break;
3635
3636 case SLANG_CHAR_TYPE:
3637 case SLANG_UCHAR_TYPE: (void) push_char_object (ret_type, (char) ret);
3638 break;
3639
3640 case SLANG_SHORT_TYPE:
3641 (void) SLclass_push_short_obj (_pSLANG_SHORT_TYPE, (short) ret);
3642 break;
3643 case SLANG_USHORT_TYPE:
3644 (void) SLclass_push_short_obj (_pSLANG_USHORT_TYPE, (short) ret);
3645 break;
3646
3647 case SLANG_LONG_TYPE:
3648 (void) SLclass_push_long_obj (_pSLANG_LONG_TYPE, ret);
3649 break;
3650 case SLANG_ULONG_TYPE:
3651 (void) SLclass_push_long_obj (_pSLANG_ULONG_TYPE, ret);
3652 break;
3653
3654 case SLANG_STRING_TYPE:
3655 if (NULL == (char *)ret)
3656 (void) SLang_set_error (SL_INTRINSIC_ERROR);
3657 else (void) SLang_push_string ((char *)ret);
3658 break;
3659
3660 default:
3661 _pSLang_verror (SL_NOT_IMPLEMENTED,
3662 "Support for intrinsic functions returning %s is not provided. Use the appropriate push function.",
3663 SLclass_get_datatype_name (ret_type));
3664 }
3665
3666 if (stk_depth >= 0)
3667 {
3668 stk_depth = SLstack_depth () - stk_depth;
3669
3670 trace_dump ("<<%s (returning %d values)\n",
3671 (char *) objf->name,
3672 Stack_Pointer - stk_depth,
3673 stk_depth,
3674 1);
3675 }
3676
3677 free_and_return:
3678 while (i < argc)
3679 {
3680 #if SLANG_OPTIMIZE_FOR_SPEED
3681 SLang_Class_Type *cl;
3682 SLtype type = objs[i].o_data_type;
3683 GET_CLASS(cl, type);
3684 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
3685 free_object (objs+i, cl);
3686 #else
3687 SLang_free_object (objs + i);
3688 #endif
3689 i++;
3690 }
3691
3692 if (num_args != SLang_Num_Function_Args)
3693 SLang_verror (SL_INTERNAL_ERROR, "execute_intrinsic_fun: SLang_Num_Function_Args changed");
3694
3695 return _pSL_decrement_frame_pointer ();
3696 }
3697
3698 /* Switch_Obj_Ptr points to the NEXT available free switch object */
3699 static SLang_Object_Type Switch_Objects[SLANG_MAX_NESTED_SWITCH];
3700 static SLang_Object_Type *Switch_Obj_Ptr = Switch_Objects;
3701 static SLang_Object_Type *Switch_Obj_Max = Switch_Objects + SLANG_MAX_NESTED_SWITCH;
3702
3703 /* Returns 0 if the loops were completed, 1 if they were terminated via break,
3704 * or -1 if an error occured.
3705 */
3706 static int
lang_do_loops(int stype,SLBlock_Type * block,unsigned int num_blocks)3707 lang_do_loops (int stype, SLBlock_Type *block, unsigned int num_blocks)
3708 {
3709 int i, ctrl;
3710 int first, last;
3711 SLBlock_Type *blks[4];
3712 SLCONST char *loop_name;
3713 SLang_Foreach_Context_Type *foreach_context;
3714 SLang_Class_Type *cl;
3715 int type;
3716 unsigned int j;
3717
3718 j = 0;
3719 for (i = 0; i < (int) num_blocks; i++)
3720 {
3721 if (block[i].bc_main_type != SLANG_BC_BLOCK)
3722 {
3723 #if USE_BC_LINE_NUM
3724 if (block[i].bc_main_type == SLANG_BC_LINE_NUM)
3725 continue;
3726 #endif
3727 _pSLang_verror (SL_SYNTAX_ERROR, "Bytecode is not a looping block");
3728 return -1;
3729 }
3730 blks[j] = block[i].b.blk;
3731 j++;
3732 }
3733
3734 num_blocks = j;
3735 block = blks[0];
3736
3737 switch (stype)
3738 {
3739 int next_fn_args;
3740
3741 case SLANG_BCST_FOREACH_EARGS:
3742 if (-1 == end_arg_list ())
3743 goto return_error;
3744 /* drop */
3745 case SLANG_BCST_FOREACH: /* obsolete */
3746 loop_name = "foreach";
3747 if (num_blocks != 1)
3748 goto wrong_num_blocks_error;
3749
3750 /* We should find Next_Function_Num_Args + 1 items on the stack.
3751 * The first Next_Function_Num_Args items represent the arguments to
3752 * to USING. The last item (deepest in stack) is the object to loop
3753 * over. So, roll the stack up and grab it.
3754 */
3755 next_fn_args = Next_Function_Num_Args;
3756 Next_Function_Num_Args = 0;
3757 if ((-1 == roll_stack (-(next_fn_args + 1)))
3758 || (-1 == (type = peek_at_stack ())))
3759 goto return_error;
3760
3761 GET_CLASS(cl, (SLtype)type);
3762 if ((cl->cl_foreach == NULL)
3763 || (cl->cl_foreach_open == NULL)
3764 || (cl->cl_foreach_close == NULL))
3765 {
3766 _pSLang_verror (SL_NOT_IMPLEMENTED, "%s does not permit foreach", cl->cl_name);
3767 SLdo_pop_n (next_fn_args + 1);
3768 goto return_error;
3769 }
3770
3771 if (NULL == (foreach_context = (*cl->cl_foreach_open) ((SLtype)type, next_fn_args)))
3772 goto return_error;
3773
3774 while (1)
3775 {
3776 int status;
3777
3778 if (IS_SLANG_ERROR)
3779 {
3780 (*cl->cl_foreach_close) ((SLtype) type, foreach_context);
3781 goto return_error;
3782 }
3783
3784 status = (*cl->cl_foreach) ((SLtype) type, foreach_context);
3785 if (status <= 0)
3786 {
3787 if (status == 0)
3788 break;
3789
3790 (*cl->cl_foreach_close) ((SLtype) type, foreach_context);
3791 goto return_error;
3792 }
3793
3794 inner_interp (block);
3795 if (Lang_Break) break;
3796 Lang_Break_Condition = /* Lang_Continue = */ 0;
3797 }
3798 (*cl->cl_foreach_close) ((SLtype) type, foreach_context);
3799 break;
3800
3801 case SLANG_BCST_WHILE:
3802 loop_name = "while";
3803
3804 if (num_blocks != 2)
3805 goto wrong_num_blocks_error;
3806
3807 type = blks[1]->bc_main_type;
3808 while (1)
3809 {
3810 if (IS_SLANG_ERROR)
3811 goto return_error;
3812
3813 inner_interp (block);
3814 if (Lang_Break) break;
3815
3816 if (-1 == pop_ctrl_integer (&ctrl))
3817 goto return_error;
3818
3819 if (ctrl == 0) break;
3820
3821 if (type)
3822 {
3823 inner_interp (blks[1]);
3824 if (Lang_Break) break;
3825 Lang_Break_Condition = /* Lang_Continue = */ 0;
3826 }
3827 }
3828 break;
3829
3830 case SLANG_BCST_DOWHILE:
3831 loop_name = "do...while";
3832
3833 if (num_blocks != 2)
3834 goto wrong_num_blocks_error;
3835
3836 while (1)
3837 {
3838 if (IS_SLANG_ERROR)
3839 goto return_error;
3840
3841 Lang_Break_Condition = /* Lang_Continue = */ 0;
3842 inner_interp (block);
3843 if (Lang_Break) break;
3844 Lang_Break_Condition = /* Lang_Continue = */ 0;
3845 inner_interp (blks[1]);
3846 if (-1 == pop_ctrl_integer (&ctrl))
3847 goto return_error;
3848
3849 if (ctrl == 0) break;
3850 }
3851 break;
3852
3853 case SLANG_BCST_CFOR:
3854 loop_name = "for";
3855
3856 /* we need 4 blocks: first 3 control, the last is code */
3857 if (num_blocks != 4) goto wrong_num_blocks_error;
3858
3859 inner_interp (block);
3860 while (1)
3861 {
3862 if (IS_SLANG_ERROR)
3863 goto return_error;
3864
3865 inner_interp(blks[1]); /* test */
3866 if (-1 == pop_ctrl_integer (&ctrl))
3867 goto return_error;
3868
3869 if (ctrl == 0) break;
3870 inner_interp(blks[3]); /* code */
3871 if (Lang_Break) break;
3872 inner_interp(blks[2]); /* bump */
3873 Lang_Break_Condition = /* Lang_Continue = */ 0;
3874 }
3875 break;
3876
3877 case SLANG_BCST_FOR:
3878 {
3879 #if SLANG_OPTIMIZE_FOR_SPEED
3880 SLang_Object_Type *objp;
3881 #endif
3882 loop_name = "_for";
3883
3884 if (num_blocks != 1)
3885 goto wrong_num_blocks_error;
3886
3887 /* 3 elements: first, last, step */
3888 if ((-1 == pop_int (&ctrl))
3889 || (-1 == pop_int (&last))
3890 || (-1 == pop_int (&first)))
3891 goto return_error;
3892
3893 #if SLANG_OPTIMIZE_FOR_SPEED
3894 objp = NULL;
3895 if ((block->bc_main_type == SLANG_BC_SET_LOCAL_LVALUE)
3896 && (block->bc_sub_type == SLANG_BCST_ASSIGN))
3897 {
3898 objp = Local_Variable_Frame - block->b.i_blk;
3899 block++;
3900 }
3901 #endif
3902 i = first;
3903 while (1)
3904 {
3905 /* It is ugly to have this test here but I do not know of a
3906 * simple way to do this without using two while loops.
3907 */
3908 if (ctrl >= 0)
3909 {
3910 if (i > last) break;
3911 }
3912 else if (i < last) break;
3913
3914 if (IS_SLANG_ERROR) goto return_error;
3915 #if SLANG_OPTIMIZE_FOR_SPEED
3916 if (objp != NULL)
3917 {
3918 if (objp->o_data_type != SLANG_INT_TYPE)
3919 {
3920 if (SLANG_CLASS_TYPE_SCALAR != GET_CLASS_TYPE(objp->o_data_type))
3921 SLang_free_object (objp);
3922 objp->o_data_type = SLANG_INT_TYPE;
3923 }
3924 objp->v.int_val = i;
3925 }
3926 else
3927 #endif
3928 push_int_object (SLANG_INT_TYPE, i);
3929
3930 inner_interp (block);
3931 if (Lang_Break) break;
3932 Lang_Break_Condition = /* Lang_Continue = */ 0;
3933
3934 i += ctrl;
3935 }
3936 }
3937 break;
3938
3939 case SLANG_BCST_LOOP:
3940 loop_name = "loop";
3941 if (num_blocks != 1)
3942 goto wrong_num_blocks_error;
3943
3944 if (-1 == pop_int (&ctrl))
3945 goto return_error;
3946 while (ctrl > 0)
3947 {
3948 ctrl--;
3949
3950 if (IS_SLANG_ERROR)
3951 goto return_error;
3952
3953 inner_interp (block);
3954 if (Lang_Break) break;
3955 Lang_Break_Condition = /* Lang_Continue = */ 0;
3956 }
3957 break;
3958
3959 case SLANG_BCST_FOREVER:
3960 loop_name = "forever";
3961
3962 if (num_blocks != 1)
3963 goto wrong_num_blocks_error;
3964
3965 while (1)
3966 {
3967 if (IS_SLANG_ERROR)
3968 goto return_error;
3969
3970 inner_interp (block);
3971 if (Lang_Break) break;
3972 Lang_Break_Condition = /* Lang_Continue = */ 0;
3973 }
3974 break;
3975
3976 default: _pSLang_verror(SL_INTERNAL_ERROR, "Unknown loop type");
3977 return -1;
3978 }
3979 if (Lang_Break == 0)
3980 {
3981 Lang_Break_Condition = Lang_Return;
3982 return 0;
3983 }
3984
3985 if (Lang_Break < 0)
3986 {
3987 Lang_Break++;
3988 Lang_Break_Condition = 1;
3989 }
3990 else
3991 {
3992 Lang_Break--;
3993 Lang_Break_Condition = (Lang_Return || Lang_Break);
3994 }
3995 return 1;
3996
3997 wrong_num_blocks_error:
3998 _pSLang_verror (SL_SYNTAX_ERROR, "Wrong number of blocks for '%s' construct", loop_name);
3999
4000 /* drop */
4001 return_error:
4002 return -1;
4003 /* do_traceback (loop_name, NULL, -1); */
4004 }
4005
lang_do_and_orelse(int is_or,SLBlock_Type * addr,SLBlock_Type * addr_max)4006 static void lang_do_and_orelse (int is_or, SLBlock_Type *addr, SLBlock_Type *addr_max)
4007 {
4008 int test = 0;
4009
4010 while (addr <= addr_max)
4011 {
4012 #if USE_BC_LINE_NUM
4013 if (addr->bc_main_type == SLANG_BC_LINE_NUM)
4014 {
4015 addr++;
4016 continue;
4017 }
4018 #endif
4019 inner_interp (addr->b.blk);
4020 if (IS_SLANG_ERROR
4021 || Lang_Break_Condition
4022 || (-1 == pop_ctrl_integer (&test)))
4023 return;
4024
4025 test = (test != 0);
4026 if (is_or == test)
4027 break;
4028
4029 /* if (((stype == SLANG_BCST_ANDELSE) && (test == 0))
4030 * || ((stype == SLANG_BCST_ORELSE) && test))
4031 * break;
4032 */
4033
4034 addr++;
4035 }
4036 push_char_object (SLANG_CHAR_TYPE, (char) test);
4037 }
4038
4039 /* Executes the block in error-free context. If execution goes wrong, returns -1 */
try_interp_block(SLBlock_Type ** bp)4040 static int try_interp_block (SLBlock_Type **bp)
4041 {
4042 SLBlock_Type *b = *bp;
4043
4044 #if USE_BC_LINE_NUM
4045 while (b->bc_main_type == SLANG_BC_LINE_NUM)
4046 b++;
4047 *bp = b;
4048 #endif
4049
4050 b = b->b.blk;
4051 if (b->bc_main_type == 0)
4052 return 0;
4053
4054 (void) inner_interp (b);
4055
4056 if (IS_SLANG_ERROR)
4057 return -1;
4058
4059 return 0;
4060 }
4061
do_try_internal(SLBlock_Type * ev_block,SLBlock_Type * final)4062 static int do_try_internal (SLBlock_Type *ev_block, SLBlock_Type *final)
4063 {
4064 SLBlock_Type *b;
4065 int stack_depth, num;
4066 unsigned int frame_depth, recurs_depth;
4067 #if SLANG_HAS_BOSEOS
4068 int bos_stack_depth;
4069 #endif
4070 int e1;
4071 int status;
4072
4073 /* Try blocks have the form:
4074 * {ev_block} {try-statements} {exception-list}{catch-block}...{final}
4075 *
4076 * The parser guarantees that the first, second, and final blocks will be
4077 * present. Line number blocks may also be present.
4078 */
4079 stack_depth = SLstack_depth ();
4080 frame_depth = Frame_Pointer_Depth;
4081 recurs_depth = Recursion_Depth;
4082
4083 #if SLANG_HAS_BOSEOS
4084 bos_stack_depth = BOS_Stack_Depth;
4085 #endif
4086 b = ev_block + 1;
4087 #if USE_BC_LINE_NUM
4088 while (b->bc_main_type == SLANG_BC_LINE_NUM)
4089 b++;
4090 #endif
4091 (void) inner_interp (b->b.blk); /* try-block */
4092
4093 if (0 == (e1 = SLang_get_error ()))
4094 return 0;
4095
4096 num = SLstack_depth () - stack_depth;
4097 if (num > 0)
4098 SLdo_pop_n (num);
4099
4100 #if SLANG_HAS_BOSEOS
4101 while (bos_stack_depth < BOS_Stack_Depth)
4102 {
4103 (void) _pSLcall_eos_handler ();
4104 BOS_Stack_Depth--;
4105 }
4106 #endif
4107 while (Recursion_Depth > recurs_depth)
4108 {
4109 (void) _pSL_decrement_frame_pointer ();
4110 }
4111 while (frame_depth < Frame_Pointer_Depth)
4112 {
4113 end_arg_list ();
4114 }
4115
4116 if (-1 == _pSLang_push_error_context ())
4117 return -1;
4118
4119 status = -1;
4120
4121 if (-1 == try_interp_block (&ev_block)) /* evaluate the exception */
4122 goto return_error;
4123
4124 b++; /* skip try-block */
4125
4126 while (b < final)
4127 {
4128 stack_depth = SLstack_depth ();
4129
4130 if (-1 == try_interp_block (&b))/* exception-list */
4131 goto return_error;
4132
4133 num = SLstack_depth () - stack_depth;
4134 if (num < 0)
4135 {
4136 _pSLang_verror (SL_StackUnderflow_Error, "Exception list is invalid");
4137 goto return_error;
4138 }
4139
4140 if (num > 0)
4141 {
4142 while (num)
4143 {
4144 int e;
4145 if (-1 == _pSLerr_pop_exception (&e))
4146 goto return_error;
4147
4148 if (SLerr_exception_eqs (e1, e))
4149 break;
4150
4151 num--;
4152 }
4153 if (num == 0)
4154 {
4155 /* No match, skip the exception-list */
4156 b++;
4157 #if USE_BC_LINE_NUM
4158 while (b->bc_main_type == SLANG_BC_LINE_NUM)
4159 b++;
4160 #endif
4161 /* And the block associated with it */
4162 b++;
4163 continue;
4164 }
4165 if (num > 1)
4166 SLdo_pop_n (num-1);
4167 }
4168
4169 /* Found a match--- move on to the code to be executed */
4170 b++;
4171 /* _pSLerr_clear_error (); */
4172 #if USE_BC_LINE_NUM
4173 while (b->bc_main_type == SLANG_BC_LINE_NUM)
4174 b++;
4175 #endif
4176 status = try_interp_block (&b);
4177 _pSLang_pop_error_context (status);
4178 if (status == 0)
4179 _pSLerr_clear_error (0);
4180 return status;
4181 }
4182
4183 if (b == final)
4184 {
4185 /* No matching catch block */
4186 status = 0;
4187 }
4188
4189 return_error:
4190 _pSLang_pop_error_context (status);
4191
4192 return -1;
4193 }
4194
do_try(SLBlock_Type * ev_block,SLBlock_Type * final)4195 static void do_try (SLBlock_Type *ev_block, SLBlock_Type *final)
4196 {
4197 (void) do_try_internal (ev_block, final);
4198
4199 if (final->b.blk->bc_main_type)
4200 {
4201 int bc = Lang_Break_Condition, r = Lang_Return, br = Lang_Break;
4202 /* Need to reset these so that loops work in the finally block */
4203 Lang_Break_Condition = Lang_Break = Lang_Return = 0;
4204 if (-1 == _pSLang_push_error_context ())
4205 return;
4206
4207 if (-1 == try_interp_block (&final))
4208 _pSLang_pop_error_context (1);
4209 else
4210 _pSLang_pop_error_context (0);
4211
4212 Lang_Break = br; Lang_Return = r; Lang_Break_Condition = bc;
4213 }
4214 }
4215
4216 /* This evaluates:
4217 * (x0 op1 x1) and (x1 op2 x2) ... and (x{N-1} opN xN)
4218 * On stack: x0 x1 ... xN
4219 * Need to perform:
4220 * x0 x1 op1 x1 x2 op2 and x2 x3 op3 and ... x{N-1} xN opN and
4221 * -------- -------- -------- ....... -------------
4222 * y1 y2 y3 yN
4223 * y1 y2 and y3 and ... yN and
4224 */
do_compare(SLBlock_Type * ops1)4225 static int do_compare (SLBlock_Type *ops1)
4226 {
4227 SLang_Object_Type a, b, c;
4228 SLang_Object_Type *ap, *bp, *cp;
4229 SLBlock_Type *ops = ops1;
4230 int ret = -1;
4231
4232 /* skip to opN */
4233 while ((ops->bc_main_type == SLANG_BC_BINARY)
4234 || (ops->bc_main_type == SLANG_BC_BINARY2)
4235 || (ops->bc_main_type == SLANG_BC_COMBINED)
4236 || (ops->bc_main_type == SLANG_BC_BINARY_LASTBLOCK)
4237 || (ops->bc_main_type == SLANG_BC_BINARY_SET_LOCLVAL))
4238 ops++;
4239
4240 bp = &b;
4241 if (-1 == SLang_pop (bp))
4242 return -1;
4243
4244 ap = &a;
4245 cp = NULL;
4246 while (1)
4247 {
4248 SLang_Object_Type *tmp;
4249 ops--;
4250 if (-1 == SLang_pop (ap))
4251 goto return_error;
4252
4253 if (-1 == do_binary_ab_inc_ref (ops->b.i_blk, ap, bp))
4254 {
4255 SLang_free_object (ap);
4256 goto return_error;
4257 }
4258 SLang_free_object (bp);
4259 tmp = bp; bp = ap; ap = tmp;
4260
4261 if (cp == NULL)
4262 {
4263 if (-1 == SLang_pop (&c))
4264 goto return_error;
4265 cp = &c;
4266 continue;
4267 }
4268
4269 if (-1 == do_binary_b (SLANG_AND, cp))
4270 goto return_error;
4271 SLang_free_object (cp);
4272
4273 if (ops == ops1)
4274 {
4275 cp = NULL;
4276 break;
4277 }
4278
4279 if (-1 == SLang_pop (cp))
4280 {
4281 cp = NULL;
4282 goto return_error;
4283 }
4284 }
4285 ret = 0;
4286 /* drop */
4287 return_error:
4288 if (cp != NULL)
4289 SLang_free_object (cp);
4290 SLang_free_object (bp);
4291 return ret;
4292 }
4293
do_else_if(SLBlock_Type * zero_block,SLBlock_Type * non_zero_block)4294 static void do_else_if (SLBlock_Type *zero_block, SLBlock_Type *non_zero_block)
4295 {
4296 int test;
4297
4298 if (-1 == pop_ctrl_integer (&test))
4299 return;
4300
4301 if (test == 0)
4302 non_zero_block = zero_block;
4303
4304 if (non_zero_block != NULL)
4305 inner_interp (non_zero_block->b.blk);
4306 }
4307
_pSLang_trace_fun(SLFUTURE_CONST char * f)4308 int _pSLang_trace_fun (SLFUTURE_CONST char *f)
4309 {
4310 if (NULL == (f = SLang_create_slstring (f)))
4311 return -1;
4312
4313 SLang_free_slstring ((char *) Trace_Function);
4314 Trace_Function = f;
4315 _pSLang_Trace = 1;
4316 return 0;
4317 }
4318
_pSLdump_objects(char * prefix,SLang_Object_Type * x,unsigned int n,int dir)4319 int _pSLdump_objects (char *prefix, SLang_Object_Type *x, unsigned int n, int dir)
4320 {
4321 while (n)
4322 {
4323 SLang_Class_Type *cl;
4324 char *s;
4325
4326 GET_CLASS(cl,x->o_data_type);
4327
4328 s = _pSLstringize_object (x);
4329
4330 _pSLerr_dump_msg ("%s[%s]:%s\n", prefix, cl->cl_name,
4331 ((s != NULL) ? s : "??"));
4332 SLang_free_slstring (s);
4333
4334 x += dir;
4335 n--;
4336 }
4337 return 0;
4338 }
4339
4340 /* Do NOT change this-- it corresponds to USRBLK[0-4]_TOKEN */
4341 #define MAX_USER_BLOCKS 5
4342 static SLBlock_Type *Exit_Block_Ptr;
4343 static SLBlock_Type *Global_User_Block[MAX_USER_BLOCKS];
4344 static SLBlock_Type **User_Block_Ptr = Global_User_Block;
4345
find_local_variable_index(Function_Header_Type * header,char * name)4346 static int find_local_variable_index (Function_Header_Type *header, char *name)
4347 {
4348 char **local_variables;
4349 unsigned int nlocals;
4350 unsigned int i;
4351
4352 if (header == NULL)
4353 return -1;
4354 local_variables = header->local_variables;
4355 nlocals = header->nlocals;
4356
4357 for (i = 0; i < nlocals; i++)
4358 {
4359 if ((*name == local_variables[i][0])
4360 && (0 == strcmp (name, local_variables[i])))
4361 return (int)i;
4362 }
4363 return -1;
4364 }
4365
4366 static SLang_Name_Type *
find_global_name(char * name,SLang_NameSpace_Type * pns,SLang_NameSpace_Type * sns,SLang_NameSpace_Type * gns,int do_error)4367 find_global_name (char *name,
4368 SLang_NameSpace_Type *pns, SLang_NameSpace_Type *sns,
4369 SLang_NameSpace_Type *gns,
4370 int do_error)
4371 {
4372 return find_global_hashed_name (name, SLcompute_string_hash (name), pns, sns, gns, do_error);
4373 }
4374
4375 #if SLANG_HAS_DEBUGGER_SUPPORT
4376 /* frame depth numbered two ways:
4377 *
4378 * positive: 12345..N
4379 * negative: ..543210
4380 */
_pSLang_get_frame_depth(void)4381 int _pSLang_get_frame_depth (void)
4382 {
4383 return (int) (Function_Stack_Ptr - Function_Stack);
4384 }
get_function_stack_info(int depth,Function_Stack_Type * sp)4385 static int get_function_stack_info (int depth, Function_Stack_Type *sp)
4386 {
4387 int current_depth = _pSLang_get_frame_depth ();
4388
4389 if (depth <= 0)
4390 depth += current_depth;
4391
4392 if (depth == current_depth)
4393 {
4394 sp->function = Current_Function;
4395 sp->header = Current_Function_Header;
4396 sp->local_variable_frame = Local_Variable_Frame;
4397 sp->line = This_Compile_Linenum;
4398 sp->file = This_Compile_Filename;
4399 sp->static_ns = This_Static_NameSpace;
4400 sp->private_ns = This_Private_NameSpace;
4401 return 0;
4402 }
4403
4404 if ((depth >= current_depth) || (depth <= 0))
4405 {
4406 _pSLang_verror (SL_INVALID_PARM, "Invalid Frame Depth");
4407 return -1;
4408 }
4409 *sp = *(Function_Stack + depth);
4410 return 0;
4411 }
4412
_pSLang_get_frame_fun_info(int depth,_pSLang_Frame_Info_Type * f)4413 int _pSLang_get_frame_fun_info (int depth, _pSLang_Frame_Info_Type *f)
4414 {
4415 Function_Stack_Type s;
4416
4417 if (-1 == get_function_stack_info (depth, &s))
4418 return -1;
4419
4420 f->locals = NULL;
4421 f->nlocals = 0;
4422 f->function = NULL;
4423
4424 f->line = s.line;
4425 f->file = s.file;
4426 f->ns = s.static_ns->namespace_name;
4427
4428 if (s.header != NULL)
4429 {
4430 f->locals = s.header->local_variables;
4431 f->nlocals = s.header->nlocals;
4432 }
4433
4434 if (s.function != NULL)
4435 f->function = s.function->name;
4436
4437 return 0;
4438 }
4439
_pSLang_set_frame_variable(int depth,char * name)4440 int _pSLang_set_frame_variable (int depth, char *name)
4441 {
4442 Function_Stack_Type s;
4443 SLang_Name_Type *nt;
4444 int i;
4445
4446 if (-1 == get_function_stack_info (depth, &s))
4447 return -1;
4448
4449 if (-1 != (i = find_local_variable_index (s.header, name)))
4450 {
4451 SLang_Object_Type *obj = s.local_variable_frame - i;
4452 return set_lvalue_obj (SLANG_BCST_ASSIGN, obj);
4453 }
4454
4455 if (NULL == (nt = find_global_name (name, s.private_ns, s.static_ns, Global_NameSpace, 1)))
4456 return -1;
4457
4458 return set_nametype_variable (nt);
4459 }
4460
_pSLang_get_frame_variable(int depth,char * name)4461 int _pSLang_get_frame_variable (int depth, char *name)
4462 {
4463 Function_Stack_Type s;
4464 SLang_Name_Type *nt;
4465 int i;
4466
4467 if (-1 == get_function_stack_info (depth, &s))
4468 return -1;
4469
4470 if (-1 != (i = find_local_variable_index (s.header, name)))
4471 {
4472 SLang_Class_Type *cl;
4473 SLang_Object_Type *obj = s.local_variable_frame - i;
4474 GET_CLASS(cl,obj->o_data_type);
4475 return (*cl->cl_push) (obj->o_data_type, (VOID_STAR) &obj->v);
4476 }
4477
4478 if (NULL == (nt = find_global_name (name, s.private_ns, s.static_ns, Global_NameSpace, 1)))
4479 return -1;
4480
4481 return push_nametype_variable (nt);
4482 }
4483
4484 #endif
4485
execute_slang_fun(_pSLang_Function_Type * fun,unsigned int linenum)4486 static void execute_slang_fun (_pSLang_Function_Type *fun, unsigned int linenum)
4487 {
4488 register unsigned int i;
4489 register SLang_Object_Type *frame, *lvf;
4490 register unsigned int n_locals;
4491 Function_Header_Type *header;
4492 /* SLBlock_Type *val; */
4493 SLBlock_Type *exit_block_save;
4494 SLBlock_Type **user_block_save;
4495 SLBlock_Type *user_blocks[MAX_USER_BLOCKS];
4496 int issue_bofeof_info = 0;
4497 int nargs;
4498
4499 exit_block_save = Exit_Block_Ptr;
4500 user_block_save = User_Block_Ptr;
4501 User_Block_Ptr = user_blocks;
4502 memset ((char *)user_blocks, 0, MAX_USER_BLOCKS*sizeof (SLBlock_Type *));
4503 Exit_Block_Ptr = NULL;
4504
4505 if (-1 == increment_slang_frame_pointer (fun, linenum))
4506 return;
4507 nargs = SLang_Num_Function_Args;
4508
4509 header = fun->header;
4510 /* Make sure we do not allow this header to get destroyed by something
4511 * like: define crash () { eval ("define crash ();") }
4512 */
4513 header->num_refs++;
4514 n_locals = header->nlocals;
4515
4516 /* let the error propagate through since it will do no harm
4517 and allow us to restore stack. */
4518
4519 /* set new stack frame */
4520 lvf = frame = Local_Variable_Frame;
4521 i = n_locals;
4522 if ((lvf + i) >= Local_Variable_Stack_Max)
4523 {
4524 _pSLang_verror(SL_STACK_OVERFLOW, "%s: Local Variable Stack Overflow",
4525 fun->name);
4526 goto the_return;
4527 }
4528
4529 while (i--)
4530 {
4531 lvf++;
4532 lvf->o_data_type = SLANG_UNDEFINED_TYPE;
4533 }
4534 Local_Variable_Frame = lvf;
4535
4536 /* read values of function arguments */
4537 if (header->nargs)
4538 (void) pop_n_objs_reverse (Local_Variable_Frame - (header->nargs-1), header->nargs);
4539
4540 #if SLANG_HAS_BOSEOS
4541 if (header->issue_bofeof_info)
4542 {
4543 issue_bofeof_info = 1;
4544 (void) _pSLcall_bof_handler (fun->name, header->file);
4545 }
4546 #endif
4547 if (SLang_Enter_Function != NULL)
4548 (*SLang_Enter_Function) (fun->name);
4549
4550 if (_pSLang_Trace)
4551 {
4552 int stack_depth;
4553
4554 stack_depth = SLstack_depth ();
4555
4556 if ((Trace_Function != NULL)
4557 && (0 == strcmp (Trace_Function, fun->name))
4558 && (Trace_Mode == 0))
4559 Trace_Mode = 1;
4560
4561 if (Trace_Mode)
4562 {
4563 /* The local variable frame grows backwards */
4564 trace_dump (">>%s (%d args)\n",
4565 (char *) fun->name,
4566 Local_Variable_Frame,
4567 (int) header->nargs,
4568 -1);
4569 Trace_Mode++;
4570 }
4571
4572 inner_interp (header->body);
4573 Lang_Break_Condition = Lang_Return = Lang_Break = 0;
4574 if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
4575
4576 if (Trace_Mode)
4577 {
4578 Trace_Mode--;
4579 stack_depth = SLstack_depth () - stack_depth;
4580
4581 trace_dump ("<<%s (returning %d values)\n", (char *) fun->name,
4582 Stack_Pointer - stack_depth,
4583 stack_depth,
4584 1);
4585
4586 if (Trace_Mode == 1)
4587 Trace_Mode = 0;
4588 }
4589 }
4590 else
4591 {
4592 inner_interp (header->body);
4593 Lang_Break_Condition = Lang_Return = Lang_Break = 0;
4594 if (Exit_Block_Ptr != NULL) inner_interp(Exit_Block_Ptr);
4595 }
4596
4597 if (SLang_Exit_Function != NULL)
4598 (*SLang_Exit_Function)(fun->name);
4599
4600 if (IS_SLANG_ERROR)
4601 {
4602 do_function_traceback (header, linenum);
4603 #if SLANG_HAS_BOSEOS && SLANG_HAS_DEBUGGER_SUPPORT
4604 /* (void) _pSLcall_debug_hook (); */
4605 #endif
4606 }
4607
4608 /* free local variables.... */
4609 lvf = Local_Variable_Frame;
4610 while (lvf > frame)
4611 {
4612 #if SLANG_OPTIMIZE_FOR_SPEED
4613 SLang_Class_Type *cl;
4614 GET_CLASS(cl, lvf->o_data_type);
4615 if (SLANG_CLASS_TYPE_SCALAR != cl->cl_class_type)
4616 free_object (lvf, cl);
4617 #else
4618 SLang_free_object (lvf);
4619 #endif
4620 lvf--;
4621 }
4622 Local_Variable_Frame = lvf;
4623
4624 the_return:
4625
4626 if (header->num_refs == 1)
4627 free_function_header (header);
4628 else
4629 header->num_refs--;
4630
4631 Lang_Break_Condition = Lang_Return = Lang_Break = 0;
4632 Exit_Block_Ptr = exit_block_save;
4633 User_Block_Ptr = user_block_save;
4634
4635 if (nargs != SLang_Num_Function_Args)
4636 SLang_verror (SL_INTERNAL_ERROR, "execute_slang_fun: SLang_Num_Function_Args changed");
4637
4638 (void) decrement_slang_frame_pointer ();
4639 #if SLANG_HAS_BOSEOS
4640 if (issue_bofeof_info)
4641 (void) _pSLcall_eof_handler ();
4642 #endif
4643 }
4644
do_traceback(SLCONST char * message)4645 static void do_traceback (SLCONST char *message)
4646 {
4647 if (SLang_Traceback == SL_TB_NONE)
4648 return;
4649
4650 if (message != NULL)
4651 _pSLerr_traceback_msg ("Traceback: %s\n", message);
4652 }
4653
do_function_traceback(Function_Header_Type * header,unsigned int linenum)4654 static void do_function_traceback (Function_Header_Type *header, unsigned int linenum)
4655 {
4656 unsigned int nlocals;
4657 unsigned int i;
4658 SLang_Object_Type *objp;
4659
4660 if (SLang_Traceback == SL_TB_NONE)
4661 return;
4662
4663 /* Doing this will allow line number errors in recursive functions to be reported */
4664 _pSLerr_set_line_info (header->file, (int)linenum, "");
4665
4666 if ((0 == (SLang_Traceback & SL_TB_FULL))
4667 || (SLang_Traceback & SL_TB_OMIT_LOCALS)
4668 || (0 == (nlocals = header->nlocals))
4669 || (header->local_variables == NULL))
4670 return;
4671
4672 _pSLerr_traceback_msg (" Local variables for %s:\n", Current_Function->name);
4673
4674 for (i = 0; i < nlocals; i++)
4675 {
4676 SLang_Class_Type *cl;
4677 char *class_name;
4678 char *s;
4679 SLtype stype;
4680
4681 objp = Local_Variable_Frame - i;
4682 stype = objp->o_data_type;
4683
4684 s = _pSLstringize_object (objp);
4685 GET_CLASS(cl,stype);
4686 class_name = cl->cl_name;
4687
4688 _pSLerr_traceback_msg ("\t%s %s = ", class_name, header->local_variables[i]);
4689
4690 if (s == NULL) _pSLerr_traceback_msg ("??\n");
4691 else
4692 {
4693 SLCONST char *q = "";
4694 #ifndef HAVE_VSNPRINTF
4695 char buf[256];
4696 if (strlen (s) >= sizeof (buf))
4697 {
4698 strncpy (buf, s, sizeof(buf));
4699 s = buf;
4700 s[sizeof(buf) - 1] = 0;
4701 }
4702 #endif
4703 if (SLANG_STRING_TYPE == stype) q = "\"";
4704 _pSLerr_traceback_msg ("%s%s%s\n", q, s, q);
4705 }
4706 }
4707 }
4708
do_app_unary(SLang_App_Unary_Type * nt)4709 static void do_app_unary (SLang_App_Unary_Type *nt)
4710 {
4711 if (-1 == do_unary (nt->unary_op, nt->name_type))
4712 do_traceback (nt->name);
4713 }
4714
do_arith_binary(SLang_Arith_Binary_Type * nt)4715 static void do_arith_binary (SLang_Arith_Binary_Type *nt)
4716 {
4717 if (-1 == do_binary (nt->binary_op))
4718 do_traceback (nt->name);
4719 }
4720
_pSLang_dereference_ref(SLang_Ref_Type * ref)4721 int _pSLang_dereference_ref (SLang_Ref_Type *ref)
4722 {
4723 return ref->deref (ref->data);
4724 }
4725
_pSLang_is_ref_initialized(SLang_Ref_Type * ref)4726 int _pSLang_is_ref_initialized (SLang_Ref_Type *ref)
4727 {
4728 if (ref->is_initialized != NULL)
4729 return ref->is_initialized (ref->data);
4730
4731 return 1; /* punt */
4732 }
4733
_pSLang_uninitialize_ref(SLang_Ref_Type * ref)4734 int _pSLang_uninitialize_ref (SLang_Ref_Type *ref)
4735 {
4736 if (ref->uninitialize != NULL)
4737 return (*ref->uninitialize) (ref->data);
4738
4739 return 0;
4740 }
4741
4742 void (*SLang_Interrupt)(void) = NULL;
4743
_pSLpush_slang_obj(SLang_Object_Type * obj)4744 int _pSLpush_slang_obj (SLang_Object_Type *obj)
4745 {
4746 SLtype subtype;
4747 SLang_Class_Type *cl;
4748
4749 if (obj == NULL) return SLang_push_null ();
4750
4751 subtype = obj->o_data_type;
4752
4753 #if SLANG_OPTIMIZE_FOR_SPEED
4754 if (SLANG_CLASS_TYPE_SCALAR == GET_CLASS_TYPE(subtype))
4755 return push_object (obj);
4756 #endif
4757
4758 GET_CLASS(cl,subtype);
4759 return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
4760 }
4761
4762 _INLINE_
carefully_push_object(SLang_Object_Type * obj)4763 static int carefully_push_object (SLang_Object_Type *obj)
4764 {
4765 SLang_Class_Type *cl;
4766 SLtype subtype;
4767
4768 subtype = obj->o_data_type;
4769
4770 GET_CLASS(cl,subtype);
4771
4772 #if SLANG_OPTIMIZE_FOR_SPEED
4773 if (SLANG_CLASS_TYPE_SCALAR == cl->cl_class_type)
4774 return push_object (obj);
4775 if (subtype == SLANG_STRING_TYPE)
4776 return _pSLang_dup_and_push_slstring (obj->v.s_val);
4777 if (subtype == SLANG_ARRAY_TYPE)
4778 return _pSLang_push_array (obj->v.array_val, 0);
4779 #endif
4780
4781 return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
4782 }
4783
_pSLslang_copy_obj(SLang_Object_Type * obja,SLang_Object_Type * objb)4784 int _pSLslang_copy_obj (SLang_Object_Type *obja, SLang_Object_Type *objb)
4785 {
4786 SLtype type;
4787
4788 type = obja->o_data_type;
4789
4790 #if SLANG_OPTIMIZE_FOR_SPEED
4791 if (SLANG_CLASS_TYPE_SCALAR == GET_CLASS_TYPE(type))
4792 {
4793 *objb = *obja;
4794 return 0;
4795 }
4796 #endif
4797
4798 if (-1 == carefully_push_object (obja))
4799 return -1;
4800
4801 return pop_object (objb);
4802 }
4803
4804 #define PUSH_LOCAL_VARIABLE(_indx) \
4805 { \
4806 SLang_Object_Type *_obj = Local_Variable_Frame - (_indx); \
4807 (void) carefully_push_object (_obj); \
4808 }
4809
push_local_variable(int i)4810 static int push_local_variable (int i)
4811 {
4812 SLang_Object_Type *obj = Local_Variable_Frame - i;
4813 SLang_Class_Type *cl;
4814 SLtype subtype;
4815
4816 subtype = obj->o_data_type;
4817
4818 #if SLANG_OPTIMIZE_FOR_SPEED
4819 if (SLANG_CLASS_TYPE_SCALAR == GET_CLASS_TYPE(subtype))
4820 return push_object (obj);
4821 if (subtype == SLANG_STRING_TYPE)
4822 return _pSLang_dup_and_push_slstring (obj->v.s_val);
4823 if (subtype == SLANG_ARRAY_TYPE)
4824 return _pSLang_push_array (obj->v.array_val, 0);
4825 #endif
4826
4827 GET_CLASS(cl,subtype);
4828 return (*cl->cl_push) (subtype, (VOID_STAR) &obj->v);
4829 }
4830
4831 #if SLANG_OPTIMIZE_FOR_SPEED
push_array_element(int lvaridx,SLindex_Type idx)4832 static int push_array_element (int lvaridx, SLindex_Type idx)
4833 {
4834 SLang_Object_Type *obj = Local_Variable_Frame - lvaridx;
4835
4836 if (obj->o_data_type == SLANG_ARRAY_TYPE)
4837 {
4838 SLang_Array_Type *at = obj->v.array_val;
4839
4840 if (at->num_dims == 1)
4841 {
4842 if (at->data_type == SLANG_INT_TYPE)
4843 {
4844 int *ptr = (int *)at->index_fun (at, &idx);
4845 if (ptr == NULL)
4846 return -1;
4847 return push_int_object (SLANG_INT_TYPE, *ptr);
4848 }
4849 # if SLANG_HAS_FLOAT
4850 else if (at->data_type == SLANG_DOUBLE_TYPE)
4851 {
4852 double *ptr = (double *)at->index_fun (at, &idx);
4853 if (ptr == NULL)
4854 return -1;
4855 return push_double_object (SLANG_DOUBLE_TYPE, *ptr);
4856 }
4857 # endif
4858 return _pSLarray1d_push_elem (at, idx);
4859 }
4860 /* drop and fail */
4861 }
4862
4863 /* Do it the hard way */
4864 if ((0 == push_array_index (SLANG_ARRAY_INDEX_TYPE, idx))
4865 && (0 == push_local_variable (lvaridx)))
4866 return _pSLarray_aget1 (1);
4867
4868 return -1;
4869 }
4870 #endif
4871
4872 #if SLANG_OPTIMIZE_FOR_SPEED
pop_to_lvar_array_element(int lvaridx,SLindex_Type idx)4873 static int pop_to_lvar_array_element (int lvaridx, SLindex_Type idx)
4874 {
4875 SLang_Object_Type *obj = Local_Variable_Frame - lvaridx;
4876
4877 if ((obj->o_data_type == SLANG_ARRAY_TYPE)
4878 && (idx >= 0))
4879 {
4880 SLang_Array_Type *at = obj->v.array_val;
4881
4882 if ((at->num_dims == 1)
4883 && (at->flags == 0)
4884 && (idx < (SLindex_Type) at->num_elements))
4885 {
4886 if (at->data_type == SLANG_INT_TYPE)
4887 return pop_int ((int *)at->data + idx);
4888 #if SLANG_HAS_FLOAT
4889 else if (at->data_type == SLANG_DOUBLE_TYPE)
4890 {
4891 SLang_Object_Type dobj;
4892 if (-1 == pop_object_of_type (SLANG_DOUBLE_TYPE, &dobj, 0))
4893 return -1;
4894 *((double *)at->data + idx) = dobj.v.double_val;
4895 return 0;
4896 }
4897 #endif
4898 }
4899 }
4900 /* Do it the hard way */
4901 if ((0 == push_array_index (SLANG_ARRAY_INDEX_TYPE, idx))
4902 && (0 == push_local_variable (lvaridx)))
4903 return _pSLarray_aput1 (1);
4904
4905 return -1;
4906 }
4907 #endif
4908
4909 #if SLANG_OPTIMIZE_FOR_SPEED
aget1_from_lvar_binary(int lvaridx,SLindex_Type idx,int op,SLang_Object_Type * objb)4910 static int aget1_from_lvar_binary (int lvaridx, SLindex_Type idx, int op,
4911 SLang_Object_Type *objb)
4912 {
4913 SLang_Object_Type *obj;
4914
4915 obj = Local_Variable_Frame - lvaridx;
4916
4917 if (obj->o_data_type == SLANG_ARRAY_TYPE)
4918 {
4919 SLang_Array_Type *at = obj->v.array_val;
4920
4921 if (at->num_dims == 1)
4922 {
4923 SLang_Object_Type a, c;
4924 if (at->data_type == SLANG_INT_TYPE)
4925 {
4926 int *ptr = (int *)at->index_fun (at, &idx);
4927 if (ptr == NULL)
4928 return -1;
4929 a.o_data_type = SLANG_INT_TYPE;
4930 a.v.int_val = *ptr;
4931 if (objb->o_data_type == SLANG_INT_TYPE)
4932 return int_int_binary (op, &a, objb);
4933 #if SLANG_HAS_FLOAT
4934 else if (objb->o_data_type == SLANG_DOUBLE_TYPE)
4935 {
4936 if (-1 == int_dbl_binary_result (op, &a, objb, &c))
4937 return -1;
4938 return push_object (&c);
4939 }
4940 #endif
4941 /* else handled below */
4942 }
4943 # if SLANG_HAS_FLOAT
4944 else if (at->data_type == SLANG_DOUBLE_TYPE)
4945 {
4946 double *ptr;
4947
4948 ptr = (double *)at->index_fun (at, &idx);
4949 if (ptr == NULL)
4950 return -1;
4951
4952 a.o_data_type = SLANG_DOUBLE_TYPE;
4953 a.v.double_val = *ptr;
4954
4955 if (objb->o_data_type == SLANG_DOUBLE_TYPE)
4956 return dbl_dbl_binary (op, &a, objb);
4957 else if (objb->o_data_type == SLANG_INT_TYPE)
4958 {
4959 if (-1 == dbl_int_binary_result (op, &a, objb, &c))
4960 return -1;
4961 return push_object (&c);
4962 }
4963 /* else handled below */
4964 }
4965 # endif
4966 if (-1 == _pSLarray1d_push_elem (at, idx))
4967 return -1;
4968 return do_binary_b (op, objb);
4969 }
4970 }
4971
4972 if (-1 == push_array_element (lvaridx, idx))
4973 return -1;
4974
4975 return do_binary_b (op, objb);
4976 }
4977 #endif
4978
dereference_object(void)4979 static int dereference_object (void)
4980 {
4981 SLang_Object_Type obj;
4982 SLang_Class_Type *cl;
4983 SLtype type;
4984 int ret;
4985
4986 if (-1 == pop_object(&obj))
4987 return -1;
4988
4989 type = obj.o_data_type;
4990
4991 GET_CLASS(cl,type);
4992 ret = (*cl->cl_dereference)(type, (VOID_STAR) &obj.v);
4993
4994 free_object (&obj, cl);
4995 return ret;
4996 }
4997
4998 /* This function gets called with the stack of the form:
4999 * ... func __args ...
5000 * We need to pop func from within the stack.
5001 */
5002 /* End the argument list, and make the function call */
deref_fun_call(int linenum)5003 static int deref_fun_call (int linenum)
5004 {
5005 SLang_Object_Type obj;
5006
5007 if (-1 == end_arg_list ())
5008 return -1;
5009
5010 if (-1 == roll_stack (-(Next_Function_Num_Args + 1)))
5011 return -1;
5012
5013 if (-1 == pop_object(&obj))
5014 return -1;
5015
5016 return deref_call_object (&obj, linenum);
5017 }
5018
obsolete_deref_fun_call(int linenum)5019 static int obsolete_deref_fun_call (int linenum)
5020 {
5021 SLang_Object_Type obj;
5022
5023 if (-1 == end_arg_list ())
5024 return -1;
5025
5026 Next_Function_Num_Args--; /* do not include function to be derefed. */
5027
5028 if (-1 == pop_object(&obj))
5029 return -1;
5030
5031 return deref_call_object (&obj, linenum);
5032 }
5033
case_function(void)5034 static int case_function (void)
5035 {
5036 SLang_Object_Type a_obj;
5037 SLang_Object_Type *swobjptr;
5038 int eqs;
5039
5040 swobjptr = Switch_Obj_Ptr - 1;
5041
5042 if ((swobjptr < Switch_Objects)
5043 || (0 == swobjptr->o_data_type))
5044 {
5045 _pSLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case' keyword");
5046 return -1;
5047 }
5048
5049 if (-1 == pop_object(&a_obj))
5050 return -1;
5051
5052 eqs = _pSLclass_obj_eqs (&a_obj, swobjptr);
5053 SLang_free_object (&a_obj);
5054
5055 if (eqs == -1)
5056 return -1;
5057
5058 return push_int_object (SLANG_INT_TYPE, eqs);
5059 }
5060
tmp_variable_function(SLBlock_Type * addr)5061 static void tmp_variable_function (SLBlock_Type *addr)
5062 {
5063 SLang_Object_Type *obj;
5064
5065 switch (addr->bc_sub_type)
5066 {
5067 case SLANG_GVARIABLE:
5068 case SLANG_PVARIABLE:
5069 obj = &addr->b.nt_gvar_blk->obj;
5070 break;
5071
5072 case SLANG_LVARIABLE:
5073 obj = Local_Variable_Frame - addr->b.i_blk;
5074 break;
5075
5076 default:
5077 (void) SLang_set_error (SL_INTERNAL_ERROR);
5078 return;
5079 }
5080
5081 /* There is no need to go through higher level routines since we are
5082 * not creating or destroying extra copies.
5083 */
5084 if (-1 == push_object (obj))
5085 return;
5086
5087 obj->o_data_type = SLANG_UNDEFINED_TYPE;
5088 obj->v.ptr_val = NULL;
5089 }
5090
5091 static
_pSLang_parse_dollar_string(SLFUTURE_CONST char * str,char *** argvp,unsigned int * argcp)5092 int _pSLang_parse_dollar_string (SLFUTURE_CONST char *str, char ***argvp, unsigned int *argcp)
5093 {
5094 unsigned int len;
5095 SLFUTURE_CONST char *s;
5096 char *fmt;
5097 char **argv;
5098 char ch;
5099 unsigned int num_dollars;
5100 unsigned int i, argc;
5101
5102 len = 0;
5103 num_dollars = 1; /* allow for argv[0]=fmt */
5104 s = str;
5105 while ((ch = *s++) != 0)
5106 {
5107 len++;
5108 if (ch == '%')
5109 {
5110 len++;
5111 continue;
5112 }
5113 if (ch == '$')
5114 {
5115 num_dollars++;
5116 continue;
5117 }
5118 }
5119 fmt = (char *)SLmalloc (len+1);
5120 if (fmt == NULL)
5121 return -1;
5122
5123 argv = (char **)SLcalloc (sizeof (char *), num_dollars);
5124 if (argv == NULL)
5125 {
5126 SLfree (fmt);
5127 return -1;
5128 }
5129
5130 argc = 0;
5131 argv[argc] = fmt;
5132 argc++;
5133
5134 s = str;
5135 while ((ch = *s++) != 0)
5136 {
5137 SLFUTURE_CONST char *s0, *s1;
5138 char *arg;
5139
5140 if (ch != '$')
5141 {
5142 *fmt++ = ch;
5143 if (ch == '%')
5144 *fmt++ = ch;
5145 continue;
5146 }
5147 ch = *s++;
5148 if (ch == '$')
5149 {
5150 *fmt++ = '$';
5151 continue;
5152 }
5153 if (ch == 0)
5154 {
5155 *fmt++ = '$';
5156 break;
5157 }
5158
5159 if ((ch != '_')
5160 && (0 == SLwchar_isalnum (ch)))
5161 {
5162 if (ch != '{')
5163 {
5164 *fmt++ = '$';
5165 *fmt++ = ch;
5166 continue;
5167 }
5168 s0 = s;
5169 while (*s && (*s != '}'))
5170 s++;
5171 if (*s == 0)
5172 {
5173 _pSLang_verror (SL_SYNTAX_ERROR, "Unable to find matching }");
5174 goto return_error;
5175 }
5176 s1 = s + 1;
5177 }
5178 else
5179 {
5180 s0 = s-1;
5181 if (SLwchar_isdigit (ch)) /* e.g., $1 */
5182 s0--;
5183
5184 while ((*s == '_')
5185 || SLwchar_isalnum (*s))
5186 s++;
5187 s1 = s;
5188 }
5189
5190 if (NULL == (arg = SLmake_nstring (s0, s-s0)))
5191 goto return_error;
5192
5193 argv[argc] = arg;
5194 argc++;
5195
5196 *fmt++ = '%';
5197 *fmt++ = 'S';
5198
5199 s = s1;
5200 }
5201 *fmt = 0;
5202
5203 *argvp = argv;
5204 *argcp = argc;
5205 return 0;
5206
5207 return_error:
5208 for (i = 0; i < argc; i++)
5209 SLfree (argv[i]);
5210 SLfree ((char *)argv);
5211 return -1;
5212 }
5213
5214 /* Convert "bla bla $foo bla" to sprintf ("bla bla %S bla", foo)
5215 */
_pSLpush_dollar_string(SLFUTURE_CONST char * str)5216 int _pSLpush_dollar_string (SLFUTURE_CONST char *str)
5217 {
5218 /* return SLang_push_string (str); */
5219 char **argv;
5220 unsigned int argc;
5221 unsigned int i;
5222 SLang_NameSpace_Type *private_ns, *static_ns;
5223 int status = -1;
5224
5225 if (-1 == _pSLang_parse_dollar_string (str, &argv, &argc))
5226 return -1;
5227
5228 if (-1 == SLang_push_string (argv[0]))
5229 goto free_return;
5230
5231 if (Current_Function_Header == NULL)
5232 {
5233 private_ns = This_Private_NameSpace;
5234 static_ns = This_Static_NameSpace;
5235 }
5236 else
5237 {
5238 private_ns = Current_Function_Header->private_ns;
5239 static_ns = Current_Function_Header->static_ns;
5240 }
5241
5242 for (i = 1; i < argc; i++)
5243 {
5244 char *name = argv[i];
5245 SLang_Name_Type *nt;
5246 SLFUTURE_CONST char *env;
5247 int j;
5248
5249 if (*name == 0)
5250 {
5251 if (-1 == SLang_push_string (name))
5252 goto free_return;
5253
5254 continue;
5255 }
5256
5257 j = find_local_variable_index (Current_Function_Header, name);
5258 if (j != -1)
5259 {
5260 if (-1 == push_local_variable (j))
5261 goto free_return;
5262
5263 continue;
5264 }
5265 if (NULL != (nt = find_global_name (name, private_ns, static_ns, Global_NameSpace, 0)))
5266 {
5267 if (-1 == push_nametype_variable (nt))
5268 goto free_return;
5269 continue;
5270 }
5271
5272 /* Assume it is an environment variable */
5273 env = getenv (name);
5274 if (env == NULL)
5275 env = "";
5276 if (-1 == SLang_push_string (env))
5277 goto free_return;
5278 }
5279
5280 status = _pSLstrops_do_sprintf_n (argc-1);
5281 /* drop */
5282
5283 free_return:
5284 for (i = 0; i < argc; i++)
5285 SLfree (argv[i]);
5286
5287 SLfree ((char *) argv);
5288 return status;
5289 }
5290
5291 static int
do_inner_interp_error(SLBlock_Type * err_block,SLBlock_Type * addr_start,SLBlock_Type * addr)5292 do_inner_interp_error (SLBlock_Type *err_block,
5293 SLBlock_Type *addr_start,
5294 SLBlock_Type *addr)
5295 {
5296 SLFUTURE_CONST char *file = NULL, *funname = NULL;
5297 int line;
5298
5299 /* Someday I can use the theses variable to provide extra information
5300 * about what went wrong.
5301 */
5302 (void) addr_start;
5303 (void) addr;
5304
5305 if (Current_Function_Header != NULL)
5306 {
5307 file = Current_Function_Header->file;
5308 funname = Current_Function->name;
5309 }
5310 else file = This_Compile_Filename;
5311
5312 line = addr->linenum;
5313
5314 /* #if SLANG_HAS_BOSEOS && SLANG_HAS_DEBUGGER_SUPPORT */
5315 /* if (SLang_get_error () == SL_USER_BREAK) */
5316 /* (void) _pSLcall_debug_hook (file, linenum); */
5317 /* #endif */
5318
5319 if (err_block == NULL)
5320 goto return_error;
5321
5322 if (-1 == _pSLang_push_error_context ())
5323 goto return_error;
5324
5325 inner_interp (err_block->b.blk);
5326
5327 (void) _pSLang_pop_error_context (0);
5328 if (SLang_get_error () == 0)
5329 return 0;
5330
5331 return_error:
5332 #if SLANG_HAS_DEBUG_CODE
5333 if ((_pSLang_Error == SL_USAGE_ERROR)
5334 && (SLang_Traceback == SL_TB_NONE))
5335 return -1;
5336
5337 if (file != NULL)
5338 (void) _pSLerr_set_line_info (file, line, funname);
5339 #endif
5340 return -1;
5341 }
5342
5343 #define GATHER_STATISTICS 0
5344 #if GATHER_STATISTICS
5345 static unsigned int Bytecodes[0xFFFF];
5346
print_stats(void)5347 static void print_stats (void)
5348 {
5349 unsigned int i;
5350 unsigned long total;
5351 FILE *fp = fopen ("stats.txt", "w");
5352 if (fp == NULL)
5353 return;
5354
5355 total = 0;
5356 for (i = 0; i < 0xFFFF; i++)
5357 total += Bytecodes[i];
5358
5359 if (total == 0)
5360 total = 1;
5361
5362 for (i = 0; i < 0xFFFF; i++)
5363 {
5364 if (Bytecodes[i])
5365 fprintf (fp, "0x%04X %9u %e\n", i, Bytecodes[i], Bytecodes[i]/(double) total);
5366 }
5367 fclose (fp);
5368 }
5369
add_to_statistics(SLBlock_Type * b)5370 static void add_to_statistics (SLBlock_Type *b)
5371 {
5372 unsigned short x, y;
5373
5374 while (1)
5375 {
5376 x = b->bc_main_type;
5377 if (x == 0)
5378 {
5379 Bytecodes[0] += 1;
5380 return;
5381 }
5382 b++;
5383
5384 while (SLANG_IS_BC_COMBINED(b->bc_main_type))
5385 b++;
5386
5387 y = b->bc_main_type;
5388
5389 Bytecodes[(x << 8) | y] += 1;
5390 }
5391 }
5392
5393 #endif
5394
5395 #define EXECUTE_INTRINSIC(addr) \
5396 { \
5397 SLang_Intrin_Fun_Type *f = (addr)->b.nt_ifun_blk; \
5398 if ((f->num_args == 0) && (f->return_type == SLANG_VOID_TYPE) && (Trace_Mode == 0)) \
5399 { \
5400 if (0 == _pSL_increment_frame_pointer ()) \
5401 { \
5402 ((VF0_Type) f->i_fun)(); \
5403 (void) _pSL_decrement_frame_pointer (); \
5404 } \
5405 } \
5406 else execute_intrinsic_fun (f); \
5407 }
5408
5409 /* inner interpreter */
5410 /* The return value from this function is only meaningful when it is used
5411 * to process blocks for the switch statement. If it returns 0, the calling
5412 * routine should pass the next block to it. Otherwise it will
5413 * return non-zero, with or without error.
5414 */
inner_interp(SLBlock_Type * addr_start)5415 static int inner_interp (SLBlock_Type *addr_start)
5416 {
5417 SLBlock_Type *block, *err_block, *addr;
5418 #if GATHER_STATISTICS
5419 static int inited = 0;
5420
5421 if (inited == 0)
5422 {
5423 (void) SLang_add_cleanup_function (print_stats);
5424 inited = 1;
5425 }
5426 #endif
5427
5428 /* for systems that have no real interrupt facility (e.g. go32 on dos) */
5429 if (SLang_Interrupt != NULL) (*SLang_Interrupt)();
5430
5431 block = err_block = NULL;
5432 addr = addr_start;
5433
5434 if (IS_SLANG_ERROR)
5435 {
5436 (void) do_inner_interp_error (err_block, addr_start, addr);
5437 return 0;
5438 }
5439
5440 #if GATHER_STATISTICS
5441 add_to_statistics (addr);
5442 #endif
5443 /* Moving addr++ to top of switch instead of bottom was suggested by
5444 * Paul Boekholt to improve branch-prediction.
5445 */
5446 addr--;
5447
5448 while (1)
5449 {
5450 addr++;
5451 switch (addr->bc_main_type)
5452 {
5453 case SLANG_BC_LAST_BLOCK:
5454 goto return_1;
5455 case SLANG_BC_LVARIABLE:
5456 PUSH_LOCAL_VARIABLE (addr->b.i_blk)
5457 break;
5458 case SLANG_BC_GVARIABLE:
5459 if (-1 == _pSLpush_slang_obj (&addr->b.nt_gvar_blk->obj))
5460 do_name_type_error (addr->b.nt_blk);
5461 break;
5462
5463 case SLANG_BC_IVARIABLE:
5464 case SLANG_BC_RVARIABLE:
5465 push_intrinsic_variable (addr->b.nt_ivar_blk);
5466 break;
5467
5468 case SLANG_BC_INTRINSIC:
5469 EXECUTE_INTRINSIC(addr)
5470 if (IS_SLANG_ERROR)
5471 do_traceback(addr->b.nt_ifun_blk->name);
5472 break;
5473
5474 case SLANG_BC_FUNCTION:
5475 execute_slang_fun (addr->b.nt_fun_blk, addr->linenum);
5476 if (Lang_Break_Condition) goto handle_break_condition;
5477 break;
5478
5479 case SLANG_BC_MATH_UNARY:
5480 case SLANG_BC_APP_UNARY:
5481 case SLANG_BC_ARITH_UNARY:
5482 /* Make sure we treat these like function calls since the
5483 * parser took abs(x), sin(x), etc to be a function call.
5484 */
5485 if (0 == _pSL_increment_frame_pointer ())
5486 {
5487 do_app_unary (addr->b.nt_unary_blk);
5488 (void) _pSL_decrement_frame_pointer ();
5489 }
5490 break;
5491
5492 case SLANG_BC_ARITH_BINARY:
5493 /* Make sure we treat these like function calls since the
5494 * parser took _op_eqs, etc as function calls.
5495 */
5496 if (0 == _pSL_increment_frame_pointer ())
5497 {
5498 do_arith_binary (addr->b.nt_binary_blk);
5499 (void) _pSL_decrement_frame_pointer ();
5500 }
5501 break;
5502
5503 case SLANG_BC_ICONST:
5504 push_int_object (addr->b.iconst_blk->data_type, addr->b.iconst_blk->value);
5505 break;
5506
5507 #if SLANG_HAS_FLOAT
5508 case SLANG_BC_DCONST:
5509 push_double_object (SLANG_DOUBLE_TYPE, addr->b.dconst_blk->d);
5510 break;
5511 case SLANG_BC_FCONST:
5512 SLclass_push_float_obj (SLANG_FLOAT_TYPE, addr->b.fconst_blk->f);
5513 break;
5514 #endif
5515 #ifdef HAVE_LONG_LONG
5516 case SLANG_BC_LLCONST:
5517 SLclass_push_llong_obj (addr->b.llconst_blk->data_type, addr->b.llconst_blk->value);
5518 break;
5519 #endif
5520 case SLANG_BC_PVARIABLE:
5521 if (-1 == _pSLpush_slang_obj (&addr->b.nt_gvar_blk->obj))
5522 do_name_type_error (addr->b.nt_blk);
5523 break;
5524
5525 case SLANG_BC_PFUNCTION:
5526 execute_slang_fun (addr->b.nt_fun_blk, addr->linenum);
5527 if (Lang_Break_Condition) goto handle_break_condition;
5528 break;
5529 case SLANG_BC_HCONST:
5530 SLclass_push_short_obj (addr->b.iconst_blk->data_type, addr->b.hconst_blk->value);
5531 break;
5532 case SLANG_BC_LCONST:
5533 SLclass_push_long_obj (addr->b.iconst_blk->data_type, addr->b.lconst_blk->value);
5534 break;
5535
5536 #if USE_UNUSED_BYCODES_IN_SWITCH
5537 # ifndef HAVE_LONG_LONG
5538 case SLANG_BC_LLCONST:
5539 # endif
5540 case SLANG_BC_UNUSED_0x13:
5541 case SLANG_BC_UNUSED_0x14:
5542 case SLANG_BC_UNUSED_0x15:
5543 case SLANG_BC_UNUSED_0x16:
5544 case SLANG_BC_UNUSED_0x17:
5545 case SLANG_BC_UNUSED_0x18:
5546 case SLANG_BC_UNUSED_0x19:
5547 case SLANG_BC_UNUSED_0x1A:
5548 case SLANG_BC_UNUSED_0x1B:
5549 case SLANG_BC_UNUSED_0x1C:
5550 case SLANG_BC_UNUSED_0x1D:
5551 case SLANG_BC_UNUSED_0x1E:
5552 case SLANG_BC_UNUSED_0x1F:
5553 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
5554 break;
5555 #endif
5556 case SLANG_BC_SET_LOCAL_LVALUE:
5557 set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
5558 break;
5559 case SLANG_BC_SET_GLOBAL_LVALUE:
5560 if (-1 == set_lvalue_obj (addr->bc_sub_type, &addr->b.nt_gvar_blk->obj))
5561 do_name_type_error (addr->b.nt_blk);
5562 break;
5563 case SLANG_BC_SET_INTRIN_LVALUE:
5564 set_intrin_lvalue (addr);
5565 break;
5566 case SLANG_BC_SET_STRUCT_LVALUE:
5567 set_struct_lvalue (addr);
5568 break;
5569 case SLANG_BC_SET_ARRAY_LVALUE:
5570 set_array_lvalue (addr->bc_sub_type);
5571 break;
5572 case SLANG_BC_SET_DEREF_LVALUE:
5573 set_deref_lvalue (addr->bc_sub_type);
5574 break;
5575
5576 case SLANG_BC_FIELD:
5577 (void) push_struct_field (addr->b.s_blk);
5578 break;
5579 case SLANG_BC_METHOD:
5580 do_struct_method (addr->b.s_blk, addr->linenum);
5581 break;
5582 #if SLANG_OPTIMIZE_FOR_SPEED
5583 case SLANG_BC_LVARIABLE_AGET:
5584 {
5585 SLang_Object_Type *obj = Local_Variable_Frame - addr->b.i_blk;
5586 if (0 == carefully_push_object (obj))
5587 do_bc_call_direct_nargs (_pSLarray_aget);
5588 }
5589 break;
5590
5591 case SLANG_BC_LVARIABLE_APUT:
5592 {
5593 SLang_Object_Type *obj = Local_Variable_Frame - addr->b.i_blk;
5594 if (0 == carefully_push_object (obj))
5595 do_bc_call_direct_nargs (_pSLarray_aput);
5596 }
5597 break;
5598 #else
5599 case SLANG_BC_LVARIABLE_AGET:
5600 case SLANG_BC_LVARIABLE_APUT:
5601 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
5602 break;
5603 #endif
5604 case SLANG_BC_LOBJPTR:
5605 (void)push_lv_as_ref (Local_Variable_Frame - addr->b.i_blk);
5606 break;
5607
5608 case SLANG_BC_GOBJPTR:
5609 (void)_pSLang_push_nt_as_ref (addr->b.nt_blk);
5610 break;
5611
5612 case SLANG_BC_FIELD_REF:
5613 (void) _pSLstruct_push_field_ref (addr->b.s_blk);
5614 break;
5615
5616 case SLANG_BC_OBSOLETE_DEREF_FUN_CALL:
5617 (void) obsolete_deref_fun_call (addr->linenum);
5618 break;
5619
5620 case SLANG_BC_DEREF_FUN_CALL:
5621 (void) deref_fun_call (addr->linenum);
5622 break;
5623
5624 #if USE_UNUSED_BYCODES_IN_SWITCH
5625 case SLANG_BC_UNUSED_0x2F:
5626 case SLANG_BC_UNUSED_0x30:
5627 case SLANG_BC_UNUSED_0x31:
5628 case SLANG_BC_UNUSED_0x32:
5629 case SLANG_BC_UNUSED_0x33:
5630 case SLANG_BC_UNUSED_0x34:
5631 case SLANG_BC_UNUSED_0x35:
5632 case SLANG_BC_UNUSED_0x36:
5633 case SLANG_BC_UNUSED_0x37:
5634 case SLANG_BC_UNUSED_0x38:
5635 case SLANG_BC_UNUSED_0x39:
5636 case SLANG_BC_UNUSED_0x3A:
5637 case SLANG_BC_UNUSED_0x3B:
5638 case SLANG_BC_UNUSED_0x3C:
5639 case SLANG_BC_UNUSED_0x3D:
5640 case SLANG_BC_UNUSED_0x3E:
5641 case SLANG_BC_UNUSED_0x3F:
5642 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
5643 break;
5644 #endif
5645 case SLANG_BC_LITERAL:
5646 #if !SLANG_OPTIMIZE_FOR_SPEED
5647 case SLANG_BC_LITERAL_INT:
5648 # if SLANG_HAS_FLOAT
5649 case SLANG_BC_LITERAL_DBL:
5650 # endif
5651 case SLANG_BC_LITERAL_STR:
5652 #endif
5653 {
5654 SLang_Class_Type *cl;
5655
5656 /* No user types should be here */
5657 GET_BUILTIN_CLASS(cl, addr->bc_sub_type);
5658 (*cl->cl_push_literal) (addr->bc_sub_type, (VOID_STAR) &addr->b.ptr_blk);
5659 }
5660 break;
5661 #if SLANG_OPTIMIZE_FOR_SPEED
5662 case SLANG_BC_LITERAL_INT:
5663 push_int_object (addr->bc_sub_type, (int) addr->b.l_blk);
5664 break;
5665 #if SLANG_HAS_FLOAT
5666 case SLANG_BC_LITERAL_DBL:
5667 push_double_object (addr->bc_sub_type, *addr->b.double_blk);
5668 break;
5669 #endif
5670 case SLANG_BC_LITERAL_STR:
5671 _pSLang_dup_and_push_slstring (addr->b.s_blk);
5672 break;
5673 #endif
5674 case SLANG_BC_DOLLAR_STR:
5675 (void) _pSLpush_dollar_string (addr->b.s_blk);
5676 break;
5677
5678 #if USE_UNUSED_BYCODES_IN_SWITCH
5679 case SLANG_BC_UNUSED_0x45:
5680 case SLANG_BC_UNUSED_0x46:
5681 case SLANG_BC_UNUSED_0x47:
5682 case SLANG_BC_UNUSED_0x48:
5683 case SLANG_BC_UNUSED_0x49:
5684 case SLANG_BC_UNUSED_0x4A:
5685 case SLANG_BC_UNUSED_0x4B:
5686 case SLANG_BC_UNUSED_0x4C:
5687 case SLANG_BC_UNUSED_0x4D:
5688 case SLANG_BC_UNUSED_0x4E:
5689 case SLANG_BC_UNUSED_0x4F:
5690 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
5691 break;
5692 #endif
5693 case SLANG_BC_UNARY:
5694 do_unary (addr->b.i_blk, SLANG_BC_UNARY);
5695 break;
5696
5697 case SLANG_BC_BINARY:
5698 (void) do_binary (addr->b.i_blk);
5699 break;
5700
5701 #if SLANG_OPTIMIZE_FOR_SPEED
5702 case SLANG_BC_INTEGER_PLUS:
5703 if (0 == push_int_object (addr->bc_sub_type, (int) addr->b.l_blk))
5704 (void) do_binary (SLANG_PLUS);
5705 break;
5706
5707 case SLANG_BC_INTEGER_MINUS:
5708 if (0 == push_int_object (addr->bc_sub_type, (int) addr->b.l_blk))
5709 (void) do_binary (SLANG_MINUS);
5710 break;
5711 #endif
5712 #if USE_UNUSED_BYCODES_IN_SWITCH
5713 # if !SLANG_OPTIMIZE_FOR_SPEED
5714 case SLANG_BC_INTEGER_PLUS:
5715 case SLANG_BC_INTEGER_MINUS:
5716 break;
5717 # endif
5718 case SLANG_BC_UNUSED_0x54:
5719 case SLANG_BC_UNUSED_0x55:
5720 case SLANG_BC_UNUSED_0x56:
5721 case SLANG_BC_UNUSED_0x57:
5722 case SLANG_BC_UNUSED_0x58:
5723 case SLANG_BC_UNUSED_0x59:
5724 case SLANG_BC_UNUSED_0x5A:
5725 case SLANG_BC_UNUSED_0x5B:
5726 case SLANG_BC_UNUSED_0x5C:
5727 case SLANG_BC_UNUSED_0x5D:
5728 case SLANG_BC_UNUSED_0x5E:
5729 case SLANG_BC_UNUSED_0x5F:
5730 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
5731 break;
5732 #endif
5733 case SLANG_BC_TMP:
5734 tmp_variable_function (addr);
5735 break;
5736 case SLANG_BC_EXCH:
5737 (void) SLreverse_stack (2);
5738 break;
5739 case SLANG_BC_LABEL:
5740 {
5741 int test;
5742 if ((0 == pop_int (&test))
5743 && (test == 0))
5744 goto return_0;
5745 }
5746 break;
5747
5748 case SLANG_BC_BLOCK:
5749 #if SLANG_OPTIMIZE_FOR_SPEED
5750 while ((addr->bc_main_type == SLANG_BC_BLOCK)
5751 && (addr->bc_sub_type == 0))
5752 {
5753 if (block == NULL)
5754 block = addr;
5755
5756 addr++;
5757 }
5758 if (addr->bc_main_type != SLANG_BC_BLOCK)
5759 {
5760 addr--;
5761 break;
5762 }
5763 #endif
5764 switch (addr->bc_sub_type) /*{{{*/
5765 {
5766 case SLANG_BCST_ERROR_BLOCK:
5767 err_block = addr;
5768 break;
5769
5770 case SLANG_BCST_EXIT_BLOCK:
5771 Exit_Block_Ptr = addr->b.blk;
5772 break;
5773
5774 case SLANG_BCST_USER_BLOCK0:
5775 case SLANG_BCST_USER_BLOCK1:
5776 case SLANG_BCST_USER_BLOCK2:
5777 case SLANG_BCST_USER_BLOCK3:
5778 case SLANG_BCST_USER_BLOCK4:
5779 User_Block_Ptr[addr->bc_sub_type - SLANG_BCST_USER_BLOCK0] = addr->b.blk;
5780 break;
5781
5782 case SLANG_BCST_LOOP:
5783 case SLANG_BCST_WHILE:
5784 case SLANG_BCST_FOR:
5785 case SLANG_BCST_FOREVER:
5786 case SLANG_BCST_CFOR:
5787 case SLANG_BCST_DOWHILE:
5788 case SLANG_BCST_FOREACH:
5789 case SLANG_BCST_FOREACH_EARGS:
5790 {
5791 int status;
5792 SLBlock_Type *addr1 = addr + 1;
5793 if (block == NULL) block = addr;
5794
5795 status = lang_do_loops(addr->bc_sub_type, block, 1 + (unsigned int) (addr - block));
5796 block = NULL;
5797 while (addr1->bc_main_type == SLANG_BC_BLOCK)
5798 {
5799 if (addr1->bc_sub_type == SLANG_BCST_LOOP_THEN)
5800 {
5801 addr = addr1;
5802 if (status == 0)
5803 inner_interp (addr->b.blk);
5804 addr1++;
5805 continue;
5806 }
5807 #ifdef LOOP_ELSE_TOKEN
5808 if (addr1->bc_sub_type == SLANG_BCST_LOOP_ELSE)
5809 {
5810 addr = addr1;
5811 if (status == 1)
5812 inner_interp (addr->b.blk);
5813 addr1++;
5814 continue;
5815 }
5816 #endif
5817 break;
5818 }
5819 }
5820 break;
5821
5822 case SLANG_BCST_IFNOT:
5823 #if SLANG_OPTIMIZE_FOR_SPEED
5824 {
5825 int i;
5826
5827 if ((0 == pop_ctrl_integer (&i)) && (i == 0))
5828 inner_interp (addr->b.blk);
5829 }
5830 #else
5831 do_else_if (addr, NULL);
5832 #endif
5833 break;
5834
5835 case SLANG_BCST_IF:
5836 #if SLANG_OPTIMIZE_FOR_SPEED
5837 {
5838 int i;
5839
5840 if ((0 == pop_ctrl_integer (&i)) && i)
5841 inner_interp (addr->b.blk);
5842 }
5843 #else
5844 do_else_if (NULL, addr);
5845 #endif
5846 break;
5847
5848 case SLANG_BCST_NOTELSE:
5849 do_else_if (block, addr);
5850 block = NULL;
5851 break;
5852
5853 case SLANG_BCST_ELSE:
5854 do_else_if (addr, block);
5855 block = NULL;
5856 break;
5857
5858 case SLANG_BCST_SWITCH:
5859 if (Switch_Obj_Ptr == Switch_Obj_Max)
5860 {
5861 _pSLang_verror (SL_BUILTIN_LIMIT_EXCEEDED, "switch nesting too deep");
5862 break;
5863 }
5864 (void) pop_object(Switch_Obj_Ptr);
5865 Switch_Obj_Ptr++;
5866
5867 if (block == NULL) block = addr;
5868 while ((0 == IS_SLANG_ERROR)
5869 && (block <= addr)
5870 && (Lang_Break_Condition == 0)
5871 && (0 == inner_interp (block->b.blk)))
5872 block++;
5873 Switch_Obj_Ptr--;
5874 SLang_free_object (Switch_Obj_Ptr);
5875 Switch_Obj_Ptr->o_data_type = 0;
5876 block = NULL;
5877 break;
5878
5879 case SLANG_BCST_SC_AND:
5880 {
5881 int i;
5882 if ((0 == pop_ctrl_integer (&i)) && (i == 0))
5883 {
5884 (void) push_char_object (SLANG_CHAR_TYPE, 0);
5885 block = NULL;
5886 break;
5887 }
5888 }
5889 /* drop */
5890 case SLANG_BCST_ANDELSE:
5891 if (block == NULL) block = addr;
5892 lang_do_and_orelse (0, block, addr);
5893 block = NULL;
5894 break;
5895
5896 case SLANG_BCST_SC_OR:
5897 {
5898 int i;
5899 if ((0 == pop_ctrl_integer (&i)) && i)
5900 {
5901 i = (i != 0);
5902 (void) push_char_object (SLANG_CHAR_TYPE, (char)i);
5903 block = NULL;
5904 break;
5905 }
5906 }
5907 /* drop */
5908 case SLANG_BCST_ORELSE:
5909 if (block == NULL) block = addr;
5910 lang_do_and_orelse (1, block, addr);
5911 block = NULL;
5912 break;
5913
5914 case SLANG_BCST_TRY:
5915 do_try (block, addr);
5916 block = NULL;
5917 break;
5918
5919 case SLANG_BCST_COMPARE:
5920 do_compare (addr->b.blk);
5921 block = NULL;
5922 break;
5923
5924 default:
5925 if (block == NULL) block = addr;
5926 break;
5927 }
5928
5929 /*}}}*/
5930
5931 if (Lang_Break_Condition) goto handle_break_condition;
5932 break;
5933 /* End of SLANG_BC_BLOCK */
5934
5935 case SLANG_BC_RETURN:
5936 Lang_Break_Condition = Lang_Return = Lang_Break = 1; goto return_1;
5937 case SLANG_BC_BREAK:
5938 Lang_Break_Condition = Lang_Break = 1; goto return_1;
5939 case SLANG_BC_CONTINUE:
5940 Lang_Break_Condition = /* Lang_Continue = */ 1; goto return_1;
5941
5942 #if USE_UNUSED_BYCODES_IN_SWITCH
5943 case SLANG_BC_UNUSED_0x67:
5944 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
5945 break;
5946 #endif
5947 case SLANG_BC_BREAK_N:
5948 Lang_Break_Condition = Lang_Break = addr->b.i_blk;
5949 goto return_1;
5950
5951 case SLANG_BC_CONTINUE_N:
5952 Lang_Break = -(addr->b.i_blk - 1);
5953 Lang_Break_Condition = 1;
5954 goto return_1;
5955
5956 case SLANG_BC_X_ERROR:
5957 if (err_block != NULL)
5958 {
5959 inner_interp(err_block->b.blk);
5960 if (SLang_get_error ()) err_block = NULL;
5961 }
5962 else _pSLang_verror(SL_SYNTAX_ERROR, "No ERROR_BLOCK");
5963 if (Lang_Break_Condition) goto handle_break_condition;
5964 break;
5965
5966 case SLANG_BC_X_USER0:
5967 case SLANG_BC_X_USER1:
5968 case SLANG_BC_X_USER2:
5969 case SLANG_BC_X_USER3:
5970 case SLANG_BC_X_USER4:
5971 if (User_Block_Ptr[addr->bc_main_type - SLANG_BC_X_USER0] != NULL)
5972 {
5973 inner_interp(User_Block_Ptr[addr->bc_main_type - SLANG_BC_X_USER0]);
5974 }
5975 else _pSLang_verror(SL_SYNTAX_ERROR, "No block for X_USERBLOCK");
5976 if (Lang_Break_Condition) goto handle_break_condition;
5977 break;
5978
5979 case SLANG_BC_CALL_DIRECT:
5980 (*addr->b.call_function) ();
5981 break;
5982
5983 case SLANG_BC_CALL_DIRECT_FRAME:
5984 do_bc_call_direct_frame (addr->b.call_function);
5985 break;
5986
5987 case SLANG_BC_CALL_DIRECT_NARGS:
5988 do_bc_call_direct_nargs (addr->b.call_function);
5989 break;
5990
5991 case SLANG_BC_EARG_LVARIABLE:
5992 PUSH_LOCAL_VARIABLE(addr->b.i_blk)
5993 (void) end_arg_list ();
5994 break;
5995 #if USE_BC_LINE_NUM
5996 case SLANG_BC_LINE_NUM:
5997 break;
5998 #else
5999 # if USE_UNUSED_BYCODES_IN_SWITCH
6000 case SLANG_BC_UNUSED_0x74:
6001 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
6002 break;
6003 # endif
6004 #endif
6005 case SLANG_BC_BOS:
6006 #if SLANG_HAS_BOSEOS
6007 BOS_Stack_Depth++;
6008 This_Compile_Linenum = addr->b.line_info->linenum;
6009 (void) _pSLcall_bos_handler (addr->b.line_info->filename, addr->b.line_info->linenum);
6010 #endif
6011 break;
6012 case SLANG_BC_EOS:
6013 #if SLANG_HAS_BOSEOS
6014 This_Compile_Linenum = addr->linenum;
6015 (void) _pSLcall_eos_handler ();
6016 BOS_Stack_Depth--;
6017 #endif
6018 break;
6019
6020 #if USE_UNUSED_BYCODES_IN_SWITCH
6021 case SLANG_BC_UNUSED_0x77:
6022 case SLANG_BC_UNUSED_0x78:
6023 case SLANG_BC_UNUSED_0x79:
6024 case SLANG_BC_UNUSED_0x7A:
6025 case SLANG_BC_UNUSED_0x7B:
6026 case SLANG_BC_UNUSED_0x7C:
6027 case SLANG_BC_UNUSED_0x7D:
6028 case SLANG_BC_UNUSED_0x7E:
6029 case SLANG_BC_UNUSED_0x7F:
6030 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
6031 break;
6032 #endif
6033
6034 #if USE_COMBINED_BYTECODES
6035 case SLANG_BC_CALL_DIRECT_INTRINSIC:
6036 (*addr->b.call_function) ();
6037 addr++;
6038 EXECUTE_INTRINSIC(addr)
6039 if (IS_SLANG_ERROR)
6040 do_traceback(addr->b.nt_ifun_blk->name);
6041 break;
6042
6043 case SLANG_BC_INTRINSIC_CALL_DIRECT:
6044 EXECUTE_INTRINSIC(addr)
6045 if (IS_SLANG_ERROR)
6046 {
6047 do_traceback(addr->b.nt_ifun_blk->name);
6048 break;
6049 }
6050 addr++;
6051 (*addr->b.call_function) ();
6052 break;
6053
6054 case SLANG_BC_CALL_DIRECT_LSTR:
6055 (*addr->b.call_function) ();
6056 addr++;
6057 _pSLang_dup_and_push_slstring (addr->b.s_blk);
6058 break;
6059
6060 case SLANG_BC_CALL_DIRECT_SLFUN:
6061 (*addr->b.call_function) ();
6062 addr++;
6063 execute_slang_fun (addr->b.nt_fun_blk, addr->linenum);
6064 if (Lang_Break_Condition) goto handle_break_condition;
6065 break;
6066
6067 case SLANG_BC_CALL_DIRECT_RETINTR:
6068 (*addr->b.call_function) ();
6069 addr++;
6070 /* drop */
6071 case SLANG_BC_RET_INTRINSIC:
6072 EXECUTE_INTRINSIC (addr)
6073 if (0 == Handle_Interrupt)
6074 return 1;
6075 if (IS_SLANG_ERROR)
6076 do_traceback(addr->b.nt_ifun_blk->name);
6077 break;
6078
6079 case SLANG_BC_CALL_DIRECT_EARG_LVAR:
6080 (*addr->b.call_function) ();
6081 addr++;
6082 PUSH_LOCAL_VARIABLE (addr->b.i_blk)
6083 (void) end_arg_list ();
6084 break;
6085
6086 case SLANG_BC_CALL_DIRECT_LINT:
6087 (*addr->b.call_function) ();
6088 addr++;
6089 push_int_object (addr->bc_sub_type, (int) addr->b.l_blk);
6090 break;
6091
6092 case SLANG_BC_CALL_DIRECT_LVAR:
6093 (*addr->b.call_function) ();
6094 addr++;
6095 PUSH_LOCAL_VARIABLE (addr->b.i_blk)
6096 break;
6097
6098 case SLANG_BC_LLVARIABLE_BINARY:
6099 {
6100 SLang_Object_Type *obj1 = Local_Variable_Frame - (addr+1)->b.i_blk;
6101 SLang_Object_Type *obj2 = Local_Variable_Frame - (addr+2)->b.i_blk;
6102 if (obj1->o_data_type == obj2->o_data_type)
6103 {
6104 if (obj1->o_data_type == SLANG_INT_TYPE)
6105 (void) int_int_binary (addr->b.i_blk, obj1, obj2);
6106 # if SLANG_HAS_FLOAT
6107 else if (obj1->o_data_type == SLANG_DOUBLE_TYPE)
6108 (void) dbl_dbl_binary (addr->b.i_blk, obj1, obj2);
6109 # endif
6110 else
6111 (void) do_binary_ab_inc_ref (addr->b.i_blk, obj1, obj2);
6112 }
6113 else do_binary_ab_inc_ref (addr->b.i_blk, obj1, obj2);
6114 addr += 2;
6115 }
6116 break;
6117
6118 case SLANG_BC_LGVARIABLE_BINARY:
6119 do_binary_ab_inc_ref (addr->b.i_blk,
6120 Local_Variable_Frame - (addr+1)->b.i_blk,
6121 &(addr+2)->b.nt_gvar_blk->obj);
6122 addr += 2;
6123 break;
6124
6125 case SLANG_BC_GLVARIABLE_BINARY:
6126 do_binary_ab_inc_ref (addr->b.i_blk,
6127 &(addr+1)->b.nt_gvar_blk->obj,
6128 Local_Variable_Frame - (addr+2)->b.i_blk);
6129 addr += 2;
6130 break;
6131 case SLANG_BC_GGVARIABLE_BINARY:
6132 do_binary_ab_inc_ref (addr->b.i_blk,
6133 &(addr+1)->b.nt_gvar_blk->obj,
6134 &(addr+2)->b.nt_gvar_blk->obj);
6135 addr += 2;
6136 break;
6137
6138 case SLANG_BC_LIVARIABLE_BINARY:
6139 {
6140 SLang_Object_Type o, *obj1;
6141 o.o_data_type = SLANG_INT_TYPE;
6142 o.v.int_val = (int) (addr+2)->b.l_blk;
6143 obj1 = Local_Variable_Frame - (addr+1)->b.i_blk;
6144 if (obj1->o_data_type == SLANG_INT_TYPE)
6145 (void) int_int_binary (addr->b.i_blk, obj1, &o);
6146 else
6147 do_binary_ab_inc_ref (addr->b.i_blk, obj1, &o);
6148 }
6149 addr += 2;
6150 break;
6151 # if SLANG_HAS_FLOAT
6152 case SLANG_BC_LDVARIABLE_BINARY:
6153 {
6154 SLang_Object_Type o, *obj1;
6155 o.o_data_type = SLANG_DOUBLE_TYPE;
6156 o.v.double_val = *(addr+2)->b.double_blk;
6157 obj1 = Local_Variable_Frame - (addr+1)->b.i_blk;
6158 if (obj1->o_data_type == SLANG_DOUBLE_TYPE)
6159 (void) dbl_dbl_binary (addr->b.i_blk, obj1, &o);
6160 else
6161 do_binary_ab_inc_ref (addr->b.i_blk, obj1, &o);
6162 }
6163 addr += 2;
6164 break;
6165 # endif
6166 case SLANG_BC_ILVARIABLE_BINARY:
6167 {
6168 SLang_Object_Type o, *obj1;
6169 o.o_data_type = SLANG_INT_TYPE;
6170 o.v.int_val = (int) (addr+1)->b.l_blk;
6171 obj1 = Local_Variable_Frame - (addr+2)->b.i_blk;
6172 if (obj1->o_data_type == SLANG_INT_TYPE)
6173 (void) int_int_binary (addr->b.i_blk, &o, obj1);
6174 else
6175 (void) do_binary_ab_inc_ref (addr->b.i_blk, &o, obj1);
6176 }
6177 addr += 2;
6178 break;
6179 # if SLANG_HAS_FLOAT
6180 case SLANG_BC_DLVARIABLE_BINARY:
6181 {
6182 SLang_Object_Type o, *obj1;
6183 o.o_data_type = SLANG_DOUBLE_TYPE;
6184 o.v.double_val = *(addr+1)->b.double_blk;
6185 obj1 = Local_Variable_Frame - (addr+2)->b.i_blk;
6186 if (obj1->o_data_type == SLANG_DOUBLE_TYPE)
6187 (void) dbl_dbl_binary (addr->b.i_blk, &o, obj1);
6188 else
6189 (void) do_binary_ab_inc_ref (addr->b.i_blk, &o, obj1);
6190
6191 }
6192 addr += 2;
6193 break;
6194 # endif
6195 case SLANG_BC_LVARIABLE_BINARY:
6196 do_binary_b_inc_ref (addr->b.i_blk,
6197 Local_Variable_Frame - (addr+1)->b.i_blk);
6198 addr++;
6199 break;
6200
6201 case SLANG_BC_GVARIABLE_BINARY:
6202 do_binary_b_inc_ref (addr->b.i_blk,
6203 &(addr+1)->b.nt_gvar_blk->obj);
6204 addr++;
6205 break;
6206
6207 case SLANG_BC_LITERAL_INT_BINARY:
6208 {
6209 SLang_Object_Type o;
6210 o.o_data_type = SLANG_INT_TYPE;
6211 o.v.int_val = (int) (addr+1)->b.l_blk;
6212 (void) do_binary_b (addr->b.i_blk, &o);
6213 }
6214 addr++;
6215 break;
6216 # if SLANG_HAS_FLOAT
6217 case SLANG_BC_LITERAL_DBL_BINARY:
6218 {
6219 SLang_Object_Type o;
6220 o.o_data_type = SLANG_DOUBLE_TYPE;
6221 o.v.double_val = *(addr+1)->b.double_blk;
6222 (void) do_binary_b (addr->b.i_blk, &o);
6223 }
6224 addr++;
6225 break;
6226 # endif
6227 case SLANG_BC_LASSIGN_LLBINARY:
6228 (void) do_binary_ab_inc_ref_assign ((addr+1)->b.i_blk,
6229 Local_Variable_Frame - (addr+2)->b.i_blk,
6230 Local_Variable_Frame - (addr+3)->b.i_blk,
6231 Local_Variable_Frame - addr->b.i_blk);
6232 addr += 3;
6233 break;
6234
6235 case SLANG_BC_LASSIGN_LIBINARY:
6236 {
6237 SLang_Object_Type o;
6238 o.o_data_type = SLANG_INT_TYPE;
6239 o.v.int_val = (int) (addr+3)->b.l_blk;
6240
6241 (void) do_binary_ab_inc_ref_assign ((addr+1)->b.i_blk,
6242 Local_Variable_Frame - (addr+2)->b.i_blk,
6243 &o,
6244 Local_Variable_Frame - addr->b.i_blk);
6245 }
6246 addr += 3;
6247 break;
6248 case SLANG_BC_LASSIGN_ILBINARY:
6249 {
6250 SLang_Object_Type o;
6251 o.o_data_type = SLANG_INT_TYPE;
6252 o.v.int_val = (int) (addr+2)->b.l_blk;
6253
6254 (void) do_binary_ab_inc_ref_assign ((addr+1)->b.i_blk,
6255 &o,
6256 Local_Variable_Frame - (addr+3)->b.i_blk,
6257 Local_Variable_Frame - addr->b.i_blk);
6258 }
6259 addr += 3;
6260 break;
6261 # if SLANG_HAS_FLOAT
6262 case SLANG_BC_LASSIGN_LDBINARY:
6263 {
6264 SLang_Object_Type o;
6265 o.o_data_type = SLANG_DOUBLE_TYPE;
6266 o.v.double_val = *(addr+3)->b.double_blk;
6267
6268 (void) do_binary_ab_inc_ref_assign ((addr+1)->b.i_blk,
6269 Local_Variable_Frame - (addr+2)->b.i_blk,
6270 &o,
6271 Local_Variable_Frame - addr->b.i_blk);
6272 }
6273 addr += 3;
6274 break;
6275 case SLANG_BC_LASSIGN_DLBINARY:
6276 {
6277 SLang_Object_Type o;
6278 o.o_data_type = SLANG_DOUBLE_TYPE;
6279 o.v.double_val = *(addr+2)->b.double_blk;
6280
6281 (void) do_binary_ab_inc_ref_assign ((addr+1)->b.i_blk,
6282 &o,
6283 Local_Variable_Frame - (addr+3)->b.i_blk,
6284 Local_Variable_Frame - addr->b.i_blk);
6285 }
6286 addr += 3;
6287 break;
6288 # endif
6289 case SLANG_BC_RET_LVARIABLE:
6290 if (0 != push_local_variable (addr->b.i_blk))
6291 break;
6292 Lang_Break_Condition = Lang_Return = Lang_Break = 1;
6293 goto return_1;
6294
6295 case SLANG_BC_RET_LITERAL_INT:
6296 if (-1 == push_int_object (addr->bc_sub_type, (int) addr->b.l_blk))
6297 break;
6298 Lang_Break_Condition = Lang_Return = Lang_Break = 1;
6299 goto return_1;
6300
6301 case SLANG_BC_MANY_LVARIABLE:
6302 (void) push_local_variable (addr->b.i_blk);
6303 addr++;
6304 (void) push_local_variable (addr->b.i_blk);
6305 addr++;
6306 while (addr->bc_main_type == SLANG_BC_LVARIABLE_COMBINED)
6307 {
6308 (void) push_local_variable (addr->b.i_blk);
6309 addr++;
6310 }
6311 addr--;
6312 break;
6313
6314 case SLANG_BC_MANY_LVARIABLE_DIR:
6315 (void) push_local_variable (addr->b.i_blk);
6316 addr++;
6317 (void) push_local_variable (addr->b.i_blk);
6318 addr++;
6319 while (addr->bc_main_type == SLANG_BC_LVARIABLE_COMBINED)
6320 {
6321 (void) push_local_variable (addr->b.i_blk);
6322 addr++;
6323 }
6324 (*addr->b.call_function) ();
6325 break;
6326
6327 case SLANG_BC_LVARIABLE_AGET1:
6328 {
6329 SLang_Object_Type *o;
6330
6331 addr++; /* not used */
6332 o = (Local_Variable_Frame - addr->b.i_blk);
6333 if (o->o_data_type == SLANG_INT_TYPE)
6334 {
6335 addr++;
6336 (void) push_array_element (addr->b.i_blk, o->v.int_val);
6337 break;
6338 }
6339 if (-1 == push_local_variable (addr->b.i_blk))
6340 break;
6341 addr++;
6342 if (-1 == push_local_variable (addr->b.i_blk))
6343 break;
6344 (void) _pSLarray_aget1 (1);
6345 break;
6346 }
6347
6348 case SLANG_BC_LITERAL_AGET1:
6349 addr++; /* not used */
6350 push_array_element ((addr+1)->b.i_blk, (int) addr->b.l_blk);
6351 addr++;
6352 break;
6353
6354 case SLANG_BC_LVAR_LVAR_APUT1:
6355 if (-1 == push_local_variable (addr->b.i_blk))
6356 break;
6357 addr++;
6358 /* drop */
6359 case SLANG_BC_LVARIABLE_APUT1:
6360 {
6361 SLang_Object_Type *o;
6362
6363 addr++; /* not used */
6364 o = (Local_Variable_Frame - addr->b.i_blk);
6365 if (o->o_data_type == SLANG_INT_TYPE)
6366 {
6367 addr++;
6368 (void) pop_to_lvar_array_element (addr->b.i_blk, o->v.int_val);
6369 break;
6370 }
6371 if (-1 == push_local_variable (addr->b.i_blk))
6372 break;
6373 addr++;
6374 if (-1 == push_local_variable (addr->b.i_blk))
6375 break;
6376 (void) _pSLarray_aput1 (1);
6377 }
6378 break;
6379
6380 case SLANG_BC_LITERAL_APUT1:
6381 (void) pop_to_lvar_array_element ((addr+2)->b.i_blk, (SLindex_Type)((addr+1)->b.l_blk));
6382 addr += 2;
6383 break;
6384
6385 case SLANG_BC_LLVARIABLE_BINARY2:
6386 {
6387 SLang_Object_Type *obj1 = Local_Variable_Frame - (addr+1)->b.i_blk;
6388 SLang_Object_Type *obj2 = Local_Variable_Frame - (addr+2)->b.i_blk;
6389 SLang_Object_Type obj3;
6390
6391 if (obj1->o_data_type == obj2->o_data_type)
6392 {
6393 if (obj1->o_data_type == SLANG_INT_TYPE)
6394 {
6395 if (-1 == int_int_binary_result (addr->b.i_blk, obj1, obj2, &obj3))
6396 break;
6397 addr += 3;
6398 (void) do_binary_b (addr->b.i_blk, &obj3);
6399 break;
6400 }
6401 # if SLANG_HAS_FLOAT
6402 else if (obj1->o_data_type == SLANG_DOUBLE_TYPE)
6403 {
6404 if (-1 == dbl_dbl_binary_result (addr->b.i_blk, obj1, obj2, &obj3))
6405 break;
6406 addr += 3;
6407 (void) do_binary_b (addr->b.i_blk, &obj3);
6408 break;
6409 }
6410 # endif
6411 }
6412
6413 obj3.o_data_type = SLANG_UNDEFINED_TYPE;
6414 if (-1 == do_binary_ab_inc_ref_assign (addr->b.i_blk, obj1, obj2, &obj3))
6415 break;
6416 addr += 3;
6417 (void) do_binary_b (addr->b.i_blk, &obj3);
6418 SLang_free_object (&obj3);
6419 }
6420 break;
6421
6422 case SLANG_BC_SET_LOCLV_LIT_INT:
6423 set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
6424 addr++;
6425 push_int_object (addr->bc_sub_type, (int) addr->b.l_blk);
6426 break;
6427
6428 case SLANG_BC_SET_LOCLV_LIT_AGET1:
6429 set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
6430 addr += 3;
6431 push_array_element (addr->b.i_blk, (int) (addr-1)->b.l_blk);
6432 break;
6433
6434 case SLANG_BC_SET_LOCLV_LVAR:
6435 set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
6436 addr++;
6437 PUSH_LOCAL_VARIABLE (addr->b.i_blk)
6438 break;
6439
6440 case SLANG_BC_SET_LOCLV_LASTBLOCK:
6441 if (0 == set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk))
6442 goto return_1;
6443 break;
6444
6445 case SLANG_BC_LVAR_EARG_LVAR:
6446 PUSH_LOCAL_VARIABLE (addr->b.i_blk);
6447 addr++;
6448 PUSH_LOCAL_VARIABLE(addr->b.i_blk);
6449 (void) end_arg_list ();
6450 break;
6451
6452 case SLANG_BC_LVAR_FIELD:
6453 PUSH_LOCAL_VARIABLE (addr->b.i_blk);
6454 addr++;
6455 (void) push_struct_field (addr->b.s_blk);
6456 break;
6457
6458 case SLANG_BC_BINARY_LASTBLOCK:
6459 if (-1 == do_binary (addr->b.i_blk))
6460 break;
6461 goto return_1;
6462
6463 case SLANG_BC_EARG_LVARIABLE_INTRINSIC:
6464 PUSH_LOCAL_VARIABLE(addr->b.i_blk);
6465 if (0 == end_arg_list ())
6466 {
6467 addr++;
6468 EXECUTE_INTRINSIC(addr)
6469 if (IS_SLANG_ERROR)
6470 do_traceback(addr->b.nt_ifun_blk->name);
6471 }
6472 break;
6473
6474 case SLANG_BC_LVAR_LITERAL_INT:
6475 PUSH_LOCAL_VARIABLE (addr->b.i_blk);
6476 addr++;
6477 push_int_object (addr->bc_sub_type, (int) addr->b.l_blk);
6478 break;
6479
6480 case SLANG_BC_BINARY_SET_LOCLVAL:
6481 if (-1 == do_binary (addr->b.i_blk))
6482 break;
6483 addr++;
6484 (void) set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
6485 break;
6486
6487 case SLANG_BC_LVAR_AGET_SET_LOCLVAL:
6488 {
6489 SLang_Object_Type *obj = Local_Variable_Frame - addr->b.i_blk;
6490 if ((0 == carefully_push_object (obj))
6491 && (0 == do_bc_call_direct_nargs (_pSLarray_aget)))
6492 {
6493 addr++;
6494 (void) set_lvalue_obj (addr->bc_sub_type, Local_Variable_Frame - addr->b.i_blk);
6495 }
6496 }
6497 break;
6498
6499 case SLANG_BC_LLVAR_BINARY_IF:
6500 {
6501 SLang_Object_Type *obj1 = Local_Variable_Frame - (addr+1)->b.i_blk;
6502 SLang_Object_Type *obj2 = Local_Variable_Frame - (addr+2)->b.i_blk;
6503 SLang_Object_Type obj3;
6504
6505 if (obj1->o_data_type == obj2->o_data_type)
6506 {
6507 if (obj1->o_data_type == SLANG_INT_TYPE)
6508 {
6509 if (-1 == int_int_binary_result (addr->b.i_blk, obj1, obj2, &obj3))
6510 break;
6511 }
6512 # if SLANG_HAS_FLOAT
6513 else if (obj1->o_data_type == SLANG_DOUBLE_TYPE)
6514 {
6515 if (-1 == dbl_dbl_binary_result (addr->b.i_blk, obj1, obj2, &obj3))
6516 break;
6517 }
6518 # endif
6519 else
6520 {
6521 obj3.o_data_type = SLANG_UNDEFINED_TYPE;
6522 if (-1 == do_binary_ab_inc_ref_assign (addr->b.i_blk, obj1, obj2, &obj3))
6523 break;
6524 }
6525 }
6526 else
6527 {
6528 obj3.o_data_type = SLANG_UNDEFINED_TYPE;
6529 if (-1 == do_binary_ab_inc_ref_assign (addr->b.i_blk, obj1, obj2, &obj3))
6530 break;
6531 }
6532 addr += 3;
6533 if (obj3.o_data_type == SLANG_CHAR_TYPE)
6534 {
6535 if (obj3.v.char_val)
6536 goto execute_BC_IF_BLOCK;
6537 break;
6538 }
6539 if (obj3.o_data_type == SLANG_INT_TYPE)
6540 {
6541 if (obj3.v.int_val)
6542 goto execute_BC_IF_BLOCK;
6543 break;
6544 }
6545
6546 /* Otherwise let pop_ctrl_integer do the dirty work */
6547 if (-1 == push_object (&obj3))
6548 break;
6549 }
6550 /* drop */
6551 case SLANG_BC_IF_BLOCK:
6552 {
6553 int i;
6554
6555 if ((-1 == pop_ctrl_integer (&i)) || (i == 0))
6556 break;
6557 }
6558
6559 execute_BC_IF_BLOCK:
6560 {
6561 SLBlock_Type *addr1 = addr->b.blk;
6562 if (addr1->bc_main_type == SLANG_BC_RETURN)
6563 {
6564 Lang_Break_Condition = Lang_Return = Lang_Break = 1;
6565 goto return_1;
6566 }
6567 if (addr1->bc_main_type == SLANG_BC_RET_LVARIABLE)
6568 {
6569 if (0 != push_local_variable (addr1->b.i_blk))
6570 break;
6571 Lang_Break_Condition = Lang_Return = Lang_Break = 1;
6572 goto return_1;
6573 }
6574 inner_interp (addr1);
6575 if (Lang_Break_Condition) goto handle_break_condition;
6576 }
6577 break;
6578
6579 case SLANG_BC_LVAR_SET_FIELD:
6580 (void) set_struct_obj_lvalue (addr+1, Local_Variable_Frame - addr->b.i_blk, 0);
6581 addr++;
6582 break;
6583
6584 case SLANG_BC_PVAR_SET_GLOB_LVAL:
6585 addr++;
6586 if (-1 == set_lvalue_obj_with_obj (addr->bc_sub_type,
6587 &addr->b.nt_gvar_blk->obj,
6588 &(addr-1)->b.nt_gvar_blk->obj))
6589 do_name_type_error (addr->b.nt_blk);
6590 break;
6591 case SLANG_BC_LVAR_SET_GLOB_LVAL:
6592 addr++;
6593 if (-1 == set_lvalue_obj_with_obj (addr->bc_sub_type,
6594 &addr->b.nt_gvar_blk->obj,
6595 Local_Variable_Frame - (addr-1)->b.i_blk))
6596 do_name_type_error (addr->b.nt_blk);
6597 break;
6598
6599 case SLANG_BC_LIT_AGET1_INT_BINARY:
6600 {
6601 SLang_Object_Type o;
6602 o.o_data_type = SLANG_INT_TYPE;
6603 o.v.int_val = (int)(addr+4)->b.l_blk;
6604 (void) aget1_from_lvar_binary ((addr+2)->b.i_blk, (SLindex_Type) (addr+1)->b.l_blk,
6605 (addr+3)->b.i_blk, &o);
6606 }
6607 addr += 4;
6608 break;
6609 case SLANG_BC_BINARY2:
6610 if (0 == do_binary (addr->b.i_blk))
6611 {
6612 addr++;
6613 (void) do_binary (addr->b.i_blk);
6614 }
6615 break;
6616
6617 case SLANG_BC_LVAR_LIT_AGET1:
6618 PUSH_LOCAL_VARIABLE(addr->b.i_blk);
6619 (void) push_array_element ((addr+3)->b.i_blk, (int)((addr+2)->b.l_blk));
6620 addr += 3;
6621 break;
6622 #endif /* USE_COMBINED_BYTECODES */
6623
6624 #if USE_UNUSED_BYCODES_IN_SWITCH
6625 # if !USE_COMBINED_BYTECODES
6626 case SLANG_BC_CALL_DIRECT_INTRINSIC:
6627 case SLANG_BC_INTRINSIC_CALL_DIRECT:
6628 case SLANG_BC_CALL_DIRECT_LSTR:
6629 case SLANG_BC_CALL_DIRECT_SLFUN:
6630 case SLANG_BC_CALL_DIRECT_RETINTR:
6631 case SLANG_BC_RET_INTRINSIC:
6632 case SLANG_BC_CALL_DIRECT_EARG_LVAR:
6633 case SLANG_BC_CALL_DIRECT_LINT:
6634 case SLANG_BC_CALL_DIRECT_LVAR:
6635 case SLANG_BC_LLVARIABLE_BINARY:
6636 case SLANG_BC_LGVARIABLE_BINARY:
6637 case SLANG_BC_GLVARIABLE_BINARY:
6638 case SLANG_BC_GGVARIABLE_BINARY:
6639 case SLANG_BC_LIVARIABLE_BINARY:
6640 case SLANG_BC_LDVARIABLE_BINARY:
6641 case SLANG_BC_ILVARIABLE_BINARY:
6642 case SLANG_BC_DLVARIABLE_BINARY:
6643 case SLANG_BC_LVARIABLE_BINARY:
6644 case SLANG_BC_GVARIABLE_BINARY:
6645 case SLANG_BC_LITERAL_INT_BINARY:
6646 case SLANG_BC_LITERAL_DBL_BINARY:
6647 case SLANG_BC_LASSIGN_LLBINARY:
6648 case SLANG_BC_LASSIGN_LIBINARY:
6649 case SLANG_BC_LASSIGN_ILBINARY:
6650 case SLANG_BC_LASSIGN_LDBINARY:
6651 case SLANG_BC_LASSIGN_DLBINARY:
6652 case SLANG_BC_RET_LVARIABLE:
6653 case SLANG_BC_RET_LITERAL_INT:
6654 case SLANG_BC_MANY_LVARIABLE:
6655 case SLANG_BC_MANY_LVARIABLE_DIR:
6656 case SLANG_BC_LVARIABLE_AGET1:
6657 case SLANG_BC_LITERAL_AGET1:
6658 case SLANG_BC_LVAR_LVAR_APUT1:
6659 case SLANG_BC_LVARIABLE_APUT1:
6660 case SLANG_BC_LITERAL_APUT1:
6661 case SLANG_BC_LLVARIABLE_BINARY2:
6662 case SLANG_BC_SET_LOCLV_LIT_INT:
6663 case SLANG_BC_SET_LOCLV_LIT_AGET1:
6664 case SLANG_BC_SET_LOCLV_LVAR:
6665 case SLANG_BC_SET_LOCLV_LASTBLOCK:
6666 case SLANG_BC_LVAR_EARG_LVAR:
6667 case SLANG_BC_LVAR_FIELD:
6668 case SLANG_BC_BINARY_LASTBLOCK:
6669 case SLANG_BC_EARG_LVARIABLE_INTRINSIC:
6670 case SLANG_BC_LVAR_LITERAL_INT:
6671 case SLANG_BC_BINARY_SET_LOCLVAL:
6672 case SLANG_BC_LVAR_AGET_SET_LOCLVAL:
6673 case SLANG_BC_LLVAR_BINARY_IF:
6674 case SLANG_BC_IF_BLOCK:
6675 case SLANG_BC_LVAR_SET_FIELD:
6676 case SLANG_BC_PVAR_SET_GLOB_LVAL:
6677 case SLANG_BC_LVAR_SET_GLOB_LVAL:
6678 case SLANG_BC_LIT_AGET1_INT_BINARY:
6679 case SLANG_BC_BINARY2:
6680 case SLANG_BC_LVAR_LIT_AGET1:
6681 # endif
6682 case SLANG_BC_UNUSED_0xB7:
6683 case SLANG_BC_UNUSED_0xB8:
6684 case SLANG_BC_UNUSED_0xB9:
6685 case SLANG_BC_UNUSED_0xBA:
6686 case SLANG_BC_UNUSED_0xBB:
6687 case SLANG_BC_UNUSED_0xBC:
6688 case SLANG_BC_UNUSED_0xBD:
6689 case SLANG_BC_UNUSED_0xBE:
6690 case SLANG_BC_UNUSED_0xBF:
6691 case SLANG_BC_LVARIABLE_COMBINED:
6692 case SLANG_BC_GVARIABLE_COMBINED:
6693 case SLANG_BC_LITERAL_COMBINED:
6694 case SLANG_BC_CALL_DIRECT_COMB:
6695 case SLANG_BC_COMBINED:
6696 case SLANG_BC_BLOCK_COMBINED:
6697 case SLANG_BC_UNUSED_0xC6:
6698 case SLANG_BC_UNUSED_0xC7:
6699 case SLANG_BC_UNUSED_0xC8:
6700 case SLANG_BC_UNUSED_0xC9:
6701 case SLANG_BC_UNUSED_0xCA:
6702 case SLANG_BC_UNUSED_0xCB:
6703 case SLANG_BC_UNUSED_0xCC:
6704 case SLANG_BC_UNUSED_0xCD:
6705 case SLANG_BC_UNUSED_0xCE:
6706 case SLANG_BC_UNUSED_0xCF:
6707 case SLANG_BC_UNUSED_0xD0:
6708 case SLANG_BC_UNUSED_0xD1:
6709 case SLANG_BC_UNUSED_0xD2:
6710 case SLANG_BC_UNUSED_0xD3:
6711 case SLANG_BC_UNUSED_0xD4:
6712 case SLANG_BC_UNUSED_0xD5:
6713 case SLANG_BC_UNUSED_0xD6:
6714 case SLANG_BC_UNUSED_0xD7:
6715 case SLANG_BC_UNUSED_0xD8:
6716 case SLANG_BC_UNUSED_0xD9:
6717 case SLANG_BC_UNUSED_0xDA:
6718 case SLANG_BC_UNUSED_0xDB:
6719 case SLANG_BC_UNUSED_0xDC:
6720 case SLANG_BC_UNUSED_0xDD:
6721 case SLANG_BC_UNUSED_0xDE:
6722 case SLANG_BC_UNUSED_0xDF:
6723 case SLANG_BC_UNUSED_0xE0:
6724 case SLANG_BC_UNUSED_0xE1:
6725 case SLANG_BC_UNUSED_0xE2:
6726 case SLANG_BC_UNUSED_0xE3:
6727 case SLANG_BC_UNUSED_0xE4:
6728 case SLANG_BC_UNUSED_0xE5:
6729 case SLANG_BC_UNUSED_0xE6:
6730 case SLANG_BC_UNUSED_0xE7:
6731 case SLANG_BC_UNUSED_0xE8:
6732 case SLANG_BC_UNUSED_0xE9:
6733 case SLANG_BC_UNUSED_0xEA:
6734 case SLANG_BC_UNUSED_0xEB:
6735 case SLANG_BC_UNUSED_0xEC:
6736 case SLANG_BC_UNUSED_0xED:
6737 case SLANG_BC_UNUSED_0xEE:
6738 case SLANG_BC_UNUSED_0xEF:
6739 case SLANG_BC_UNUSED_0xF0:
6740 case SLANG_BC_UNUSED_0xF1:
6741 case SLANG_BC_UNUSED_0xF2:
6742 case SLANG_BC_UNUSED_0xF3:
6743 case SLANG_BC_UNUSED_0xF4:
6744 case SLANG_BC_UNUSED_0xF5:
6745 case SLANG_BC_UNUSED_0xF6:
6746 case SLANG_BC_UNUSED_0xF7:
6747 case SLANG_BC_UNUSED_0xF8:
6748 case SLANG_BC_UNUSED_0xF9:
6749 case SLANG_BC_UNUSED_0xFA:
6750 case SLANG_BC_UNUSED_0xFB:
6751 case SLANG_BC_UNUSED_0xFC:
6752 case SLANG_BC_UNUSED_0xFD:
6753 case SLANG_BC_UNUSED_0xFE:
6754 case SLANG_BC_UNUSED_0xFF:
6755 #else
6756 default:
6757 #endif
6758 _pSLang_verror (SL_INTERNAL_ERROR, "Byte-Code 0x%X is not valid", addr->bc_main_type);
6759 }
6760
6761 IF_UNLIKELY(Handle_Interrupt != 0)
6762 {
6763 if (SLang_get_error ())
6764 {
6765 if (-1 == do_inner_interp_error (err_block, addr_start, addr))
6766 return 1;
6767 if (SLang_get_error ())
6768 return 1;
6769 /* Otherwise, error cleared. Continue onto next bytecode */
6770 }
6771 #if SLANG_HAS_SIGNALS
6772 (void) check_signals ();
6773 #endif
6774 if (Lang_Break_Condition) goto handle_break_condition;
6775 }
6776 }
6777
6778 handle_break_condition:
6779 /* Get here if Lang_Break_Condition != 0, which implies that either
6780 * Lang_Return, Lang_Break, or Lang_Continue is non zero
6781 */
6782 if (Lang_Return)
6783 Lang_Break = 1;
6784
6785 return_1:
6786 #if SLANG_HAS_SIGNALS
6787 if (Handle_Interrupt)
6788 check_signals ();
6789 #endif
6790 return 1;
6791
6792 return_0:
6793 #if SLANG_HAS_SIGNALS
6794 if (Handle_Interrupt)
6795 check_signals ();
6796 #endif
6797 return 0;
6798 }
6799
6800 /*}}}*/
6801
6802 /* The functions below this point are used to implement the parsed token
6803 * to byte-compiled code.
6804 */
6805 /* static SLang_Name_Type **Static_Hash_Table; */
6806
6807 /* static SLang_Name_Type **Locals_Hash_Table; */
6808 int _pSLang_Auto_Declare_Globals = 0;
6809 int (*SLang_Auto_Declare_Var_Hook) (SLFUTURE_CONST char *);
6810
6811 static int Local_Variable_Number;
6812 static unsigned int Function_Args_Number;
6813
6814 static int Lang_Defining_Function;
6815 static void (*Default_Variable_Mode) (_pSLang_Token_Type *);
6816 static void (*Default_Define_Function) (SLFUTURE_CONST char *, unsigned long);
6817 static int setup_default_compile_linkage (int);
6818
6819 static int push_compile_context (SLFUTURE_CONST char *);
6820 static int pop_compile_context (void);
6821
6822 typedef struct
6823 {
6824 int block_type;
6825 SLBlock_Type *block; /* beginning of block definition */
6826 SLBlock_Type *block_ptr; /* current location */
6827 SLBlock_Type *block_max; /* end of definition */
6828 SLang_NameSpace_Type *static_namespace;
6829 }
6830 Block_Context_Type;
6831
6832 static Block_Context_Type Block_Context_Stack [SLANG_MAX_BLOCK_STACK_LEN];
6833 static unsigned int Block_Context_Stack_Len;
6834
6835 static SLBlock_Type *Compile_ByteCode_Ptr;
6836 static SLBlock_Type *This_Compile_Block;
6837 static SLBlock_Type *This_Compile_Block_Max;
6838
6839 #define COMPILE_BLOCK_TYPE_NONE 0
6840 #define COMPILE_BLOCK_TYPE_FUNCTION 1
6841 #define COMPILE_BLOCK_TYPE_BLOCK 2
6842 #define COMPILE_BLOCK_TYPE_TOP_LEVEL 3
6843 static int This_Compile_Block_Type = COMPILE_BLOCK_TYPE_NONE;
6844
6845 /* If it returns 0, DO NOT FREE p */
lang_free_branch(SLBlock_Type * p)6846 static int lang_free_branch (SLBlock_Type *p)
6847 {
6848 while (1)
6849 {
6850 SLang_Class_Type *cl;
6851
6852 switch (p->bc_main_type)
6853 {
6854 case SLANG_BC_BLOCK:
6855 case SLANG_BC_IF_BLOCK:
6856 case SLANG_BC_BLOCK_COMBINED:
6857 if (lang_free_branch(p->b.blk))
6858 SLfree((char *)p->b.blk);
6859 break;
6860
6861 case SLANG_BC_COMBINED:
6862 if (0 == (p->bc_flags & BC_LITERAL_MASK))
6863 break;
6864 /* drop */
6865 case SLANG_BC_LITERAL:
6866 case SLANG_BC_LITERAL_STR:
6867 case SLANG_BC_LITERAL_DBL:
6868 case SLANG_BC_LITERAL_COMBINED:
6869 /* No user types should be here. */
6870 GET_BUILTIN_CLASS(cl, p->bc_sub_type);
6871 (*cl->cl_byte_code_destroy) (p->bc_sub_type, (VOID_STAR) &p->b.ptr_blk);
6872 break;
6873
6874 case SLANG_BC_FIELD:
6875 case SLANG_BC_FIELD_REF:
6876 case SLANG_BC_SET_STRUCT_LVALUE:
6877 SLang_free_slstring ((char *) p->b.s_blk);
6878 break;
6879 case SLANG_BC_BOS:
6880 #if USE_BC_LINE_NUM
6881 case SLANG_BC_LINE_NUM:
6882 #endif
6883 #if SLANG_HAS_DEBUG_CODE
6884 if (p->b.line_info != NULL)
6885 {
6886 SLang_free_slstring (p->b.line_info->filename);
6887 SLfree ((char *) p->b.line_info);
6888 }
6889 #endif
6890 break;
6891 default:
6892 break;
6893
6894 case 0:
6895 return 1;
6896 }
6897 p++;
6898 }
6899 }
6900
free_local_variable_names(char ** list,unsigned int num)6901 static void free_local_variable_names (char **list, unsigned int num)
6902 {
6903 unsigned int i;
6904
6905 if (list == NULL)
6906 return;
6907
6908 for (i = 0; i < num; i++)
6909 SLang_free_slstring (list[i]);
6910
6911 SLfree ((char *) list);
6912 }
6913
free_function_header(Function_Header_Type * h)6914 static void free_function_header (Function_Header_Type *h)
6915 {
6916 if (h->num_refs > 1)
6917 {
6918 h->num_refs--;
6919 return;
6920 }
6921
6922 if (h->body != NULL)
6923 {
6924 if (lang_free_branch (h->body))
6925 SLfree ((char *) h->body);
6926 }
6927
6928 if (h->file != NULL) SLang_free_slstring ((char *) h->file);
6929
6930 if (h->local_variables != NULL)
6931 free_local_variable_names (h->local_variables, h->nlocals);
6932
6933 SLfree ((char *) h);
6934 }
6935
6936 static Function_Header_Type *
allocate_function_header(unsigned int nargs,unsigned int nlocals,SLFUTURE_CONST char * file)6937 allocate_function_header (unsigned int nargs, unsigned int nlocals, SLFUTURE_CONST char *file)
6938 {
6939 Function_Header_Type *h;
6940 char **local_variables;
6941 unsigned int i;
6942
6943 if (NULL == (h = (Function_Header_Type *)SLcalloc (sizeof (Function_Header_Type), 1)))
6944 return h;
6945
6946 h->num_refs = 1;
6947 /* h->body = NULL; */ /* body added later */
6948 h->nlocals = nlocals;
6949 h->nargs = nargs;
6950 if (NULL == (h->file = SLang_create_slstring (file)))
6951 {
6952 free_function_header (h);
6953 return NULL;
6954 }
6955
6956 #if SLANG_HAS_BOSEOS
6957 h->issue_bofeof_info = (_pSLang_Compile_BOFEOF != 0);
6958 #endif
6959
6960 if (nlocals == 0)
6961 return h;
6962
6963 if (NULL == (local_variables = (char **)SLcalloc (nlocals, sizeof (char *))))
6964 {
6965 free_function_header (h);
6966 return NULL;
6967 }
6968 h->local_variables = local_variables;
6969
6970 for (i = 0; i < nlocals; i++)
6971 {
6972 if (NULL == (local_variables[i] = SLang_create_slstring (Local_Variable_Names[i])))
6973 {
6974 free_function_header (h);
6975 return NULL;
6976 }
6977 }
6978 return h;
6979 }
6980
push_block_context(int type)6981 static int push_block_context (int type)
6982 {
6983 Block_Context_Type *c;
6984 unsigned int num;
6985 SLBlock_Type *b;
6986
6987 if (Block_Context_Stack_Len == SLANG_MAX_BLOCK_STACK_LEN)
6988 {
6989 _pSLang_verror (SL_STACK_OVERFLOW, "Block stack overflow");
6990 return -1;
6991 }
6992
6993 num = 20;
6994 if (NULL == (b = (SLBlock_Type *) _SLcalloc (num, sizeof (SLBlock_Type))))
6995 return -1;
6996 memset ((char *)b, 0, num*sizeof(SLBlock_Type)); /* not done by _SLcalloc */
6997
6998 c = Block_Context_Stack + Block_Context_Stack_Len;
6999 c->block = This_Compile_Block;
7000 c->block_ptr = Compile_ByteCode_Ptr;
7001 c->block_max = This_Compile_Block_Max;
7002 c->block_type = This_Compile_Block_Type;
7003 c->static_namespace = This_Static_NameSpace;
7004
7005 Compile_ByteCode_Ptr = This_Compile_Block = b;
7006 This_Compile_Block_Max = b + num;
7007 This_Compile_Block_Type = type;
7008
7009 Block_Context_Stack_Len += 1;
7010 return 0;
7011 }
7012
pop_block_context(void)7013 static int pop_block_context (void)
7014 {
7015 Block_Context_Type *c;
7016
7017 if (Block_Context_Stack_Len == 0)
7018 {
7019 if (_pSLang_Error == 0)
7020 SLang_verror (SL_StackUnderflow_Error, "block context stack underflow");
7021 return -1;
7022 }
7023
7024 Block_Context_Stack_Len -= 1;
7025 c = Block_Context_Stack + Block_Context_Stack_Len;
7026
7027 if (This_Compile_Block != NULL)
7028 {
7029 SLang_verror (SL_Internal_Error, "pop_block_context: block is not NULL");
7030 }
7031
7032 This_Compile_Block = c->block;
7033 This_Compile_Block_Max = c->block_max;
7034 This_Compile_Block_Type = c->block_type;
7035 Compile_ByteCode_Ptr = c->block_ptr;
7036 This_Static_NameSpace = c->static_namespace;
7037
7038 return 0;
7039 }
7040
setup_compile_namespaces(SLFUTURE_CONST char * name,SLFUTURE_CONST char * namespace_name)7041 static int setup_compile_namespaces (SLFUTURE_CONST char *name, SLFUTURE_CONST char *namespace_name)
7042 {
7043 SLang_NameSpace_Type *static_ns = NULL, *private_ns = NULL;
7044
7045 if (NULL == (private_ns = _pSLns_get_private_namespace (name, namespace_name)))
7046 return -1;
7047
7048 /* The Global namespace is special. It does not have the same semantics as
7049 * the static namespace since the Global namespace is _always_ available.
7050 */
7051 if ((namespace_name != NULL)
7052 && (*namespace_name)
7053 && (0 != strcmp (namespace_name, "Global")))
7054 {
7055 if (NULL == (static_ns = _pSLns_create_namespace2 (name, namespace_name)))
7056 return -1;
7057 }
7058 else static_ns = private_ns;
7059
7060 setup_default_compile_linkage (static_ns == private_ns);
7061
7062 This_Static_NameSpace = static_ns;
7063 This_Private_NameSpace = private_ns;
7064 return 0;
7065 }
7066
_pSLcompile_push_context(SLang_Load_Type * load_object)7067 int _pSLcompile_push_context (SLang_Load_Type *load_object)
7068 {
7069 SLFUTURE_CONST char *name = load_object->name;
7070 char *ext;
7071 int status = -1;
7072 int free_name = 0;
7073
7074 ext = SLpath_extname (name);
7075 if (((0 == strncmp (ext, ".slc", 4)) || (0 == strncmp (ext, ".SLC", 4)))
7076 && ((ext[4] == 0)
7077 #ifdef VMS
7078 || (ext[4] == ';')
7079 #endif
7080 ))
7081 {
7082 unsigned int len = (unsigned int) (ext - name) + 3;
7083
7084 if (NULL == (name = SLang_create_nslstring (name, len)))
7085 return -1;
7086 free_name = 1;
7087 }
7088
7089 if (-1 == push_compile_context (name))
7090 goto free_return;
7091
7092 if (-1 == setup_compile_namespaces (name, load_object->namespace_name))
7093 {
7094 pop_compile_context ();
7095 goto free_return;
7096 }
7097
7098 if (-1 == push_block_context (COMPILE_BLOCK_TYPE_TOP_LEVEL))
7099 {
7100 pop_compile_context ();
7101 goto free_return;
7102 }
7103
7104 (void) _pSLerr_suspend_messages ();
7105 status = 0;
7106 /* drop */
7107
7108 free_return:
7109 if (free_name)
7110 SLang_free_slstring ((char *) name);
7111
7112 return status;
7113 }
7114
7115 static void reset_compiler_state (void);
_pSLcompile_pop_context(void)7116 int _pSLcompile_pop_context (void)
7117 {
7118 (void) _pSLerr_resume_messages ();
7119
7120 if (_pSLang_Error) reset_compiler_state ();
7121
7122 if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL)
7123 {
7124 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LAST_BLOCK;
7125 if (lang_free_branch (This_Compile_Block))
7126 {
7127 SLfree ((char *) This_Compile_Block);
7128 This_Compile_Block = NULL;
7129 }
7130 }
7131
7132 (void) pop_block_context ();
7133 (void) pop_compile_context ();
7134
7135 if (This_Compile_Block == NULL)
7136 return 0;
7137
7138 #if 0
7139 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
7140 {
7141 _pSLang_verror (SL_INTERNAL_ERROR, "Not at top-level");
7142 return -1;
7143 }
7144 #endif
7145
7146 return 0;
7147 }
7148
7149 /*{{{ Hash and Name Table Functions */
7150
7151 /* Returns a pointer to the first character past "->" in name. If "->" does
7152 * not exist, then it returns a pointer to the beginning of name.
7153 */
7154 _INLINE_
parse_namespace_encoded_name(SLCONST char * name)7155 static char *parse_namespace_encoded_name (SLCONST char *name)
7156 {
7157 char *ns;
7158
7159 ns = (char *)name;
7160 name = strchr (name, '-');
7161 if ((name == NULL) || (name [1] != '>'))
7162 return ns;
7163
7164 return (char*)name + 2;
7165 }
7166
locate_namespace_encoded_name(SLCONST char * name,int err_on_bad_ns)7167 static SLang_Name_Type *locate_namespace_encoded_name (SLCONST char *name, int err_on_bad_ns)
7168 {
7169 char *ns;
7170 SLang_NameSpace_Type *table;
7171 SLang_Name_Type *nt;
7172
7173 ns = (char *) name;
7174 name = parse_namespace_encoded_name (ns);
7175
7176 if (name == ns)
7177 {
7178 /* Use Global Namespace */
7179 return _pSLns_locate_hashed_name (Global_NameSpace, name, SLcompute_string_hash (name));
7180 }
7181
7182 ns = SLang_create_nslstring (ns, (unsigned int) ((name-2) - ns));
7183 if (ns == NULL)
7184 return NULL;
7185 if (NULL == (table = _pSLns_find_namespace (ns)))
7186 {
7187 if (err_on_bad_ns)
7188 _pSLang_verror (SL_SYNTAX_ERROR, "Unable to find namespace called %s", ns);
7189 SLang_free_slstring (ns);
7190 return NULL;
7191 }
7192 SLang_free_slstring (ns);
7193
7194 nt = _pSLns_locate_hashed_name (table, name, SLcompute_string_hash (name));
7195 if (nt == NULL)
7196 return NULL;
7197
7198 switch (nt->name_type)
7199 {
7200 /* These are private and cannot be accessed through the namespace. */
7201 case SLANG_PVARIABLE:
7202 case SLANG_PFUNCTION:
7203 return NULL;
7204 }
7205 return nt;
7206 }
7207
7208 static SLang_Name_Type *
find_global_hashed_name(SLCONST char * name,unsigned long hash,SLang_NameSpace_Type * pns,SLang_NameSpace_Type * sns,SLang_NameSpace_Type * gns,int do_error)7209 find_global_hashed_name (SLCONST char *name, unsigned long hash,
7210 SLang_NameSpace_Type *pns, SLang_NameSpace_Type *sns,
7211 SLang_NameSpace_Type *gns,
7212 int do_error)
7213 {
7214 SLang_Name_Type *nt;
7215
7216 if ((pns != NULL) && (pns != sns))
7217 {
7218 if (NULL != (nt = _pSLns_locate_hashed_name (pns, name, hash)))
7219 return nt;
7220 }
7221 if ((sns != NULL) && (sns != gns))
7222 {
7223 if (NULL != (nt = _pSLns_locate_hashed_name (sns, name, hash)))
7224 return nt;
7225 }
7226
7227 if (gns != NULL)
7228 {
7229 if (NULL != (nt = _pSLns_locate_hashed_name (gns, name, hash)))
7230 return nt;
7231 }
7232
7233 if (do_error)
7234 _pSLang_verror (SL_UNDEFINED_NAME, "Unable to locate '%s'", name);
7235
7236 return NULL;
7237 }
7238
locate_hashed_name(SLCONST char * name,unsigned long hash,int err_on_bad_ns)7239 static SLang_Name_Type *locate_hashed_name (SLCONST char *name, unsigned long hash, int err_on_bad_ns)
7240 {
7241 SLang_Name_Type *t;
7242
7243 if (Locals_NameSpace != NULL)
7244 {
7245 t = _pSLns_locate_hashed_name (Locals_NameSpace, name, hash);
7246 if (t != NULL)
7247 return t;
7248 }
7249
7250 t = find_global_hashed_name (name, hash, This_Private_NameSpace, This_Static_NameSpace, Global_NameSpace, 0);
7251 if (t == NULL)
7252 t = locate_namespace_encoded_name (name, err_on_bad_ns);
7253 return t;
7254 }
7255
_pSLlocate_name(SLCONST char * name)7256 SLang_Name_Type *_pSLlocate_name (SLCONST char *name)
7257 {
7258 return locate_hashed_name (name, SLcompute_string_hash (name), 0);
7259 }
7260
_pSLlocate_global_name(SLCONST char * name)7261 SLang_Name_Type *_pSLlocate_global_name (SLCONST char *name)
7262 {
7263 return _pSLns_locate_name (Global_NameSpace, name);
7264 }
7265
7266 static SLang_Name_Type *
add_name_to_namespace(SLCONST char * name,unsigned long hash,unsigned int sizeof_obj,unsigned char name_type,SLang_NameSpace_Type * ns)7267 add_name_to_namespace (SLCONST char *name, unsigned long hash,
7268 unsigned int sizeof_obj, unsigned char name_type,
7269 SLang_NameSpace_Type *ns)
7270 {
7271 SLang_Name_Type *t;
7272
7273 if (-1 == _pSLcheck_identifier_syntax (name))
7274 return NULL;
7275
7276 t = (SLang_Name_Type *) SLcalloc (sizeof_obj, 1);
7277 if (t == NULL)
7278 return t;
7279
7280 t->name_type = name_type;
7281
7282 if ((NULL == (t->name = _pSLstring_dup_hashed_string (name, hash)))
7283 || (-1 == _pSLns_add_hashed_name (ns, t, hash)))
7284 {
7285 SLfree ((char *) t);
7286 return NULL;
7287 }
7288 return t;
7289 }
7290
7291 static SLang_Name_Type *
add_global_name(SLCONST char * name,unsigned long hash,unsigned char name_type,unsigned int sizeof_obj,SLang_NameSpace_Type * ns)7292 add_global_name (SLCONST char *name, unsigned long hash,
7293 unsigned char name_type, unsigned int sizeof_obj,
7294 SLang_NameSpace_Type *ns)
7295 {
7296 SLang_Name_Type *nt;
7297
7298 nt = _pSLns_locate_hashed_name (ns, name, hash);
7299 if (nt != NULL)
7300 {
7301 if (nt->name_type == name_type)
7302 return nt;
7303
7304 _pSLang_verror (SL_DUPLICATE_DEFINITION, "%s cannot be re-defined", name);
7305 return NULL;
7306 }
7307
7308 return add_name_to_namespace (name, hash, sizeof_obj, name_type, ns);
7309 }
7310
add_intrinsic_function(SLang_NameSpace_Type * ns,SLCONST char * name,FVOID_STAR addr,SLtype ret_type,unsigned int nargs,SLtype * arg_types)7311 static int add_intrinsic_function (SLang_NameSpace_Type *ns,
7312 SLCONST char *name, FVOID_STAR addr, SLtype ret_type,
7313 unsigned int nargs, SLtype *arg_types)
7314 {
7315 SLang_Intrin_Fun_Type *f;
7316 unsigned int i;
7317
7318 if (-1 == init_interpreter ())
7319 return -1;
7320
7321 if (ns == NULL) ns = Global_NameSpace;
7322
7323 if (ret_type == SLANG_FLOAT_TYPE)
7324 {
7325 _pSLang_verror (SL_NOT_IMPLEMENTED, "Function %s is not permitted to return float", name);
7326 return -1;
7327 }
7328
7329 f = (SLang_Intrin_Fun_Type *) add_global_name (name, SLcompute_string_hash (name),
7330 SLANG_INTRINSIC, sizeof (SLang_Intrin_Fun_Type),
7331 ns);
7332
7333 if (f == NULL)
7334 return -1;
7335
7336 f->i_fun = addr;
7337 f->num_args = nargs;
7338 f->return_type = ret_type;
7339
7340 for (i = 0; i < nargs; i++)
7341 f->arg_types [i] = arg_types[i];
7342
7343 return 0;
7344 }
7345
va_add_intrinsic_function(SLang_NameSpace_Type * ns,SLCONST char * name,FVOID_STAR addr,SLtype ret_type,unsigned int nargs,va_list ap)7346 static int va_add_intrinsic_function (SLang_NameSpace_Type *ns,
7347 SLCONST char *name, FVOID_STAR addr, SLtype ret_type,
7348 unsigned int nargs, va_list ap)
7349 {
7350 SLtype arg_types [SLANG_MAX_INTRIN_ARGS];
7351 unsigned int i;
7352
7353 if (nargs > SLANG_MAX_INTRIN_ARGS)
7354 {
7355 _pSLang_verror (SL_APPLICATION_ERROR, "Function %s requires too many arguments", name);
7356 return -1;
7357 }
7358
7359 for (i = 0; i < nargs; i++)
7360 arg_types [i] = va_arg (ap, unsigned int);
7361
7362 return add_intrinsic_function (ns, name, addr, ret_type, nargs, arg_types);
7363 }
7364
SLadd_intrinsic_function(SLFUTURE_CONST char * name,FVOID_STAR addr,SLtype ret_type,unsigned int nargs,...)7365 int SLadd_intrinsic_function (SLFUTURE_CONST char *name, FVOID_STAR addr, SLtype ret_type,
7366 unsigned int nargs, ...)
7367 {
7368 va_list ap;
7369 int status;
7370
7371 va_start (ap, nargs);
7372 status = va_add_intrinsic_function (NULL, name, addr, ret_type, nargs, ap);
7373 va_end (ap);
7374
7375 return status;
7376 }
7377
SLns_add_intrinsic_function(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,FVOID_STAR addr,SLtype ret_type,unsigned int nargs,...)7378 int SLns_add_intrinsic_function (SLang_NameSpace_Type *ns,
7379 SLFUTURE_CONST char *name, FVOID_STAR addr, SLtype ret_type,
7380 unsigned int nargs, ...)
7381 {
7382 va_list ap;
7383 int status;
7384
7385 va_start (ap, nargs);
7386 status = va_add_intrinsic_function (ns, name, addr, ret_type, nargs, ap);
7387 va_end (ap);
7388
7389 return status;
7390 }
7391
add_xxx_helper(SLang_NameSpace_Type * ns,SLCONST char * name,int what,unsigned int sizeof_what)7392 static SLang_Name_Type *add_xxx_helper (SLang_NameSpace_Type *ns, SLCONST char *name,
7393 int what, unsigned int sizeof_what)
7394 {
7395 if (-1 == init_interpreter ())
7396 return NULL;
7397
7398 if (ns == NULL) ns = Global_NameSpace;
7399
7400 return add_global_name (name,
7401 SLcompute_string_hash (name),
7402 what, sizeof_what, ns);
7403 }
7404
SLns_add_hconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,SLtype type,short value)7405 int SLns_add_hconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, SLtype type, short value)
7406 {
7407 SLang_HConstant_Type *v;
7408
7409 v = (SLang_HConstant_Type *)add_xxx_helper (ns, name, SLANG_HCONSTANT, sizeof (SLang_HConstant_Type));
7410 if (v == NULL)
7411 return -1;
7412 v->value = value;
7413 v->data_type = type;
7414 return 0;
7415 }
7416
SLns_add_iconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,SLtype type,int value)7417 int SLns_add_iconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, SLtype type, int value)
7418 {
7419 SLang_IConstant_Type *v;
7420
7421 v = (SLang_IConstant_Type *)add_xxx_helper (ns, name, SLANG_ICONSTANT, sizeof (SLang_IConstant_Type));
7422 if (v == NULL)
7423 return -1;
7424 v->value = value;
7425 v->data_type = type;
7426 return 0;
7427 }
7428
SLns_add_lconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,SLtype type,long value)7429 int SLns_add_lconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, SLtype type, long value)
7430 {
7431 SLang_LConstant_Type *v;
7432
7433 v = (SLang_LConstant_Type *)add_xxx_helper (ns, name, SLANG_LCONSTANT, sizeof (SLang_LConstant_Type));
7434 if (v == NULL)
7435 return -1;
7436 v->value = value;
7437 v->data_type = type;
7438 return 0;
7439 }
7440
7441 #ifdef HAVE_LONG_LONG
_pSLns_add_llconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,SLtype type,long long value)7442 int _pSLns_add_llconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, SLtype type, long long value)
7443 {
7444 _pSLang_LLConstant_Type *v;
7445
7446 v = (_pSLang_LLConstant_Type *)add_xxx_helper (ns, name, SLANG_LLCONSTANT, sizeof (_pSLang_LLConstant_Type));
7447 if (v == NULL)
7448 return -1;
7449 v->value = value;
7450 v->data_type = type;
7451 return 0;
7452 }
7453 #endif
7454
7455 #if SLANG_HAS_FLOAT
SLns_add_dconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,double value)7456 int SLns_add_dconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, double value)
7457 {
7458 SLang_DConstant_Type *v;
7459
7460 v = (SLang_DConstant_Type *)add_xxx_helper (ns, name, SLANG_DCONSTANT, sizeof (SLang_DConstant_Type));
7461 if (v == NULL)
7462 return -1;
7463 v->d = value;
7464 return 0;
7465 }
7466
SLns_add_fconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,float value)7467 int SLns_add_fconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, float value)
7468 {
7469 SLang_FConstant_Type *v;
7470
7471 v = (SLang_FConstant_Type *)add_xxx_helper (ns, name, SLANG_FCONSTANT, sizeof (SLang_FConstant_Type));
7472 if (v == NULL)
7473 return -1;
7474 v->f = value;
7475 return 0;
7476 }
7477 #endif
7478
7479 #ifdef HAVE_LONG_LONG
SLns_add_llconstant(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,long long value)7480 int SLns_add_llconstant (SLang_NameSpace_Type *ns, SLFUTURE_CONST char *name, long long value)
7481 {
7482 SLang_LLConstant_Type *v;
7483
7484 v = (SLang_LLConstant_Type *)add_xxx_helper (ns, name, SLANG_LLCONSTANT, sizeof (SLang_LLConstant_Type));
7485 if (v == NULL)
7486 return -1;
7487 v->ll = value;
7488 return 0;
7489 }
7490
7491 #endif
SLns_add_intrinsic_variable(SLang_NameSpace_Type * ns,SLFUTURE_CONST char * name,VOID_STAR addr,SLtype data_type,int ro)7492 int SLns_add_intrinsic_variable (SLang_NameSpace_Type *ns,
7493 SLFUTURE_CONST char *name, VOID_STAR addr, SLtype data_type, int ro)
7494 {
7495 SLang_Intrin_Var_Type *v;
7496
7497 v = (SLang_Intrin_Var_Type *)add_xxx_helper (ns, name,
7498 (ro ? SLANG_RVARIABLE : SLANG_IVARIABLE),
7499 sizeof (SLang_Intrin_Var_Type));
7500 if (v == NULL)
7501 return -1;
7502
7503 v->addr = addr;
7504 v->type = data_type;
7505 return 0;
7506 }
7507
SLadd_intrinsic_variable(SLFUTURE_CONST char * name,VOID_STAR addr,SLtype data_type,int ro)7508 int SLadd_intrinsic_variable (SLFUTURE_CONST char *name, VOID_STAR addr, SLtype data_type, int ro)
7509 {
7510 return SLns_add_intrinsic_variable (NULL, name, addr, data_type, ro);
7511 }
7512
7513 static int
add_slang_function(SLFUTURE_CONST char * name,unsigned char type,unsigned long hash,Function_Header_Type * h,SLFUTURE_CONST char * file,SLang_NameSpace_Type * ns)7514 add_slang_function (SLFUTURE_CONST char *name, unsigned char type, unsigned long hash,
7515 Function_Header_Type *h, SLFUTURE_CONST char *file,
7516 SLang_NameSpace_Type *ns)
7517 {
7518 _pSLang_Function_Type *f;
7519
7520 if (file != NULL)
7521 {
7522 if (NULL == (file = SLang_create_slstring (file)))
7523 return -1;
7524 }
7525
7526 f = (_pSLang_Function_Type *)add_global_name (name, hash,
7527 type,
7528 sizeof (_pSLang_Function_Type),
7529 ns);
7530 if (f == NULL)
7531 {
7532 SLang_free_slstring ((char *) file);
7533 return -1;
7534 }
7535
7536 if (f->header != NULL)
7537 {
7538 free_function_header (f->header);
7539 /* free_namespace (f->v.ns); */
7540 }
7541 else if (f->autoload_file != NULL)
7542 {
7543 SLang_free_slstring ((char *) f->autoload_file);
7544 f->autoload_file = NULL;
7545 }
7546
7547 f->header = h;
7548
7549 if (h != NULL)
7550 {
7551 h->private_ns = This_Private_NameSpace;
7552 h->static_ns = This_Static_NameSpace;
7553 }
7554 else
7555 {
7556 f->autoload_ns = ns;
7557 f->autoload_file = file;
7558 }
7559
7560 return 0;
7561 }
7562
SLns_autoload(SLFUTURE_CONST char * name,SLFUTURE_CONST char * file,SLFUTURE_CONST char * nsname)7563 static int SLns_autoload (SLFUTURE_CONST char *name, SLFUTURE_CONST char *file, SLFUTURE_CONST char *nsname)
7564 {
7565 unsigned long hash;
7566 SLang_NameSpace_Type *ns;
7567 SLFUTURE_CONST char *cnsname = nsname;
7568
7569 if (cnsname == NULL)
7570 cnsname = _pSLang_cur_namespace_intrinsic ();
7571
7572 if (*cnsname == 0)
7573 cnsname = "Global";
7574
7575 hash = SLcompute_string_hash (name);
7576 if (NULL != (ns = _pSLns_find_namespace (cnsname)))
7577 {
7578 _pSLang_Function_Type *f;
7579
7580 f = (_pSLang_Function_Type *)_pSLns_locate_hashed_name (ns, name, hash);
7581
7582 if ((f != NULL)
7583 && (f->name_type == SLANG_FUNCTION)
7584 && (f->header != NULL))
7585 {
7586 /* already loaded */
7587 return 0;
7588 }
7589 }
7590 else if (NULL == (ns = SLns_create_namespace (cnsname)))
7591 return -1;
7592
7593 if (-1 == add_slang_function (name, SLANG_FUNCTION, hash,
7594 NULL, file, ns))
7595 return -1;
7596
7597 return 0;
7598 }
7599
SLang_autoload(SLFUTURE_CONST char * name,SLFUTURE_CONST char * file)7600 int SLang_autoload (SLFUTURE_CONST char *name, SLFUTURE_CONST char *file)
7601 {
7602 SLFUTURE_CONST char *ns;
7603 int status;
7604
7605 ns = name;
7606 name = parse_namespace_encoded_name (ns);
7607 if (ns == name)
7608 return SLns_autoload (name, file, NULL);
7609
7610 /* At this point, name points past "->" in ns. */
7611 if (NULL == (ns = SLmake_nstring (ns, ((name-2) - ns))))
7612 return -1;
7613
7614 status = SLns_autoload (name, file, ns);
7615 SLfree ((char *) ns);
7616 return status;
7617 }
7618
7619 /*}}}*/
7620
7621 /* call inner interpreter or return for more */
lang_try_now(void)7622 static void lang_try_now(void)
7623 {
7624 /* #if SLANG_HAS_DEBUG_CODE */
7625 Compile_ByteCode_Ptr->linenum = (unsigned short) This_Compile_Linenum;
7626 /* #endif */
7627 Compile_ByteCode_Ptr++;
7628 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
7629 return;
7630
7631 /* #if SLANG_HAS_DEBUG_CODE */
7632 Compile_ByteCode_Ptr->linenum = (unsigned short) This_Compile_Linenum;
7633 /* #endif */
7634 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LAST_BLOCK;
7635
7636 /* now do it */
7637 inner_interp (This_Compile_Block);
7638 (void) lang_free_branch (This_Compile_Block);
7639 Compile_ByteCode_Ptr = This_Compile_Block;
7640 Lang_Break = Lang_Break_Condition = Lang_Return = 0;
7641 }
7642
interp_pending_blocks(void)7643 static void interp_pending_blocks (void)
7644 {
7645 if ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
7646 || (Compile_ByteCode_Ptr == This_Compile_Block))
7647 return;
7648
7649 Compile_ByteCode_Ptr->linenum = (unsigned short) This_Compile_Linenum;
7650 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LAST_BLOCK;
7651
7652 inner_interp (This_Compile_Block);
7653 (void) lang_free_branch (This_Compile_Block);
7654 Compile_ByteCode_Ptr = This_Compile_Block;
7655 Lang_Break = Lang_Break_Condition = Lang_Return = 0;
7656 }
7657
7658 /* returns positive number if name is a function or negative number if it
7659 is a variable. If it is intrinsic, it returns magnitude of 1, else 2 */
SLang_is_defined(SLFUTURE_CONST char * name)7660 int SLang_is_defined(SLFUTURE_CONST char *name)
7661 {
7662 SLang_Name_Type *t;
7663
7664 if (-1 == init_interpreter ())
7665 return -1;
7666
7667 t = locate_namespace_encoded_name (name, 0);
7668 if (t == NULL)
7669 return 0;
7670
7671 switch (t->name_type)
7672 {
7673 case SLANG_FUNCTION:
7674 /* case SLANG_PFUNCTION: */
7675 return 2;
7676 case SLANG_GVARIABLE:
7677 /* case SLANG_PVARIABLE: */
7678 return -2;
7679
7680 case SLANG_HCONSTANT:
7681 case SLANG_ICONSTANT:
7682 case SLANG_LCONSTANT:
7683 case SLANG_LLCONSTANT:
7684 case SLANG_FCONSTANT:
7685 case SLANG_DCONSTANT:
7686 case SLANG_RVARIABLE:
7687 case SLANG_IVARIABLE:
7688 return -1;
7689
7690 case SLANG_INTRINSIC:
7691 case SLANG_MATH_UNARY:
7692 case SLANG_APP_UNARY:
7693 case SLANG_ARITH_UNARY:
7694 case SLANG_ARITH_BINARY:
7695 default:
7696 return 1;
7697 }
7698 }
7699
SLang_get_fun_from_ref(SLang_Ref_Type * ref)7700 SLang_Name_Type *SLang_get_fun_from_ref (SLang_Ref_Type *ref)
7701 {
7702 if (ref->data_is_nametype)
7703 {
7704 SLang_Name_Type *nt = *(SLang_Name_Type **)ref->data;
7705
7706 if (_pSLang_ref_is_callable (ref))
7707 return nt;
7708
7709 _pSLang_verror (SL_TYPE_MISMATCH,
7710 "Reference to a function expected. Found &%s",
7711 nt->name);
7712 }
7713 else
7714 _pSLang_verror (SL_TYPE_MISMATCH,
7715 "Reference to a function expected");
7716 return NULL;
7717 }
7718
7719 /* This function shall never run if there is an error */
SLexecute_function(SLang_Name_Type * nt)7720 int SLexecute_function (SLang_Name_Type *nt)
7721 {
7722 unsigned char type;
7723 SLCONST char *name;
7724 int status = 1;
7725
7726 if (nt == NULL)
7727 return -1;
7728
7729 if (IS_SLANG_ERROR)
7730 return -1;
7731
7732 (void) _pSLerr_suspend_messages ();
7733
7734 type = nt->name_type;
7735 name = nt->name;
7736
7737 switch (type)
7738 {
7739 case SLANG_PFUNCTION:
7740 case SLANG_FUNCTION:
7741 execute_slang_fun ((_pSLang_Function_Type *) nt, This_Compile_Linenum);
7742 break;
7743
7744 case SLANG_INTRINSIC:
7745 execute_intrinsic_fun ((SLang_Intrin_Fun_Type *) nt);
7746 break;
7747
7748 case SLANG_MATH_UNARY:
7749 case SLANG_APP_UNARY:
7750 case SLANG_ARITH_UNARY:
7751 case SLANG_ARITH_BINARY:
7752 inner_interp_nametype (nt, 0);
7753 break;
7754
7755 default:
7756 _pSLang_verror (SL_TYPE_MISMATCH, "%s is not a function", name);
7757 }
7758
7759 if (IS_SLANG_ERROR)
7760 {
7761 if (SLang_Traceback & SL_TB_FULL)
7762 _pSLang_verror (0, "Error encountered while executing %s", name);
7763 status = -1;
7764 }
7765
7766 (void) _pSLerr_resume_messages ();
7767 return status;
7768 }
7769
SLang_execute_function(SLFUTURE_CONST char * name)7770 int SLang_execute_function (SLFUTURE_CONST char *name)
7771 {
7772 SLang_Name_Type *entry;
7773
7774 if (NULL == (entry = SLang_get_function (name)))
7775 return 0;
7776
7777 return SLexecute_function (entry);
7778 }
7779
7780 /* return S-Lang function or NULL */
SLang_get_function(SLFUTURE_CONST char * name)7781 SLang_Name_Type *SLang_get_function (SLFUTURE_CONST char *name)
7782 {
7783 SLang_Name_Type *entry;
7784
7785 if (NULL == (entry = locate_namespace_encoded_name (name, 0)))
7786 return NULL;
7787
7788 if (is_nametype_callable (entry))
7789 return entry;
7790
7791 return NULL;
7792 }
7793
lang_begin_function(void)7794 static void lang_begin_function (void)
7795 {
7796 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
7797 {
7798 _pSLang_verror (SL_SYNTAX_ERROR, "Function nesting is illegal");
7799 return;
7800 }
7801 Lang_Defining_Function = 1;
7802 (void) push_block_context (COMPILE_BLOCK_TYPE_FUNCTION);
7803 }
7804
7805 #if USE_COMBINED_BYTECODES
rearrange_optimized_binary(SLBlock_Type * b,_pSLang_BC_Type t1,_pSLang_BC_Type t2,_pSLang_BC_Type t3)7806 static void rearrange_optimized_binary (SLBlock_Type *b, _pSLang_BC_Type t1, _pSLang_BC_Type t2, _pSLang_BC_Type t3)
7807 {
7808 SLBlock_Type tmp;
7809
7810 b->bc_main_type = t1;
7811 (b-1)->bc_main_type = t3;
7812 (b-2)->bc_main_type = t2;
7813
7814 tmp = *b;
7815 *b = *(b-1);
7816 *(b-1) = *(b-2);
7817 *(b-2) = tmp;
7818 }
7819
rearrange_optimized_optimized(SLBlock_Type * b,_pSLang_BC_Type t1)7820 static void rearrange_optimized_optimized (SLBlock_Type *b, _pSLang_BC_Type t1)
7821 {
7822 SLBlock_Type tmp;
7823 b->bc_main_type = t1;
7824
7825 tmp = *b;
7826 *b = *(b-1);
7827 *(b-1) = *(b-2);
7828 *(b-2) = *(b-3);
7829 *(b-3) = tmp;
7830 # if 1
7831 (b)->bc_main_type = SLANG_BC_COMBINED;
7832 (b-1)->bc_main_type = SLANG_BC_COMBINED;
7833 (b-2)->bc_main_type = SLANG_BC_COMBINED;
7834 # endif
7835 }
7836
rearrange_optimized_unary(SLBlock_Type * b,_pSLang_BC_Type t1,_pSLang_BC_Type t2)7837 static void rearrange_optimized_unary (SLBlock_Type *b, _pSLang_BC_Type t1, _pSLang_BC_Type t2)
7838 {
7839 SLBlock_Type tmp;
7840
7841 b->bc_main_type = t1;
7842 (b-1)->bc_main_type = t2;
7843
7844 tmp = *b;
7845 *b = *(b-1);
7846 *(b-1) = tmp;
7847 }
7848
7849 #define COMPILE_COMBINE_STATS 0
7850 #if COMPILE_COMBINE_STATS
7851 static unsigned int Combine_Statistics [0x10000U];
write_combine_stats(void)7852 static void write_combine_stats (void)
7853 {
7854 unsigned int i;
7855 FILE *fp = fopen ("combine_stats.dat", "w");
7856 if (fp == NULL)
7857 return;
7858
7859 for (i = 0; i < 0x10000U; i++)
7860 {
7861 if (Combine_Statistics[i])
7862 fprintf (fp, "%5d\t0x%04X\n", Combine_Statistics[i], i);
7863 }
7864 (void) fclose (fp);
7865 }
7866
gather_statistics(SLBlock_Type * b)7867 static void gather_statistics (SLBlock_Type *b)
7868 {
7869 static int inited = 0;
7870 unsigned char last, next;
7871
7872 if (inited == 0)
7873 SLang_add_cleanup_function (write_combine_stats);
7874
7875 last = 0;
7876 while ((next = b->bc_main_type) != 0)
7877 {
7878 Combine_Statistics[last*256 + next] += 1;
7879 last = next;
7880 b++;
7881 }
7882 }
7883
7884 #endif
7885
optimize_block4(SLBlock_Type * b)7886 static void optimize_block4 (SLBlock_Type *b)
7887 {
7888 while (1)
7889 {
7890 switch (b->bc_main_type)
7891 {
7892 case SLANG_BC_LAST_BLOCK:
7893 return;
7894
7895 default:
7896 b++;
7897 break;
7898
7899 case SLANG_BC_LVARIABLE:
7900 b++;
7901 if (b->bc_main_type == SLANG_BC_LVARIABLE)
7902 {
7903 SLBlock_Type *b0 = b - 1;
7904 b0->bc_main_type = SLANG_BC_MANY_LVARIABLE;
7905 do
7906 {
7907 b->bc_main_type = SLANG_BC_LVARIABLE_COMBINED;
7908 b++;
7909 }
7910 while (b->bc_main_type == SLANG_BC_LVARIABLE);
7911 if (b->bc_main_type == SLANG_BC_CALL_DIRECT)
7912 {
7913 b0->bc_main_type = SLANG_BC_MANY_LVARIABLE_DIR;
7914 b->bc_main_type = SLANG_BC_CALL_DIRECT_COMB;
7915 b++;
7916 }
7917 break;
7918 }
7919 if (b->bc_main_type == SLANG_BC_LITERAL_AGET1)
7920 {
7921 (b-1)->bc_main_type = SLANG_BC_LVAR_LIT_AGET1;
7922 b->bc_main_type = SLANG_BC_COMBINED;
7923 b += 3;
7924 break;
7925 }
7926 break;
7927 }
7928 }
7929 }
7930
optimize_block3(SLBlock_Type * b)7931 static void optimize_block3 (SLBlock_Type *b)
7932 {
7933 while (1)
7934 {
7935 switch (b->bc_main_type)
7936 {
7937 case SLANG_BC_LAST_BLOCK:
7938 return;
7939
7940 default:
7941 b++;
7942 break;
7943
7944 case SLANG_BC_SET_LOCAL_LVALUE:
7945 b++;
7946 if (b->bc_main_type == SLANG_BC_LITERAL_INT)
7947 {
7948 (b-1)->bc_main_type = SLANG_BC_SET_LOCLV_LIT_INT;
7949 b->bc_main_type = SLANG_BC_LITERAL_COMBINED;
7950 b++;
7951 break;
7952 }
7953 if (b->bc_main_type == SLANG_BC_LITERAL_AGET1)
7954 {
7955 (b-1)->bc_main_type = SLANG_BC_SET_LOCLV_LIT_AGET1;
7956 b->bc_main_type = SLANG_BC_COMBINED;
7957 b++;
7958 b->bc_main_type = SLANG_BC_COMBINED;
7959 b++;
7960 b->bc_main_type = SLANG_BC_COMBINED;
7961 b++;
7962 break;
7963 }
7964 if (b->bc_main_type == SLANG_BC_LVARIABLE)
7965 {
7966 (b-1)->bc_main_type = SLANG_BC_SET_LOCLV_LVAR;
7967 b->bc_main_type = SLANG_BC_LVARIABLE_COMBINED;
7968 b++;
7969 break;
7970 }
7971 if (b->bc_main_type == SLANG_BC_LAST_BLOCK)
7972 {
7973 (b-1)->bc_main_type = SLANG_BC_SET_LOCLV_LASTBLOCK;
7974 return;
7975 }
7976 break;
7977
7978 case SLANG_BC_LVARIABLE:
7979 b++;
7980 if (b->bc_main_type == SLANG_BC_EARG_LVARIABLE)
7981 {
7982 (b-1)->bc_main_type = SLANG_BC_LVAR_EARG_LVAR;
7983 b->bc_main_type = SLANG_BC_COMBINED;
7984 b++;
7985 break;
7986 }
7987 if (b->bc_main_type == SLANG_BC_FIELD)
7988 {
7989 (b-1)->bc_main_type = SLANG_BC_LVAR_FIELD;
7990 b->bc_main_type = SLANG_BC_COMBINED;
7991 b++;
7992 break;
7993 }
7994 if (b->bc_main_type == SLANG_BC_LITERAL_INT)
7995 {
7996 (b-1)->bc_main_type = SLANG_BC_LVAR_LITERAL_INT;
7997 b->bc_main_type = SLANG_BC_LITERAL_COMBINED;
7998 b++;
7999 break;
8000 }
8001 if (b->bc_main_type == SLANG_BC_LVARIABLE_APUT1)
8002 {
8003 (b-1)->bc_main_type = SLANG_BC_LVAR_LVAR_APUT1;
8004 b->bc_main_type = SLANG_BC_COMBINED;
8005 b++;
8006 b->bc_main_type = SLANG_BC_COMBINED;
8007 b++;
8008 b->bc_main_type = SLANG_BC_COMBINED;
8009 b++;
8010 break;
8011 }
8012 if (b->bc_main_type == SLANG_BC_SET_STRUCT_LVALUE)
8013 {
8014 (b-1)->bc_main_type = SLANG_BC_LVAR_SET_FIELD;
8015 b->bc_main_type = SLANG_BC_COMBINED;
8016 b++;
8017 break;
8018 }
8019 if (b->bc_main_type == SLANG_BC_SET_GLOBAL_LVALUE)
8020 {
8021 (b-1)->bc_main_type = SLANG_BC_LVAR_SET_GLOB_LVAL;
8022 b->bc_main_type = SLANG_BC_COMBINED;
8023 b++;
8024 break;
8025 }
8026 break;
8027
8028 case SLANG_BC_PVARIABLE:
8029 b++;
8030 if (b->bc_main_type == SLANG_BC_SET_GLOBAL_LVALUE)
8031 {
8032 (b-1)->bc_main_type = SLANG_BC_PVAR_SET_GLOB_LVAL;
8033 b->bc_main_type = SLANG_BC_COMBINED;
8034 b++;
8035 break;
8036 }
8037 break;
8038
8039 case SLANG_BC_BINARY:
8040 /* Anything added here may need to be accounted for in do_compare() */
8041 b++;
8042 if (b->bc_main_type == SLANG_BC_LAST_BLOCK)
8043 {
8044 (b-1)->bc_main_type = SLANG_BC_BINARY_LASTBLOCK;
8045 return;
8046 }
8047 if (b->bc_main_type == SLANG_BC_SET_LOCAL_LVALUE)
8048 {
8049 (b-1)->bc_main_type = SLANG_BC_BINARY_SET_LOCLVAL;
8050 b->bc_main_type = SLANG_BC_COMBINED;
8051 b++;
8052 break;
8053 }
8054 if (b->bc_main_type == SLANG_BC_BINARY)
8055 {
8056 (b-1)->bc_main_type = SLANG_BC_BINARY2;
8057 b->bc_main_type = SLANG_BC_COMBINED;
8058 b++;
8059 break;
8060 }
8061 break;
8062
8063 case SLANG_BC_EARG_LVARIABLE:
8064 b++;
8065 if (b->bc_main_type == SLANG_BC_INTRINSIC)
8066 {
8067 (b-1)->bc_main_type = SLANG_BC_EARG_LVARIABLE_INTRINSIC;
8068 b->bc_main_type = SLANG_BC_COMBINED;
8069 b++;
8070 break;
8071 }
8072 break;
8073
8074 case SLANG_BC_LVARIABLE_AGET:
8075 b++;
8076 if (b->bc_main_type == SLANG_BC_SET_LOCAL_LVALUE)
8077 {
8078 (b-1)->bc_main_type = SLANG_BC_LVAR_AGET_SET_LOCLVAL;
8079 b->bc_main_type= SLANG_BC_COMBINED;
8080 b++;
8081 break;
8082 }
8083 break;
8084
8085 case SLANG_BC_LLVARIABLE_BINARY:
8086 b += 3;
8087 if (b->bc_main_type == SLANG_BC_BINARY)
8088 {
8089 (b-3)->bc_main_type = SLANG_BC_LLVARIABLE_BINARY2;
8090 b->bc_main_type = SLANG_BC_COMBINED;
8091 b++;
8092 break;
8093 }
8094 if (b->bc_main_type == SLANG_BC_IF_BLOCK)
8095 {
8096 (b-3)->bc_main_type = SLANG_BC_LLVAR_BINARY_IF;
8097 b->bc_main_type = SLANG_BC_BLOCK_COMBINED;
8098 b++;
8099 break;
8100 }
8101 break;
8102
8103 case SLANG_BC_LITERAL_AGET1:
8104 b += 3;
8105 if (b->bc_main_type == SLANG_BC_LITERAL_INT_BINARY)
8106 {
8107 (b-3)->bc_main_type = SLANG_BC_LIT_AGET1_INT_BINARY;
8108 b->bc_main_type = SLANG_BC_COMBINED;
8109 b += 2;
8110 break;
8111 }
8112 break;
8113 }
8114 }
8115 }
8116
optimize_block2(SLBlock_Type * b)8117 static void optimize_block2 (SLBlock_Type *b)
8118 {
8119 while (1)
8120 {
8121 switch (b->bc_main_type)
8122 {
8123 default:
8124 b++;
8125 break;
8126
8127 case SLANG_BC_LAST_BLOCK:
8128 return;
8129
8130 case SLANG_BC_CALL_DIRECT_LVAR:
8131 if (b->b.call_function != start_arg_list)
8132 {
8133 b += 2; /* combined code, add 2 */
8134 break;
8135 }
8136 b += 2; /* combined code */
8137 if (((b-1)->bc_main_type == SLANG_BC_LVARIABLE_COMBINED)
8138 && (b->bc_main_type == SLANG_BC_LVARIABLE_AGET))
8139 {
8140 b->bc_main_type = SLANG_BC_COMBINED;
8141 (b-2)->bc_main_type = SLANG_BC_LVARIABLE_AGET1;
8142 b++;
8143 break;
8144 }
8145 if (((b-1)->bc_main_type == SLANG_BC_LVARIABLE_COMBINED)
8146 && (b->bc_main_type == SLANG_BC_LVARIABLE_APUT))
8147 {
8148 b->bc_main_type = SLANG_BC_COMBINED;
8149 (b-2)->bc_main_type = SLANG_BC_LVARIABLE_APUT1;
8150 b++;
8151 break;
8152 }
8153 break;
8154
8155 case SLANG_BC_CALL_DIRECT_LINT:
8156 if (b->b.call_function != start_arg_list)
8157 {
8158 b += 2; /* combined code, add 2 */
8159 break;
8160 }
8161 b += 2; /* combined code */
8162 if (((b-1)->bc_main_type == SLANG_BC_LITERAL_COMBINED)
8163 && (b->bc_main_type == SLANG_BC_LVARIABLE_AGET))
8164 {
8165 b->bc_main_type = SLANG_BC_COMBINED;
8166 (b-2)->bc_main_type = SLANG_BC_LITERAL_AGET1;
8167 b++;
8168 break;
8169 }
8170 if (((b-1)->bc_main_type == SLANG_BC_LITERAL_COMBINED)
8171 && (b->bc_main_type == SLANG_BC_LVARIABLE_APUT))
8172 {
8173 b->bc_main_type = SLANG_BC_COMBINED;
8174 (b-2)->bc_main_type = SLANG_BC_LITERAL_APUT1;
8175 b++;
8176 break;
8177 }
8178 break;
8179 }
8180 }
8181 }
8182
8183 /* Note: Make sure lang_free_branch is suitably modified to account for
8184 * changes here.
8185 */
optimize_block1(SLBlock_Type * b)8186 static void optimize_block1 (SLBlock_Type *b)
8187 {
8188 SLBlock_Type *bstart, *b1, *b2;
8189 SLtype b2_main_type;
8190
8191 bstart = b;
8192
8193 while (1)
8194 {
8195 switch (b->bc_main_type)
8196 {
8197 case 0:
8198 return;
8199
8200 default:
8201 b++;
8202 break;
8203
8204 case SLANG_BC_SET_LOCAL_LVALUE:
8205 if ((b->bc_sub_type != SLANG_BCST_ASSIGN)
8206 || (bstart + 3 > b))
8207 {
8208 b++;
8209 continue;
8210 }
8211 b2 = b - 3;
8212 b2_main_type = b2->bc_main_type;
8213
8214 switch (b2_main_type)
8215 {
8216 case SLANG_BC_LLVARIABLE_BINARY:
8217 rearrange_optimized_optimized (b, SLANG_BC_LASSIGN_LLBINARY);
8218 break;
8219 case SLANG_BC_LIVARIABLE_BINARY:
8220 rearrange_optimized_optimized (b, SLANG_BC_LASSIGN_LIBINARY);
8221 break;
8222 case SLANG_BC_ILVARIABLE_BINARY:
8223 rearrange_optimized_optimized (b, SLANG_BC_LASSIGN_ILBINARY);
8224 break;
8225 case SLANG_BC_LDVARIABLE_BINARY:
8226 rearrange_optimized_optimized (b, SLANG_BC_LASSIGN_LDBINARY);
8227 break;
8228 case SLANG_BC_DLVARIABLE_BINARY:
8229 rearrange_optimized_optimized (b, SLANG_BC_LASSIGN_DLBINARY);
8230 break;
8231 }
8232 b++;
8233 break;
8234
8235 case SLANG_BC_BINARY:
8236 if (bstart + 2 > b)
8237 {
8238 b++;
8239 break;
8240 }
8241 b2 = b-1;
8242 b1 = b2-1;
8243 b2_main_type = b2->bc_main_type;
8244
8245 switch (b1->bc_main_type)
8246 {
8247 case SLANG_LVARIABLE:
8248 if (b2_main_type == SLANG_LVARIABLE)
8249 rearrange_optimized_binary (b,
8250 SLANG_BC_LLVARIABLE_BINARY,
8251 SLANG_BC_LVARIABLE_COMBINED,
8252 SLANG_BC_LVARIABLE_COMBINED);
8253 else if (b2_main_type == SLANG_GVARIABLE)
8254 rearrange_optimized_binary (b,
8255 SLANG_BC_LGVARIABLE_BINARY,
8256 SLANG_BC_LVARIABLE_COMBINED,
8257 SLANG_BC_GVARIABLE_COMBINED);
8258 else if (b2_main_type == SLANG_BC_LITERAL_INT)
8259 rearrange_optimized_binary (b,
8260 SLANG_BC_LIVARIABLE_BINARY,
8261 SLANG_BC_LVARIABLE_COMBINED,
8262 SLANG_BC_LITERAL_COMBINED);
8263 else if (b2_main_type == SLANG_BC_LITERAL_DBL)
8264 rearrange_optimized_binary (b,
8265 SLANG_BC_LDVARIABLE_BINARY,
8266 SLANG_BC_LVARIABLE_COMBINED,
8267 SLANG_BC_LITERAL_COMBINED);
8268 break;
8269
8270 case SLANG_GVARIABLE:
8271 if (b2_main_type == SLANG_LVARIABLE)
8272 rearrange_optimized_binary (b,
8273 SLANG_BC_GLVARIABLE_BINARY,
8274 SLANG_BC_GVARIABLE_COMBINED,
8275 SLANG_BC_LVARIABLE_COMBINED);
8276 else if (b2_main_type == SLANG_GVARIABLE)
8277 rearrange_optimized_binary (b,
8278 SLANG_BC_GGVARIABLE_BINARY,
8279 SLANG_BC_GVARIABLE_COMBINED,
8280 SLANG_BC_GVARIABLE_COMBINED);
8281 break;
8282
8283 case SLANG_BC_LITERAL_INT:
8284 if (b2_main_type == SLANG_LVARIABLE)
8285 rearrange_optimized_binary (b,
8286 SLANG_BC_ILVARIABLE_BINARY,
8287 SLANG_BC_LITERAL_COMBINED,
8288 SLANG_BC_LVARIABLE_COMBINED);
8289 break;
8290
8291 case SLANG_BC_LITERAL_DBL:
8292 if (b2_main_type == SLANG_LVARIABLE)
8293 rearrange_optimized_binary (b,
8294 SLANG_BC_DLVARIABLE_BINARY,
8295 SLANG_BC_LITERAL_COMBINED,
8296 SLANG_BC_LVARIABLE_COMBINED);
8297 break;
8298
8299 default:
8300 if (b2_main_type == SLANG_LVARIABLE)
8301 rearrange_optimized_unary (b,
8302 SLANG_BC_LVARIABLE_BINARY,
8303 SLANG_BC_LVARIABLE_COMBINED);
8304 else if (b2_main_type == SLANG_GVARIABLE)
8305 rearrange_optimized_unary (b,
8306 SLANG_BC_GVARIABLE_BINARY,
8307 SLANG_BC_GVARIABLE_COMBINED);
8308 else if (b2_main_type == SLANG_BC_LITERAL_INT)
8309 rearrange_optimized_unary (b,
8310 SLANG_BC_LITERAL_INT_BINARY,
8311 SLANG_BC_LITERAL_COMBINED);
8312 else if (b2_main_type == SLANG_BC_LITERAL_DBL)
8313 rearrange_optimized_unary (b,
8314 SLANG_BC_LITERAL_DBL_BINARY,
8315 SLANG_BC_LITERAL_COMBINED);
8316 }
8317 b++;
8318 break;
8319
8320 case SLANG_BC_CALL_DIRECT:
8321 b++;
8322 switch (b->bc_main_type)
8323 {
8324 default:
8325 break;
8326
8327 case 0:
8328 return;
8329
8330 case SLANG_BC_INTRINSIC:
8331 b->bc_main_type = SLANG_BC_COMBINED;
8332 if ((b+1)->bc_main_type == 0)
8333 {
8334 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_RETINTR;
8335 return;
8336 }
8337 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_INTRINSIC;
8338 b++;
8339 break;
8340 case SLANG_BC_LITERAL_STR:
8341 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_LSTR;
8342 b->bc_main_type = SLANG_BC_COMBINED;
8343 b++;
8344 break;
8345 case SLANG_BC_FUNCTION:
8346 case SLANG_BC_PFUNCTION:
8347 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_SLFUN;
8348 b->bc_main_type = SLANG_BC_COMBINED;
8349 b++;
8350 break;
8351 case SLANG_BC_EARG_LVARIABLE:
8352 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_EARG_LVAR;
8353 b->bc_main_type = SLANG_BC_COMBINED;
8354 b++;
8355 break;
8356 case SLANG_BC_LITERAL_INT:
8357 b->bc_main_type = SLANG_BC_LITERAL_COMBINED;
8358 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_LINT;
8359 b++;
8360 break;
8361 case SLANG_BC_LVARIABLE:
8362 b->bc_main_type = SLANG_BC_LVARIABLE_COMBINED;
8363 (b-1)->bc_main_type = SLANG_BC_CALL_DIRECT_LVAR;
8364 b++;
8365 break;
8366 }
8367 break;
8368
8369 case SLANG_BC_INTRINSIC:
8370 b++;
8371 switch (b->bc_main_type)
8372 {
8373 case SLANG_BC_CALL_DIRECT:
8374 (b-1)->bc_main_type = SLANG_BC_INTRINSIC_CALL_DIRECT;
8375 b->bc_main_type = SLANG_BC_COMBINED;
8376 b++;
8377 break;
8378 #if 0
8379 case SLANG_BC_BLOCK:
8380 (b-1)->bc_main_type = SLANG_BC_INTRINSIC_BLOCK;
8381 b->bc_main_type = SLANG_BC_COMBINED;
8382 b++;
8383 break;
8384 #endif
8385
8386 case 0:
8387 (b-1)->bc_main_type = SLANG_BC_RET_INTRINSIC;
8388 return;
8389
8390 default:
8391 break;
8392 }
8393 break;
8394
8395 case SLANG_BC_BLOCK:
8396 if (b->bc_sub_type == SLANG_BCST_IF)
8397 {
8398 b->bc_main_type = SLANG_BC_IF_BLOCK;
8399 b++;
8400 break;
8401 }
8402 b++;
8403 break;
8404 case SLANG_BC_LITERAL_INT:
8405 b++;
8406 if (b->bc_main_type == SLANG_BC_RETURN)
8407 {
8408 (b-1)->bc_main_type = SLANG_BC_RET_LITERAL_INT;
8409 b->bc_main_type = SLANG_BC_COMBINED;
8410 b++;
8411 }
8412 break;
8413
8414 case SLANG_BC_LVARIABLE:
8415 b++;
8416 if (b->bc_main_type == SLANG_BC_RETURN)
8417 {
8418 (b-1)->bc_main_type = SLANG_BC_RET_LVARIABLE;
8419 b->bc_main_type = SLANG_BC_COMBINED;
8420 b++;
8421 }
8422 break;
8423 }
8424 }
8425 }
8426
optimize_block(SLBlock_Type * b)8427 static void optimize_block (SLBlock_Type *b)
8428 {
8429 optimize_block1 (b);
8430 optimize_block2 (b);
8431 optimize_block3 (b);
8432 optimize_block4 (b);
8433 }
8434
8435 #endif
8436
end_define_function(void)8437 static void end_define_function (void)
8438 {
8439 /* free_local_variable_table (); */
8440 _pSLns_deallocate_namespace (Locals_NameSpace);
8441 Locals_NameSpace = NULL;
8442 Local_Variable_Number = 0;
8443 Function_Args_Number = 0;
8444 Lang_Defining_Function = 0;
8445 }
8446
8447 /* name will be NULL if the object is to simply terminate the function
8448 * definition. See SLang_restart.
8449 */
lang_define_function(SLFUTURE_CONST char * name,unsigned char type,unsigned long hash,SLang_NameSpace_Type * ns)8450 static int lang_define_function (SLFUTURE_CONST char *name, unsigned char type, unsigned long hash,
8451 SLang_NameSpace_Type *ns)
8452 {
8453 Function_Header_Type *h;
8454
8455 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_FUNCTION)
8456 {
8457 _pSLang_verror (SL_SYNTAX_ERROR, "Premature end of function");
8458 return -1;
8459 }
8460
8461 /* terminate function */
8462 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LAST_BLOCK;
8463 if (name == NULL)
8464 {
8465 end_define_function ();
8466 return -1;
8467 }
8468
8469 h = allocate_function_header (Function_Args_Number,
8470 Local_Variable_Number,
8471 This_Compile_Filename);
8472 if (h == NULL)
8473 {
8474 end_define_function ();
8475 return -1;
8476 }
8477
8478 if (-1 == add_slang_function (name, type, hash, h, NULL, ns))
8479 {
8480 free_function_header (h);
8481 end_define_function ();
8482 return -1;
8483 }
8484
8485 h->body = This_Compile_Block;
8486 This_Compile_Block = NULL;
8487 #if USE_COMBINED_BYTECODES
8488 optimize_block (h->body);
8489 #endif
8490 end_define_function ();
8491 pop_block_context ();
8492
8493 /* A function is only defined at top-level */
8494 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
8495 {
8496 _pSLang_verror (SL_INTERNAL_ERROR, "Not at top-level");
8497 return -1;
8498 }
8499 Compile_ByteCode_Ptr = This_Compile_Block;
8500 return 0;
8501 }
8502
check_linkage(SLCONST char * name,unsigned long hash,int check_static)8503 static int check_linkage (SLCONST char *name, unsigned long hash, int check_static)
8504 {
8505 SLang_NameSpace_Type *ns;
8506 int found = 0;
8507
8508 /* If the variable is already defined in the static hash table,
8509 * generate an error.
8510 */
8511 ns = This_Private_NameSpace;
8512 if ((ns != NULL) && (This_Static_NameSpace != ns))
8513 found = (NULL != _pSLns_locate_hashed_name (ns, name, hash));
8514
8515 if ((found == 0) && (check_static))
8516 {
8517 ns = This_Static_NameSpace;
8518 if ((ns != NULL) && (Global_NameSpace != ns))
8519 found = (NULL != _pSLns_locate_hashed_name (ns, name, hash));
8520 }
8521
8522 if (found == 0)
8523 return 0;
8524
8525 _pSLang_verror (SL_DUPLICATE_DEFINITION,
8526 "%s already has static or private linkage in this unit",
8527 name);
8528 return -1;
8529 }
8530
define_private_function(SLFUTURE_CONST char * name,unsigned long hash)8531 static void define_private_function (SLFUTURE_CONST char *name, unsigned long hash)
8532 {
8533 (void) lang_define_function (name, SLANG_PFUNCTION, hash, This_Private_NameSpace);
8534 }
8535
define_static_function(SLFUTURE_CONST char * name,unsigned long hash)8536 static void define_static_function (SLFUTURE_CONST char *name, unsigned long hash)
8537 {
8538 if (0 == check_linkage (name, hash, 0))
8539 (void) lang_define_function (name, SLANG_FUNCTION, hash, This_Static_NameSpace);
8540 }
8541
define_public_function(SLFUTURE_CONST char * name,unsigned long hash)8542 static void define_public_function (SLFUTURE_CONST char *name, unsigned long hash)
8543 {
8544 if (0 == check_linkage (name, hash, 1))
8545 (void) lang_define_function (name, SLANG_FUNCTION, hash, Global_NameSpace);
8546 }
8547
lang_end_block(void)8548 static void lang_end_block (void)
8549 {
8550 SLBlock_Type *node, *branch;
8551
8552 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK)
8553 {
8554 _pSLang_verror (SL_SYNTAX_ERROR, "Not defining a block");
8555 return;
8556 }
8557
8558 /* terminate the block */
8559 /* #if SLANG_HAS_DEBUG_CODE */
8560 Compile_ByteCode_Ptr->linenum = (unsigned short) This_Compile_Linenum;
8561 /* #endif */
8562 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LAST_BLOCK;
8563 branch = This_Compile_Block; This_Compile_Block = NULL;
8564
8565 #if USE_COMBINED_BYTECODES
8566 optimize_block (branch);
8567 #endif
8568
8569 pop_block_context ();
8570 node = Compile_ByteCode_Ptr++;
8571
8572 node->bc_main_type = SLANG_BC_BLOCK;
8573 node->bc_sub_type = 0;
8574 node->b.blk = branch;
8575 }
8576
lang_begin_block(void)8577 static int lang_begin_block (void)
8578 {
8579 return push_block_context (COMPILE_BLOCK_TYPE_BLOCK);
8580 }
8581
lang_check_space(void)8582 static int lang_check_space (void)
8583 {
8584 size_t dn, n;
8585 SLBlock_Type *p;
8586
8587 if (NULL == (p = This_Compile_Block))
8588 {
8589 _pSLang_verror (SL_INTERNAL_ERROR, "Top-level block not present");
8590 return -1;
8591 }
8592
8593 /* Allow 1 extra for terminator */
8594 if (Compile_ByteCode_Ptr + 1 < This_Compile_Block_Max)
8595 return 0;
8596
8597 n = (This_Compile_Block_Max - p);
8598
8599 /* enlarge the space by 20 objects */
8600 dn = 20;
8601
8602 if (NULL == (p = (SLBlock_Type *) _SLrecalloc((char *)p, n+dn, sizeof(SLBlock_Type))))
8603 return -1;
8604 memset ((char *)(p+n), 0, dn*sizeof(SLBlock_Type));
8605
8606 n = Compile_ByteCode_Ptr - This_Compile_Block;
8607 This_Compile_Block = p;
8608 Compile_ByteCode_Ptr = p + n;
8609 This_Compile_Block_Max = Compile_ByteCode_Ptr + dn;
8610
8611 return 0;
8612 }
8613
add_global_variable(SLCONST char * name,char name_type,unsigned long hash,SLang_NameSpace_Type * ns)8614 static int add_global_variable (SLCONST char *name, char name_type, unsigned long hash,
8615 SLang_NameSpace_Type *ns)
8616 {
8617 SLang_Name_Type *g;
8618
8619 /* Note the importance of checking if it is already defined or not. For example,
8620 * suppose X is defined as an intrinsic variable. Then S-Lang code like:
8621 * !if (is_defined("X")) { variable X; }
8622 * will not result in a global variable X. On the other hand, this would
8623 * not be an issue if 'variable' statements always were not processed
8624 * immediately. That is, as it is now, 'if (0) {variable ZZZZ;}' will result
8625 * in the variable ZZZZ being defined because of the immediate processing.
8626 * The current solution is to do: if (0) { eval("variable ZZZZ;"); }
8627 */
8628 /* hash = SLcompute_string_hash (name); */
8629 g = _pSLns_locate_hashed_name (ns, name, hash);
8630
8631 if (g != NULL)
8632 {
8633 if (g->name_type == name_type)
8634 return 0;
8635 }
8636
8637 if (NULL == add_global_name (name, hash, name_type,
8638 sizeof (SLang_Global_Var_Type), ns))
8639 return -1;
8640
8641 return 0;
8642 }
8643
SLadd_global_variable(SLCONST char * name)8644 int SLadd_global_variable (SLCONST char *name)
8645 {
8646 if (-1 == init_interpreter ())
8647 return -1;
8648
8649 return add_global_variable (name, SLANG_GVARIABLE,
8650 SLcompute_string_hash (name),
8651 Global_NameSpace);
8652 }
8653
add_local_variable(SLCONST char * name,unsigned long hash)8654 static int add_local_variable (SLCONST char *name, unsigned long hash)
8655 {
8656 SLang_Local_Var_Type *t;
8657
8658 /* local variable */
8659 if (Local_Variable_Number >= SLANG_MAX_LOCAL_VARIABLES)
8660 {
8661 _pSLang_verror (SL_SYNTAX_ERROR, "Too many local variables");
8662 return -1;
8663 }
8664
8665 if (NULL != _pSLns_locate_hashed_name (Locals_NameSpace, name, hash))
8666 {
8667 _pSLang_verror (SL_SYNTAX_ERROR, "Local variable %s has already been defined", name);
8668 return -1;
8669 }
8670
8671 t = (SLang_Local_Var_Type *)
8672 add_name_to_namespace (name, hash,
8673 sizeof (SLang_Local_Var_Type), SLANG_LVARIABLE,
8674 Locals_NameSpace);
8675 if (t == NULL)
8676 return -1;
8677
8678 t->local_var_number = Local_Variable_Number;
8679 Local_Variable_Names[Local_Variable_Number] = t->name;
8680 /* we will copy this later -- it is an slstring and will persist as long
8681 * as the Locals_NameSpace persists
8682 */
8683
8684 Local_Variable_Number++;
8685 return 0;
8686 }
8687
8688 static void (*Compile_Mode_Function) (_pSLang_Token_Type *);
8689 static void compile_basic_token_mode (_pSLang_Token_Type *);
8690
8691 /* This function could be called when an error has occured during parsing.
8692 * Its purpose is to "close" any currently opened blocks and functions.
8693 */
reset_compiler_state(void)8694 void reset_compiler_state (void)
8695 {
8696 _pSLcompile_ptr = _pSLcompile;
8697 Compile_Mode_Function = compile_basic_token_mode;
8698
8699 while (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK)
8700 lang_end_block();
8701
8702 if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_FUNCTION)
8703 {
8704 /* Terminate function definition and free variables */
8705 lang_define_function (NULL, SLANG_FUNCTION, 0, Global_NameSpace);
8706 if (lang_free_branch (This_Compile_Block))
8707 {
8708 SLfree((char *)This_Compile_Block);
8709 This_Compile_Block = NULL;
8710 }
8711 }
8712 Lang_Defining_Function = 0;
8713
8714 while ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_TOP_LEVEL)
8715 && (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_NONE)
8716 && (0 == pop_block_context ()))
8717 ;
8718 }
8719
8720 /* The active interpreter is the one that is currently executing. We may
8721 * have a situation where: slang -> C -> slang
8722 * Each "slang" is an interpreter and only one is active.
8723 */
reset_active_interpreter(void)8724 static void reset_active_interpreter (void)
8725 {
8726 reset_compiler_state ();
8727
8728 Trace_Mode = 0;
8729 Lang_Break = Lang_Return = 0;
8730 }
8731
free_local_variables(void)8732 static void free_local_variables (void)
8733 {
8734 while (Local_Variable_Frame > Local_Variable_Stack)
8735 {
8736 SLang_free_object (Local_Variable_Frame);
8737 Local_Variable_Frame--;
8738 }
8739 }
8740
clear_switch_objects(void)8741 static void clear_switch_objects (void)
8742 {
8743 SLang_Object_Type *p;
8744
8745 p = Switch_Objects;
8746 while (p < Switch_Obj_Max)
8747 {
8748 if (p->o_data_type != 0)
8749 {
8750 SLang_free_object (p);
8751 p->o_data_type = 0;
8752 }
8753 p++;
8754 }
8755 Switch_Obj_Ptr = Switch_Objects;
8756 }
8757
SLang_restart(int localv)8758 void SLang_restart (int localv)
8759 {
8760 reset_active_interpreter ();
8761
8762 if (SLang_get_error () == SL_STACK_OVERFLOW)
8763 {
8764 /* This loop guarantees that the stack is properly cleaned. */
8765 /* The validity of this step needs to be reexamined in the context
8766 * of the new exception handling for slang 2
8767 */
8768 while (Stack_Pointer != Run_Stack)
8769 {
8770 SLdo_pop ();
8771 }
8772 }
8773
8774 if (localv)
8775 {
8776 free_local_variables ();
8777 clear_switch_objects ();
8778 while (0 == pop_compile_context ())
8779 ;
8780 }
8781 _pSLerr_print_message_queue ();
8782 _pSLerr_clear_error (0);
8783 }
8784
8785 #if SLANG_HAS_DEBUG_CODE
compile_line_info(_pSLang_BC_Type bc_main_type,SLFUTURE_CONST char * file,long linenum)8786 static void compile_line_info (_pSLang_BC_Type bc_main_type, SLFUTURE_CONST char *file, long linenum)
8787 {
8788 Linenum_Info_Type *info;
8789
8790 if (NULL == (info = (Linenum_Info_Type *) SLmalloc (sizeof (Linenum_Info_Type))))
8791 return;
8792
8793 info->linenum = (int) linenum;
8794 if (file == NULL)
8795 file = "";
8796
8797 if (NULL == (info->filename = SLang_create_slstring (file)))
8798 {
8799 SLfree ((char *) info);
8800 return;
8801 }
8802 Compile_ByteCode_Ptr->bc_main_type = bc_main_type;
8803 Compile_ByteCode_Ptr->b.line_info = info;
8804 lang_try_now ();
8805 }
8806
set_line_number_info(long val)8807 static void set_line_number_info (long val)
8808 {
8809 This_Compile_Linenum = (unsigned int) val;
8810 }
8811 #endif
8812
compile_directive(unsigned char sub_type,int delay_inner_interp)8813 static void compile_directive (unsigned char sub_type, int delay_inner_interp)
8814 {
8815 /* This function is called only from compile_directive_mode which is
8816 * only possible when a block is available.
8817 */
8818
8819 /* use BLOCK */
8820 Compile_ByteCode_Ptr--;
8821 Compile_ByteCode_Ptr->bc_sub_type = sub_type;
8822
8823 if (delay_inner_interp)
8824 {
8825 Compile_ByteCode_Ptr->linenum = (unsigned short) This_Compile_Linenum;
8826 Compile_ByteCode_Ptr++;
8827 return;
8828 }
8829 lang_try_now ();
8830 }
8831
compile_unary(int op,_pSLang_BC_Type mt)8832 static void compile_unary (int op, _pSLang_BC_Type mt)
8833 {
8834 Compile_ByteCode_Ptr->bc_main_type = mt;
8835 Compile_ByteCode_Ptr->b.i_blk = op;
8836 Compile_ByteCode_Ptr->bc_sub_type = 0;
8837
8838 lang_try_now ();
8839 }
8840
compile_binary(int op)8841 static void compile_binary (int op)
8842 {
8843 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_BINARY;
8844 Compile_ByteCode_Ptr->b.i_blk = op;
8845 Compile_ByteCode_Ptr->bc_sub_type = 0;
8846
8847 lang_try_now ();
8848 }
8849
8850 #if SLANG_OPTIMIZE_FOR_SPEED
try_compressed_bytecode(_pSLang_BC_Type last_bc,_pSLang_BC_Type bc)8851 static int try_compressed_bytecode (_pSLang_BC_Type last_bc, _pSLang_BC_Type bc)
8852 {
8853 if (Compile_ByteCode_Ptr != This_Compile_Block)
8854 {
8855 SLBlock_Type *b;
8856 b = Compile_ByteCode_Ptr - 1;
8857 if (b->bc_main_type == last_bc)
8858 {
8859 Compile_ByteCode_Ptr = b;
8860 b->bc_main_type = bc;
8861 lang_try_now ();
8862 return 0;
8863 }
8864 }
8865 return -1;
8866 }
8867 #endif
8868
8869 /* This is a hack */
8870 typedef struct _Special_NameTable_Type
8871 {
8872 SLCONST char *name;
8873 int (*fun) (struct _Special_NameTable_Type *, _pSLang_Token_Type *);
8874 VOID_STAR blk_data;
8875 _pSLang_BC_Type main_type;
8876 }
8877 Special_NameTable_Type;
8878
handle_special(Special_NameTable_Type * nt,_pSLang_Token_Type * tok)8879 static int handle_special (Special_NameTable_Type *nt, _pSLang_Token_Type *tok)
8880 {
8881 (void) tok;
8882 Compile_ByteCode_Ptr->bc_main_type = nt->main_type;
8883 Compile_ByteCode_Ptr->b.ptr_blk = nt->blk_data;
8884 return 0;
8885 }
8886
handle_special_file(Special_NameTable_Type * nt,_pSLang_Token_Type * tok)8887 static int handle_special_file (Special_NameTable_Type *nt, _pSLang_Token_Type *tok)
8888 {
8889 SLFUTURE_CONST char *name;
8890
8891 (void) nt; (void) tok;
8892
8893 if (This_Private_NameSpace == NULL) name = "***Unknown***";
8894 else
8895 name = This_Private_NameSpace->name;
8896
8897 name = SLang_create_slstring (name);
8898 if (name == NULL)
8899 return -1;
8900
8901 Compile_ByteCode_Ptr->b.s_blk = name;
8902 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LITERAL_STR;
8903 Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE;
8904 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
8905 return 0;
8906 }
8907
handle_special_line(Special_NameTable_Type * nt,_pSLang_Token_Type * tok)8908 static int handle_special_line (Special_NameTable_Type *nt, _pSLang_Token_Type *tok)
8909 {
8910 (void) nt;
8911 #if SLANG_HAS_DEBUG_CODE
8912 if ((Compile_ByteCode_Ptr->b.l_blk = (long) tok->line_number) <= 0)
8913 Compile_ByteCode_Ptr->b.l_blk = This_Compile_Linenum;
8914 #else
8915 (void) tok;
8916 #endif
8917 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LITERAL;
8918 Compile_ByteCode_Ptr->bc_sub_type = SLANG_UINT_TYPE;
8919 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
8920
8921 return 0;
8922 }
8923
8924 static Special_NameTable_Type Special_Name_Table [] =
8925 {
8926 {"EXECUTE_ERROR_BLOCK", handle_special, NULL, SLANG_BC_X_ERROR},
8927 {"X_USER_BLOCK0", handle_special, NULL, SLANG_BC_X_USER0},
8928 {"X_USER_BLOCK1", handle_special, NULL, SLANG_BC_X_USER1},
8929 {"X_USER_BLOCK2", handle_special, NULL, SLANG_BC_X_USER2},
8930 {"X_USER_BLOCK3", handle_special, NULL, SLANG_BC_X_USER3},
8931 {"X_USER_BLOCK4", handle_special, NULL, SLANG_BC_X_USER4},
8932 {"__FILE__", handle_special_file, NULL, SLANG_BC_LAST_BLOCK},
8933 {"__LINE__", handle_special_line, NULL, SLANG_BC_LAST_BLOCK},
8934 #if 0
8935 {"__NAMESPACE__", handle_special_namespace, NULL, SLANG_BC_LAST_BLOCK},
8936 #endif
8937 {NULL, NULL, NULL, SLANG_BC_LAST_BLOCK}
8938 };
8939
compile_hashed_identifier(SLCONST char * name,unsigned long hash,_pSLang_Token_Type * tok)8940 static void compile_hashed_identifier (SLCONST char *name, unsigned long hash, _pSLang_Token_Type *tok)
8941 {
8942 SLang_Name_Type *entry;
8943 _pSLang_BC_Type name_type;
8944
8945 entry = locate_hashed_name (name, hash, 1);
8946
8947 if (entry == NULL)
8948 {
8949 Special_NameTable_Type *nt = Special_Name_Table;
8950
8951 while (nt->name != NULL)
8952 {
8953 if (strcmp (name, nt->name))
8954 {
8955 nt++;
8956 continue;
8957 }
8958
8959 if (0 == (*nt->fun)(nt, tok))
8960 lang_try_now ();
8961 return;
8962 }
8963
8964 _pSLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
8965 return;
8966 }
8967
8968 name_type = (_pSLang_BC_Type)entry->name_type;
8969 Compile_ByteCode_Ptr->bc_main_type = name_type;
8970
8971 if (name_type == SLANG_LVARIABLE) /* == SLANG_BC_LVARIABLE */
8972 Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number;
8973 else
8974 Compile_ByteCode_Ptr->b.nt_blk = entry;
8975
8976 lang_try_now ();
8977 }
8978
compile_tmp_variable(SLCONST char * name,unsigned long hash)8979 static void compile_tmp_variable (SLCONST char *name, unsigned long hash)
8980 {
8981 SLang_Name_Type *entry;
8982 unsigned char name_type;
8983
8984 if (NULL == (entry = locate_hashed_name (name, hash, 1)))
8985 {
8986 _pSLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
8987 return;
8988 }
8989
8990 name_type = entry->name_type;
8991 switch (name_type)
8992 {
8993 case SLANG_LVARIABLE:
8994 Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) entry)->local_var_number;
8995 break;
8996
8997 case SLANG_GVARIABLE:
8998 case SLANG_PVARIABLE:
8999 Compile_ByteCode_Ptr->b.nt_blk = entry;
9000 break;
9001
9002 default:
9003 _pSLang_verror (SL_SYNTAX_ERROR, "__tmp(%s) does not specifiy a variable", name);
9004 return;
9005 }
9006
9007 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_TMP;
9008 Compile_ByteCode_Ptr->bc_sub_type = name_type;
9009
9010 lang_try_now ();
9011 }
9012
compile_simple(_pSLang_BC_Type main_type)9013 static void compile_simple (_pSLang_BC_Type main_type)
9014 {
9015 Compile_ByteCode_Ptr->bc_main_type = main_type;
9016 Compile_ByteCode_Ptr->bc_sub_type = 0;
9017 Compile_ByteCode_Ptr->b.blk = NULL;
9018 lang_try_now ();
9019 }
9020
compile_identifier(SLCONST char * name,_pSLang_Token_Type * tok)9021 static void compile_identifier (SLCONST char *name, _pSLang_Token_Type *tok)
9022 {
9023 compile_hashed_identifier (name, SLcompute_string_hash (name), tok);
9024 }
9025
compile_call_direct(int (* f)(void),_pSLang_BC_Type byte_code)9026 static void compile_call_direct (int (*f) (void), _pSLang_BC_Type byte_code)
9027 {
9028 Compile_ByteCode_Ptr->b.call_function = f;
9029 Compile_ByteCode_Ptr->bc_main_type = byte_code;
9030 Compile_ByteCode_Ptr->bc_sub_type = 0;
9031 lang_try_now ();
9032 }
9033
compile_lvar_call_direct(int (* f)(void),_pSLang_BC_Type bc,_pSLang_BC_Type frame_op)9034 static void compile_lvar_call_direct (int (*f)(void), _pSLang_BC_Type bc,
9035 _pSLang_BC_Type frame_op)
9036 {
9037 #if 1 && SLANG_OPTIMIZE_FOR_SPEED
9038 if (0 == try_compressed_bytecode (SLANG_BC_LVARIABLE, bc))
9039 return;
9040 #else
9041 (void) bc;
9042 #endif
9043
9044 compile_call_direct (f, frame_op);
9045 }
9046
compile_integer(long i,_pSLang_BC_Type bc_main_type,SLtype bc_sub_type)9047 static void compile_integer (long i, _pSLang_BC_Type bc_main_type, SLtype bc_sub_type)
9048 {
9049 Compile_ByteCode_Ptr->b.l_blk = i;
9050 Compile_ByteCode_Ptr->bc_main_type = bc_main_type;
9051 Compile_ByteCode_Ptr->bc_sub_type = bc_sub_type;
9052 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9053
9054 lang_try_now ();
9055 }
9056
9057 #ifdef HAVE_LONG_LONG
compile_llong(long long i,_pSLang_BC_Type bc_main_type,SLtype bc_sub_type)9058 static void compile_llong (long long i, _pSLang_BC_Type bc_main_type, SLtype bc_sub_type)
9059 {
9060 # if LLONG_IS_NOT_LONG
9061 long long *ptr;
9062
9063 if (NULL == (ptr = (long long *) SLmalloc (sizeof(long long))))
9064 return;
9065 *ptr = i;
9066
9067 Compile_ByteCode_Ptr->b.llong_blk = ptr;
9068 # else
9069 Compile_ByteCode_Ptr->b.l_blk = i;
9070 # endif
9071 Compile_ByteCode_Ptr->bc_main_type = bc_main_type;
9072 Compile_ByteCode_Ptr->bc_sub_type = bc_sub_type;
9073 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9074
9075 lang_try_now ();
9076 }
9077 #endif
9078
9079 #if SLANG_HAS_FLOAT
compile_double(_pSLang_Token_Type * t,_pSLang_BC_Type main_type,SLtype type)9080 static void compile_double (_pSLang_Token_Type *t, _pSLang_BC_Type main_type, SLtype type)
9081 {
9082 unsigned int factor = 1;
9083 double *ptr;
9084 double d;
9085
9086 d = _pSLang_atof (t->v.s_val);
9087
9088 #if SLANG_HAS_COMPLEX
9089 if (type == SLANG_COMPLEX_TYPE) factor = 2;
9090 #endif
9091 if (NULL == (ptr = (double *) SLmalloc(factor * sizeof(double))))
9092 return;
9093
9094 Compile_ByteCode_Ptr->b.double_blk = ptr;
9095 #if SLANG_HAS_COMPLEX
9096 if (type == SLANG_COMPLEX_TYPE)
9097 *ptr++ = 0;
9098 #endif
9099 *ptr = d;
9100
9101 Compile_ByteCode_Ptr->bc_main_type = main_type;
9102 Compile_ByteCode_Ptr->bc_sub_type = type;
9103 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9104 lang_try_now ();
9105 }
9106
compile_float(_pSLang_Token_Type * t)9107 static void compile_float (_pSLang_Token_Type *t)
9108 {
9109 float f = (float) _pSLang_atof (t->v.s_val);
9110
9111 Compile_ByteCode_Ptr->b.float_blk = f;
9112 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LITERAL;
9113 Compile_ByteCode_Ptr->bc_sub_type = SLANG_FLOAT_TYPE;
9114 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9115 lang_try_now ();
9116 }
9117
9118 #endif
9119
compile_string(SLCONST char * s,unsigned long hash)9120 static void compile_string (SLCONST char *s, unsigned long hash)
9121 {
9122 if (NULL == (Compile_ByteCode_Ptr->b.s_blk = _pSLstring_dup_hashed_string (s, hash)))
9123 return;
9124
9125 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LITERAL_STR;
9126 Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE;
9127 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9128
9129 lang_try_now ();
9130 }
9131
compile_string_dollar(SLCONST char * s,unsigned long hash)9132 static void compile_string_dollar (SLCONST char *s, unsigned long hash)
9133 {
9134 if (NULL == (Compile_ByteCode_Ptr->b.s_blk = _pSLstring_dup_hashed_string (s, hash)))
9135 return;
9136
9137 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_DOLLAR_STR;
9138 Compile_ByteCode_Ptr->bc_sub_type = SLANG_STRING_TYPE;
9139 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9140
9141 lang_try_now ();
9142 }
9143
compile_bstring(SLang_BString_Type * s)9144 static void compile_bstring (SLang_BString_Type *s)
9145 {
9146 if (NULL == (Compile_ByteCode_Ptr->b.bs_blk = SLbstring_dup (s)))
9147 return;
9148
9149 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_LITERAL;
9150 Compile_ByteCode_Ptr->bc_sub_type = SLANG_BSTRING_TYPE;
9151 Compile_ByteCode_Ptr->bc_flags |= BC_LITERAL_MASK;
9152
9153 lang_try_now ();
9154 }
9155
locate_hashed_name_autodeclare(SLFUTURE_CONST char * name,unsigned long hash,unsigned char assign_type)9156 static SLang_Name_Type *locate_hashed_name_autodeclare (SLFUTURE_CONST char *name, unsigned long hash,
9157 unsigned char assign_type)
9158 {
9159 SLang_Name_Type *v;
9160
9161 v = locate_hashed_name (name, hash, 1);
9162
9163 if (v != NULL)
9164 return v;
9165
9166 if ((_pSLang_Auto_Declare_Globals == 0)
9167 || Lang_Defining_Function
9168 || (NULL != strchr (name, '-')) /* namespace->name form */
9169 || (assign_type != SLANG_BCST_ASSIGN)
9170 || (This_Static_NameSpace == NULL))
9171 {
9172 _pSLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
9173 return NULL;
9174 }
9175 /* Note that function local variables are not at top level */
9176
9177 /* Variables that are automatically declared are given static
9178 * scope.
9179 */
9180 if ((NULL != SLang_Auto_Declare_Var_Hook)
9181 && (-1 == (*SLang_Auto_Declare_Var_Hook) (name)))
9182 return NULL;
9183
9184 if ((-1 == add_global_variable (name, SLANG_GVARIABLE, hash, This_Static_NameSpace))
9185 || (NULL == (v = locate_hashed_name (name, hash, 1))))
9186 return NULL;
9187
9188 return v;
9189 }
9190
9191 /* assign_type is one of SLANG_BCST_ASSIGN, ... values */
compile_assign(unsigned char assign_type,SLFUTURE_CONST char * name,unsigned long hash)9192 static void compile_assign (unsigned char assign_type,
9193 SLFUTURE_CONST char *name, unsigned long hash)
9194 {
9195 SLang_Name_Type *v;
9196 _pSLang_BC_Type main_type;
9197 SLang_Class_Type *cl;
9198
9199 if (NULL == (v = locate_hashed_name_autodeclare (name, hash, assign_type)))
9200 return;
9201
9202 switch (v->name_type)
9203 {
9204 case SLANG_LVARIABLE:
9205 main_type = SLANG_BC_SET_LOCAL_LVALUE;
9206 Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number;
9207 break;
9208
9209 case SLANG_GVARIABLE:
9210 case SLANG_PVARIABLE:
9211 main_type = SLANG_BC_SET_GLOBAL_LVALUE;
9212 Compile_ByteCode_Ptr->b.nt_blk = v;
9213 break;
9214
9215 case SLANG_IVARIABLE:
9216 GET_CLASS(cl, ((SLang_Intrin_Var_Type *)v)->type);
9217 if (cl->cl_class_type != SLANG_CLASS_TYPE_SCALAR)
9218 {
9219 _pSLang_verror (SL_Forbidden_Error, "Assignment to %s is not allowed", name);
9220 return;
9221 }
9222 main_type = SLANG_BC_SET_INTRIN_LVALUE;
9223 Compile_ByteCode_Ptr->b.nt_blk = v;
9224 break;
9225
9226 case SLANG_RVARIABLE:
9227 _pSLang_verror (SL_READONLY_ERROR, "%s is read-only", name);
9228 return;
9229
9230 default:
9231 _pSLang_verror (SL_Forbidden_Error, "%s may not be used as an lvalue", name);
9232 return;
9233 }
9234
9235 Compile_ByteCode_Ptr->bc_sub_type = assign_type;
9236 Compile_ByteCode_Ptr->bc_main_type = main_type;
9237
9238 lang_try_now ();
9239 }
9240
9241 #if 0
9242 static void compile_deref_assign (char *name, unsigned long hash)
9243 {
9244 SLang_Name_Type *v;
9245
9246 v = locate_hashed_name (name, hash, 1);
9247
9248 if (v == NULL)
9249 {
9250 _pSLang_verror (SL_UNDEFINED_NAME, "%s is undefined", name);
9251 return;
9252 }
9253
9254 switch (v->name_type)
9255 {
9256 case SLANG_LVARIABLE:
9257 Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *) v)->local_var_number;
9258 break;
9259
9260 case SLANG_GVARIABLE:
9261 case SLANG_PVARIABLE:
9262 Compile_ByteCode_Ptr->b.nt_blk = v;
9263 break;
9264
9265 default:
9266 /* FIXME: Priority=low
9267 * This could be made to work. It is not a priority because
9268 * I cannot imagine application intrinsics which are references.
9269 */
9270 _pSLang_verror (SL_NOT_IMPLEMENTED, "Deref assignment to %s is not allowed", name);
9271 return;
9272 }
9273
9274 Compile_ByteCode_Ptr->bc_sub_type = v->name_type;
9275 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_DEREF_ASSIGN;
9276
9277 lang_try_now ();
9278 }
9279 #endif
9280 static void
compile_struct_assign(_pSLang_Token_Type * t)9281 compile_struct_assign (_pSLang_Token_Type *t)
9282 {
9283 Compile_ByteCode_Ptr->bc_sub_type = SLANG_BCST_ASSIGN + (t->type - _STRUCT_ASSIGN_TOKEN);
9284 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_SET_STRUCT_LVALUE;
9285 Compile_ByteCode_Ptr->b.s_blk = _pSLstring_dup_hashed_string (t->v.s_val, t->hash);
9286 lang_try_now ();
9287 }
9288
9289 static void
compile_array_assign(_pSLang_Token_Type * t)9290 compile_array_assign (_pSLang_Token_Type *t)
9291 {
9292 Compile_ByteCode_Ptr->bc_sub_type = SLANG_BCST_ASSIGN + (t->type - _ARRAY_ASSIGN_TOKEN);
9293 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_SET_ARRAY_LVALUE;
9294 Compile_ByteCode_Ptr->b.s_blk = NULL;
9295 lang_try_now ();
9296 }
9297
9298 static void
compile_deref_assign(_pSLang_Token_Type * t)9299 compile_deref_assign (_pSLang_Token_Type *t)
9300 {
9301 Compile_ByteCode_Ptr->bc_sub_type = SLANG_BCST_ASSIGN + (t->type - _DEREF_ASSIGN_TOKEN);
9302 Compile_ByteCode_Ptr->bc_main_type = SLANG_BC_SET_DEREF_LVALUE;
9303 Compile_ByteCode_Ptr->b.s_blk = NULL;
9304 lang_try_now ();
9305 }
9306
compile_dot(_pSLang_Token_Type * t,_pSLang_BC_Type bc_main_type)9307 static void compile_dot (_pSLang_Token_Type *t, _pSLang_BC_Type bc_main_type)
9308 {
9309 Compile_ByteCode_Ptr->bc_main_type = bc_main_type;
9310 Compile_ByteCode_Ptr->b.s_blk = _pSLstring_dup_hashed_string(t->v.s_val, t->hash);
9311 lang_try_now ();
9312 }
9313
compile_ref(SLFUTURE_CONST char * name,unsigned long hash)9314 static void compile_ref (SLFUTURE_CONST char *name, unsigned long hash)
9315 {
9316 SLang_Name_Type *entry;
9317 _pSLang_BC_Type main_type;
9318
9319 if (NULL == (entry = locate_hashed_name_autodeclare (name, hash, SLANG_BCST_ASSIGN)))
9320 return;
9321
9322 main_type = (_pSLang_BC_Type) entry->name_type;
9323
9324 if (main_type == SLANG_LVARIABLE)
9325 {
9326 main_type = SLANG_BC_LOBJPTR;
9327 Compile_ByteCode_Ptr->b.i_blk = ((SLang_Local_Var_Type *)entry)->local_var_number;
9328 }
9329 else
9330 {
9331 main_type = SLANG_BC_GOBJPTR;
9332 Compile_ByteCode_Ptr->b.nt_blk = entry;
9333 }
9334
9335 Compile_ByteCode_Ptr->bc_main_type = main_type;
9336 lang_try_now ();
9337 }
9338
compile_break(_pSLang_BC_Type break_type,int requires_block,int requires_fun,SLCONST char * str,int opt_val)9339 static void compile_break (_pSLang_BC_Type break_type,
9340 int requires_block, int requires_fun,
9341 SLCONST char *str, int opt_val)
9342 {
9343 if ((requires_fun
9344 && (Lang_Defining_Function == 0))
9345 || (requires_block
9346 && (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK)))
9347 {
9348 _pSLang_verror (SL_SYNTAX_ERROR, "misplaced %s", str);
9349 return;
9350 }
9351
9352 Compile_ByteCode_Ptr->bc_main_type = break_type;
9353 Compile_ByteCode_Ptr->bc_sub_type = 0;
9354 Compile_ByteCode_Ptr->b.i_blk = opt_val;
9355
9356 lang_try_now ();
9357 }
9358
compile_public_variable_mode(_pSLang_Token_Type * t)9359 static void compile_public_variable_mode (_pSLang_Token_Type *t)
9360 {
9361 if (t->type == IDENT_TOKEN)
9362 {
9363 if (-1 == check_linkage (t->v.s_val, t->hash, 1))
9364 return;
9365 add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, Global_NameSpace);
9366 }
9367 else if (t->type == CBRACKET_TOKEN)
9368 Compile_Mode_Function = compile_basic_token_mode;
9369 else
9370 _pSLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
9371 }
9372
compile_local_variable_mode(_pSLang_Token_Type * t)9373 static void compile_local_variable_mode (_pSLang_Token_Type *t)
9374 {
9375 if (Locals_NameSpace == NULL)
9376 {
9377 Locals_NameSpace = _pSLns_allocate_namespace ("**locals**", SLLOCALS_HASH_TABLE_SIZE);
9378 if (Locals_NameSpace == NULL)
9379 return;
9380 }
9381
9382 if (t->type == IDENT_TOKEN)
9383 add_local_variable (t->v.s_val, t->hash);
9384 else if (t->type == CBRACKET_TOKEN)
9385 Compile_Mode_Function = compile_basic_token_mode;
9386 else
9387 _pSLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
9388 }
9389
compile_static_variable_mode(_pSLang_Token_Type * t)9390 static void compile_static_variable_mode (_pSLang_Token_Type *t)
9391 {
9392 if (t->type == IDENT_TOKEN)
9393 {
9394 if (-1 == check_linkage (t->v.s_val, t->hash, 0))
9395 return;
9396 add_global_variable (t->v.s_val, SLANG_GVARIABLE, t->hash, This_Static_NameSpace);
9397 }
9398 else if (t->type == CBRACKET_TOKEN)
9399 Compile_Mode_Function = compile_basic_token_mode;
9400 else
9401 _pSLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
9402 }
9403
compile_private_variable_mode(_pSLang_Token_Type * t)9404 static void compile_private_variable_mode (_pSLang_Token_Type *t)
9405 {
9406 if (t->type == IDENT_TOKEN)
9407 add_global_variable (t->v.s_val, SLANG_PVARIABLE, t->hash, This_Private_NameSpace);
9408 else if (t->type == CBRACKET_TOKEN)
9409 Compile_Mode_Function = compile_basic_token_mode;
9410 else
9411 _pSLang_verror (SL_SYNTAX_ERROR, "Misplaced token in variable list");
9412 }
9413
compile_function_mode(_pSLang_Token_Type * t)9414 static void compile_function_mode (_pSLang_Token_Type *t)
9415 {
9416 if (-1 == lang_check_space ())
9417 return;
9418
9419 if (t->type != IDENT_TOKEN)
9420 _pSLang_verror (SL_SYNTAX_ERROR, "Expecting a function name");
9421 else
9422 lang_define_function (t->v.s_val, SLANG_FUNCTION, t->hash, Global_NameSpace);
9423
9424 Compile_Mode_Function = compile_basic_token_mode;
9425 }
9426
9427 /* An error block is not permitted to contain continue or break statements.
9428 * This restriction may be removed later but for now reject them.
9429 */
check_error_block(void)9430 static int check_error_block (void)
9431 {
9432 SLBlock_Type *p;
9433 _pSLang_BC_Type t;
9434
9435 /* Back up to the block and then scan it. */
9436 p = (Compile_ByteCode_Ptr - 1)->b.blk;
9437
9438 while (0 != (t = p->bc_main_type))
9439 {
9440 if ((t == SLANG_BC_BREAK)
9441 || (t == SLANG_BC_CONTINUE))
9442 {
9443 _pSLang_verror (SL_SYNTAX_ERROR,
9444 "An ERROR_BLOCK is not permitted to contain continue or break statements");
9445 return -1;
9446 }
9447 p++;
9448 }
9449 return 0;
9450 }
9451
9452 /* The only allowed tokens are the directives and another block start.
9453 * The mode is only active if a block is available. The inner_interp routine
9454 * expects such safety checks.
9455 */
compile_directive_mode(_pSLang_Token_Type * t)9456 static void compile_directive_mode (_pSLang_Token_Type *t)
9457 {
9458 int bc_sub_type;
9459 int delay;
9460
9461 if (-1 == lang_check_space ())
9462 return;
9463
9464 bc_sub_type = -1;
9465 delay = 0;
9466 switch (t->type)
9467 {
9468 case FOREVER_TOKEN:
9469 bc_sub_type = SLANG_BCST_FOREVER;
9470 delay = 1;
9471 break;
9472
9473 case IFNOT_TOKEN:
9474 bc_sub_type = SLANG_BCST_IFNOT;
9475 break;
9476
9477 case IF_TOKEN:
9478 bc_sub_type = SLANG_BCST_IF;
9479 break;
9480
9481 case ANDELSE_TOKEN:
9482 bc_sub_type = SLANG_BCST_ANDELSE;
9483 break;
9484
9485 case SWITCH_TOKEN:
9486 bc_sub_type = SLANG_BCST_SWITCH;
9487 break;
9488
9489 case EXITBLK_TOKEN:
9490 if (Lang_Defining_Function == 0)
9491 {
9492 _pSLang_verror (SL_SYNTAX_ERROR, "misplaced EXIT_BLOCK");
9493 break;
9494 }
9495 bc_sub_type = SLANG_BCST_EXIT_BLOCK;
9496 break;
9497
9498 case ERRBLK_TOKEN:
9499 if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL)
9500 {
9501 _pSLang_verror (SL_SYNTAX_ERROR, "misplaced ERROR_BLOCK");
9502 break;
9503 }
9504 if (0 == check_error_block ())
9505 bc_sub_type = SLANG_BCST_ERROR_BLOCK;
9506 break;
9507
9508 case USRBLK0_TOKEN:
9509 case USRBLK1_TOKEN:
9510 case USRBLK2_TOKEN:
9511 case USRBLK3_TOKEN:
9512 case USRBLK4_TOKEN:
9513 /* if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_TOP_LEVEL) */
9514 if (Lang_Defining_Function == 0)
9515 {
9516 _pSLang_verror (SL_SYNTAX_ERROR, "misplaced USER_BLOCK");
9517 break;
9518 }
9519 bc_sub_type = SLANG_BCST_USER_BLOCK0 + (t->type - USRBLK0_TOKEN);
9520 break;
9521
9522 case NOTELSE_TOKEN:
9523 bc_sub_type = SLANG_BCST_NOTELSE;
9524 break;
9525
9526 case ELSE_TOKEN:
9527 bc_sub_type = SLANG_BCST_ELSE;
9528 break;
9529 #ifdef LOOP_ELSE_TOKEN
9530 case LOOP_ELSE_TOKEN:
9531 bc_sub_type = SLANG_BCST_LOOP_ELSE;
9532 break;
9533 #endif
9534 case LOOP_THEN_TOKEN:
9535 bc_sub_type = SLANG_BCST_LOOP_THEN;
9536 break;
9537
9538 case LOOP_TOKEN:
9539 bc_sub_type = SLANG_BCST_LOOP;
9540 delay = 1;
9541 break;
9542
9543 case DOWHILE_TOKEN:
9544 bc_sub_type = SLANG_BCST_DOWHILE;
9545 delay = 1;
9546 break;
9547
9548 case WHILE_TOKEN:
9549 bc_sub_type = SLANG_BCST_WHILE;
9550 delay = 1;
9551 break;
9552
9553 case ORELSE_TOKEN:
9554 bc_sub_type = SLANG_BCST_ORELSE;
9555 break;
9556
9557 case _FOR_TOKEN:
9558 bc_sub_type = SLANG_BCST_FOR;
9559 delay = 1;
9560 break;
9561
9562 case FOR_TOKEN:
9563 bc_sub_type = SLANG_BCST_CFOR;
9564 delay = 1;
9565 break;
9566
9567 case FOREACH_TOKEN:
9568 delay = 1;
9569 bc_sub_type = SLANG_BCST_FOREACH;
9570 break;
9571
9572 case FOREACH_EARGS_TOKEN:
9573 delay = 1;
9574 bc_sub_type = SLANG_BCST_FOREACH_EARGS;
9575 break;
9576
9577 case OBRACE_TOKEN:
9578 lang_begin_block ();
9579 break;
9580
9581 case TRY_TOKEN:
9582 bc_sub_type = SLANG_BCST_TRY;
9583 break;
9584
9585 case SC_OR_TOKEN:
9586 bc_sub_type = SLANG_BCST_SC_OR;
9587 break;
9588
9589 case SC_AND_TOKEN:
9590 bc_sub_type = SLANG_BCST_SC_AND;
9591 break;
9592
9593 case _COMPARE_TOKEN:
9594 bc_sub_type = SLANG_BCST_COMPARE;
9595 break;
9596
9597 default:
9598 _pSLang_verror (SL_SYNTAX_ERROR, "Expecting directive token. Found 0x%X", t->type);
9599 break;
9600 }
9601
9602 /* Reset this pointer first because compile_directive may cause a
9603 * file to be loaded.
9604 */
9605 Compile_Mode_Function = compile_basic_token_mode;
9606
9607 if (bc_sub_type != -1)
9608 compile_directive (bc_sub_type, delay);
9609 }
9610
9611 static unsigned int Assign_Mode_Type;
compile_assign_mode(_pSLang_Token_Type * t)9612 static void compile_assign_mode (_pSLang_Token_Type *t)
9613 {
9614 if (t->type != IDENT_TOKEN)
9615 {
9616 _pSLang_verror (SL_SYNTAX_ERROR, "Expecting identifier for assignment");
9617 return;
9618 }
9619
9620 compile_assign (Assign_Mode_Type, t->v.s_val, t->hash);
9621 Compile_Mode_Function = compile_basic_token_mode;
9622 }
9623
compile_basic_token_mode(_pSLang_Token_Type * t)9624 static void compile_basic_token_mode (_pSLang_Token_Type *t)
9625 {
9626 if (-1 == lang_check_space ())
9627 return;
9628
9629 switch (t->type)
9630 {
9631 case EOF_TOKEN:
9632 case NOP_TOKEN:
9633 interp_pending_blocks ();
9634 break;
9635
9636 case PUSH_TOKEN:
9637 case READONLY_TOKEN:
9638 case DO_TOKEN:
9639 case VARIABLE_TOKEN:
9640 case SEMICOLON_TOKEN:
9641 default:
9642 _pSLang_verror (SL_SYNTAX_ERROR, "Unknown or unsupported token type 0x%X", t->type);
9643 break;
9644
9645 case DEREF_TOKEN:
9646 compile_call_direct (dereference_object, SLANG_BC_CALL_DIRECT);
9647 break;
9648
9649 case _DEREF_OBSOLETE_FUNCALL_TOKEN:
9650 compile_simple (SLANG_BC_OBSOLETE_DEREF_FUN_CALL);
9651 break;
9652
9653 case _DEREF_FUNCALL_TOKEN:
9654 compile_simple (SLANG_BC_DEREF_FUN_CALL);
9655 break;
9656
9657 case STRUCT_TOKEN:
9658 compile_call_direct (_pSLstruct_define_struct, SLANG_BC_CALL_DIRECT);
9659 break;
9660
9661 case STRUCT_WITH_ASSIGN_TOKEN:
9662 compile_call_direct (_pSLstruct_define_struct2, SLANG_BC_CALL_DIRECT);
9663 break;
9664
9665 case TYPEDEF_TOKEN:
9666 compile_call_direct (_pSLstruct_define_typedef, SLANG_BC_CALL_DIRECT);
9667 break;
9668
9669 case DOT_TOKEN: /* X . field */
9670 compile_dot (t, SLANG_BC_FIELD);
9671 break;
9672
9673 case DOT_METHOD_CALL_TOKEN: /* X . field (args) */
9674 compile_dot (t, SLANG_BC_METHOD);
9675 break;
9676
9677 case COMMA_TOKEN:
9678 break; /* do nothing */
9679
9680 case IDENT_TOKEN:
9681 compile_hashed_identifier (t->v.s_val, t->hash, t);
9682 break;
9683
9684 case _REF_TOKEN:
9685 compile_ref (t->v.s_val, t->hash);
9686 break;
9687
9688 case ARG_TOKEN:
9689 compile_call_direct (start_arg_list, SLANG_BC_CALL_DIRECT);
9690 break;
9691
9692 case EARG_TOKEN:
9693 compile_lvar_call_direct (end_arg_list, SLANG_BC_EARG_LVARIABLE, SLANG_BC_CALL_DIRECT);
9694 break;
9695
9696 case COLON_TOKEN:
9697 if (This_Compile_Block_Type == COMPILE_BLOCK_TYPE_BLOCK)
9698 compile_simple (SLANG_BC_LABEL);
9699 else (void) SLang_set_error (SL_SYNTAX_ERROR);
9700 break;
9701
9702 case POP_TOKEN:
9703 compile_call_direct (SLdo_pop, SLANG_BC_CALL_DIRECT);
9704 break;
9705
9706 case CASE_TOKEN:
9707 if (This_Compile_Block_Type != COMPILE_BLOCK_TYPE_BLOCK)
9708 _pSLang_verror (SL_SYNTAX_ERROR, "Misplaced 'case'");
9709 else
9710 compile_call_direct (case_function, SLANG_BC_CALL_DIRECT);
9711 break;
9712
9713 case CHAR_TOKEN:
9714 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_CHAR_TYPE);
9715 break;
9716 case UCHAR_TOKEN:
9717 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_UCHAR_TYPE);
9718 break;
9719 #if SHORT_IS_NOT_INT
9720 case SHORT_TOKEN:
9721 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_SHORT_TYPE);
9722 break;
9723 case USHORT_TOKEN:
9724 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_USHORT_TYPE);
9725 break;
9726 #endif
9727 #if SHORT_IS_INT
9728 case SHORT_TOKEN:
9729 #endif
9730 #if LONG_IS_INT
9731 case LONG_TOKEN:
9732 #endif
9733 case INT_TOKEN:
9734 compile_integer (t->v.long_val, SLANG_BC_LITERAL_INT, SLANG_INT_TYPE);
9735 break;
9736 #if SHORT_IS_INT
9737 case USHORT_TOKEN:
9738 #endif
9739 #if LONG_IS_INT
9740 case ULONG_TOKEN:
9741 #endif
9742 case UINT_TOKEN:
9743 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_UINT_TYPE);
9744 break;
9745 #if LONG_IS_NOT_INT
9746 case LONG_TOKEN:
9747 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_LONG_TYPE);
9748 break;
9749 case ULONG_TOKEN:
9750 compile_integer (t->v.long_val, SLANG_BC_LITERAL, SLANG_ULONG_TYPE);
9751 break;
9752 #endif
9753
9754 #if SLANG_HAS_FLOAT
9755 case FLOAT_TOKEN:
9756 compile_float (t);
9757 break;
9758
9759 case DOUBLE_TOKEN:
9760 compile_double (t, SLANG_BC_LITERAL_DBL, SLANG_DOUBLE_TYPE);
9761 break;
9762 #endif
9763 #if SLANG_HAS_COMPLEX
9764 case COMPLEX_TOKEN:
9765 compile_double (t, SLANG_BC_LITERAL, SLANG_COMPLEX_TYPE);
9766 break;
9767 #endif
9768 #ifdef HAVE_LONG_LONG
9769 case LLONG_TOKEN:
9770 compile_llong (t->v.llong_val, SLANG_BC_LITERAL, _pSLANG_LLONG_TYPE);
9771 break;
9772 case ULLONG_TOKEN:
9773 compile_llong (t->v.ullong_val, SLANG_BC_LITERAL, _pSLANG_ULLONG_TYPE);
9774 break;
9775 #endif
9776 case STRING_TOKEN:
9777 compile_string (t->v.s_val, t->hash);
9778 break;
9779
9780 case STRING_DOLLAR_TOKEN:
9781 compile_string_dollar (t->v.s_val, t->hash);
9782 break;
9783
9784 case _BSTRING_TOKEN:
9785 {
9786 SLang_BString_Type *b = SLbstring_create ((unsigned char *)t->v.s_val, (unsigned int) t->hash);
9787 if (b != NULL)
9788 {
9789 compile_bstring (b);
9790 SLbstring_free (b);
9791 }
9792 }
9793 break;
9794
9795 case BSTRING_TOKEN:
9796 compile_bstring (t->v.b_val);
9797 break;
9798
9799 case MULTI_STRING_TOKEN:
9800 {
9801 _pSLang_Multiline_String_Type *m = t->v.multistring_val;
9802 if (m->type == STRING_TOKEN)
9803 compile_string (m->v.s_val, m->hash);
9804 else if (m->type == STRING_DOLLAR_TOKEN)
9805 compile_string_dollar (m->v.s_val, m->hash);
9806 else if (m->type == BSTRING_TOKEN)
9807 compile_bstring (m->v.b_val);
9808 }
9809 break;
9810
9811 case _NULL_TOKEN:
9812 compile_identifier ("NULL", t);
9813 break;
9814
9815 case _INLINE_WILDCARD_ARRAY_TOKEN:
9816 compile_call_direct (_pSLarray_wildcard_array, SLANG_BC_CALL_DIRECT);
9817 break;
9818
9819 case _INLINE_ARRAY_TOKEN:
9820 compile_call_direct (_pSLarray_inline_array, SLANG_BC_CALL_DIRECT_NARGS);
9821 break;
9822
9823 case _INLINE_IMPLICIT_ARRAY_TOKEN:
9824 compile_call_direct (_pSLarray_inline_implicit_array, SLANG_BC_CALL_DIRECT_NARGS);
9825 break;
9826
9827 case _INLINE_LIST_TOKEN:
9828 compile_call_direct (_pSLlist_inline_list, SLANG_BC_CALL_DIRECT_NARGS);
9829 break;
9830
9831 case ARRAY_TOKEN:
9832 compile_lvar_call_direct (_pSLarray_aget, SLANG_BC_LVARIABLE_AGET, SLANG_BC_CALL_DIRECT_NARGS);
9833 break;
9834
9835 case _INLINE_IMPLICIT_ARRAYN_TOKEN:
9836 compile_call_direct (_pSLarray_inline_implicit_arrayn, SLANG_BC_CALL_DIRECT_NARGS);
9837 break;
9838
9839 /* Note: I need to add the other _ARRAY assign tokens. */
9840 case _ARRAY_PLUSEQS_TOKEN:
9841 case _ARRAY_MINUSEQS_TOKEN:
9842 case _ARRAY_TIMESEQS_TOKEN:
9843 case _ARRAY_DIVEQS_TOKEN:
9844 case _ARRAY_BOREQS_TOKEN:
9845 case _ARRAY_BANDEQS_TOKEN:
9846 case _ARRAY_POST_MINUSMINUS_TOKEN:
9847 case _ARRAY_MINUSMINUS_TOKEN:
9848 case _ARRAY_POST_PLUSPLUS_TOKEN:
9849 case _ARRAY_PLUSPLUS_TOKEN:
9850 compile_array_assign (t);
9851 break;
9852
9853 case _ARRAY_ASSIGN_TOKEN:
9854 compile_lvar_call_direct (_pSLarray_aput, SLANG_BC_LVARIABLE_APUT, SLANG_BC_CALL_DIRECT_NARGS);
9855 break;
9856
9857 case _STRUCT_ASSIGN_TOKEN:
9858 case _STRUCT_PLUSEQS_TOKEN:
9859 case _STRUCT_MINUSEQS_TOKEN:
9860 case _STRUCT_TIMESEQS_TOKEN:
9861 case _STRUCT_DIVEQS_TOKEN:
9862 case _STRUCT_BOREQS_TOKEN:
9863 case _STRUCT_BANDEQS_TOKEN:
9864 case _STRUCT_POST_MINUSMINUS_TOKEN:
9865 case _STRUCT_MINUSMINUS_TOKEN:
9866 case _STRUCT_POST_PLUSPLUS_TOKEN:
9867 case _STRUCT_PLUSPLUS_TOKEN:
9868 compile_struct_assign (t);
9869 break;
9870
9871 case _SCALAR_ASSIGN_TOKEN:
9872 case _SCALAR_PLUSEQS_TOKEN:
9873 case _SCALAR_MINUSEQS_TOKEN:
9874 case _SCALAR_TIMESEQS_TOKEN:
9875 case _SCALAR_DIVEQS_TOKEN:
9876 case _SCALAR_BOREQS_TOKEN:
9877 case _SCALAR_BANDEQS_TOKEN:
9878 case _SCALAR_POST_MINUSMINUS_TOKEN:
9879 case _SCALAR_MINUSMINUS_TOKEN:
9880 case _SCALAR_POST_PLUSPLUS_TOKEN:
9881 case _SCALAR_PLUSPLUS_TOKEN:
9882 compile_assign (SLANG_BCST_ASSIGN + (t->type - _SCALAR_ASSIGN_TOKEN),
9883 t->v.s_val, t->hash);
9884 break;
9885
9886 case _DEREF_ASSIGN_TOKEN:
9887 case _DEREF_PLUSEQS_TOKEN:
9888 case _DEREF_MINUSEQS_TOKEN:
9889 case _DEREF_TIMESEQS_TOKEN:
9890 case _DEREF_DIVEQS_TOKEN:
9891 case _DEREF_BOREQS_TOKEN:
9892 case _DEREF_BANDEQS_TOKEN:
9893 case _DEREF_PLUSPLUS_TOKEN:
9894 case _DEREF_POST_PLUSPLUS_TOKEN:
9895 case _DEREF_MINUSMINUS_TOKEN:
9896 case _DEREF_POST_MINUSMINUS_TOKEN:
9897 compile_deref_assign (t);
9898 break;
9899
9900 /* For processing RPN tokens */
9901 case ASSIGN_TOKEN:
9902 case PLUSEQS_TOKEN:
9903 case MINUSEQS_TOKEN:
9904 case TIMESEQS_TOKEN:
9905 case DIVEQS_TOKEN:
9906 case BOREQS_TOKEN:
9907 case BANDEQS_TOKEN:
9908 case POST_MINUSMINUS_TOKEN:
9909 case MINUSMINUS_TOKEN:
9910 case POST_PLUSPLUS_TOKEN:
9911 case PLUSPLUS_TOKEN:
9912 Compile_Mode_Function = compile_assign_mode;
9913 Assign_Mode_Type = SLANG_BCST_ASSIGN + (t->type - ASSIGN_TOKEN);
9914 break;
9915
9916 case LT_TOKEN:
9917 compile_binary (SLANG_LT);
9918 break;
9919
9920 case LE_TOKEN:
9921 compile_binary (SLANG_LE);
9922 break;
9923
9924 case GT_TOKEN:
9925 compile_binary (SLANG_GT);
9926 break;
9927
9928 case GE_TOKEN:
9929 compile_binary (SLANG_GE);
9930 break;
9931
9932 case EQ_TOKEN:
9933 compile_binary (SLANG_EQ);
9934 break;
9935
9936 case NE_TOKEN:
9937 compile_binary (SLANG_NE);
9938 break;
9939
9940 case AND_TOKEN:
9941 compile_binary (SLANG_AND);
9942 break;
9943
9944 case ADD_TOKEN:
9945 compile_binary (SLANG_PLUS);
9946 break;
9947
9948 case SUB_TOKEN:
9949 compile_binary (SLANG_MINUS);
9950 break;
9951
9952 case TIMES_TOKEN:
9953 compile_binary (SLANG_TIMES);
9954 break;
9955
9956 case DIV_TOKEN:
9957 compile_binary (SLANG_DIVIDE);
9958 break;
9959
9960 case POW_TOKEN:
9961 compile_binary (SLANG_POW);
9962 break;
9963
9964 case BXOR_TOKEN:
9965 compile_binary (SLANG_BXOR);
9966 break;
9967
9968 case BAND_TOKEN:
9969 compile_binary (SLANG_BAND);
9970 break;
9971
9972 case BOR_TOKEN:
9973 compile_binary (SLANG_BOR);
9974 break;
9975
9976 case SHR_TOKEN:
9977 compile_binary (SLANG_SHR);
9978 break;
9979
9980 case SHL_TOKEN:
9981 compile_binary (SLANG_SHL);
9982 break;
9983
9984 case MOD_TOKEN:
9985 compile_binary (SLANG_MOD);
9986 break;
9987
9988 case OR_TOKEN:
9989 compile_binary (SLANG_OR);
9990 break;
9991
9992 case NOT_TOKEN:
9993 compile_unary (SLANG_NOT, SLANG_BC_UNARY);
9994 break;
9995
9996 case BNOT_TOKEN:
9997 compile_unary (SLANG_BNOT, SLANG_BC_UNARY);
9998 break;
9999 case CHS_TOKEN:
10000 compile_unary (SLANG_CHS, SLANG_BC_UNARY);
10001 break;
10002 #if 0
10003 case MUL2_TOKEN:
10004 compile_unary (SLANG_MUL2, SLANG_BC_ARITH_UNARY);
10005 break;
10006 case ABS_TOKEN:
10007 compile_unary (SLANG_ABS, SLANG_BC_ARITH_UNARY);
10008 break;
10009 case SQR_TOKEN:
10010 compile_unary (SLANG_SQR, SLANG_BC_ARITH_UNARY);
10011 break;
10012 case SIGN_TOKEN:
10013 compile_unary (SLANG_SIGN, SLANG_BC_ARITH_UNARY);
10014 break;
10015 #endif
10016 case BREAK_TOKEN:
10017 compile_break (SLANG_BC_BREAK, 1, 0, "break", 1);
10018 break;
10019
10020 case BREAK_N_TOKEN:
10021 compile_break (SLANG_BC_BREAK_N, 1, 0, "break", abs((int)t->v.long_val));
10022 break;
10023
10024 case RETURN_TOKEN:
10025 compile_break (SLANG_BC_RETURN, 0, 1, "return", 1);
10026 break;
10027
10028 case CONT_TOKEN:
10029 compile_break (SLANG_BC_CONTINUE, 1, 0, "continue", 1);
10030 break;
10031 case CONT_N_TOKEN:
10032 compile_break (SLANG_BC_CONTINUE_N, 1, 0, "continue", abs((int)t->v.long_val));
10033 break;
10034 case EXCH_TOKEN:
10035 compile_break (SLANG_BC_EXCH, 0, 0, "", 0); /* FIXME: Priority=low */
10036 break;
10037
10038 case STATIC_TOKEN:
10039 interp_pending_blocks ();
10040 if (Lang_Defining_Function == 0)
10041 Compile_Mode_Function = compile_static_variable_mode;
10042 else
10043 _pSLang_verror (SL_NOT_IMPLEMENTED, "static variables not permitted in functions");
10044 break;
10045
10046 case PRIVATE_TOKEN:
10047 interp_pending_blocks ();
10048 if (Lang_Defining_Function == 0)
10049 Compile_Mode_Function = compile_private_variable_mode;
10050 else
10051 _pSLang_verror (SL_NOT_IMPLEMENTED, "private variables not permitted in functions");
10052 break;
10053
10054 case PUBLIC_TOKEN:
10055 interp_pending_blocks ();
10056 if (Lang_Defining_Function == 0)
10057 Compile_Mode_Function = compile_public_variable_mode;
10058 else
10059 _pSLang_verror (SL_NOT_IMPLEMENTED, "public variables not permitted in functions");
10060 break;
10061
10062 case OBRACKET_TOKEN:
10063 interp_pending_blocks ();
10064 if (Lang_Defining_Function == 0)
10065 Compile_Mode_Function = Default_Variable_Mode;
10066 else
10067 Compile_Mode_Function = compile_local_variable_mode;
10068 break;
10069
10070 case OPAREN_TOKEN:
10071 interp_pending_blocks ();
10072 lang_begin_function ();
10073 break;
10074
10075 case DEFINE_STATIC_TOKEN:
10076 if (Lang_Defining_Function)
10077 define_static_function (t->v.s_val, t->hash);
10078 else (void) SLang_set_error (SL_SYNTAX_ERROR);
10079 break;
10080
10081 case DEFINE_PRIVATE_TOKEN:
10082 interp_pending_blocks ();
10083 if (Lang_Defining_Function)
10084 define_private_function (t->v.s_val, t->hash);
10085 else (void) SLang_set_error (SL_SYNTAX_ERROR);
10086 break;
10087
10088 case DEFINE_PUBLIC_TOKEN:
10089 if (Lang_Defining_Function)
10090 define_public_function (t->v.s_val, t->hash);
10091 else (void) SLang_set_error (SL_SYNTAX_ERROR);
10092 break;
10093
10094 case THROW_TOKEN:
10095 compile_call_direct (_pSLerr_throw, SLANG_BC_CALL_DIRECT_NARGS);
10096 break;
10097
10098 case DEFINE_TOKEN:
10099 if (Lang_Defining_Function)
10100 (*Default_Define_Function) (t->v.s_val, t->hash);
10101 else
10102 (void) SLang_set_error (SL_SYNTAX_ERROR);
10103 break;
10104
10105 case CPAREN_TOKEN:
10106 if (Lang_Defining_Function)
10107 Compile_Mode_Function = compile_function_mode;
10108 else (void) SLang_set_error (SL_SYNTAX_ERROR);
10109 break;
10110
10111 case CBRACE_TOKEN:
10112 lang_end_block ();
10113 Compile_Mode_Function = compile_directive_mode;
10114 break;
10115
10116 case OBRACE_TOKEN:
10117 lang_begin_block ();
10118 break;
10119
10120 case FARG_TOKEN:
10121 Function_Args_Number = Local_Variable_Number;
10122 break;
10123
10124 case TMP_TOKEN:
10125 compile_tmp_variable (t->v.s_val, t->hash);
10126 break;
10127 #if SLANG_HAS_QUALIFIERS
10128 case QUALIFIER_TOKEN:
10129 compile_call_direct (set_qualifier, SLANG_BC_CALL_DIRECT);
10130 break;
10131 #endif
10132 case BOS_TOKEN:
10133 #if SLANG_HAS_DEBUG_CODE && SLANG_HAS_BOSEOS
10134 compile_line_info (SLANG_BC_BOS, This_Compile_Filename, t->v.long_val);
10135 #endif
10136 break;
10137 case EOS_TOKEN:
10138 #if SLANG_HAS_DEBUG_CODE && SLANG_HAS_BOSEOS
10139 compile_simple (SLANG_BC_EOS);
10140 #endif
10141 break;
10142
10143 case LINE_NUM_TOKEN:
10144 #if SLANG_HAS_DEBUG_CODE
10145 set_line_number_info (t->v.long_val);
10146 #endif
10147 break;
10148
10149 case _ARRAY_ELEM_REF_TOKEN:
10150 compile_call_direct (_pSLarray_push_elem_ref, SLANG_BC_CALL_DIRECT_NARGS);
10151 break;
10152
10153 case _STRUCT_FIELD_REF_TOKEN:
10154 compile_dot (t, SLANG_BC_FIELD_REF);
10155 break;
10156
10157 case POUND_TOKEN:
10158 compile_call_direct (_pSLarray_matrix_multiply, SLANG_BC_CALL_DIRECT);
10159 break;
10160 }
10161 }
10162
_pSLcompile(_pSLang_Token_Type * t)10163 void _pSLcompile (_pSLang_Token_Type *t)
10164 {
10165 if (SLang_get_error () == 0)
10166 {
10167 if (Compile_Mode_Function != compile_basic_token_mode)
10168 {
10169 if (Compile_Mode_Function == NULL)
10170 Compile_Mode_Function = compile_basic_token_mode;
10171 if (t->type == LINE_NUM_TOKEN)
10172 {
10173 compile_basic_token_mode (t);
10174 return;
10175 }
10176 }
10177
10178 (*Compile_Mode_Function) (t);
10179 }
10180
10181 if (SLang_get_error ())
10182 {
10183 Compile_Mode_Function = compile_basic_token_mode;
10184 reset_active_interpreter ();
10185 }
10186 }
10187
10188 void (*_pSLcompile_ptr)(_pSLang_Token_Type *) = _pSLcompile;
10189
10190 typedef struct _Compile_Context_Type
10191 {
10192 struct _Compile_Context_Type *next;
10193 SLang_NameSpace_Type *static_namespace;
10194 SLang_NameSpace_Type *private_namespace;
10195 SLang_NameSpace_Type *locals_namespace;
10196 void (*compile_variable_mode) (_pSLang_Token_Type *);
10197 void (*define_function) (SLFUTURE_CONST char *, unsigned long);
10198 int lang_defining_function;
10199 int local_variable_number;
10200 char *local_variable_names[SLANG_MAX_LOCAL_VARIABLES];
10201 unsigned int function_args_number;
10202 void (*compile_mode_function)(_pSLang_Token_Type *);
10203 SLFUTURE_CONST char *compile_filename;
10204 unsigned int compile_linenum;
10205 _pSLang_Function_Type *current_function;
10206 Function_Header_Type *current_function_header;
10207 }
10208 Compile_Context_Type;
10209
10210 static Compile_Context_Type *Compile_Context_Stack;
10211
10212 /* The only way the push/pop_context functions can get called is via
10213 * an eval type function. That can only happen when executed from a
10214 * top level block. This means that Compile_ByteCode_Ptr can always be
10215 * reset back to the beginning of a block.
10216 */
10217
pop_compile_context(void)10218 static int pop_compile_context (void)
10219 {
10220 Compile_Context_Type *cc;
10221
10222 if (NULL == (cc = Compile_Context_Stack))
10223 return -1;
10224
10225 This_Static_NameSpace = cc->static_namespace;
10226 This_Private_NameSpace = cc->private_namespace;
10227 Compile_Context_Stack = cc->next;
10228 Default_Variable_Mode = cc->compile_variable_mode;
10229 Default_Define_Function = cc->define_function;
10230 Compile_Mode_Function = cc->compile_mode_function;
10231
10232 Lang_Defining_Function = cc->lang_defining_function;
10233 Local_Variable_Number = cc->local_variable_number;
10234 memcpy ((char *)Local_Variable_Names, (char *)cc->local_variable_names, sizeof(Local_Variable_Names));
10235
10236 Function_Args_Number = cc->function_args_number;
10237
10238 SLang_free_slstring ((char *) This_Compile_Filename);
10239 This_Compile_Filename = cc->compile_filename;
10240 This_Compile_Linenum = cc->compile_linenum;
10241
10242 Current_Function_Header = cc->current_function_header;
10243 Current_Function = cc->current_function;
10244
10245 Locals_NameSpace = cc->locals_namespace;
10246
10247 /* These should be when returning from a compile context */
10248 Lang_Return = 0;
10249 Lang_Break = 0;
10250 Lang_Break_Condition = 0;
10251
10252 SLfree ((char *) cc);
10253
10254 return decrement_slang_frame_pointer ();
10255 }
10256
push_compile_context(SLFUTURE_CONST char * name)10257 static int push_compile_context (SLFUTURE_CONST char *name)
10258 {
10259 Compile_Context_Type *cc;
10260
10261 cc = (Compile_Context_Type *)SLmalloc (sizeof (Compile_Context_Type));
10262 if (cc == NULL)
10263 return -1;
10264 memset ((char *) cc, 0, sizeof (Compile_Context_Type));
10265
10266 if ((name != NULL)
10267 && (NULL == (name = SLang_create_slstring (name))))
10268 {
10269 SLfree ((char *) cc);
10270 return -1;
10271 }
10272
10273 /* This is necessary since Current_Function and Current_Function_Header
10274 * will be set to NULL. Otherwise, top-level blocks would not get
10275 * properly counted by the _get_frame_depth function. It is also probably
10276 * not necessary to add the current_function and current_function_header
10277 * to the compile context structure.
10278 */
10279 if (-1 == increment_slang_frame_pointer (NULL, This_Compile_Linenum))
10280 {
10281 SLfree ((char *)cc);
10282 SLang_free_slstring ((char *) name); /* NULL ok */
10283 return -1;
10284 }
10285
10286 cc->compile_filename = This_Compile_Filename;
10287 This_Compile_Filename = name;
10288 cc->compile_linenum = This_Compile_Linenum;
10289 This_Compile_Linenum = 0;
10290
10291 cc->static_namespace = This_Static_NameSpace;
10292 cc->private_namespace = This_Private_NameSpace;
10293 cc->compile_variable_mode = Default_Variable_Mode;
10294 cc->define_function = Default_Define_Function;
10295 cc->locals_namespace = Locals_NameSpace;
10296
10297 cc->lang_defining_function = Lang_Defining_Function;
10298 cc->local_variable_number = Local_Variable_Number;
10299 memcpy ((char *)cc->local_variable_names, (char *)Local_Variable_Names, sizeof(Local_Variable_Names));
10300
10301 cc->function_args_number = Function_Args_Number;
10302 cc->compile_mode_function = Compile_Mode_Function;
10303
10304 cc->current_function_header = Current_Function_Header;
10305 cc->current_function = Current_Function;
10306
10307 cc->next = Compile_Context_Stack;
10308 Compile_Context_Stack = cc;
10309
10310 Compile_Mode_Function = compile_basic_token_mode;
10311 Default_Variable_Mode = compile_public_variable_mode;
10312 Default_Define_Function = define_public_function;
10313 Lang_Defining_Function = 0;
10314 Function_Args_Number = 0;
10315 Local_Variable_Number = 0;
10316 Locals_NameSpace = NULL;
10317 Current_Function = NULL;
10318 Current_Function_Header = NULL;
10319
10320 This_Static_NameSpace = NULL; /* allocated by caller-- here for completeness */
10321 This_Private_NameSpace = NULL; /* allocated by caller-- here for completeness */
10322 return 0;
10323 }
10324
10325 /* Error handling */
unset_interrupt_state(VOID_STAR maskp)10326 static int unset_interrupt_state (VOID_STAR maskp)
10327 {
10328 Handle_Interrupt &= ~(*(int *)maskp);
10329 return 0;
10330 }
10331
set_interrupt_state(VOID_STAR maskp)10332 static int set_interrupt_state (VOID_STAR maskp)
10333 {
10334 Handle_Interrupt |= *(int *)maskp;
10335 return 0;
10336 }
10337
interpreter_error_hook(int set)10338 static void interpreter_error_hook (int set)
10339 {
10340 int mask = INTERRUPT_ERROR;
10341 if (set)
10342 (void) _pSLsig_block_and_call (set_interrupt_state, (VOID_STAR) &mask);
10343 else
10344 (void) _pSLsig_block_and_call (unset_interrupt_state, (VOID_STAR) &mask);
10345 }
10346
10347 #if SLANG_HAS_SIGNALS
_pSLang_signal_interrupt(void)10348 void _pSLang_signal_interrupt (void)
10349 {
10350 int mask = INTERRUPT_SIGNAL;
10351 (void) _pSLsig_block_and_call (set_interrupt_state, (VOID_STAR)&mask);
10352 }
10353
10354 #define CHECK_SIGNALS_NOT_REENTRANT 0
check_signals(void)10355 static int check_signals (void)
10356 {
10357 #if CHECK_SIGNALS_NOT_REENTRANT
10358 static volatile int inprogress = 0;
10359 #endif
10360 int nargs = SLang_Num_Function_Args;
10361 int nnargs = Next_Function_Num_Args;
10362 int bc, r, br;
10363 int status;
10364
10365 if (0 == (Handle_Interrupt & INTERRUPT_SIGNAL))
10366 return 0;
10367 #if CHECK_SIGNALS_NOT_REENTRANT
10368 if (inprogress)
10369 return 0;
10370 inprogress = 1;
10371 #endif
10372 bc = Lang_Break_Condition; r = Lang_Return; br = Lang_Break;
10373 status = 0;
10374 /* The race condition that may be here can be ignored as long
10375 * as the Handle_Interrupt variable is modified before the
10376 * call to _pSLinterp_handle_signals.
10377 */
10378 Handle_Interrupt &= ~INTERRUPT_SIGNAL;
10379 if (-1 == _pSLsig_handle_signals ())
10380 status = -1;
10381
10382 SLang_Num_Function_Args = nargs;
10383 Next_Function_Num_Args = nnargs;
10384 Lang_Break = br; Lang_Return = r; Lang_Break_Condition = bc;
10385 #if CHECK_SIGNALS_NOT_REENTRANT
10386 inprogress = 0;
10387 #endif
10388 return status;
10389 }
10390
_pSLang_check_signals_hook(VOID_STAR unused)10391 int _pSLang_check_signals_hook (VOID_STAR unused)
10392 {
10393 (void) unused;
10394 (void) check_signals ();
10395 if (_pSLang_Error)
10396 return -1;
10397 return 0;
10398 }
10399
10400 #endif /* SLANG_HAS_SIGNALS */
10401
free_stacks(void)10402 static void free_stacks (void)
10403 {
10404 /* SLfree can grok NULLs */
10405 SLfree ((char *)Num_Args_Stack); Num_Args_Stack = NULL;
10406 SLfree ((char *)Run_Stack); Run_Stack = NULL;
10407 SLfree ((char *)Num_Args_Stack); Num_Args_Stack = NULL;
10408 SLfree ((char *)Frame_Pointer_Stack); Frame_Pointer_Stack = NULL;
10409 #if SLANG_HAS_QUALIFIERS
10410 SLfree ((char *)Function_Qualifiers_Stack); Function_Qualifiers_Stack = NULL;
10411 #endif
10412 SLfree ((char *)Local_Variable_Stack); Local_Variable_Stack = NULL;
10413 }
10414
delete_interpreter(void)10415 static void delete_interpreter (void)
10416 {
10417 if (Run_Stack != NULL)
10418 {
10419 /* Allow any object destructors to run */
10420 while (Stack_Pointer != Run_Stack)
10421 {
10422 SLdo_pop ();
10423 }
10424 }
10425
10426 SLang_restart (0);
10427
10428 while ((This_Compile_Block_Type != COMPILE_BLOCK_TYPE_NONE)
10429 && (0 == _pSLcompile_pop_context ()))
10430 ;
10431
10432 _pSLns_delete_namespaces ();
10433 free_stacks ();
10434 }
10435
init_interpreter(void)10436 static int init_interpreter (void)
10437 {
10438 SLang_NameSpace_Type *ns;
10439
10440 if (Global_NameSpace != NULL)
10441 return 0;
10442
10443 free_stacks ();
10444
10445 _pSLinterpreter_Error_Hook = interpreter_error_hook;
10446
10447 if (NULL == (ns = _pSLns_new_namespace (NULL, SLGLOBALS_HASH_TABLE_SIZE)))
10448 return -1;
10449 if (-1 == _pSLns_set_namespace_name (ns, "Global"))
10450 return -1;
10451 Global_NameSpace = ns;
10452
10453 Run_Stack = (SLang_Object_Type *) SLcalloc (SLANG_MAX_STACK_LEN,
10454 sizeof (SLang_Object_Type));
10455 if (Run_Stack == NULL)
10456 goto return_error;
10457
10458 Stack_Pointer = Run_Stack;
10459 Stack_Pointer_Max = Run_Stack + SLANG_MAX_STACK_LEN;
10460
10461 Num_Args_Stack = (int *) _SLcalloc (SLANG_MAX_RECURSIVE_DEPTH, sizeof(int));
10462 if (Num_Args_Stack == NULL)
10463 goto return_error;
10464
10465 Recursion_Depth = 0;
10466 Frame_Pointer_Stack = (unsigned int *) _SLcalloc (SLANG_MAX_RECURSIVE_DEPTH, sizeof(unsigned int));
10467 if (Frame_Pointer_Stack == NULL)
10468 goto return_error;
10469 Frame_Pointer_Depth = 0;
10470 Frame_Pointer = Run_Stack;
10471
10472 Local_Variable_Stack = (SLang_Object_Type *) _SLcalloc (SLANG_MAX_LOCAL_STACK, sizeof(SLang_Object_Type));
10473 if (Local_Variable_Stack == NULL)
10474 goto return_error;
10475 Local_Variable_Frame = Local_Variable_Stack;
10476 Local_Variable_Stack_Max = Local_Variable_Stack + SLANG_MAX_LOCAL_STACK;
10477
10478 #if SLANG_HAS_QUALIFIERS
10479 Function_Qualifiers_Stack = (SLang_Struct_Type **) SLcalloc (SLANG_MAX_RECURSIVE_DEPTH, sizeof (SLang_Struct_Type *));
10480 if (Function_Qualifiers_Stack == NULL)
10481 goto return_error;
10482 #endif
10483
10484 Function_Stack = (Function_Stack_Type *) _SLcalloc (SLANG_MAX_RECURSIVE_DEPTH, sizeof (Function_Stack_Type));
10485 if (Function_Stack == NULL)
10486 goto return_error;
10487
10488 Function_Stack_Ptr = Function_Stack;
10489 /* Function_Stack_Ptr_Max = Function_Stack_Ptr + SLANG_MAX_RECURSIVE_DEPTH; */
10490
10491 (void) setup_default_compile_linkage (1);
10492 if (-1 == SLang_add_cleanup_function (delete_interpreter))
10493 goto return_error;
10494
10495 return 0;
10496
10497 return_error:
10498 free_stacks ();
10499 return -1;
10500 }
10501
add_generic_table(SLang_NameSpace_Type * ns,SLang_Name_Type * table,SLFUTURE_CONST char * pp_name,unsigned int entry_len)10502 static int add_generic_table (SLang_NameSpace_Type *ns,
10503 SLang_Name_Type *table, SLFUTURE_CONST char *pp_name,
10504 unsigned int entry_len)
10505 {
10506 SLang_Name_Type *t, **ns_table;
10507 SLFUTURE_CONST char *name;
10508 unsigned int table_size;
10509
10510 if (-1 == init_interpreter ())
10511 return -1;
10512
10513 if (ns == NULL)
10514 ns = Global_NameSpace;
10515
10516 if ((pp_name != NULL)
10517 && (-1 == SLdefine_for_ifdef (pp_name)))
10518 return -1;
10519
10520 ns_table = ns->table;
10521 table_size = ns->table_size;
10522
10523 t = table;
10524 while (NULL != (name = t->name))
10525 {
10526 unsigned long hash;
10527
10528 /* Backward compatibility: '.' WAS used as hash marker */
10529 if (*name == '.')
10530 {
10531 name++;
10532 t->name = name;
10533 }
10534
10535 if (-1 == _pSLcheck_identifier_syntax (name))
10536 return -1;
10537
10538 if (NULL == (name = SLang_create_slstring (name)))
10539 return -1;
10540
10541 t->name = name;
10542
10543 hash = SLcompute_string_hash (name);
10544 hash = hash % table_size;
10545
10546 /* First time. Make sure this has not already been added */
10547 if (t == table)
10548 {
10549 SLang_Name_Type *tt = ns_table[(unsigned int) hash];
10550 while (tt != NULL)
10551 {
10552 if (tt == t)
10553 {
10554 _pSLang_verror (SL_APPLICATION_ERROR,
10555 "An intrinsic symbol table may not be added twice. [%s]",
10556 pp_name == NULL ? "" : pp_name);
10557 return -1;
10558 }
10559 tt = tt->next;
10560 }
10561 }
10562
10563 t->next = ns_table [(unsigned int) hash];
10564 ns_table [(unsigned int) hash] = t;
10565
10566 t = (SLang_Name_Type *) ((char *)t + entry_len);
10567 }
10568
10569 return 0;
10570 }
10571
10572 /* FIXME: I should add code to make sure that the objects in, e.g., an iconstant table
10573 * have sizeof(int).
10574 */
SLadd_intrin_fun_table(SLang_Intrin_Fun_Type * tbl,SLFUTURE_CONST char * pp)10575 int SLadd_intrin_fun_table (SLang_Intrin_Fun_Type *tbl, SLFUTURE_CONST char *pp)
10576 {
10577 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type));
10578 }
10579
SLadd_intrin_var_table(SLang_Intrin_Var_Type * tbl,SLFUTURE_CONST char * pp)10580 int SLadd_intrin_var_table (SLang_Intrin_Var_Type *tbl, SLFUTURE_CONST char *pp)
10581 {
10582 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type));
10583 }
10584
SLadd_app_unary_table(SLang_App_Unary_Type * tbl,SLFUTURE_CONST char * pp)10585 int SLadd_app_unary_table (SLang_App_Unary_Type *tbl, SLFUTURE_CONST char *pp)
10586 {
10587 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type));
10588 }
10589
_pSLadd_arith_unary_table(SLang_Arith_Unary_Type * tbl,SLFUTURE_CONST char * pp)10590 int _pSLadd_arith_unary_table (SLang_Arith_Unary_Type *tbl, SLFUTURE_CONST char *pp)
10591 {
10592 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Arith_Unary_Type));
10593 }
10594
_pSLadd_arith_binary_table(SLang_Arith_Binary_Type * tbl,SLFUTURE_CONST char * pp)10595 int _pSLadd_arith_binary_table (SLang_Arith_Binary_Type *tbl, SLFUTURE_CONST char *pp)
10596 {
10597 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Arith_Binary_Type));
10598 }
10599
SLadd_math_unary_table(SLang_Math_Unary_Type * tbl,SLFUTURE_CONST char * pp)10600 int SLadd_math_unary_table (SLang_Math_Unary_Type *tbl, SLFUTURE_CONST char *pp)
10601 {
10602 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type));
10603 }
10604
SLadd_iconstant_table(SLang_IConstant_Type * tbl,SLFUTURE_CONST char * pp)10605 int SLadd_iconstant_table (SLang_IConstant_Type *tbl, SLFUTURE_CONST char *pp)
10606 {
10607 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type));
10608 }
10609
SLadd_lconstant_table(SLang_LConstant_Type * tbl,SLFUTURE_CONST char * pp)10610 int SLadd_lconstant_table (SLang_LConstant_Type *tbl, SLFUTURE_CONST char *pp)
10611 {
10612 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_LConstant_Type));
10613 }
10614
10615 #if SLANG_HAS_FLOAT
SLadd_dconstant_table(SLang_DConstant_Type * tbl,SLFUTURE_CONST char * pp)10616 int SLadd_dconstant_table (SLang_DConstant_Type *tbl, SLFUTURE_CONST char *pp)
10617 {
10618 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type));
10619 }
SLadd_fconstant_table(SLang_FConstant_Type * tbl,SLFUTURE_CONST char * pp)10620 int SLadd_fconstant_table (SLang_FConstant_Type *tbl, SLFUTURE_CONST char *pp)
10621 {
10622 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_FConstant_Type));
10623 }
10624 #endif
10625 #ifdef HAVE_LONG_LONG
SLadd_llconstant_table(SLang_LLConstant_Type * tbl,SLFUTURE_CONST char * pp)10626 int SLadd_llconstant_table (SLang_LLConstant_Type *tbl, SLFUTURE_CONST char *pp)
10627 {
10628 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (SLang_LLConstant_Type));
10629 }
_pSLadd_llconstant_table(_pSLang_LLConstant_Type * tbl,SLFUTURE_CONST char * pp)10630 int _pSLadd_llconstant_table (_pSLang_LLConstant_Type *tbl, SLFUTURE_CONST char *pp)
10631 {
10632 return add_generic_table (NULL, (SLang_Name_Type *) tbl, pp, sizeof (_pSLang_LLConstant_Type));
10633 }
10634 #endif
10635
10636 /* ----------- */
SLns_add_intrin_fun_table(SLang_NameSpace_Type * ns,SLang_Intrin_Fun_Type * tbl,SLFUTURE_CONST char * pp)10637 int SLns_add_intrin_fun_table (SLang_NameSpace_Type *ns, SLang_Intrin_Fun_Type *tbl, SLFUTURE_CONST char *pp)
10638 {
10639 if ((ns == NULL) || (ns == (Global_NameSpace)))
10640 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Fun_Type));
10641
10642 if ((pp != NULL)
10643 && (-1 == SLdefine_for_ifdef (pp)))
10644 return -1;
10645
10646 while (tbl->name != NULL)
10647 {
10648 if (-1 == add_intrinsic_function (ns, tbl->name, tbl->i_fun,
10649 tbl->return_type, tbl->num_args,
10650 tbl->arg_types))
10651 return -1;
10652 tbl++;
10653 }
10654 return 0;
10655 }
10656
SLns_add_intrin_var_table(SLang_NameSpace_Type * ns,SLang_Intrin_Var_Type * tbl,SLFUTURE_CONST char * pp)10657 int SLns_add_intrin_var_table (SLang_NameSpace_Type *ns, SLang_Intrin_Var_Type *tbl, SLFUTURE_CONST char *pp)
10658 {
10659 if ((ns == NULL) || (ns == Global_NameSpace))
10660 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Intrin_Var_Type));
10661
10662 if ((pp != NULL)
10663 && (-1 == SLdefine_for_ifdef (pp)))
10664 return -1;
10665
10666 while (tbl->name != NULL)
10667 {
10668 if (-1 == SLns_add_intrinsic_variable (ns, tbl->name, tbl->addr, tbl->type, tbl->name_type == SLANG_RVARIABLE))
10669 return -1;
10670
10671 tbl++;
10672 }
10673 return 0;
10674 }
10675
SLns_add_app_unary_table(SLang_NameSpace_Type * ns,SLang_App_Unary_Type * tbl,SLFUTURE_CONST char * pp)10676 int SLns_add_app_unary_table (SLang_NameSpace_Type *ns, SLang_App_Unary_Type *tbl, SLFUTURE_CONST char *pp)
10677 {
10678 if ((ns == NULL) || (ns == (Global_NameSpace)))
10679 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_App_Unary_Type));
10680
10681 if ((pp != NULL)
10682 && (-1 == SLdefine_for_ifdef (pp)))
10683 return -1;
10684
10685 while (tbl->name != NULL)
10686 {
10687 SLang_App_Unary_Type *a;
10688
10689 a = (SLang_App_Unary_Type *)add_xxx_helper (ns, tbl->name, SLANG_APP_UNARY, sizeof(SLang_App_Unary_Type));
10690 if (a == NULL)
10691 return -1;
10692 a->unary_op = tbl->unary_op;
10693 tbl++;
10694 }
10695 return 0;
10696 }
10697
SLns_add_math_unary_table(SLang_NameSpace_Type * ns,SLang_Math_Unary_Type * tbl,SLFUTURE_CONST char * pp)10698 int SLns_add_math_unary_table (SLang_NameSpace_Type *ns, SLang_Math_Unary_Type *tbl, SLFUTURE_CONST char *pp)
10699 {
10700 if ((ns == NULL) || (ns == (Global_NameSpace)))
10701 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_Math_Unary_Type));
10702
10703 if ((pp != NULL)
10704 && (-1 == SLdefine_for_ifdef (pp)))
10705 return -1;
10706
10707 while (tbl->name != NULL)
10708 {
10709 SLang_Math_Unary_Type *a;
10710
10711 a = (SLang_Math_Unary_Type *)add_xxx_helper (ns, tbl->name, SLANG_MATH_UNARY, sizeof(SLang_Math_Unary_Type));
10712 if (a == NULL)
10713 return -1;
10714 a->unary_op = tbl->unary_op;
10715 tbl++;
10716 }
10717 return 0;
10718 }
10719
SLns_add_hconstant_table(SLang_NameSpace_Type * ns,SLang_HConstant_Type * tbl,SLFUTURE_CONST char * pp)10720 int SLns_add_hconstant_table (SLang_NameSpace_Type *ns, SLang_HConstant_Type *tbl, SLFUTURE_CONST char *pp)
10721 {
10722 if ((ns == NULL) || (ns == (Global_NameSpace)))
10723 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_HConstant_Type));
10724
10725 if ((pp != NULL)
10726 && (-1 == SLdefine_for_ifdef (pp)))
10727 return -1;
10728
10729 while (tbl->name != NULL)
10730 {
10731 if (-1 == SLns_add_hconstant (ns, tbl->name, tbl->data_type, tbl->value))
10732 return -1;
10733 tbl++;
10734 }
10735 return 0;
10736 }
10737
SLns_add_iconstant_table(SLang_NameSpace_Type * ns,SLang_IConstant_Type * tbl,SLFUTURE_CONST char * pp)10738 int SLns_add_iconstant_table (SLang_NameSpace_Type *ns, SLang_IConstant_Type *tbl, SLFUTURE_CONST char *pp)
10739 {
10740 if ((ns == NULL) || (ns == (Global_NameSpace)))
10741 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_IConstant_Type));
10742
10743 if ((pp != NULL)
10744 && (-1 == SLdefine_for_ifdef (pp)))
10745 return -1;
10746
10747 while (tbl->name != NULL)
10748 {
10749 if (-1 == SLns_add_iconstant (ns, tbl->name, tbl->data_type, tbl->value))
10750 return -1;
10751 tbl++;
10752 }
10753 return 0;
10754 }
10755
SLns_add_lconstant_table(SLang_NameSpace_Type * ns,SLang_LConstant_Type * tbl,SLFUTURE_CONST char * pp)10756 int SLns_add_lconstant_table (SLang_NameSpace_Type *ns, SLang_LConstant_Type *tbl, SLFUTURE_CONST char *pp)
10757 {
10758 if ((ns == NULL) || (ns == (Global_NameSpace)))
10759 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_LConstant_Type));
10760
10761 if ((pp != NULL)
10762 && (-1 == SLdefine_for_ifdef (pp)))
10763 return -1;
10764
10765 while (tbl->name != NULL)
10766 {
10767 if (-1 == SLns_add_lconstant (ns, tbl->name, tbl->data_type, tbl->value))
10768 return -1;
10769 tbl++;
10770 }
10771 return 0;
10772 }
10773
10774 #ifdef HAVE_LONG_LONG
_pSLns_add_llconstant_table(SLang_NameSpace_Type * ns,_pSLang_LLConstant_Type * tbl,SLFUTURE_CONST char * pp)10775 int _pSLns_add_llconstant_table (SLang_NameSpace_Type *ns, _pSLang_LLConstant_Type *tbl, SLFUTURE_CONST char *pp)
10776 {
10777 if ((ns == NULL) || (ns == (Global_NameSpace)))
10778 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (_pSLang_LLConstant_Type));
10779
10780 if ((pp != NULL)
10781 && (-1 == SLdefine_for_ifdef (pp)))
10782 return -1;
10783
10784 while (tbl->name != NULL)
10785 {
10786 if (-1 == _pSLns_add_llconstant (ns, tbl->name, tbl->data_type, tbl->value))
10787 return -1;
10788 tbl++;
10789 }
10790 return 0;
10791 }
10792 #endif
10793
10794 #if SLANG_HAS_FLOAT
SLns_add_dconstant_table(SLang_NameSpace_Type * ns,SLang_DConstant_Type * tbl,SLFUTURE_CONST char * pp)10795 int SLns_add_dconstant_table (SLang_NameSpace_Type *ns, SLang_DConstant_Type *tbl, SLFUTURE_CONST char *pp)
10796 {
10797 if ((ns == NULL) || (ns == (Global_NameSpace)))
10798 return add_generic_table (ns, (SLang_Name_Type *) tbl, pp, sizeof (SLang_DConstant_Type));
10799
10800 if ((pp != NULL)
10801 && (-1 == SLdefine_for_ifdef (pp)))
10802 return -1;
10803
10804 while (tbl->name != NULL)
10805 {
10806 if (-1 == SLns_add_dconstant (ns, tbl->name, tbl->d))
10807 return -1;
10808 tbl++;
10809 }
10810 return 0;
10811 }
10812 #endif
10813
setup_default_compile_linkage(int is_public)10814 static int setup_default_compile_linkage (int is_public)
10815 {
10816 if (is_public)
10817 {
10818 Default_Define_Function = define_public_function;
10819 Default_Variable_Mode = compile_public_variable_mode;
10820 }
10821 else
10822 {
10823 Default_Define_Function = define_static_function;
10824 Default_Variable_Mode = compile_static_variable_mode;
10825 }
10826
10827 return 0;
10828 }
10829
10830 /* what is a bitmapped value:
10831 * 1 intrin fun
10832 * 2 user fun
10833 * 4 intrin var
10834 * 8 user defined var
10835 */
_pSLang_apropos(SLFUTURE_CONST char * namespace_name,SLFUTURE_CONST char * pat,unsigned int what)10836 SLang_Array_Type *_pSLang_apropos (SLFUTURE_CONST char *namespace_name, SLFUTURE_CONST char *pat, unsigned int what)
10837 {
10838 SLang_NameSpace_Type *ns;
10839
10840 if (namespace_name == NULL)
10841 namespace_name = "Global";
10842
10843 if (*namespace_name == 0)
10844 ns = This_Static_NameSpace;
10845 else ns = _pSLns_find_namespace (namespace_name);
10846
10847 return _pSLnspace_apropos (ns, pat, what);
10848 }
10849
10850 /* An anonymous namespace in one in which the private and static objects share
10851 * the same namespace. This function causes a new namespace to be created or
10852 * an existing one used, and where the static objects will be placed. The
10853 * private objects will continue using the private namespace.
10854 */
implements_ns(SLFUTURE_CONST char * namespace_name)10855 static int implements_ns (SLFUTURE_CONST char *namespace_name)
10856 {
10857 SLang_NameSpace_Type *ns;
10858 SLFUTURE_CONST char *name;
10859
10860 if (-1 == _pSLns_check_name (namespace_name))
10861 return -1;
10862
10863 if ((This_Private_NameSpace == NULL) || (This_Static_NameSpace == NULL))
10864 {
10865 /* This error should never happen */
10866 _pSLang_verror (SL_INTERNAL_ERROR, "No namespace available");
10867 return -1;
10868 }
10869 name = This_Private_NameSpace->name;
10870
10871 if (NULL != (ns = _pSLns_find_namespace (namespace_name)))
10872 {
10873 /* If it exists but is associated with the private namespace, the it is ok */
10874 if (ns->name != name)
10875 {
10876 _pSLang_verror (SL_Namespace_Error, "Namespace %s already exists", namespace_name);
10877 return -1;
10878 }
10879 }
10880 return setup_compile_namespaces (name, namespace_name);
10881 }
10882
_pSLang_implements_intrinsic(SLFUTURE_CONST char * name)10883 void _pSLang_implements_intrinsic (SLFUTURE_CONST char *name)
10884 {
10885 (void) implements_ns (name);
10886 }
10887
_pSLang_use_namespace_intrinsic(char * name)10888 void _pSLang_use_namespace_intrinsic (char *name)
10889 {
10890 SLang_NameSpace_Type *ns;
10891
10892 if (NULL == (ns = _pSLns_find_namespace (name)))
10893 {
10894 _pSLang_verror (SL_Namespace_Error, "Namespace %s does not exist", name);
10895 return;
10896 }
10897 This_Static_NameSpace = ns;
10898 (void) setup_default_compile_linkage (ns == Global_NameSpace);
10899 }
10900
_pSLang_cur_namespace(void)10901 static SLang_NameSpace_Type *_pSLang_cur_namespace (void)
10902 {
10903 if (This_Static_NameSpace == NULL)
10904 return Global_NameSpace;
10905
10906 if (This_Static_NameSpace->namespace_name == NULL)
10907 return NULL;
10908
10909 return This_Static_NameSpace;
10910 }
10911
_pSLang_cur_namespace_intrinsic(void)10912 SLFUTURE_CONST char *_pSLang_cur_namespace_intrinsic (void)
10913 {
10914 SLang_NameSpace_Type *ns = _pSLang_cur_namespace ();
10915 if (ns == NULL)
10916 return "";
10917 return ns->namespace_name;
10918 }
10919
_pSLang_current_function_name(void)10920 SLCONST char *_pSLang_current_function_name (void)
10921 {
10922 if (Current_Function == NULL)
10923 return NULL;
10924
10925 return Current_Function->name;
10926 }
10927
_pSLang_get_run_stack_pointer(void)10928 SLang_Object_Type *_pSLang_get_run_stack_pointer (void)
10929 {
10930 return Stack_Pointer;
10931 }
10932
_pSLang_get_run_stack_base(void)10933 SLang_Object_Type *_pSLang_get_run_stack_base (void)
10934 {
10935 return Run_Stack;
10936 }
10937
_pSLang_dump_stack(void)10938 int _pSLang_dump_stack (void) /*{{{*/
10939 {
10940 char buf[32];
10941 unsigned int n;
10942
10943 n = (unsigned int) (Stack_Pointer - Run_Stack);
10944 while (n)
10945 {
10946 n--;
10947 sprintf (buf, "(%u)", n);
10948 _pSLdump_objects (buf, Run_Stack + n, 1, 1);
10949 }
10950 return 0;
10951 }
10952
10953 /*}}}*/
10954
_pSLang_is_arith_type(SLtype t)10955 int _pSLang_is_arith_type (SLtype t)
10956 {
10957 return (int) IS_ARITH_TYPE(t);
10958 }
_pSLang_set_arith_type(SLtype t,unsigned char v)10959 void _pSLang_set_arith_type (SLtype t, unsigned char v)
10960 {
10961 if (t < 256)
10962 Is_Arith_Type_Array[t] = v;
10963 }
10964
10965 #if SLANG_HAS_DEBUGGER_SUPPORT
_pSLang_use_frame_namespace(int depth)10966 void _pSLang_use_frame_namespace (int depth)
10967 {
10968 Function_Stack_Type s;
10969 if (-1 == get_function_stack_info (depth, &s))
10970 return;
10971
10972 This_Static_NameSpace = s.static_ns;
10973 This_Private_NameSpace = s.private_ns;
10974 (void) setup_default_compile_linkage (s.static_ns == Global_NameSpace);
10975 }
10976 #endif
10977