1 /*---------------------------------------------------------------------------
2 * Closure compiler and functions; including the switch() code generation.
3 *
4 *---------------------------------------------------------------------------
5 * Closures implement the possibility to treat code as data. This means
6 * both 'function pointers' (efun, simul-efun and lfun closures) as well
7 * as functions compiled from data at runtime (lambda closures).
8 *
9 * The data for closures are stored in two places: in T_CLOSURE-svalues and
10 * in additional lambda structures. The exact type of the closure is
11 * stored in the secondary type of the svalue, the x.closure_type.
12 * Depending on this closure type, the data part of the svalue (union u)
13 * holds additional data or not.
14 *
15 * operator closure: type = CLOSURE_OPERATOR (-0x1800) + instr
16 * These are the closures for the LPC operators (e.g. #'&& or #'?).
17 * The 'instr' is usually the machine instruction implementing
18 * the operator (see lex::symbol_operator() for the exact mapping).
19 * u.ob is the object this closure is bound to.
20 *
21 * efun closure: type = CLOSURE_EFUN (-0x1000) + instr
22 * These are the closures for the LPC efuns (e.g. #'atan or #'call_other).
23 * The 'instr' is usually the machine instruction implementing
24 * the efun (see lex::symbol_efun() for the exact mapping).
25 * u.ob is the object this closure is bound to.
26 *
27 * operator and efun closure could be implemented using the same number
28 * range because the use of unique machine instructions guarantees no
29 * value collision. This way however makes distinguishing the two cases
30 * easier.
31 *
32 * simul-efun closure: type = CLOSURE_SIMUL_EFUN (-0x0800) + index
33 * These are the closures for the simul-efuns. The 'index' is the
34 * the index of the simul-efun in the function table of the simul-efun
35 * object.
36 * u.ob is the object this closure is bound to.
37 *
38 * lfun closure: type = CLOSURE_LFUN (0)
39 * Reference to a lfun in an object.
40 * u.lambda points to the lambda structure with the detailed data.
41 *
42 * identifier closure: type = CLOSURE_IDENTIFIER (1)
43 * Reference to a variable in this object.
44 * u.lambda points to the lambda structure with the detailed data.
45 *
46 * preliminary closure: type = CLOSURE_PRELIMINARY (2)
47 * TODO: ???
48 *
49 * bound lambda closure: type = CLOSURE_BOUND_LAMBDA (3)
50 * This is an unbound lambda closure which was bound to an object.
51 * To allow binding the same unbound lambda to different objects
52 * at the same time, this construct uses a double indirection:
53 * u.lambda points to a lambda structure with the binding information,
54 * which then points to the actual unbound lambda structure.
55 *
56 * lambda closure: type = CLOSURE_LAMBDA (4)
57 * Lambda closure bound to an object at compilation time.
58 * u.lambda points to the lambda structure with the compiled function.
59 *
60 * unbound lambda closure: type = CLOSURE_UNBOUND_LAMBDA (5)
61 * Unbound lambda closure, which is not bound to any object at
62 * compile time.
63 * u.lambda points to the lambda structure with the compiled function.
64 *
65 *
66 * The additional information for closure are stored in structures
67 * of type lambda_s, which are refcounted. For lambda closures the lambda
68 * structure is in fact embedded in the middle of a larger memory block:
69 * it is prepended by an array of the svalues used as constants in
70 * the function, and followed by the actual function code.
71 *
72 * struct lambda_s
73 * {
74 * svalue_t values[] (lambda closures only)
75 * For lambda closures, the constant values used by the function
76 * which are indexed from the end ((svalue_t*)lambda_t).
77 * p_int ref;
78 * object_t *ob;
79 * Object the closure is bound to (for bound UNBOUND_LAMBDAs just
80 * during the execution of the lambda).
81 * union --- Closure information ---
82 * {
83 * unsigned short var_index;
84 * _IDENTIFIER: index in the variable table
85 * Function indices are lower than CLOSURE_IDENTIFIER_OFFS
86 * (0xe800), variable indices are higher.
87 * The special value VANISHED_VARCLOSURE_INDEX (-1) is
88 * used to mark vanished variables.
89 *
90 * struct -- CLOSURE_LFUN
91 * {
92 * object_t *ob;
93 * Originating object
94 * unsigned short index
95 * Index in the objects function table
96 * } lfun;
97 *
98 * bytecode_t code[1];
99 * LAMBDA and UNBOUND_LAMBDA closures: the function code.
100 * The first bytes are:
101 * +0: uint8 num_values
102 * +1: uint8 num_args
103 * +2: uint8 num_vars
104 * +3...: the function code
105 * 'num_values' is the number of constants store before
106 * the lambda structure. If it is 0xff, the actual number
107 * is stored in .values[-0x100].u.number.
108 *
109 * lambda_t *lambda;
110 * BOUND_LAMBDA: pointer to the UNBOUND_LAMBDA structure.
111 *
112 * } function;
113 *
114 * svalue_t context[.lfun.context_size];
115 * lfun-closure context variables, if any.
116 * Putting this array into the function.lfun somehow causes memory
117 * corruption because some lambda structures won't be allocated large
118 * enough.
119 * }
120 *
121 *
122 * If a lambda() is compiled while replace_program() is scheduled, the
123 * construction information is stored in the protector and the lambda
124 * is recompiled when the program replacement is put into place.
125 *
126 *
127 * To handle lambda closures, two more svalue types are needed:
128 *
129 * Symbols (T_SYMBOL svalue)
130 * Symbols are names to be used as variable names.
131 * The name is stored as shared string in u.string, the number
132 * of quotes is stored in x.quotes.
133 * If the number of quotes is reduced to 0, the lambda compiler
134 * will find/create a local variable with this name.
135 *
136 * Quoted Arrays (T_QUOTED_ARRAY svalue)
137 * Quoted arrays are needed to put array literals into lambda
138 * closures which usually treat arrays as code.
139 * u.vec is the reference to the array, x.quotes the number
140 * of quotes.
141 *---------------------------------------------------------------------------
142 */
143
144 #include "driver.h"
145 #include "typedefs.h"
146
147 #include "my-alloca.h"
148 #include <stdarg.h>
149 #include <stddef.h>
150 #include <stdio.h>
151
152 #include "closure.h"
153 #include "array.h"
154 #include "backend.h"
155 #include "exec.h"
156 #include "instrs.h"
157 #include "interpret.h"
158 #include "lex.h"
159 #include "main.h"
160 #include "mstrings.h"
161 #include "object.h"
162 #include "prolang.h"
163 #include "simulate.h"
164 #include "simul_efun.h"
165 #include "stdstrings.h"
166 #ifdef USE_STRUCTS
167 #include "structs.h"
168 #endif /* USE_STRUCTS */
169 #include "svalue.h"
170 #include "swap.h"
171 #include "switch.h"
172 #include "xalloc.h"
173
174 #ifdef USE_NEW_INLINES
175 #include "i-svalue_cmp.h"
176 #endif /* USE_NEW_INLINES */
177
178 /*-------------------------------------------------------------------------*/
179
180 #define MAX_LAMBDA_LEVELS 0x8000;
181 /* Maximum recursion depth for compile_value.
182 */
183
184 #define SYMTAB_START_SIZE 16
185 /* Initial number of entries in the work_area.symbols table.
186 */
187
188 #define CODE_BUFFER_START_SIZE 1024
189 /* Initial size of the work_area codebuffer.
190 */
191
192 #define VALUE_START_MAX 0x20
193 /* Initial number of value entries in the work_area.values table.
194 */
195
196 /* Flags passed to resp. returned by compile_value().
197 * They must fit into one bytecode_t (the #'? needs that)
198 */
199 #define ZERO_ACCEPTED 0x01 /* in: a return value of zero need not be coded */
200 #define VOID_ACCEPTED 0x02 /* in: any return value can be left out */
201 #define VOID_GIVEN 0x04 /* out: no return value given */
202 #define NEGATE_ACCEPTED 0x08 /* in: Caller accepts a reversed logic result */
203 #define NEGATE_GIVEN 0x10 /* out: Result is in reversed logic */
204 #define REF_REJECTED 0x20 /* in: lvalues not accepted */
205
206 #define VOID_WANTED (ZERO_ACCEPTED | VOID_ACCEPTED | NEGATE_ACCEPTED)
207 /* all "don't care for the result" flags.
208 */
209
210
211 /* Flags passed to compile_lvalue()
212 */
213 #define USE_INDEX_LVALUE 0x1 /* Use INDEX_LVALUE instead of PUSH_INDEX_LVALUE */
214 #define PROTECT_LVALUE 0x2 /* Protect the generated lvalue */
215
216
217 #define UNIMPLEMENTED \
218 lambda_error("Unimplemented - contact the maintainer\n");
219 /* Guess :-)
220 */
221
222 /*-------------------------------------------------------------------------*/
223 /* Types */
224
225 typedef struct symbol_s symbol_t;
226 typedef struct work_area_s work_area_t;
227
228
229 /* --- struct lambda_replace_program_protecter ---
230 *
231 * If closures are bound to objects for which a program replacement
232 * has been scheduled, a list of these structures, one for each closure,
233 * is kept in replace_ob_s.lambda_rpp to hold the necessary information
234 * to adjust the closures after the program has been replaced.
235 *
236 * The list is created by calls to lambda_ref_replace_program() and evaluated
237 * in lambda_replace_program_adjust().
238 */
239
240 struct lambda_replace_program_protector
241 {
242 struct lambda_replace_program_protector *next; /* The list link */
243 svalue_t l; /* The closure bound, counted as reference */
244 p_int size; /* 0, or for lambda()s the number of parameters in .args */
245 vector_t *args; /* If .size != 0: the parameter array of a lambda() */
246 svalue_t block; /* If .size != 0: the lambda() body */
247 };
248
249
250 /* --- struct symbol_s: Symbolentry ---
251 *
252 * All encountered local symbols (arguments and variables) are stored using
253 * this structure in a hashed symbol table in the work_area.
254 */
255
256 struct symbol_s
257 {
258 string_t *name; /* Tabled name of the symbol (not counted as ref) */
259 symbol_t *next; /* Next symbol structure in hash list */
260 symbol_t *next_local;
261 int index; /* Index number of this symbol, -1 if unassigned */
262 };
263
264
265 /* --- struct work_area_s: Information for the lambda compilation ---
266 *
267 * This structure holds all the information for a lambda compilation.
268 * In theory this allows nested compilations, but this feature hasn't been
269 * implemented yet.
270 */
271
272 struct work_area_s
273 {
274 symbol_t **symbols; /* Dynamic ashtable of lists of symbols */
275 mp_int symbol_max; /* Allocated size of .symbols in byte */
276 mp_int symbol_mask; /* Mask hashvalue -> .symbols index */
277 mp_int symbols_left;
278 /* Size(!) of symbols left to enter into .symbols before the table
279 * has to be enlarged.
280 */
281 bytecode_p code;
282 /* Memory block for the generated code, filled from the beginning */
283 bytecode_p codep; /* First free bytecode in .code */
284 mp_int code_max; /* Size of .code in byte */
285 mp_int code_left; /* Unused .code left in byte */
286 svalue_t *values;
287 /* Memory block for the values, filled from the end */
288 svalue_t *valuep; /* Last value assigned in .values */
289 mp_int value_max; /* Size of *.values in entries */
290 mp_int values_left; /* Number of unused values */
291 mp_int num_locals; /* Number of local vars, including args */
292 mp_int levels_left;
293 object_t *lambda_origin; /* Object the lambda will be bound to */
294 int break_stack; /* Current size of the break stack */
295 int max_break_stack; /* Max size of the break stack */
296 };
297 /* TODO: Use a pooled allocator for the memory held by the work_area (or
298 * TODO:: all workareas?)
299 */
300
301 /*-------------------------------------------------------------------------*/
302 /* Variables for the switch() code generator */
303
304 static Bool switch_initialized;
305 /* TRUE if the case_blocks/case_state variables are valid.
306 * Set to FALSE whenever a new lambda is compiled.
307 */
308
309 case_state_t case_state;
310 /* State of the current switch generation.
311 */
312
313 static case_list_entry_t *case_blocks = NULL;
314 static case_list_entry_t *case_blocks_last = NULL;
315 /* List of allocated case_list_entry_t blocks, freed in free_symbols().
316 * The blocks are arrays [CASE_BLOCKING_FACTOR] of case_list_entry_t's,
317 * and the first entry is used to link the blocks.
318 * The blocks are used from the beginning, case_state.free_block points
319 * the currently used block. There may be blocks following .free_block
320 * which were generated during the compilation of nested switch()es.
321 */
322
323 static case_list_entry_t *save_case_free_block;
324 static case_list_entry_t *save_case_next_free;
325 static case_list_entry_t *save_case_list0;
326 static case_list_entry_t *save_case_list1;
327 /* Saved case_state entries .free_block, .next_free, .list0, .list1
328 * from a LPC compilation. This happens when lambda() is called during
329 * a compile, e.g. from an LPC error handler.
330 * These values are too restored in free_symbols().
331 */
332
333 /*-------------------------------------------------------------------------*/
334 /* Lambda compiler variables */
335
336 static work_area_t current
337 = { 0, 0, 0, 0, 0, 0 };
338 /* The current (and in this implementation only) work area.
339 */
340
341 /*-------------------------------------------------------------------------*/
342 /* Forward declarations */
343
344 static void lambda_error VARPROT((const char *error_str, ...), printf, 1, 2) NORETURN;
345 static void lambda_cerror(const char *s) FORMATDEBUG(printf,1,0) NORETURN;
346 static void lambda_cerrorl(const char *s1, const char *s2 UNUSED, int line1 UNUSED,
347 int line2 UNUSED) NORETURN FORMATDEBUG(printf,1,0);
348 static void free_symbols(void);
349 static Bool is_lvalue (svalue_t *argp, int index_lvalue);
350 static void compile_lvalue(svalue_t *, int);
351 static lambda_t * lambda (vector_t *args, svalue_t *block, object_t *origin);
352
353 /*-------------------------------------------------------------------------*/
354 static INLINE int
function_cmp(const string_t * name,const program_t * prog,int ix)355 function_cmp (const string_t *name, const program_t *prog, int ix)
356
357 /* Compare <name> with the name of function number <ix> in <prog>ram.
358 * Result: 0: <name> is equal to the indexed name
359 * >0: <name> is smaller
360 * <0: <name> is bigger
361 *
362 * Note that both names are directly tabled strings, so only the pointers are
363 * compared.
364 */
365
366 {
367 funflag_t flags;
368
369 /* Set ix to the memory offset for the (possibly inherited) function
370 * function.
371 */
372 ix = prog->function_names[ix];
373 flags = prog->functions[ix];
374 while (flags & NAME_INHERITED)
375 {
376 inherit_t *inheritp;
377
378 inheritp = &prog->inherit[flags & INHERIT_MASK];
379 prog = inheritp->prog;
380 ix -= inheritp->function_index_offset;
381 flags = prog->functions[ix];
382 }
383
384 /* Return the result of the comparison */
385 /* Compare the two pointers.
386 * The comparison operation has to match the one in prolang.y:epilog().
387 */
388 return memcmp( &name, FUNCTION_NAMEP(prog->program + (flags & FUNSTART_MASK))
389 , sizeof name
390 );
391 } /* function_cmp() */
392
393 /*-------------------------------------------------------------------------*/
394 long
find_function(const string_t * name,const program_t * prog)395 find_function (const string_t *name, const program_t *prog)
396
397 /* Find the function <name> (a shared string) in the <prog>ram.
398 * Result is the index of the function in the functions[] table,
399 * or -1 if the function hasn't been found.
400 */
401 {
402 int i, o, d; /* Testindex, Partitionsize, Comparisonresult */
403 int size; /* Number of functions */
404
405 if ( !(size = prog->num_function_names) )
406 return -1;
407
408 /* A simple binary search */
409 i = size >> 1;
410 o = (i+2) >> 1;
411 for (;;)
412 {
413 d = function_cmp(name, prog, i);
414 if (d<0)
415 {
416 i -= o;
417 if (i < 0)
418 {
419 i = 0;
420 }
421 }
422 else if (d > 0)
423 {
424 i += o;
425 if (i >= size)
426 {
427 i = size-1;
428 }
429 }
430 else
431 {
432 return prog->function_names[i];
433 }
434
435 if (o <= 1)
436 {
437 if (function_cmp(name, prog, i))
438 return -1;
439 return prog->function_names[i];
440 }
441 o = (o+1) >> 1;
442 }
443
444 /* NOTREACHED */
445 return -1;
446 } /* find_function() */
447
448 /*-------------------------------------------------------------------------*/
449 Bool
closure_eq(svalue_t * left,svalue_t * right)450 closure_eq (svalue_t * left, svalue_t * right)
451
452 /* Compare the two closure svalues <left> and <right> and return TRUE if
453 * they refer to the same closure.
454 */
455
456 {
457 int i;
458
459 /* Operator, Efun and Simul efun closures don't have a .u.lambda
460 * part.
461 */
462 i = left->x.generic == right->x.generic;
463
464 if (i
465 && ( left->x.closure_type >= 0
466 || right->x.closure_type >= 0)
467 )
468 i = left->u.lambda == right->u.lambda;
469
470 /* Lfun- and identifier closure can be equal even if
471 * their pointers differ.
472 */
473 if (!i
474 && left->x.closure_type == right->x.closure_type
475 && ( left->x.closure_type == CLOSURE_LFUN
476 || left->x.closure_type == CLOSURE_IDENTIFIER
477 )
478 && left->u.lambda->ob == right->u.lambda->ob
479 )
480 {
481 if (left->x.closure_type == CLOSURE_LFUN)
482 {
483 i = ( left->u.lambda->function.lfun.ob
484 == right->u.lambda->function.lfun.ob)
485 && ( left->u.lambda->function.lfun.index
486 == right->u.lambda->function.lfun.index)
487 && ( left->u.lambda->function.lfun.inhProg
488 == right->u.lambda->function.lfun.inhProg)
489 && ( left->u.lambda->function.lfun.context_size
490 == right->u.lambda->function.lfun.context_size)
491 ;
492
493 #ifdef USE_NEW_INLINES
494 if (i)
495 {
496 unsigned int context_size, ix;
497
498 /* There might be a difference is in the context svalues.
499 * To prevent recursion, hide them while comparing them.
500 */
501
502 context_size = left->u.lambda->function.lfun.context_size;
503 left->u.lambda->function.lfun.context_size = 0;
504 right->u.lambda->function.lfun.context_size = 0;
505
506 for (ix = 0; i && ix < context_size; ix++)
507 {
508 i = svalue_eq( &(left->u.lambda->context[ix])
509 , &(right->u.lambda->context[ix])
510 );
511 }
512
513 /* Restore the context size.
514 */
515 left->u.lambda->function.lfun.context_size = context_size;
516 right->u.lambda->function.lfun.context_size = context_size;
517 }
518 #endif /* USE_NEW_INLINES */
519 }
520 else /* CLOSURE_IDENTIFIER */
521 {
522 i = left->u.lambda->function.var_index
523 == right->u.lambda->function.var_index;
524 }
525 }
526
527 return (Bool)i;
528 } /* closure_eq() */
529
530 /*-------------------------------------------------------------------------*/
531 int
closure_cmp(svalue_t * left,svalue_t * right)532 closure_cmp (svalue_t * left, svalue_t * right)
533
534 /* Compare the two closure svalues <left> and <right> and return a value
535 * describing their relation:
536 * -1: <left> is 'smaller' than <right>
537 * 0: the closures are equal
538 * 1: <left> is 'greater' than <right>
539 */
540
541 {
542 if (closure_eq(left, right)) return 0;
543
544 /* First comparison criterium is the closure_type */
545 if (left->x.closure_type != right->x.closure_type)
546 {
547 return (left->x.closure_type < right->x.closure_type) ? -1 : 1;
548 }
549
550 /* The types are identical and determine the next comparison.
551 * For lfun/identifier closure, we compare the actual closure data,
552 * for other closures a comparison of the lambda pointer is sufficient.
553 */
554 if (left->x.closure_type == CLOSURE_IDENTIFIER
555 || left->x.closure_type == CLOSURE_LFUN
556 )
557 {
558 if (left->u.lambda->ob != right->u.lambda->ob)
559 {
560 return (left->u.lambda->ob < right->u.lambda->ob) ? -1 : 1;
561 }
562
563 if (left->x.closure_type == CLOSURE_LFUN)
564 {
565 #ifdef USE_NEW_INLINES
566 unsigned context_size, i;
567 int d;
568 #endif /* USE_NEW_INLINES */
569
570 if ( left->u.lambda->function.lfun.ob
571 != right->u.lambda->function.lfun.ob)
572 {
573 return ( left->u.lambda->function.lfun.ob
574 < right->u.lambda->function.lfun.ob)
575 ? -1 : 1;
576 }
577
578 if ( left->u.lambda->function.lfun.index
579 != right->u.lambda->function.lfun.index
580 )
581 return ( left->u.lambda->function.lfun.index
582 < right->u.lambda->function.lfun.index)
583 ? -1 : 1;
584
585 if ( left->u.lambda->function.lfun.inhProg
586 != right->u.lambda->function.lfun.inhProg
587 )
588 return ( left->u.lambda->function.lfun.inhProg
589 < right->u.lambda->function.lfun.inhProg)
590 ? -1 : 1;
591
592 #ifdef USE_NEW_INLINES
593 /* The difference is in the context svalues.
594 * To prevent recursion, hide them while comparing them.
595 */
596 if ( left->u.lambda->function.lfun.context_size
597 != right->u.lambda->function.lfun.context_size
598 )
599 return ( left->u.lambda->function.lfun.context_size
600 < right->u.lambda->function.lfun.context_size)
601 ? -1 : 1;
602
603 context_size = left->u.lambda->function.lfun.context_size;
604 left->u.lambda->function.lfun.context_size = 0;
605 right->u.lambda->function.lfun.context_size = 0;
606
607 for (i = 0, d = 0; d == 0 && i < context_size; i++)
608 {
609 d = svalue_cmp( &(left->u.lambda->context[i])
610 , &(right->u.lambda->context[i])
611 );
612 }
613
614 /* Restore the context size, the return the comparison
615 * result in d.
616 */
617 left->u.lambda->function.lfun.context_size = context_size;
618 right->u.lambda->function.lfun.context_size = context_size;
619
620 return d;
621 #else
622 return 0; /* Shouldn't be reached */
623 #endif /* USE_NEW_INLINES */
624 }
625 else /* CLOSURE_IDENTIFIER */
626 {
627 /* This is the only field left, so it is guaranteed to differ */
628 return ( left->u.lambda->function.var_index
629 < right->u.lambda->function.var_index)
630 ? -1 : 1;
631 }
632 }
633
634 /* Normal closure: compare the lambda pointers */
635 return (left->u.lambda < right->u.lambda) ? -1 : 1;
636 } /* closure_cmp() */
637
638 /*-------------------------------------------------------------------------*/
639 Bool
lambda_ref_replace_program(object_t * curobj,lambda_t * l,int type,p_int size,vector_t * args,svalue_t * block)640 lambda_ref_replace_program( object_t * curobj, lambda_t *l, int type
641 , p_int size, vector_t *args, svalue_t *block)
642
643 /* The lambda <l> of type <type> is about to be bound to the object <curobj>
644 * which might be scheduled for program replacement.
645 * If that is the case, a(nother) protector is added to replace_ob_s.lambda_rpp
646 * and the function returns TRUE. Otherwise the function just returns FALSE.
647 *
648 * If <size> is not zero, it is the size of <args>, a vector with parameter
649 * descriptions for a lambda(), and <block> holds the body of the lambda().
650 * If <size> is zero, both <args> and <block> are undetermined.
651 */
652
653 {
654 replace_ob_t *r_ob;
655
656 /* Search for a program replacement scheduled for the current
657 * object.
658 */
659 for (r_ob = obj_list_replace; r_ob; r_ob = r_ob->next)
660 {
661 if (r_ob->ob == curobj)
662 {
663 /* Replacement found: add the protector */
664
665 struct lambda_replace_program_protector *lrpp;
666
667 l->ref++;
668 lrpp = xalloc(sizeof *lrpp);
669 lrpp->l.u.lambda = l;
670 lrpp->l.x.closure_type = (short)type;
671 lrpp->next = r_ob->lambda_rpp;
672 r_ob->lambda_rpp = lrpp;
673 if (size)
674 {
675 lrpp->size = size;
676 lrpp->args = ref_array(args);
677 assign_svalue_no_free(&lrpp->block, block);
678 }
679
680 return MY_TRUE;
681 }
682 } /* for() */
683
684 /* No replacement found: return false */
685 return MY_FALSE;
686 } /* lambda_ref_replace_program() */
687
688 /*-------------------------------------------------------------------------*/
689 void
set_closure_user(svalue_t * svp,object_t * owner)690 set_closure_user (svalue_t *svp, object_t *owner)
691
692 /* Set <owner> as the new user of the closure stored in <svp> if the closure
693 * is an operator-, sefun- or efun-closure, or if the closure is under
694 * construction ("preliminary"). Finished lambda closures can't be rebound.
695 *
696 * Sideeffect: for preliminary closures, the function also determines the
697 * proper svp->x.closure_type and updates the closures .function.index.
698 */
699
700 {
701 int type; /* Type of the closure */
702
703 if ( !CLOSURE_MALLOCED(type = svp->x.closure_type) )
704 {
705 /* Operator-, sefun-, efun-closure: just rebind */
706
707 free_object(svp->u.ob, "set_closure_user");
708 svp->u.ob = ref_object(owner, "set_closure_user");
709 }
710 else if (type == CLOSURE_PRELIMINARY)
711 {
712 /* lambda closure under construction: rebind, but take care
713 * of possible program replacement
714 */
715
716 int ix;
717 lambda_t *l;
718 funflag_t flags;
719 program_t *prog;
720
721 prog = owner->prog;
722 l = svp->u.lambda;
723 ix = l->function.lfun.index;
724
725 /* If the program is scheduled for replacement (or has been replaced),
726 * create the protector for the closure, otherwise mark the object
727 * as referenced by a lambda.
728 */
729 if ( !(prog->flags & P_REPLACE_ACTIVE)
730 || !lambda_ref_replace_program( owner, l
731 , ix >= CLOSURE_IDENTIFIER_OFFS
732 ? CLOSURE_IDENTIFIER
733 : CLOSURE_LFUN
734 , 0, NULL, NULL)
735 )
736 {
737 owner->flags |= O_LAMBDA_REFERENCED;
738 }
739
740 /* Set the svp->x.closure_type to the type of the closure. */
741
742 if (ix >= CLOSURE_IDENTIFIER_OFFS)
743 {
744 /* Identifier closure */
745 ix -= CLOSURE_IDENTIFIER_OFFS;
746 svp->x.closure_type = CLOSURE_IDENTIFIER;
747
748 /* Update the closure index */
749 l->function.var_index = (unsigned short)ix;
750 }
751 else
752 {
753 /* lfun closure. Be careful to handle cross-defined lfuns
754 * correctly.
755 */
756
757 flags = prog->functions[ix];
758 if (flags & NAME_CROSS_DEFINED)
759 {
760 ix += CROSSDEF_NAME_OFFSET(flags);
761 }
762 svp->x.closure_type = CLOSURE_LFUN;
763
764 /* Update the closure index */
765 l->function.lfun.ob = ref_object(owner, "closure");
766 l->function.lfun.index = (unsigned short)ix;
767 #ifdef USE_NEW_INLINES
768 l->function.lfun.context_size = 0;
769 #endif /* USE_NEW_INLINES */
770 }
771
772 /* (Re)Bind the closure */
773 free_object(l->ob, "closure");
774 l->ob = ref_object(owner, "set_closure_user");
775 }
776 } /* set_closure_user() */
777
778 /*-------------------------------------------------------------------------*/
779 void
replace_program_lambda_adjust(replace_ob_t * r_ob)780 replace_program_lambda_adjust (replace_ob_t *r_ob)
781
782 /* This function is called as the last step during the replacement of an
783 * object's program, but only if the object has been marked to hold
784 * closure references.
785 *
786 * The function is called in the backend context and catches errors during
787 * its execution.
788 */
789
790 {
791 static struct lambda_replace_program_protector *current_lrpp;
792 /* Copy of lrpp, static to survive errors */
793
794 struct lambda_replace_program_protector *lrpp;
795 /* Current protector */
796
797 struct lambda_replace_program_protector *next_lrpp;
798 /* Next protector */
799
800 struct error_recovery_info error_recovery_info;
801
802 /* Loop through the list of lambda protectors, adjusting
803 * the lfun closures. Vanished lfun closures are replaced by
804 * references to master::dangling_lfun_closure() if existing.
805 * Vanished identifier closures are marked with a special value
806 * and just vanish.
807 * TODO: Store the name somehow for error messages/sprintf/to_string?
808 *
809 * This is done first because these are possible building blocks.
810 */
811 lrpp = r_ob->lambda_rpp;
812 do {
813 if ( !CLOSURE_HAS_CODE(lrpp->l.x.closure_type) )
814 {
815 /* Yup, it's an lfun or identifier */
816
817 if (lrpp->l.x.closure_type == CLOSURE_LFUN)
818 {
819 lambda_t *l;
820 int i;
821
822 /* Adjust the index of the lfun
823 * If the lfun closure is a reference to an inherited
824 * program we need to check if the inheritance relation
825 * changes.
826 */
827 l = lrpp->l.u.lambda;
828
829 if (!l->function.lfun.inhProg)
830 i = l->function.lfun.index -= r_ob->fun_offset;
831 else if (l->function.lfun.inhProg == r_ob->new_prog)
832 {
833 /* First possibility: the new program is the same
834 * one the closure is pointing to.
835 * In that case, convert the closure into a straight
836 * lfun closure.
837 */
838
839 i = l->function.lfun.index -= r_ob->fun_offset;
840
841 free_prog(l->function.lfun.inhProg, MY_TRUE);
842 l->function.lfun.inhProg = NULL;
843 }
844 else if (l->function.lfun.index >= r_ob->fun_offset &&
845 l->function.lfun.index <
846 r_ob->fun_offset + r_ob->new_prog->num_functions)
847 {
848 program_t *prog;
849
850 /* Second possibility: the new program still
851 * inherits the program the closure is referencing.
852 * In that case, just update the inhIndex.
853 */
854
855 i = l->function.lfun.index -= r_ob->fun_offset;
856
857 /* Checkt hat inhProg is still in the inherit chain.
858 * If not, convert the closure into a straight
859 * lfun closure.
860 */
861
862 prog = r_ob->new_prog;
863
864 while(prog != l->function.lfun.inhProg)
865 {
866 inherit_t *inheritp;
867
868 if (!prog->num_inherited)
869 {
870 /* Didn't find it. */
871 l->function.lfun.inhProg = NULL;
872 break;
873 }
874
875 inheritp = search_function_inherit(prog, i);
876 i-= inheritp->function_index_offset;
877 prog = inheritp->prog;
878
879 if (i >= prog->num_functions)
880 {
881 /* We didn't find inhProg. */
882 l->function.lfun.inhProg = NULL;
883 break;
884 }
885 }
886
887 i = l->function.lfun.index;
888 }
889 else
890 i = -1;
891
892 /* If the function vanished, replace it with a default */
893 if (i < 0 || i >= r_ob->new_prog->num_functions)
894 {
895 assert_master_ob_loaded();
896 free_object( l->function.lfun.ob
897 , "replace_program_lambda_adjust");
898 if(l->function.lfun.inhProg)
899 free_prog(l->function.lfun.inhProg, MY_TRUE);
900
901 l->function.lfun.ob
902 = ref_object(master_ob
903 , "replace_program_lambda_adjust");
904 i = find_function( STR_DANGLING_LFUN
905 , master_ob->prog);
906 l->function.lfun.index = (unsigned short)(i < 0 ? 0 :i);
907 l->function.lfun.inhProg = NULL;
908 }
909 }
910 else /* CLOSURE_IDENTIFIER */
911 {
912 lambda_t *l;
913 int i;
914
915 /* Adjust the index of the identifier */
916 l = lrpp->l.u.lambda;
917 i = l->function.var_index -= r_ob->var_offset;
918
919 /* If it vanished, mark it as such */
920 if (i >= r_ob->new_prog->num_variables)
921 {
922 l->function.var_index = VANISHED_VARCLOSURE_INDEX;
923 /* TODO: This value should be properly publicized and
924 * TODO:: tested.
925 */
926 }
927 }
928 } /* if (!CLOSURE_HAS_CODE()) */
929 } while ( NULL != (lrpp = lrpp->next) );
930
931 /* Second pass: now adjust the lambda closures.
932 * This is done by recompilation of every closure and comparison
933 * with the original one. If the two closures differ, the closure
934 * references now-vanished entities and has to be abandoned.
935 *
936 * In such a case, an error is generated and also caught: the code
937 * for the closure is replaced by the instruction "undef" so that
938 * accidental executions are caught.
939 */
940
941 error_recovery_info.rt.last = rt_context;
942 error_recovery_info.rt.type = ERROR_RECOVERY_BACKEND;
943 rt_context = (rt_context_t *)&error_recovery_info.rt;
944 if (setjmp(error_recovery_info.con.text))
945 {
946 bytecode_p p;
947
948 lrpp = current_lrpp;
949
950 /* Replace the function with "undef" */
951 p = LAMBDA_CODE(lrpp->l.u.lambda->function.code);
952 p[0] = F_UNDEF;
953
954 /* Free the protector and all held values */
955 free_array(lrpp->args);
956 free_svalue(&lrpp->block);
957 free_closure(&lrpp->l);
958
959 next_lrpp = lrpp->next;
960 xfree(lrpp);
961
962 /* Restart the loop */
963 lrpp = next_lrpp;
964 }
965 else
966 /* Set lrpp to the first lambda to process.
967 * (Doing it here makes gcc happy).
968 */
969 lrpp = r_ob->lambda_rpp;
970
971
972 /* lrpp here is the next protector to handle, or NULL */
973
974 if (lrpp) do
975 {
976
977 /* If it's a lambda, adjust it */
978 if (lrpp->l.x.closure_type == CLOSURE_LAMBDA)
979 {
980 lambda_t *l, *l2; /* Original and recompiled closure */
981 svalue_t *svp, *svp2; /* Pointer to the two closure's values */
982 mp_int num_values, num_values2, code_size2;
983
984 current_lrpp = lrpp; /* in case an error occurs */
985
986 /* Remember the original lambda, and also recompile it */
987 l = lrpp->l.u.lambda;
988 l2 = lambda(lrpp->args, &lrpp->block, l->ob);
989
990 svp = (svalue_t *)l;
991 if ( (num_values = LAMBDA_NUM_VALUES(l->function.code)) == 0xff)
992 num_values = svp[-0x100].u.number;
993
994 svp2 = (svalue_t *)l2;
995 if ( (num_values2 = LAMBDA_NUM_VALUES(l2->function.code)) == 0xff)
996 num_values2 = svp2[-0x100].u.number;
997 code_size2 = current.code_max - current.code_left;
998
999 /* If the recompiled lambda differs from the original one, we
1000 * lose it.
1001 */
1002 if (num_values != num_values2 || lrpp->size != code_size2)
1003 {
1004 free_svalue(&lrpp->block);
1005
1006 /* lrpp->block will be freed after the error, so lets fake
1007 * a closure svalue and put the just-compiled closure in
1008 * there.
1009 */
1010 lrpp->block.type = T_CLOSURE;
1011 lrpp->block.x.closure_type = CLOSURE_UNBOUND_LAMBDA;
1012 lrpp->block.u.lambda = l2;
1013
1014 errorf("Cannot adjust lambda closure after replace_program(), "
1015 "object %s\n", get_txt(r_ob->ob->name));
1016 }
1017
1018 /* The recompiled lambda can be used (and has to: think changed
1019 * indices), so replace the original by the new one.
1020 * We have to keep the memory of the original one as other
1021 * code might already reference it.
1022 */
1023 while (--num_values >= 0)
1024 transfer_svalue(--svp, --svp2);
1025 memcpy(l->function.code, l2->function.code, (size_t)code_size2);
1026
1027 /* Free the (now empty) memory */
1028 if (l2->ob)
1029 free_object(l2->ob, "replace_program_lambda_adjust");
1030 if (l2->prog_ob)
1031 free_object(l2->prog_ob, "replace_program_lambda_adjust");
1032 xfree(svp2);
1033 free_array(lrpp->args);
1034 free_svalue(&lrpp->block);
1035 }
1036
1037 /* lambda or not, the protector is no longer needed */
1038 free_closure(&lrpp->l);
1039 next_lrpp = lrpp->next;
1040 xfree(lrpp);
1041
1042 } while ( NULL != (lrpp = next_lrpp) );
1043
1044 /* Restore the old error recovery info */
1045 rt_context = error_recovery_info.rt.last;
1046
1047 } /* replace_lambda_program_adjust() */
1048
1049 /*-------------------------------------------------------------------------*/
1050 void
closure_init_lambda(lambda_t * l,object_t * obj)1051 closure_init_lambda (lambda_t * l, object_t * obj)
1052
1053 /* Initialize the freshly created lambda <l> to be bound to object <obj>
1054 * (if given), and set the other generic fields (.ref, .prog_ob, .prog_pc).
1055 */
1056
1057 {
1058 l->ref = 1;
1059 if (current_prog)
1060 {
1061 l->prog_ob = ref_valid_object(current_prog->blueprint, "lambda creator");
1062 l->prog_pc = inter_pc - current_prog->program;
1063 }
1064 else
1065 {
1066 l->prog_ob = NULL;
1067 l->prog_pc = 0;
1068 }
1069
1070 if (obj)
1071 l->ob = ref_object(obj, "lambda object");
1072 else
1073 l->ob = NULL;
1074 } /* closure_init_lambda() */
1075
1076 /*-------------------------------------------------------------------------*/
1077 #ifndef USE_NEW_INLINES
1078 lambda_t *
closure_new_lambda(object_t * obj,Bool raise_error)1079 closure_new_lambda (object_t * obj, Bool raise_error)
1080 #else /* USE_NEW_INLINES */
1081 lambda_t *
1082 closure_new_lambda ( object_t * obj, unsigned short context_size
1083 , Bool raise_error)
1084 #endif /* USE_NEW_INLINES */
1085
1086 /* Create a basic lambda closure structure, suitable to hold <context_size>
1087 * context values, and bound to <obj>. The structure has the generic
1088 * fields (.ref, .ob, .prog_ob, .prog_pc) initialized.
1089 *
1090 * The function may raise an error on out of memory if <raise_error> is TRUE,
1091 * or just return NULL.
1092 */
1093
1094 {
1095 lambda_t *l;
1096
1097 /* Allocate a new lambda structure */
1098 #ifndef USE_NEW_INLINES
1099 l = xalloc(sizeof(*l));
1100 #else /* USE_NEW_INLINES */
1101 l = xalloc(SIZEOF_LAMBDA(context_size));
1102 #endif /* USE_NEW_INLINES */
1103 if (!l)
1104 {
1105 if (raise_error)
1106 {
1107 #ifndef USE_NEW_INLINES
1108 outofmem(sizeof(*l), "closure literal");
1109 #else /* USE_NEW_INLINES */
1110 outofmem(SIZEOF_LAMBDA(context_size)
1111 , "closure literal");
1112 #endif /* USE_NEW_INLINES */
1113 /* NOTREACHED */
1114 }
1115 return NULL;
1116 }
1117
1118 closure_init_lambda(l, obj);
1119
1120 return l;
1121 } /* closure_new_lambda() */
1122
1123 /*-------------------------------------------------------------------------*/
1124 void
closure_identifier(svalue_t * dest,object_t * obj,int ix,Bool raise_error)1125 closure_identifier (svalue_t *dest, object_t * obj, int ix, Bool raise_error)
1126
1127 /* Create a literal variable closure, bound to <obj> and with variable
1128 * index <ix>. The caller has to account for any variable offsets before
1129 * calling this function.
1130 *
1131 * The created closure is stored as new svalue into *<dest>.
1132 *
1133 * The function may raise an error on out of memory if <raise_error> is TRUE,
1134 * or set *<dest> to svalue 0 else.
1135 */
1136
1137 {
1138 lambda_t *l;
1139
1140 /* Allocate an initialise a new lambda structure */
1141 #ifndef USE_NEW_INLINES
1142 l = closure_new_lambda(obj, raise_error);
1143 #else /* USE_NEW_INLINES */
1144 l = closure_new_lambda(obj, 0, raise_error);
1145 #endif /* USE_NEW_INLINES */
1146 if (!l)
1147 {
1148 put_number(dest, 0);
1149 return;
1150 }
1151
1152 /* If the object's program will be replaced, store the closure
1153 * in lambda protector, otherwise mark the object as referenced by
1154 * a closure.
1155 */
1156 if ( !(obj->prog->flags & P_REPLACE_ACTIVE)
1157 || !lambda_ref_replace_program( obj, l, CLOSURE_IDENTIFIER
1158 , 0, NULL, NULL)
1159 )
1160 {
1161 obj->flags |= O_LAMBDA_REFERENCED;
1162 }
1163
1164 dest->x.closure_type = CLOSURE_IDENTIFIER;
1165 l->function.var_index = (unsigned short)ix;
1166
1167 /* Fill in the rest of the lambda and of the result svalue */
1168
1169 dest->type = T_CLOSURE;
1170 dest->u.lambda = l;
1171 } /* closure_identifier() */
1172
1173 /*-------------------------------------------------------------------------*/
1174 #ifndef USE_NEW_INLINES
1175 void
closure_lfun(svalue_t * dest,object_t * obj,program_t * prog,int ix,Bool raise_error)1176 closure_lfun ( svalue_t *dest, object_t *obj, program_t *prog, int ix
1177 , Bool raise_error)
1178 #else /* USE_NEW_INLINES */
1179 void
1180 closure_lfun ( svalue_t *dest, object_t *obj, program_t *prog, int ix
1181 , unsigned short num
1182 , Bool raise_error)
1183 #endif /* USE_NEW_INLINES */
1184
1185 /* Create a literal lfun closure, bound to the object <obj>. The resulting
1186 * svalue is stored in *<dest>.
1187 *
1188 * The closure is defined by the function index <ix>, for which the caller
1189 * has to make sure that all function offsets are applied before calling
1190 * this function. <ix> is relative to the object's program. <prog> is
1191 * the program used for the lookup of this function (but <ix> is nevertheless
1192 * the index into the object's function table, not neccessarily into the
1193 * function table of <prog>). <num> indicates the number of context variables
1194 * which are initialized to svalue-0.
1195 *
1196 * The function may raise an error on out of memory if <raise_error> is TRUE,
1197 * or set *<dest> to svalue 0 else.
1198 */
1199
1200 {
1201 lambda_t *l;
1202
1203 /* Allocate and initialise a new lambda structure */
1204 #ifndef USE_NEW_INLINES
1205 l = closure_new_lambda(obj, raise_error);
1206 #else /* USE_NEW_INLINES */
1207 l = closure_new_lambda(obj, num, raise_error);
1208 #endif /* USE_NEW_INLINES */
1209 if (!l)
1210 {
1211 put_number(dest, 0);
1212 return;
1213 }
1214
1215 /* If the object's program will be replaced, store the closure
1216 * in lambda protector, otherwise mark the object as referenced by
1217 * a closure.
1218 */
1219 if ( !(obj->prog->flags & P_REPLACE_ACTIVE)
1220 || !lambda_ref_replace_program( obj, l, CLOSURE_LFUN
1221 , 0, NULL, NULL)
1222 )
1223 {
1224 obj->flags |= O_LAMBDA_REFERENCED;
1225 }
1226
1227 dest->x.closure_type = CLOSURE_LFUN;
1228
1229 l->function.lfun.ob = ref_object(obj, "closure");
1230 l->function.lfun.index = (unsigned short)ix;
1231 l->function.lfun.inhProg = prog;
1232 if (prog)
1233 reference_prog(prog, "closure_lfun");
1234 #ifdef USE_NEW_INLINES
1235 l->function.lfun.context_size = num;
1236
1237 /* Init the context variables */
1238 while (num > 0)
1239 {
1240 num--;
1241 put_number(&(l->context[num]), 0);
1242 }
1243 #endif /* USE_NEW_INLINES */
1244
1245 /* Fill in the rest of the lambda and of the result svalue */
1246
1247 dest->type = T_CLOSURE;
1248 dest->u.lambda = l;
1249 } /* closure_lfun() */
1250
1251 /*-------------------------------------------------------------------------*/
1252 #ifndef USE_NEW_INLINES
1253 void
closure_literal(svalue_t * dest,int ix,unsigned short inhIndex)1254 closure_literal (svalue_t *dest, int ix, unsigned short inhIndex)
1255 #else /* USE_NEW_INLINES */
1256 void
1257 closure_literal ( svalue_t *dest
1258 , int ix, unsigned short inhIndex, unsigned short num)
1259 #endif /* USE_NEW_INLINES */
1260
1261 /* Create a literal closure (lfun or variable closure), bound to the
1262 * current object. The resulting svalue is stored in *<dest>. The function
1263 * implements the instruction F_CLOSURE.
1264 *
1265 * The closure is defined by the index <ix>/<inhIndex>, which is to be
1266 * interpreted in the context of the current, possibly inherited, program:
1267 * values < CLOSURE_IDENTIFIER_OFFS are lfun indices, values above are
1268 * variable indices. For closures referencing inherited lfuns <inhIndex>
1269 * is the index+1 in the inherit list of <prog>. For lfun closures, <num>
1270 * indicates the number context variables which are initialized to svalue-0.
1271 *
1272 * The function may raise an error on out of memory.
1273 */
1274
1275 {
1276
1277 if (ix >= CLOSURE_IDENTIFIER_OFFS)
1278 {
1279 ix += - CLOSURE_IDENTIFIER_OFFS
1280 + (current_variables - current_object->variables);
1281 /* the added difference takes into account that the
1282 * index is specified relative to the program which might
1283 * have been inherited.
1284 */
1285 closure_identifier(dest, current_object, ix, MY_TRUE);
1286 }
1287 else /* lfun closure */
1288 {
1289 funflag_t flags;
1290 program_t *prog;
1291
1292 if (inhIndex)
1293 {
1294 /* inherited lfun closure */
1295 inherit_t *inh, *vinh;
1296
1297 inh = ¤t_prog->inherit[inhIndex-1];
1298 /* Normalize pointers to functions of virtual inherits.
1299 * This is just for comparability of the closures.
1300 */
1301 vinh = adjust_variable_offsets(inh, current_prog, current_object);
1302 if (vinh)
1303 inh = vinh;
1304
1305 prog = inh->prog;
1306
1307 flags = prog->functions[ix];
1308 if (!vinh)
1309 ix += function_index_offset;
1310 ix += inh->function_index_offset;
1311 }
1312 else
1313 {
1314 ix += function_index_offset;
1315 flags = current_object->prog->functions[ix];
1316 prog = NULL;
1317 }
1318
1319 if (flags & NAME_CROSS_DEFINED)
1320 {
1321 ix += CROSSDEF_NAME_OFFSET(flags);
1322 }
1323
1324 #ifndef USE_NEW_INLINES
1325 closure_lfun(dest, current_object, prog, ix, MY_TRUE);
1326 #else
1327 closure_lfun(dest, current_object, prog, ix, num, MY_TRUE);
1328 #endif /* USE_NEW_INLINES */
1329 }
1330 } /* closure_literal() */
1331
1332 /*-------------------------------------------------------------------------*/
1333 static void
realloc_values(void)1334 realloc_values (void)
1335
1336 /* Double the size of the value block in the current workspace.
1337 * The function is called only when all values in the current block
1338 * have been assigned.
1339 *
1340 * Raise an error when out of memory.
1341 */
1342
1343 {
1344 mp_int new_max;
1345 svalue_t *new_values;
1346
1347 new_max = current.value_max * 2;
1348
1349 new_values = xalloc(new_max * sizeof(*new_values));
1350 if (!new_values)
1351 lambda_error("Out of memory (%"PRIdMPINT
1352 " bytes) for %"PRIdMPINT" new values\n",
1353 new_max, new_max * sizeof(*new_values));
1354
1355 current.values_left += current.value_max;
1356 memcpy( (current.valuep = new_values + current.value_max)
1357 , current.values
1358 , current.value_max * sizeof(*new_values)
1359 );
1360 xfree(current.values);
1361
1362 current.values = new_values;
1363 current.value_max = new_max;
1364 } /* realloc_values() */
1365
1366 /*-------------------------------------------------------------------------*/
1367 static void
realloc_code(void)1368 realloc_code (void)
1369
1370 /* Double the size of the code block in the current workspace.
1371 *
1372 * Raise an error when out of memory.
1373 */
1374
1375 {
1376 mp_int new_max;
1377 bytecode_p new_code;
1378 ptrdiff_t curr_offset;
1379
1380 curr_offset = current.codep - current.code;
1381
1382 new_max = current.code_max * 2;
1383 new_code = rexalloc(current.code, (size_t)new_max);
1384 if (!new_code)
1385 lambda_error("Out of memory (%"PRIdMPINT" bytes) for new code\n",
1386 new_max);
1387
1388 current.code_left += current.code_max;
1389 current.code_max = new_max;
1390 current.code = new_code;
1391 current.codep = current.code + curr_offset;
1392 } /* realloc_code() */
1393
1394 /*-------------------------------------------------------------------------*/
1395 static void
lambda_error(const char * error_str,...)1396 lambda_error(const char *error_str, ...)
1397
1398 /* Raise an errorf(error_str, ...) with 0 or 1 extra argument from within
1399 * the lambda compiler.
1400 *
1401 * The function takes care that all memory is deallocated.
1402 */
1403
1404 {
1405 va_list va;
1406
1407 /* Deallocate all memory held in the work_areas */
1408 free_symbols();
1409 if (current.code)
1410 xfree(current.code);
1411
1412 if (current.values)
1413 {
1414 mp_int num_values = current.value_max - current.values_left;
1415 svalue_t *svp;
1416
1417 for (svp = current.valuep; --num_values >= 0; )
1418 free_svalue(svp++);
1419 xfree(current.values);
1420 }
1421
1422 /* Now raise the error */
1423 va_start(va, error_str);
1424 errorf(error_str, va_arg(va, char *)); /* One arg or nothing :-) */
1425 /* TODO: a verror() would be handy here */
1426 va_end(va);
1427 } /* lambda_error() */
1428
1429 /*-------------------------------------------------------------------------*/
1430 static void
lambda_cerror(const char * s)1431 lambda_cerror (const char *s)
1432
1433 /* Callback for store_case_labels: raise an errorf(s) from within the
1434 * lambda compiler.
1435 *
1436 * The function takes care that all memory is deallocated.
1437 */
1438
1439 {
1440 lambda_error("%s\n", s);
1441 } /* lambda_cerror() */
1442
1443 /*-------------------------------------------------------------------------*/
1444 static void
lambda_cerrorl(const char * s1,const char * s2 UNUSED,int line1 UNUSED,int line2 UNUSED)1445 lambda_cerrorl ( const char *s1, const char *s2 UNUSED
1446 , int line1 UNUSED, int line2 UNUSED)
1447
1448 /* Callback for store_case_labels(): Raise an errorf(s1) from within the lambda
1449 * compiler. store_case_labels() also passes line numbers and filename, but
1450 * when compiling a lambda that information is not very useful.
1451 *
1452 * The function takes care that all memory is deallocated.
1453 */
1454
1455 {
1456 #ifdef __MWERKS__
1457 # pragma unused(s2,line1,line2)
1458 #endif
1459 lambda_error(s1, "\n");
1460 } /* lambda_errorl() */
1461
1462 /*-------------------------------------------------------------------------*/
1463 static bytecode_p
lambda_get_space(p_int size)1464 lambda_get_space (p_int size)
1465
1466 /* Callback for store_case_labels(): Make space for <size> bytes in the
1467 * current code space and return the pointer to the first byte.
1468 *
1469 * Internally this function reallocates the code space when necessary.
1470 */
1471
1472 {
1473 while (current.code_left < size)
1474 realloc_code();
1475 current.code_left -= size;
1476 current.codep += size;
1477 return current.codep - size;
1478 } /* lambda_get_space() */
1479
1480 /*-------------------------------------------------------------------------*/
1481 static void
lambda_move_switch_instructions(int len,p_int blocklen)1482 lambda_move_switch_instructions (int len, p_int blocklen)
1483
1484 /* Callback from store_case_labels(): Move the last instructions
1485 * of <blocklen> bytes forward by <len> bytes.
1486 */
1487
1488 {
1489 while (current.code_left < len)
1490 realloc_code();
1491 current.code_left -= len;
1492 current.codep += len;
1493 move_memory( current.codep - blocklen
1494 , current.codep - blocklen - len
1495 , (size_t)blocklen
1496 );
1497 } /* lambda_move_switch_instructions() */
1498
1499 /*-------------------------------------------------------------------------*/
1500 static void
free_symbols(void)1501 free_symbols (void)
1502
1503 /* Free the symbols in the current workarea, and also the memory allocated
1504 * for the case blocks.
1505 */
1506
1507 {
1508 p_int i;
1509 symbol_t **symp, *sym, *next;
1510
1511 /* Free the symbols */
1512 i = current.symbol_max;
1513 symp = current.symbols;
1514 do {
1515 for (sym = *symp++; sym; sym = next)
1516 {
1517 next = sym->next;
1518 xfree(sym);
1519 }
1520 } while (i -= sizeof sym);
1521
1522 xfree(current.symbols);
1523
1524 /* Clean up the memory for the case blocks */
1525 if (switch_initialized)
1526 {
1527 if (current_loc.file)
1528 {
1529 case_state.free_block = save_case_free_block;
1530 case_state.next_free = save_case_next_free;
1531 case_state.list0 = save_case_list0;
1532 case_state.list1 = save_case_list1;
1533 }
1534 else
1535 {
1536 free_case_blocks();
1537 }
1538 }
1539 } /* free_symbols() */
1540
1541 /*-------------------------------------------------------------------------*/
1542 static symbol_t *
make_symbol(string_t * name)1543 make_symbol (string_t *name)
1544
1545 /* Look up the symbol <name> in the current symbol table and return the
1546 * pointer to the symbol_t structure. If <name> is not yet in the table,
1547 * a new structure is generated, linked in, and returned.
1548 *
1549 * If necessary, the symbol table is enlarged.
1550 */
1551
1552 {
1553 p_int h;
1554 symbol_t *sym, **symp;
1555
1556 /* Hash the <name> pointer and look it up in the table.
1557 * TODO: This assumes 32-Bit ints.
1558 */
1559 h = (p_int)name;
1560 h ^= h >> 16;
1561 h ^= h >> 8;
1562 h ^= h >> 4;
1563
1564 h &= current.symbol_mask;
1565 symp = (symbol_t **)((char *)current.symbols + h);
1566 for (sym = *symp; sym; sym = sym->next)
1567 {
1568 if (sym->name == name)
1569 return sym;
1570 }
1571
1572 /* Not found: generate a new symbol entry and link it in */
1573 sym = xalloc(sizeof *sym);
1574 if (!sym)
1575 lambda_error("Out of memory (%lu bytes) for symbol\n"
1576 , (unsigned long) sizeof(*sym));
1577 sym->name = name;
1578 sym->index = -1;
1579 sym->next = *symp;
1580 *symp = sym;
1581
1582 /* Does the table has to be enlarged now? */
1583 if ( !(current.symbols_left -= sizeof sym) )
1584 {
1585 /* Yup. Double the size of the hashtable and re-hash all
1586 * existing entries.
1587 */
1588
1589 symbol_t **newtab, *sym2;
1590 p_int i;
1591
1592 sym2 = sym; /* Save the new entry */
1593
1594 /* Allocate the new table and initialize it */
1595 current.symbols_left = current.symbol_max;
1596 current.symbol_max *= 2;
1597 symp = newtab = xalloc((size_t)current.symbol_max);
1598 if (!symp) {
1599 current.symbol_max /= 2;
1600 xfree(sym);
1601 lambda_error("Out of memory (%"PRIdMPINT" bytes) for symbol table\n"
1602 , current.symbol_max);
1603 }
1604 current.symbol_mask = i = current.symbol_max - (long)sizeof sym;
1605 do {
1606 *symp++ = NULL;
1607 } while ((i -= sizeof sym) >= 0);
1608
1609 /* Loop over the old table and all entries and rehash them
1610 * into the new table.
1611 * TODO: Again the hash assumes 32-Bit-ints.
1612 */
1613 i = current.symbols_left - (long)sizeof sym;
1614 do {
1615 symbol_t *next;
1616
1617 for ( sym = *(symbol_t **)((char *)current.symbols+i)
1618 ; sym; sym = next)
1619 {
1620 next = sym->next;
1621 h = (p_int)sym->name;
1622 h ^= h >> 16;
1623 h ^= h >> 8;
1624 h ^= h >> 4;
1625 h &= current.symbol_mask;
1626 symp = (symbol_t **)((char *)newtab + h);
1627 sym->next = *symp;
1628 *symp = sym;
1629 }
1630 } while ((i -= sizeof sym) >= 0);
1631
1632 /* Put the new table in place of the old one */
1633 xfree(current.symbols);
1634 current.symbols = newtab;
1635
1636 sym = sym2; /* Restore the pointer to the new entry */
1637 }
1638
1639 /* Return the new entry */
1640 return sym;
1641 } /* make_symbol() */
1642
1643 /*-------------------------------------------------------------------------*/
1644 static void
insert_value_push(svalue_t * value)1645 insert_value_push (svalue_t *value)
1646
1647 /* Add the <value> to the value block of the closure, and insert
1648 * the appropriate F_LAMBDA_(C)CONSTANT instruction to the compiled
1649 * code.
1650 */
1651
1652 {
1653 mp_int offset; /* Index of the value in the value block */
1654
1655 if (current.code_left < 3)
1656 realloc_code();
1657
1658 offset = current.value_max - current.values_left;
1659 if (offset < 0xff)
1660 {
1661 /* Less than 255 values: the short instruction */
1662
1663 current.code_left -= 2;
1664 STORE_CODE(current.codep, F_LAMBDA_CCONSTANT);
1665 STORE_UINT8(current.codep, (unsigned char)offset);
1666 }
1667 else
1668 {
1669 /* More than 254 values: the long instruction */
1670
1671 if (offset == 0xff)
1672 {
1673 /* Offset #0xff will be used to hold the actual
1674 * number of values.
1675 */
1676 current.values_left--;
1677 offset++;
1678 (--current.valuep)->type = T_INVALID;
1679 }
1680 current.code_left -= 3;
1681 STORE_CODE(current.codep, F_LAMBDA_CONSTANT);
1682 STORE_SHORT(current.codep, offset);
1683 }
1684
1685 if (--current.values_left < 0)
1686 realloc_values();
1687
1688 /* Don't forget to copy the value itself */
1689 assign_svalue_no_free(--current.valuep, value);
1690 } /* insert_value_push() */
1691
1692 /*-------------------------------------------------------------------------*/
1693 static int
compile_value(svalue_t * value,int opt_flags)1694 compile_value (svalue_t *value, int opt_flags)
1695
1696 /* Compile the <value> into a closure in the context of the current
1697 * work_area. <opt_flags> gives additional instructions about what
1698 * to accept or reject. The generated code is appended to the code
1699 * buffer in the work_area, the function itself returns a flag whether
1700 * the code leaves a result on the stack or not.
1701 *
1702 * The function calls itself recursively for nested code sequences.
1703 *
1704 * <value> can be of these types:
1705 * array: a block of instructions in lisp-ish array notation.
1706 * quoted array: inserted as is with one quote less
1707 * symbol, 1 quote: resolved as local variable/argument
1708 * symbol, > 1 quote: inserted as symbol with one quote less
1709 * other: inserted as is
1710 */
1711
1712 {
1713 if (!--current.levels_left)
1714 lambda_error("Too deep recursion inside lambda()\n");
1715
1716 switch(value->type)
1717 {
1718 case T_POINTER: /* ----- T_POINTER ----- */
1719 {
1720 vector_t *block; /* The block of svalues to compile */
1721 svalue_t *argp; /* Pointer to the current svalue */
1722 ph_int type; /* Various types */
1723
1724 block = value->u.vec;
1725 argp = block->item;
1726 /* The first value must be a closure */
1727 if (block == &null_vector || argp->type != T_CLOSURE)
1728 {
1729 lambda_error("Missing function\n");
1730 }
1731
1732 if ( (type = argp->x.closure_type) < (ph_int)CLOSURE_SIMUL_EFUN)
1733 {
1734 /* Most common case: closure is an efun or an operator */
1735
1736 if (type < (ph_int)CLOSURE_EFUN)
1737 {
1738 /* Closure is an operator */
1739
1740 mp_int block_size; /* Number of entries */
1741
1742 block_size = (mp_int)VEC_SIZE(block);
1743 switch (type - CLOSURE_OPERATOR)
1744 {
1745 default:
1746 lambda_error("Unimplemented operator %s for lambda()\n",
1747 instrs[type - CLOSURE_OPERATOR].name);
1748
1749 /* ({ #'||, arg1, ..., argn })
1750 * ({ #'&&, arg1, ..., argn })
1751 */
1752 case F_LOR:
1753 case F_LAND:
1754 {
1755 /* For #'|| his is compiled into
1756 * <arg 1>
1757 * F_LAND end
1758 * <arg 2>
1759 * F_LAND end
1760 * ...
1761 * <arg n>
1762 * end:
1763 *
1764 * If only the logical result is needed (VOID_ACCEPTED),
1765 * F_LAND are replaced by F_BRANCH_ZERO. If the distance
1766 * to end is too big, the F_LANDs are compiled as:
1767 *
1768 * <arg i>
1769 * DUP
1770 * LBRANCH_ZERO end
1771 * POP
1772 * <arg i+1>
1773 *
1774 * respectively for the logical result:
1775 *
1776 * <arg i>
1777 * LBRANCH_ZERO end
1778 * <arg i+1>
1779 *
1780 * Analog for F_LOR, here the branches are on _NON_ZERO.
1781 */
1782 mp_int *branchp;
1783 /* Table storing the position of the branch/operator
1784 * instruction after every compiled argument.
1785 */
1786 mp_int i; /* most of the time: number of values left */
1787 mp_int start;
1788 mp_int end; /* first free code byte */
1789 Bool is_and; /* TRUE if the operator is F_LAND */
1790 int code; /* Compiled instruction */
1791 int void_given;
1792
1793 code = type - CLOSURE_OPERATOR;
1794 is_and = code == (F_LAND);
1795
1796 /* If the caller doesn't need a return value,
1797 * compile the operator as branches (much faster).
1798 */
1799 if (opt_flags & VOID_ACCEPTED)
1800 {
1801 code = is_and ? F_BRANCH_WHEN_ZERO
1802 : F_BRANCH_WHEN_NON_ZERO;
1803 opt_flags |= VOID_GIVEN;
1804 }
1805
1806 /* Generate the code for the arguments but the last one.
1807 * After every compiled argument, insert <code> and
1808 * an empty byte and store the position of the inserted
1809 * byte in the branchp table.
1810 */
1811 i = block_size - 1;
1812 branchp = alloca(i * sizeof *branchp);
1813 while (--i > 0) {
1814 compile_value(++argp, REF_REJECTED);
1815 if (current.code_left < 2)
1816 realloc_code();
1817 *branchp++ = current.code_max - current.code_left;
1818 current.code_left -= 2;
1819 PUT_CODE(current.codep, (bytecode_t)code);
1820 current.codep += 2;
1821 }
1822
1823 /* If i is != 0 here, no arguments were given.
1824 * In that case, fake a result, otherwise compile the
1825 * last argument.
1826 */
1827 if (i)
1828 void_given = compile_value(is_and ? &const1 : &const0
1829 , opt_flags & (VOID_ACCEPTED|REF_REJECTED)
1830 );
1831 else
1832 void_given = compile_value(++argp
1833 , opt_flags & (VOID_ACCEPTED|REF_REJECTED)
1834 );
1835
1836 /* If the caller accepts void, but we compiled a result,
1837 * remove it from the stack.
1838 */
1839 if (opt_flags & VOID_ACCEPTED && !(void_given & VOID_GIVEN))
1840 {
1841 if (current.code_left < 1)
1842 realloc_code();
1843 current.code_left--;
1844 STORE_CODE(current.codep, F_POP_VALUE);
1845 }
1846
1847 /* Walk backwards through the generated code segments
1848 * and store the correct offsets for the operator/branch
1849 * instructions. If necessary, the short branches are
1850 * converted into long ones.
1851 */
1852 i = block_size - 1;
1853 end = current.code_max - current.code_left;
1854 /* The target to jump to */
1855 while (--i > 0)
1856 {
1857 mp_int offset;
1858
1859 start = *--branchp;
1860 offset = end - start - 2;
1861 if (offset <= 0xff)
1862 {
1863 PUT_UINT8(current.code+start+1, (unsigned char)offset);
1864 continue;
1865 }
1866 else
1867 {
1868 /* We exceeded the limit of the short offsets.
1869 * Prepare the extension of the remaining offsets
1870 * to long offsets.
1871 */
1872
1873 mp_int growth; /* Additional bytes needed */
1874 int growth_factor; /* Additional byte per branch */
1875 mp_int j;
1876 bytecode_p p, q; /* Src/Dest for code copying */
1877
1878 if (opt_flags & VOID_ACCEPTED)
1879 {
1880 /* We don't need a result: just change the
1881 * short into long branches.
1882 */
1883 growth = i;
1884 growth_factor = 1;
1885 code = is_and ? F_LBRANCH_WHEN_ZERO
1886 : F_LBRANCH_WHEN_NON_ZERO;
1887 }
1888 else
1889 {
1890 /* We need a result: change the OP instructions
1891 * into OP/LBRANCH combinations.
1892 */
1893 growth = i * 3;
1894 growth_factor = 3;
1895 code = is_and ? F_LBRANCH_WHEN_ZERO
1896 : F_LBRANCH_WHEN_NON_ZERO;
1897 }
1898
1899 /* Prepare the copying of the code */
1900 if (current.code_left < growth)
1901 realloc_code();
1902 current.code_left -= growth;
1903 current.codep += growth;
1904 p = current.code + end;
1905 q = p + growth;
1906 end += growth_factor - 1;
1907 /* - 1 is precompensation for leading branch code */
1908 if ( !(opt_flags & VOID_ACCEPTED) )
1909 /* offset precompensation for leading F_DUP */
1910 end--;
1911
1912 /* Restart the walk through the branchpoints */
1913 branchp++;
1914 do {
1915 start = *--branchp;
1916 offset = end - start;
1917 end += growth_factor;
1918 if (offset > 0x7fff)
1919 UNIMPLEMENTED
1920
1921 /* Move the code from here back to the branch
1922 * point.
1923 */
1924 j = p - (bytecode_p)¤t.code[start+2];
1925 do {
1926 *--q = *--p;
1927 } while (--j);
1928
1929 /* Generate the new branch instructions instead
1930 * of copying the old.
1931 */
1932 p -= 2;
1933 if (opt_flags & VOID_ACCEPTED)
1934 {
1935 RSTORE_SHORT(q, offset);
1936 RSTORE_CODE(q, (bytecode_t)code);
1937 }
1938 else
1939 {
1940 RSTORE_CODE(q, F_POP_VALUE);
1941 RSTORE_SHORT(q, offset);
1942 RSTORE_CODE(q, (bytecode_t)code);
1943 RSTORE_CODE(q, F_DUP);
1944 }
1945 } while (--i > 0);
1946 break; /* outer while(), it's finished anyway */
1947 }
1948 } /* while(--i > 0); */
1949 break;
1950 }
1951
1952 /* ({#'?, expr, cond-part, ..., default-part })
1953 * ({#'?!, expr, cond-part, ..., default-part })
1954 */
1955 case F_BRANCH_WHEN_ZERO:
1956 case F_BRANCH_WHEN_NON_ZERO:
1957 {
1958 /* For #'? is compiled into:
1959 *
1960 * result required: no result required:
1961 *
1962 * <expr1> <expr1>
1963 * BRANCH_ZERO l1 BRANCH_ZERO l1
1964 * <cond1> <cond1>
1965 * BRANCH vd/nvd BRANCH vd/nvd
1966 * l1: <expr2> l1: <expr2>
1967 * BRANCH_ZERO l2 BRANCH_ZERO l2
1968 * <cond2> <cond2>
1969 * BRANCH vd/nvd BRANCH vd/nvd
1970 * l2: <expr3> l2: <expr3>
1971 * ... ...
1972 * ln-1: <exprn> ln-1: <exprn>
1973 * BRANCH_ZERO ln BRANCH_ZERO ln
1974 * <condn> <condn>
1975 * BRANCH vd/nvd BRANCH vd/nvd
1976 * ln: <default> ln: <default>
1977 * nvd: BRANCH +1 nvd: POP
1978 * vd: CONST0 vd:
1979 *
1980 * (vd: void_dest, nvd: non_void_dest)
1981 *
1982 * The branch conditions after every <expr> are reversed
1983 * for #'?! and/or if the <expr> returns a result in
1984 * reverse logic. And of course the F_BRANCHes are converted
1985 * into F_LBRANCHes where necessary.
1986 *
1987 * If <default> is required but not given, CONST0 is
1988 * inserted in its place. In that case, the branches from
1989 * <cond>s without a result are directed to that one CONST0
1990 * as well.
1991 *
1992 * There are few other ways to compile the end of the
1993 * sequence if no <default> is required and/or not given,
1994 * or if no result is required - they are explained
1995 * below.
1996 */
1997
1998 mp_int *branchp;
1999 /* Table storing two values for every argument pair: the
2000 * position after the cond-part and the position after
2001 * the cond. Yes, in reverse order.
2002 */
2003 mp_int i;
2004 mp_int start;
2005 mp_int end;
2006 mp_int void_dest; /* branch dest with no result */
2007 mp_int non_void_dest; /* branch dest with a result */
2008 Bool is_notif; /* TRUE if this is #'?! */
2009 int code; /* The instruction to compile to */
2010 int opt_used; /* Current compile() result */
2011 int all_void; /* !0 if cond-parts returns a value */
2012 mp_int last_branch; /* Position of branch after cond */
2013
2014 non_void_dest = 0;
2015 code = type - CLOSURE_OPERATOR;
2016 is_notif = (code == F_BRANCH_WHEN_NON_ZERO);
2017
2018 /* If the default part exists, is the number 0 or at least
2019 * has no side-effects, and if the caller accepts void/0
2020 * for an answer, it is not compiled as it won't have
2021 * any effect anyway.
2022 */
2023 if (!(block_size & 1)
2024 && (opt_flags & (VOID_ACCEPTED|ZERO_ACCEPTED))
2025 && ( opt_flags & VOID_ACCEPTED
2026 ? argp[block_size-1].type != T_POINTER /* no side effect */
2027 : argp[block_size-1].type == T_NUMBER
2028 && !argp[block_size-1].u.number
2029 ) )
2030 {
2031 /* Ignore the default-part by hiding it */
2032 block_size--;
2033 }
2034
2035 /* Generate the code for the (cond, cond-part) pairs,
2036 * and add the necessary branch instructions.
2037 * Also store the positions of the inserted code
2038 * in the branchp table.
2039 */
2040 i = block_size;
2041 branchp = alloca(i * sizeof *branchp);
2042 all_void = VOID_GIVEN;
2043 while ( (i -= 2) > 0)
2044 {
2045 mp_int offset;
2046
2047 /* Compile the condition and add the branch
2048 * to skip the cond-part.
2049 */
2050 opt_used = compile_value(++argp, NEGATE_ACCEPTED);
2051 if (current.code_left < 2)
2052 realloc_code();
2053 last_branch = current.code_max - current.code_left;
2054 current.code_left -= 2;
2055 if (opt_used & NEGATE_GIVEN)
2056 STORE_CODE(current.codep
2057 , (bytecode_t)
2058 (is_notif ? F_BRANCH_WHEN_ZERO
2059 : F_BRANCH_WHEN_NON_ZERO)
2060 );
2061 else
2062 STORE_CODE(current.codep, (bytecode_t)code);
2063 STORE_UINT8(current.codep, 0);
2064
2065 /* Compile the cond-part */
2066 ++argp;
2067 opt_used = compile_value(argp,
2068 (i == 1 && !all_void) ?
2069 opt_flags & REF_REJECTED :
2070 opt_flags &
2071 (VOID_ACCEPTED|ZERO_ACCEPTED|REF_REJECTED)
2072 );
2073 all_void &= opt_used;
2074 if (current.code_left < 4)
2075 realloc_code();
2076
2077 /* Now that we know the size of the cond-part, store
2078 * the branch offset into the branch instruction
2079 * before the cond-part.
2080 */
2081 offset =
2082 current.code_max - current.code_left - last_branch;
2083
2084 /* Make sure that the offset won't overflow
2085 * when incremented later during backpatching.
2086 */
2087 if (offset > 0xfe)
2088 {
2089 /* The cond-part was too big, we have to change
2090 * the 2-Byte F_BRANCH_ into an 3-Byte F_LBRANCH.
2091 */
2092 bytecode_p p;
2093 mp_int j;
2094
2095 /* Move the cond-part one byte forward */
2096 p = current.codep++;
2097 j = offset - 2;
2098 if (offset > 0x7ffd)
2099 UNIMPLEMENTED
2100 do {
2101 p--;
2102 p[1] = *p;
2103 } while (--j);
2104
2105 current.code_left--;
2106 if (current.code[last_branch] == F_BRANCH_WHEN_ZERO)
2107 PUT_CODE(current.code+last_branch
2108 , F_LBRANCH_WHEN_ZERO);
2109 else
2110 PUT_CODE(current.code+last_branch
2111 , F_LBRANCH_WHEN_NON_ZERO);
2112 PUT_SHORT(current.code+last_branch+1, offset+2);
2113 }
2114 else
2115 {
2116 /* The offset fits, just store it */
2117 PUT_UINT8(current.code+last_branch+1
2118 , (unsigned char)offset);
2119 }
2120
2121 /* Store the two branch positions */
2122 *branchp++ = current.code_max - current.code_left;
2123 *branchp++ = last_branch;
2124
2125 /* Add the unconditional branch. In place of the
2126 * offset we store the opt_used flags so that the
2127 * later backpatching run knows exactly what the cond-part
2128 * left on the stack.
2129 */
2130 current.code_left -= 2;
2131 STORE_CODE(current.codep, F_BRANCH);
2132 STORE_CODE(current.codep, (bytecode_t)opt_used);
2133 } /* while() */
2134 /* If i is not zero now, then there is no default part */
2135
2136 /* Now compile the default part.
2137 * There are a few conditions to distinguish...
2138 */
2139 if ( i /* no default */
2140 && ( opt_flags & VOID_ACCEPTED
2141 || (all_void && opt_flags & ZERO_ACCEPTED)
2142 ) )
2143 {
2144 /* There is no default part, and the caller doesn't
2145 * want a result or accepts a zero when we don't
2146 * have one.
2147 */
2148
2149 mp_int offset; /* corrective offset for the branch after
2150 * the last cond
2151 */
2152
2153 opt_flags |= VOID_GIVEN;
2154 if (all_void)
2155 {
2156 /* No cond-part returned a result, just remove
2157 * the last F_BRANCH.
2158 * The code sequence is therefore:
2159 *
2160 * <expr1>
2161 * BRANCH_ZERO l1
2162 * <cond1>
2163 * BRANCH end
2164 * l1: <expr2>
2165 * ...
2166 * ln-1: <exprn>
2167 * BRANCH_ZERO ln
2168 * <condn>
2169 * ln: end:
2170 */
2171 if (block_size < 2)
2172 {
2173 /* empty statement: all done */
2174 break; /* switch() */
2175 }
2176 offset = -2;
2177 void_dest =
2178 current.code_max - current.code_left - 2;
2179 }
2180 else
2181 {
2182 /* Some cond-parts returned a result: let them
2183 * jump to a POP statement.
2184 * The code sequence is therefore:
2185 *
2186 * <expr1>
2187 * BRANCH_ZERO l1
2188 * <cond1>
2189 * BRANCH vd/nvd
2190 * l1: <expr2>
2191 * ...
2192 * ln-1: <exprn>
2193 * BRANCH_ZERO ln
2194 * <condn>
2195 * nvd: POP
2196 * ln: vd:
2197 *
2198 * TODO: Uhm what if <condn> is void?
2199 */
2200 /* Terminating void after non-void is avoided */
2201 current.codep[-2] = F_POP_VALUE;
2202 offset = -1;
2203 non_void_dest =
2204 current.code_max - current.code_left - 2;
2205 void_dest = non_void_dest + 1;
2206 }
2207
2208 /* Now rewrite the BRANCH_ZERO ln according to offset */
2209
2210 start = *--branchp;
2211 code = GET_CODE(current.code+start);
2212 if (code == F_LBRANCH_WHEN_ZERO
2213 || code == F_LBRANCH_WHEN_NON_ZERO)
2214 {
2215 short old_offset;
2216
2217 GET_SHORT(old_offset, current.code+start+1);
2218 PUT_SHORT(current.code+start+1, old_offset+offset);
2219 }
2220 else
2221 {
2222 PUT_INT8(current.code+start+1
2223 , GET_INT8(current.code+start+1) + offset);
2224 }
2225
2226 /* Prepare for the backpatching run */
2227 current.codep += offset;
2228 current.code_left -= offset;
2229 branchp--;
2230 i = block_size - 2;
2231 }
2232 else
2233 {
2234 /* We may or may not have a default part, but
2235 * the caller expects a result.
2236 */
2237
2238 /* the following assignment is only valid if
2239 *
2240 * ( !all_void && i "no default" &&
2241 * ( (opt_flags & (VOID_ACCEPTED|ZERO_ACCEPTED)) ==
2242 * ZERO_ACCEPTED) )
2243 *
2244 * is met, and it is only needed when there is at
2245 * least one void expression, too.
2246 * However, it's easier to do the assignment
2247 * all the time, and it does no harm here.
2248 * The effect is that the 'const0' default synthesized
2249 * will be used as result from the cond-part, too.
2250 */
2251 void_dest = current.code_max - current.code_left;
2252
2253 /* Compile the default part */
2254 opt_used = compile_value(
2255 i ? &const0 : ++argp,
2256 opt_flags &
2257 ( all_void ?
2258 (VOID_ACCEPTED|ZERO_ACCEPTED|REF_REJECTED) :
2259 REF_REJECTED
2260 )
2261 );
2262
2263 /* <cond>s with a result of course want to branch
2264 * after the <default>.
2265 */
2266 non_void_dest = current.code_max - current.code_left;
2267
2268 if (opt_used & VOID_GIVEN)
2269 {
2270 /* Whoops, <default> didn't return a result.
2271 * Prepare to insert a default, and let the
2272 * void-<cond>s branch here, too.
2273 */
2274 void_dest = non_void_dest;
2275 opt_flags |= VOID_GIVEN;
2276 }
2277 else if (opt_flags & VOID_ACCEPTED)
2278 {
2279 /* We have a result, but the caller doesn't want
2280 * it: add the code sequence
2281 *
2282 * nvd: POP
2283 * vd:
2284 */
2285 opt_flags |= VOID_GIVEN;
2286 if (current.code_left < 1)
2287 realloc_code();
2288 current.code_left--;
2289 STORE_CODE(current.codep, F_POP_VALUE);
2290 opt_used = VOID_GIVEN;
2291 void_dest = non_void_dest + 1;
2292 }
2293 else if (all_void && block_size > 2)
2294 {
2295 /* The caller wants a result, <default> has one,
2296 * but none of the <cond>s does (and they exist).
2297 */
2298 if (current.code_left < 3)
2299 realloc_code();
2300 if (block_size > 4
2301 || branchp[-2] - branchp[-1] > 0xfd)
2302 {
2303 /* There is more than one <cond>, or the one
2304 * <cond> alone needs a long branch: add
2305 *
2306 * nvd: BRANCH +1
2307 * vd: CONST0
2308 */
2309 void_dest = non_void_dest + 2;
2310 current.code_left -= 3;
2311 STORE_CODE(current.codep, F_BRANCH);
2312 STORE_UINT8(current.codep, 1);
2313 STORE_CODE(current.codep, F_CONST0);
2314 }
2315 else
2316 {
2317 /* Just one <cond>: replace the 'BRANCH end'
2318 * by 'CONST0; BRANCH end'.
2319 */
2320 bytecode_p p;
2321
2322 /* Make space for the CONST0 */
2323 current.code_left--;
2324 start = branchp[-2];
2325 move_memory(
2326 ¤t.code[start+1],
2327 ¤t.code[start],
2328 (size_t)(non_void_dest - start)
2329 );
2330 current.codep++;
2331
2332 /* Add the CONST0 instruction */
2333 PUT_CODE(current.code+start, F_CONST0);
2334
2335 /* Set the saved opt_flags to 'not void' */
2336 PUT_UINT8(current.code+start+2, 0);
2337
2338 /* Increment the branch offset for the branch
2339 * skipping the <cond>
2340 */
2341 p = current.code+branchp[-1]+1;
2342 PUT_UINT8(p, GET_UINT8(p)+1);
2343
2344 /* Update the stored position */
2345 branchp[-2] = start+1;
2346
2347 non_void_dest++;
2348 /* void_dest = start; */
2349 /* all_void isn't used any more, else we'd
2350 * need to zero it now.
2351 */
2352 }
2353 }
2354 else if (!i && !all_void
2355 && opt_flags & ZERO_ACCEPTED)
2356 {
2357 /* We had a real <default> with result, there are
2358 * some <cond> which return a result, and the
2359 * caller accepts a zero for void-<conds>: add
2360 * nvd: BRANCH +1
2361 * vd: CONST0
2362 * if there are void-<conds>.
2363 */
2364 mp_int *branchp2, j;
2365
2366 /* Check all <cond>s if there is a void one */
2367 branchp2 = branchp;
2368 for (j = block_size; (j -= 2) > 0; )
2369 {
2370 start = *(branchp2 -= 2);
2371 if (current.code[start+1] & VOID_GIVEN)
2372 {
2373 /* Yup, we need the extra code.
2374 */
2375 void_dest = non_void_dest + 2;
2376 non_void_dest += 3;
2377 if (current.code_left < 3)
2378 realloc_code();
2379 current.code_left -= 3;
2380 STORE_CODE(current.codep, F_BRANCH);
2381 STORE_UINT8(current.codep, 1);
2382 STORE_CODE(current.codep, F_CONST0);
2383 break;
2384 }
2385 }
2386 }
2387
2388 /* Prepare the backpatching run */
2389 i = block_size;
2390 }
2391
2392 /* Now walk backwards through all the <cond>branches, insert
2393 * the proper offset and rewrite them to long branches where
2394 * necessary.
2395 */
2396 end = current.code_max - current.code_left;
2397 while ( (i -= 2) > 0)
2398 {
2399 mp_int offset;
2400
2401 /* Compute the distance to branch */
2402 start = *(branchp -= 2);
2403 offset = (GET_UINT8(current.code+start+1) & VOID_GIVEN)
2404 ? void_dest - start - 2
2405 : non_void_dest - start - 2;
2406
2407 if (offset <= 0xff)
2408 {
2409 /* A short branch is sufficient. */
2410 PUT_UINT8(current.code+start+1, (bytecode_t)offset);
2411 continue;
2412 }
2413 else
2414 {
2415 /* We have to rewrite this and all previous
2416 * branches to long branches.
2417 */
2418 mp_int growth; /* (Current) offset from old pos. */
2419 mp_int j;
2420 bytecode_p p, q;
2421
2422 /* Determine how much more is needed and allocate
2423 * the memory
2424 */
2425 growth = (i+1) >> 1;
2426 if (current.code_left < growth)
2427 realloc_code();
2428 current.code_left -= growth;
2429 current.codep += growth;
2430
2431 /* Now move the code, starting from the end,
2432 * and rewriting the branches when we encounter
2433 * them.
2434 * The first move will move all the code up to
2435 * the end, the next move just the code up to
2436 * the following <cond>.
2437 * The offset from the old position is given
2438 * by (q-p).
2439 */
2440 p = current.code + end;
2441 q = p + growth;
2442
2443 branchp += 2; /* have to reconsider this one */
2444 do {
2445 unsigned short dist;
2446 bytecode_p pstart;
2447
2448 /* First, increment the distance of the
2449 * branch skipping the previous <cond> (it might
2450 * already be a long branch).
2451 */
2452 start = *--branchp;
2453 pstart = current.code+start;
2454 code = GET_CODE(pstart);
2455 if (code == F_LBRANCH_WHEN_ZERO
2456 || code == F_LBRANCH_WHEN_NON_ZERO)
2457 {
2458 GET_SHORT(dist, pstart+1);
2459 PUT_SHORT(pstart+1, dist+1);
2460 }
2461 else
2462 {
2463 PUT_UINT8(pstart+1, GET_UINT8(pstart+1)+1);
2464 }
2465
2466 /* Compute the distance for the <cond> branch */
2467 start = *--branchp;
2468 offset = (current.code[start+1] & VOID_GIVEN)
2469 ? void_dest - start - 1
2470 : non_void_dest - start - 1;
2471
2472 /* Count the extra byte we're going to insert */
2473 end++;
2474 void_dest++;
2475 non_void_dest++;
2476
2477 if (offset > 0x7fff)
2478 UNIMPLEMENTED
2479
2480 /* Compute the distance to store while q and p
2481 * give the proper offset.
2482 */
2483 dist = (unsigned short)(offset + (q-p));
2484
2485 /* Move the code after this branch.
2486 */
2487 j = (p - (current.code + start)) - 2;
2488 do {
2489 *--q = *--p;
2490 } while (--j);
2491
2492 /* Store the new branch in place of the old one. */
2493 RSTORE_SHORT(q, dist);
2494
2495 p -= 2;
2496 code = GET_CODE(p);
2497 if (code == F_BRANCH_WHEN_ZERO)
2498 RSTORE_CODE(q, F_LBRANCH_WHEN_ZERO);
2499 else if (code == F_BRANCH_WHEN_NON_ZERO)
2500 RSTORE_CODE(q, F_LBRANCH_WHEN_NON_ZERO);
2501 else if (code == F_BRANCH)
2502 RSTORE_CODE(q, F_LBRANCH);
2503 else
2504 fatal("Can't rewrite %s (%02x) at %p\n"
2505 , get_f_name(code), code, p);
2506 } while ( (i -= 2) > 0);
2507 break; /* outer while() - it's finished anyway */
2508 }
2509 } /* while() backpatching */
2510 break;
2511 }
2512
2513 /* ({#', <expr1>, <expr2>, ..., <exprn> })
2514 */
2515 case F_POP_VALUE:
2516 {
2517 /* This is compiled as:
2518 *
2519 * <expr1>
2520 * POP
2521 * <expr2>
2522 * POP
2523 * ...
2524 * POP
2525 * <exprn>
2526 *
2527 * If an expression doesn't return a value, the following
2528 * POP is omitted.
2529 *
2530 * If no expression is given, 'CONST0' is compiled.
2531 */
2532
2533 mp_int i;
2534 int void_given;
2535
2536 /* Compile the first n-1 expressions */
2537 for (i = block_size - 1; --i > 0; )
2538 {
2539 void_given = compile_value(++argp, VOID_WANTED);
2540
2541 /* If we got a result, pop it */
2542 if ( !(void_given & VOID_GIVEN) )
2543 {
2544 if (current.code_left < 1)
2545 realloc_code();
2546 current.code_left--;
2547 STORE_CODE(current.codep, F_POP_VALUE);
2548 }
2549 }
2550
2551 /* Compile the last expression.
2552 * If there is none (i != 0), use CONST0 instead.
2553 */
2554 opt_flags = compile_value(i ? &const0 : ++argp, opt_flags);
2555 break;
2556 }
2557
2558 /* ({#'=, <lvalue1>, <expr1>, ..., <lvaluen>, <exprn> })
2559 */
2560 case F_ASSIGN:
2561 {
2562 /* This is compiled as:
2563 *
2564 * <expr1>
2565 * <lvalue1>
2566 * VOID_ASSIGN
2567 * <expr2>
2568 * <lvalue2>
2569 * VOID_ASSIGN
2570 * ...
2571 * <exprn>
2572 * <lvaluen>
2573 * ASSIGN
2574 *
2575 * If the caller doesn't require a result, the last
2576 * ASSIGN is compiled as VOID_ASSIGN.
2577 */
2578
2579 mp_int i;
2580
2581 /* There must be at least one assignment in order to get
2582 * a return value.
2583 */
2584 if ( !(i = block_size - 1) || (i & 1) )
2585 lambda_error("Missing value in assignment\n");
2586 argp++;
2587 for (; (i -= 2) >= 0; argp+=2)
2588 {
2589 compile_value(argp+1, REF_REJECTED);
2590 compile_lvalue(argp, USE_INDEX_LVALUE);
2591 if (!i)
2592 {
2593 /* Last assignment: we might need to keep this value */
2594 if (opt_flags & VOID_ACCEPTED)
2595 {
2596 opt_flags = VOID_GIVEN;
2597 STORE_CODE(current.codep, F_VOID_ASSIGN);
2598 }
2599 else
2600 {
2601 STORE_CODE(current.codep, F_ASSIGN);
2602 }
2603 }
2604 else
2605 {
2606 /* First assignemnts: forget the value */
2607 STORE_CODE(current.codep, F_VOID_ASSIGN);
2608 }
2609 current.code_left--;
2610 }
2611 break;
2612 }
2613
2614 /* ({#'+=, <lvalue>, <expr> })
2615 */
2616 case F_ADD_EQ:
2617 /* This is compiled as:
2618 *
2619 * <expr>
2620 * <lvalue>
2621 * (VOID_)ADD_EQ
2622 *
2623 * For the special case <expr> == 1:
2624 *
2625 * <lvalue>
2626 * (PRE_)INC
2627 */
2628
2629 if (block_size != 3)
2630 lambda_error(
2631 "Bad number of arguments to #'%s\n",
2632 instrs[type - CLOSURE_OPERATOR].name
2633 );
2634
2635 if (argp[2].type == T_NUMBER && argp[2].u.number == 1)
2636 {
2637 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2638 if (opt_flags & VOID_ACCEPTED)
2639 {
2640 opt_flags = VOID_GIVEN;
2641 STORE_CODE(current.codep, F_INC);
2642 }
2643 else
2644 {
2645 STORE_CODE(current.codep, F_PRE_INC);
2646 }
2647 current.code_left--;
2648 }
2649 else
2650 {
2651 compile_value(argp+2, REF_REJECTED);
2652 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2653 if (opt_flags & VOID_ACCEPTED)
2654 {
2655 opt_flags = VOID_GIVEN;
2656 STORE_CODE(current.codep, F_VOID_ADD_EQ);
2657 }
2658 else
2659 STORE_CODE(current.codep, F_ADD_EQ);
2660 current.code_left--;
2661 }
2662 break;
2663
2664 /* ({#'-=, <lvalue>, <expr> })
2665 */
2666 case F_SUB_EQ:
2667 /* This is compiled as:
2668 *
2669 * <expr>
2670 * <lvalue>
2671 * SUB_EQ
2672 *
2673 * For the special case <expr> == 1:
2674 *
2675 * <lvalue>
2676 * (PRE_)DEC
2677 */
2678
2679 if (block_size != 3)
2680 lambda_error(
2681 "Bad number of arguments to #'%s\n",
2682 instrs[type - CLOSURE_OPERATOR].name
2683 );
2684
2685 if (argp[2].type == T_NUMBER && argp[2].u.number == 1)
2686 {
2687 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2688 if (opt_flags & VOID_ACCEPTED)
2689 {
2690 opt_flags = VOID_GIVEN;
2691 STORE_CODE(current.codep, F_DEC);
2692 }
2693 else
2694 {
2695 STORE_CODE(current.codep, F_PRE_DEC);
2696 }
2697 current.code_left--;
2698 }
2699 else
2700 {
2701 compile_value(argp+2, REF_REJECTED);
2702 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2703 STORE_CODE(current.codep, F_SUB_EQ);
2704 current.code_left--;
2705 }
2706 break;
2707
2708 /* ({#'op=, <lvalue>, <expr> })
2709 * with op: *, &, |, ^, <<, >>, >>>, /, %, &&, ||
2710 */
2711 case F_MULT_EQ:
2712 case F_AND_EQ:
2713 case F_OR_EQ:
2714 case F_XOR_EQ:
2715 case F_LSH_EQ:
2716 case F_RSH_EQ:
2717 case F_RSHL_EQ:
2718 case F_DIV_EQ:
2719 case F_MOD_EQ:
2720 /* This is compiled as:
2721 *
2722 * <expr>
2723 * <lvalue>
2724 * <op>_EQ
2725 */
2726
2727 if (block_size != 3)
2728 {
2729 lambda_error(
2730 "Bad number of arguments to #'%s\n",
2731 instrs[type - CLOSURE_OPERATOR].name
2732 );
2733 }
2734 compile_value(argp+2, REF_REJECTED);
2735 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2736 STORE_CODE(current.codep, (bytecode_t)(type - CLOSURE_OPERATOR));
2737 current.code_left--;
2738 break;
2739
2740 /* ({#'op=, <lvalue>, <expr> })
2741 * with op: &&, ||
2742 */
2743 case F_LAND_EQ:
2744 case F_LOR_EQ:
2745 {
2746 /* This is compiled as:
2747 *
2748 * <lvalue>
2749 * LDUP
2750 * <op> l
2751 * <expr>
2752 * l: SWAP_VALUES
2753 * ASSIGN
2754 *
2755 * respectively for long branches:
2756 *
2757 * <lvalue>
2758 * LDUP
2759 * DUP
2760 * LBRANCH l
2761 * POP
2762 * <expr>
2763 * l: SWAP_VALUES
2764 * ASSIGN
2765 */
2766
2767 mp_int branchp;
2768 /* The position of the branch/operator instruction.
2769 */
2770 int code; /* Compiled instruction */
2771 Bool is_and; /* TRUE if the operator is F_LAND_EQ */
2772 mp_int end; /* The branch target */
2773 mp_int offset; /* The branch offset */
2774
2775 if (type - CLOSURE_OPERATOR == F_LAND_EQ)
2776 {
2777 code = F_LAND;
2778 is_and = MY_TRUE;
2779 }
2780 else
2781 {
2782 code = F_LOR;
2783 is_and = MY_FALSE;
2784 }
2785
2786 if (block_size != 3)
2787 {
2788 lambda_error(
2789 "Bad number of arguments to #'%s\n",
2790 instrs[type - CLOSURE_OPERATOR].name
2791 );
2792 }
2793
2794 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2795
2796 if (current.code_left < 3)
2797 realloc_code();
2798
2799 current.code_left--;
2800 STORE_CODE(current.codep, (bytecode_t)F_LDUP);
2801
2802 branchp = current.code_max - current.code_left;
2803 current.code_left -= 2;
2804 STORE_CODE(current.codep, (bytecode_t)code);
2805 STORE_CODE(current.codep, (bytecode_t)0);
2806
2807 compile_value(argp+2, REF_REJECTED);
2808
2809 /* Store the correct offsets for the operator/branch
2810 * instruction. If necessary, the short branch is
2811 * converted into long ones.
2812 */
2813 end = current.code_max - current.code_left;
2814 /* The target to jump to */
2815 offset = end - branchp - 2;
2816 if (offset <= 0xff)
2817 {
2818 PUT_UINT8(current.code+branchp+1, (unsigned char)offset);
2819 }
2820 else
2821 {
2822 /* We exceeded the limit of the short offsets.
2823 * Extend the offset into long branch.
2824 */
2825
2826 mp_int i;
2827 bytecode_p p;
2828
2829 code = is_and ? F_LBRANCH_WHEN_ZERO
2830 : F_LBRANCH_WHEN_NON_ZERO;
2831
2832 /* Prepare the copying of the code */
2833 if (current.code_left < 3)
2834 realloc_code();
2835 current.code_left -= 3;
2836 current.codep += 3;
2837 p = current.code + end + 2;
2838 for (i = offset; --i >= 0; --p )
2839 *p = p[-3];
2840 p[-4] = F_DUP;
2841 p[-3] = code;
2842 offset += 3;
2843 PUT_SHORT((p-2), offset);
2844 if (offset > 0x7fff)
2845 UNIMPLEMENTED;
2846 p[0] = F_POP_VALUE;
2847 }
2848
2849 if (current.code_left < 2)
2850 realloc_code();
2851 current.code_left -= 2;
2852 STORE_CODE(current.codep, (bytecode_t)F_SWAP_VALUES);
2853 STORE_CODE(current.codep, (bytecode_t)F_ASSIGN);
2854 break;
2855 }
2856
2857 /* ({#'++, <lvalue> })
2858 * ({#'--, <lvalue> })
2859 */
2860 case F_POST_INC:
2861 case F_POST_DEC:
2862 /* This is compiled as:
2863 *
2864 * <lvalue> <lvalue>
2865 * (POST_)INC (POST_)DEC
2866 */
2867
2868 if (block_size != 2)
2869 {
2870 lambda_error(
2871 "Bad number of arguments to #'%s\n",
2872 instrs[type - CLOSURE_OPERATOR].name
2873 );
2874 }
2875
2876 compile_lvalue(argp+1, USE_INDEX_LVALUE);
2877
2878 if (opt_flags & VOID_ACCEPTED)
2879 {
2880 opt_flags = VOID_GIVEN;
2881 if (type-CLOSURE_OPERATOR == F_POST_INC)
2882 STORE_CODE(current.codep, F_INC);
2883 else
2884 STORE_CODE(current.codep, F_DEC);
2885 }
2886 else
2887 STORE_CODE(current.codep, (bytecode_t)type);
2888 current.code_left--;
2889
2890 break;
2891
2892 /* ({#'do, <body1>, ... <bodyn>, <cond>, <result> })
2893 */
2894 case F_BBRANCH_WHEN_NON_ZERO:
2895 {
2896 /* This is compiled as:
2897 *
2898 * l: <body>
2899 * POP
2900 * <body2>
2901 * ...
2902 * <bodyn>
2903 * POP
2904 * <cond>
2905 * BBRANCH_NON_ZERO l
2906 * <result>
2907 *
2908 * If a <body> doesn't return a value, the following POP
2909 * is omitted.
2910 *
2911 * As usual, if the jump distance is too big, the BBRANCH
2912 * is converted into a LBRANCH. Also, if the <cond>
2913 * returns a result in reversed logic, the branch condition
2914 * is reversed.
2915 */
2916
2917 mp_int i;
2918 int void_given;
2919 mp_int offset; /* Position of first <body> */
2920
2921 i = block_size - 3;
2922 if (i < 0)
2923 lambda_error("Missing argument(s) to #'do\n");
2924
2925 offset = current.code_left - current.code_max;
2926
2927 /* Compile all the bodys */
2928 if (i) do
2929 {
2930 void_given = compile_value(++argp, VOID_WANTED);
2931 if ( !(void_given & VOID_GIVEN) )
2932 {
2933 /* POP the unwanted result */
2934 if (current.code_left < 1)
2935 realloc_code();
2936 current.code_left--;
2937 STORE_CODE(current.codep, F_POP_VALUE);
2938 }
2939 } while(--i);
2940
2941 /* Compile the condition */
2942 void_given = compile_value(++argp, NEGATE_ACCEPTED);
2943 offset += current.code_max - current.code_left + 1;
2944
2945 if (current.code_left < 3)
2946 realloc_code();
2947 if (offset > 0xff)
2948 {
2949 /* We need a long branch */
2950 if (offset > 0x8000)
2951 UNIMPLEMENTED
2952 current.code_left -= 3;
2953 if (void_given & NEGATE_GIVEN)
2954 STORE_CODE(current.codep, F_LBRANCH_WHEN_ZERO);
2955 else
2956 STORE_CODE(current.codep, F_LBRANCH_WHEN_NON_ZERO);
2957 STORE_SHORT(current.codep, -offset);
2958 }
2959 else
2960 {
2961 current.code_left -= 2;
2962 if (void_given & NEGATE_GIVEN)
2963 STORE_CODE(current.codep, F_BBRANCH_WHEN_ZERO);
2964 else
2965 STORE_CODE(current.codep, F_BBRANCH_WHEN_NON_ZERO);
2966 STORE_UINT8(current.codep, offset);
2967 }
2968
2969 /* Compile the result */
2970 opt_flags = compile_value(++argp, opt_flags);
2971 break;
2972 }
2973
2974 /* ({#'while, <cond>, <result>, <body1>, ... <bodyn> })
2975 */
2976 case F_BBRANCH_WHEN_ZERO:
2977 {
2978 /* This is compiled as:
2979 *
2980 * BRANCH l1
2981 * l0: <body>
2982 * POP
2983 * <body2>
2984 * ...
2985 * <bodyn>
2986 * POP
2987 * l1: <cond>
2988 * BRANCH_NON_ZERO l0
2989 * <result>
2990 *
2991 * If a <body> doesn't return a value, the following POP
2992 * is omitted.
2993 *
2994 * As usual, if the jump distances are too big, the (B)BRANCHes
2995 * are converted into LBRANCHes. Also, if the <cond>
2996 * returns a result in reversed logic, the branch condition
2997 * is reversed.
2998 */
2999
3000 mp_int i;
3001 int void_given;
3002 mp_int start_branch;
3003 mp_int offset;
3004
3005 /* Store the initial branch, and remember its position
3006 * for the backpatching.
3007 */
3008 if (current.code_left < 2)
3009 realloc_code();
3010 current.code_left -= 2;
3011 start_branch = current.code_max - current.code_left;
3012 STORE_CODE(current.codep, F_BRANCH);
3013 STORE_UINT8(current.codep, 0);
3014
3015 i = block_size - 3;
3016 if (i < 0)
3017 lambda_error("Missing argument(s) to #'while\n");
3018
3019 /* Compile all bodies */
3020 offset = current.code_left - current.code_max;
3021 argp += 2;
3022 if (i) do
3023 {
3024 void_given = compile_value(++argp, VOID_WANTED);
3025 if ( !(void_given & VOID_GIVEN) )
3026 {
3027 /* The body returned a result: POP it */
3028 if (current.code_left < 2)
3029 realloc_code();
3030 current.code_left--;
3031 STORE_CODE(current.codep, F_POP_VALUE);
3032 }
3033 } while(--i);
3034
3035 /* Store the proper distance into the initial branch.
3036 * Rewrite it to a long branch if necessary.
3037 */
3038 offset =
3039 current.code_max - current.code_left - start_branch;
3040 if (offset > 0xff)
3041 {
3042 bytecode_p p;
3043
3044 if (offset > 0x7ffd)
3045 UNIMPLEMENTED
3046 if (current.code_left < 1)
3047 realloc_code();
3048 current.code_left--;
3049
3050 /* Move the generated code */
3051 p = (bytecode_p)current.codep++;
3052 i = offset;
3053 do {
3054 p--;
3055 p[1] = *p;
3056 } while (--i);
3057
3058 /* Generate the LBRANCH */
3059 p = current.code+start_branch-2;
3060 PUT_CODE(p, F_LBRANCH);
3061 PUT_SHORT(p+1, offset+2);
3062 start_branch++;
3063 }
3064 else
3065 {
3066 PUT_UINT8(current.code+start_branch-1, (unsigned char)offset);
3067 }
3068
3069 /* Compile the condition and generate the branch */
3070 argp = block->item;
3071 void_given = compile_value(++argp, NEGATE_ACCEPTED);
3072
3073 if (current.code_left < 3)
3074 realloc_code();
3075
3076 offset =
3077 current.code_max - current.code_left - start_branch + 1;
3078 if (offset > 0xff)
3079 {
3080 if (offset > 0x8000)
3081 UNIMPLEMENTED
3082
3083 current.code_left -= 3;
3084 if (void_given & NEGATE_GIVEN)
3085 STORE_CODE(current.codep, F_LBRANCH_WHEN_ZERO);
3086 else
3087 STORE_CODE(current.codep, F_LBRANCH_WHEN_NON_ZERO);
3088 STORE_SHORT(current.codep, -offset);
3089 }
3090 else
3091 {
3092 current.code_left -= 2;
3093 if (void_given & NEGATE_GIVEN)
3094 STORE_CODE(current.codep, F_BBRANCH_WHEN_ZERO);
3095 else
3096 STORE_CODE(current.codep, F_BBRANCH_WHEN_NON_ZERO);
3097 STORE_UINT8(current.codep, (bytecode_t)offset);
3098 }
3099
3100 /* Compile the result */
3101 opt_flags = compile_value(++argp, opt_flags);
3102 break;
3103 }
3104
3105 /* ({#'foreach, <sym>, <expr>, <body1>, ... <bodyn> })
3106 * ({#'foreach, ({ <sym1>, ... <symn> }), <expr>, <body1>, ... <bodyn> })
3107 */
3108 case F_FOREACH:
3109 {
3110 /* This is compiled as:
3111 *
3112 * PUSH_(LOCAL_)LVALUE <var1>
3113 * ...
3114 * PUSH_(LOCAL_)LVALUE <varn>
3115 * <expr>
3116 * FOREACH <numargs> c
3117 * l: <body1>
3118 * POP
3119 * <body2>
3120 * ...
3121 * <bodyn>
3122 * POP
3123 * c: FOREACH_NEXT l
3124 * e: FOREACH_END
3125 * CONST0
3126 *
3127 * or if no bodies are given:
3128 *
3129 * <expr>
3130 * POP_VALUE
3131 * CONST0
3132 *
3133 * If a <body> doesn't return a value, the following POP
3134 * is omitted.
3135 * If the caller doesn't require a result, the final CONST0
3136 * is omitted.
3137 */
3138
3139 mp_int i;
3140 int void_given;
3141 mp_int start;
3142 mp_int offset;
3143 int vars_given;
3144 int body_count;
3145
3146 body_count = block_size - 3;
3147 if (body_count < 0)
3148 lambda_error("Missing argument(s) to #'foreach\n");
3149
3150 if (!body_count)
3151 {
3152 /* Just create the code for the expression
3153 * and pop the value
3154 */
3155 compile_value(argp+2, 0);
3156 if (current.code_left < 2)
3157 realloc_code();
3158 current.code_left--;
3159 STORE_CODE(current.codep, F_POP_VALUE);
3160
3161 /* If a result is required, compile a 0 */
3162 if (opt_flags & VOID_ACCEPTED)
3163 opt_flags = VOID_GIVEN;
3164 else
3165 {
3166 current.code_left--;
3167 STORE_CODE(current.codep, F_CONST0);
3168 }
3169
3170 break;
3171 }
3172
3173 /* Create the code to push the variable lvalues
3174 */
3175 if ((++argp)->type != T_POINTER)
3176 {
3177 vars_given = 1;
3178 if (!is_lvalue(argp, 0))
3179 lambda_error("Missing variable lvalue to #'foreach\n");
3180 compile_lvalue(argp, 0);
3181 }
3182 else
3183 {
3184 svalue_t * svp;
3185
3186 svp = argp->u.vec->item;
3187 vars_given = i = (int)VEC_SIZE(argp->u.vec);
3188
3189 if (!vars_given)
3190 lambda_error("Missing variable lvalue to #'foreach\n");
3191 if (vars_given > 0xFE)
3192 lambda_error("Too many lvalues to #'foreach: %d\n", vars_given);
3193 for ( ; i > 0; i--, svp++)
3194 {
3195 if (!is_lvalue(svp, 0))
3196 lambda_error("Missing variable lvalue to #'foreach\n");
3197 compile_lvalue(svp, 0);
3198 }
3199 }
3200
3201 /* Create the code for the expression */
3202 compile_value(++argp, 0);
3203
3204 /* Create the FOREACH instruction and remember the position
3205 */
3206 if (current.code_left < 4)
3207 realloc_code();
3208 current.code_left -= 4;
3209 STORE_CODE(current.codep, F_FOREACH);
3210 STORE_UINT8(current.codep, vars_given+1);
3211 STORE_SHORT(current.codep, 0);
3212 start = current.code_max - current.code_left;
3213
3214 /* Compile all bodies.
3215 */
3216 for (i = body_count; i > 0; i--)
3217 {
3218 void_given = compile_value(++argp, VOID_WANTED);
3219 if ( !(void_given & VOID_GIVEN) )
3220 {
3221 /* The body returned a result: POP it */
3222 if (current.code_left < 2)
3223 realloc_code();
3224 current.code_left--;
3225 STORE_CODE(current.codep, F_POP_VALUE);
3226 }
3227 }
3228
3229 /* Store the proper distance into the initial offset.
3230 */
3231 offset = current.code_max - current.code_left - start;
3232 PUT_SHORT(current.code+start-2, offset);
3233
3234 /* Generate the FOREACH_NEXT, followed by F_FOREACH_END.
3235 */
3236 if (current.code_left < 5)
3237 realloc_code();
3238 current.code_left -= 4;
3239 STORE_CODE(current.codep, F_FOREACH_NEXT);
3240 STORE_SHORT(current.codep, offset+3);
3241 STORE_CODE(current.codep, F_FOREACH_END);
3242
3243 /* If a result is required, compile a 0 */
3244 if (opt_flags & VOID_ACCEPTED)
3245 opt_flags = VOID_GIVEN;
3246 else
3247 {
3248 current.code_left--;
3249 STORE_CODE(current.codep, F_CONST0);
3250 }
3251 break;
3252 }
3253
3254 /* ({#'catch, <body> })
3255 * ({#'catch, <body>, 'nolog })
3256 * ({#'catch, <body>, 'publish })
3257 * ({#'catch, <body>, 'nolog, 'publish })
3258 * ({#'catch, <body>, 'nolog, 'publish, 'reserve, <expr> })
3259 */
3260 case F_CATCH:
3261 {
3262 /* This is compiled as:
3263 *
3264 * CATCH l / CATCH_NO_LOG l
3265 * <body>
3266 * l: END_CATCH
3267 */
3268
3269 mp_int start, offset;
3270 int flags, i;
3271 int void_given;
3272
3273 if (block_size < 2 && block_size > 6)
3274 lambda_error("Wrong number of arguments to #'catch\n");
3275
3276 flags = 0;
3277 for (i = 3; i <= block_size; i++)
3278 {
3279 if (argp[i-1].type == T_SYMBOL
3280 && mstreq(argp[i-1].u.str, STR_NOLOG))
3281 flags |= CATCH_FLAG_NOLOG;
3282 else if (argp[i-1].type == T_SYMBOL
3283 && mstreq(argp[i-1].u.str, STR_PUBLISH))
3284 flags |= CATCH_FLAG_PUBLISH;
3285 else if (argp[i-1].type == T_SYMBOL
3286 && mstreq(argp[i-1].u.str, STR_RESERVE)
3287 )
3288 {
3289 if (i > block_size)
3290 lambda_error("Missing expression for 'reserve "
3291 "catch-modifier.\n");
3292 flags |= CATCH_FLAG_RESERVE;
3293 if (compile_value(argp+i, 0) & VOID_GIVEN)
3294 lambda_error("Expression for 'reserve "
3295 "doesn't return a value.\n");
3296 i++;
3297 }
3298 else
3299 lambda_error("Expected 'nolog, 'publish or "
3300 "'reserve as catch-modifier.\n");
3301 }
3302
3303 if (current.code_left < 3)
3304 realloc_code();
3305 current.code_left -= 3;
3306
3307 STORE_CODE(current.codep, F_CATCH);
3308
3309 STORE_UINT8(current.codep, flags);
3310
3311 STORE_UINT8(current.codep, 0);
3312 start = current.code_max - current.code_left;
3313
3314 void_given = compile_value(++argp, 0);
3315 if (current.code_left < 1)
3316 realloc_code();
3317
3318 current.code_left -= 1;
3319 STORE_CODE(current.codep, F_END_CATCH);
3320
3321 offset = current.code_max - current.code_left - start;
3322 if (offset > 0xff)
3323 {
3324 UNIMPLEMENTED
3325 }
3326 PUT_UINT8(current.code+start-1, (bytecode_t)offset);
3327 break;
3328 }
3329
3330 /* ({#'sscanf, <data>, <fmt>, <lvalue1>, ..., <lvalueN> })
3331 */
3332 case F_SSCANF:
3333 {
3334 /* This is compiled as:
3335 *
3336 * <data>
3337 * <fmt>
3338 * <lvalue1>
3339 * ...
3340 * <lvalueN>
3341 * SSCANF N+2
3342 */
3343
3344 int lvalues;
3345
3346 if ( (lvalues = block_size - 3) < 0)
3347 lambda_error("Missing argument(s) to #'sscanf\n");
3348
3349 if (lvalues > 0xff - 2)
3350 lambda_error("Too many arguments to #'sscanf\n");
3351
3352 compile_value(++argp, 0);
3353 compile_value(++argp, 0);
3354
3355 while (--lvalues >= 0)
3356 {
3357 compile_lvalue(++argp, PROTECT_LVALUE|USE_INDEX_LVALUE);
3358 }
3359
3360 if (current.code_left < 2)
3361 realloc_code();
3362 current.code_left -= 2;
3363
3364 STORE_CODE(current.codep, F_SSCANF);
3365 STORE_CODE(current.codep, (bytecode_t)(block_size - 1));
3366 break;
3367 }
3368
3369 #ifdef USE_PARSE_COMMAND
3370 /* ({#'parse_command, <data>, <fmt>, <data>, <lvalue1>, ..., <lvalueN> })
3371 */
3372 case F_PARSE_COMMAND:
3373 {
3374 /* This is compiled as:
3375 *
3376 * <data>
3377 * <fmt>
3378 * <data>
3379 * <lvalue1>
3380 * ...
3381 * <lvalueN>
3382 * SSCANF N+2
3383 */
3384
3385 int lvalues;
3386
3387 if ( (lvalues = block_size - 3) < 0)
3388 lambda_error("Missing argument(s) to #'sscanf\n");
3389
3390 if (lvalues > 0xff - 2)
3391 lambda_error("Too many arguments to #'sscanf\n");
3392
3393 compile_value(++argp, 0);
3394 compile_value(++argp, 0);
3395 compile_value(++argp, 0);
3396
3397 while (--lvalues >= 0)
3398 {
3399 compile_lvalue(++argp, PROTECT_LVALUE|USE_INDEX_LVALUE);
3400 }
3401
3402 if (current.code_left < 2)
3403 realloc_code();
3404 current.code_left -= 2;
3405
3406 STORE_CODE(current.codep, F_SSCANF);
3407 STORE_CODE(current.codep, (bytecode_t)(block_size - 1));
3408 break;
3409 }
3410 #endif
3411
3412 /* ({#'({, <expr1>, ..., <exprN> })
3413 */
3414 case F_AGGREGATE:
3415 {
3416 /* This is compiled as:
3417 *
3418 * <expr1>
3419 * ...
3420 * <exprN>
3421 * F_AGGREGATE N
3422 */
3423 int i, size;
3424
3425 size = i = block_size - 1;
3426 while (--i >= 0)
3427 {
3428 compile_value(++argp, REF_REJECTED);
3429 }
3430 if (current.code_left < 3)
3431 realloc_code();
3432 current.code_left -= 3;
3433 STORE_CODE(current.codep, F_AGGREGATE);
3434 STORE_SHORT(current.codep, size);
3435 break;
3436 }
3437
3438 /* ({#'([, <array1>, ..., <arrayN> })
3439 */
3440 case F_M_CAGGREGATE:
3441 {
3442 /* This is compiled as:
3443 *
3444 * <array1>[0]
3445 * ...
3446 * <array1>[M]
3447 * <array2>[0]
3448 * ...
3449 * <arrayN>[M]
3450 * M_(C)AGGREGATE N M
3451 */
3452 mp_int i, j;
3453 mp_int num_keys; /* Number of keys to add */
3454 mp_int num_values; /* Number of values per key */
3455
3456 num_values = 1;
3457 i = block_size;
3458 num_keys = i - 1;
3459
3460 /* Check and compile all mapping keys and values */
3461 for (i = block_size; --i;)
3462 {
3463 svalue_t *element;
3464
3465 if ( (++argp)->type != T_POINTER )
3466 lambda_error("Bad argument to #'([\n");
3467
3468 element = argp->u.vec->item;
3469
3470 /* The first array determines the width */
3471 j = (mp_int)VEC_SIZE(argp->u.vec);
3472 if (j != num_values)
3473 {
3474 if (!j)
3475 lambda_error("#'([ : Missing key.\n");
3476 if (i != num_keys)
3477 lambda_error(
3478 "#'([ : Inconsistent value count.\n");
3479 num_values = j;
3480 }
3481
3482 while (--j >= 0)
3483 {
3484 compile_value(element++, REF_REJECTED);
3485 }
3486 }
3487
3488 if (current.code_left < 5)
3489 realloc_code();
3490
3491 num_values--; /* one item of each subarray is the key */
3492 if ( (num_keys | num_values) & ~0xff)
3493 {
3494 /* More than 255 keys or values: long instruction */
3495 current.code_left -= 5;
3496 STORE_CODE(current.codep, F_M_AGGREGATE);
3497 STORE_SHORT(current.codep, num_keys);
3498 STORE_SHORT(current.codep, num_values);
3499 }
3500 else
3501 {
3502 /* Short instruction */
3503 current.code_left -= 3;
3504 STORE_CODE(current.codep, F_M_CAGGREGATE);
3505 STORE_UINT8(current.codep, (unsigned char)num_keys);
3506 STORE_UINT8(current.codep, (unsigned char)num_values);
3507 }
3508 break;
3509 }
3510
3511 #ifdef USE_STRUCTS
3512 /* ({#'(<, <template>, <expr1>, ..., <exprN> })
3513 */
3514 case F_S_AGGREGATE:
3515 {
3516 /* This is compiled as:
3517 *
3518 * <template>
3519 * <expr1>
3520 * ...
3521 * <exprN>
3522 * F_S_AGGREGATE -1 N
3523 */
3524 int i, size;
3525
3526 size = block_size - 2;
3527 if (size > STRUCT_MAX_MEMBERS)
3528 {
3529 lambda_error("Too many elements for struct.\n");
3530 size = STRUCT_MAX_MEMBERS;
3531 }
3532
3533 if (argp[1].type == T_STRUCT
3534 && struct_size(argp[1].u.strct) < size)
3535 {
3536 lambda_error("Too many elements for struct %s.\n"
3537 , get_txt(struct_name(argp[1].u.strct))
3538 );
3539 size = struct_size(argp[1].u.strct);
3540 }
3541 i = size+1;
3542 while (--i >= 0)
3543 {
3544 compile_value(++argp, REF_REJECTED);
3545 }
3546 if (current.code_left < 4)
3547 realloc_code();
3548 current.code_left -= 4;
3549 STORE_CODE(current.codep, F_S_AGGREGATE);
3550 STORE_SHORT(current.codep, -1);
3551 STORE_UINT8(current.codep, (unsigned char)size);
3552 break;
3553 }
3554 #endif /* USE_STRUCTS */
3555
3556 /* ({#'return })
3557 * ({#'return, <expr> })
3558 */
3559 case F_RETURN:
3560 {
3561 /* This is compiled as:
3562 *
3563 * <expr> or RETURN0
3564 * RETURN
3565 */
3566
3567 if (block_size != 2)
3568 {
3569 if (block_size > 1)
3570 lambda_error("Too many arguments to #'return\n");
3571 opt_flags = VOID_GIVEN;
3572 }
3573 else
3574 {
3575 opt_flags =
3576 compile_value(++argp, ZERO_ACCEPTED|REF_REJECTED);
3577 }
3578
3579 if (current.code_left < 1)
3580 realloc_code();
3581 current.code_left--;
3582 if (opt_flags & VOID_GIVEN)
3583 {
3584 STORE_CODE(current.codep, F_RETURN0);
3585 opt_flags ^= VOID_GIVEN;
3586 }
3587 else
3588 STORE_CODE(current.codep, F_RETURN);
3589
3590 break;
3591 }
3592
3593 /* ({#'[.., <value>, <index> })
3594 * ({#'[<.., <value>, <index> })
3595 */
3596 case F_NX_RANGE:
3597 case F_RX_RANGE:
3598 case F_AX_RANGE:
3599 {
3600 /* This is compiled as:
3601 * <value>
3602 * <index>
3603 * CONST1
3604 * NR_RANGE/RR_RANGE/AR_RANGE
3605 */
3606
3607 bytecode_t opcode = (type - CLOSURE_OPERATOR);
3608 const char *opname;
3609
3610 switch (type - CLOSURE_OPERATOR)
3611 {
3612 case F_NX_RANGE:
3613 opcode = F_NR_RANGE;
3614 opname = "#'[..";
3615 break;
3616 case F_RX_RANGE:
3617 opcode = F_RR_RANGE;
3618 opname = "#'[<..";
3619 break;
3620 case F_AX_RANGE:
3621 opcode = F_AR_RANGE;
3622 opname = "#'[>..";
3623 break;
3624 default:
3625 fatal("Illegal operator %d\n", type - CLOSURE_OPERATOR);
3626 break;
3627 }
3628
3629 if (block_size != 3)
3630 lambda_error("Bad number of arguments to %s\n"
3631 , opname);
3632
3633 compile_value(++argp, REF_REJECTED);
3634
3635 /* A numeric index can be compiled directly */
3636 if ((++argp)->type == T_NUMBER)
3637 compile_value(argp, 0);
3638 else
3639 {
3640 compile_value(argp, REF_REJECTED);
3641 }
3642
3643 if (current.code_left < 2)
3644 realloc_code();
3645 current.code_left -= 2;
3646 STORE_CODE(current.codep, F_CONST1);
3647 STORE_CODE(current.codep, opcode);
3648 break;
3649 }
3650
3651 /* ({#'switch, <value>, {<case1>, <block1>, <delim>} })
3652 *
3653 * <case>s can be #'default, simple values, or arrays of values.
3654 * <delim>s are #', or #'break.
3655 */
3656 case F_SWITCH:
3657 {
3658 /* This is compiled as:
3659 *
3660 * <value>
3661 * SWITCH switchargs
3662 * <block1>
3663 * POP/BREAK
3664 * <block2>
3665 * POP/BREAK
3666 * ...
3667 * <blockN>
3668 * POP/BREAK
3669 * switchargs
3670 *
3671 * If no default case is given, a default 'CONST0; BREAK'
3672 * is inserted after the last block.
3673 *
3674 * See interpret.c for a detailed description of the SWITCH
3675 * instruction.
3676 */
3677
3678 mp_int num_blocks; /* Number different cases */
3679 mp_int i;
3680 mp_int switch_pc; /* Position of the SWITCH+1. */
3681 mp_int default_addr = 0; /* Pos of the default case */
3682 Bool some_numeric = MY_FALSE;
3683 /* TRUE if some cases are numeric */
3684 Bool no_string = MY_TRUE;
3685 /* TRUE if the case list contains no strings (yet) */
3686 case_list_entry_t *zero = NULL;
3687 /* Case label with value 0. */
3688 case_list_entry_t *save_free_block;
3689 case_list_entry_t *save_next_free;
3690 case_list_entry_t *save_list0;
3691 case_list_entry_t *save_list1;
3692 /* Save the vitals of the outer switch.
3693 * We don't need an explicite list of case_states
3694 * because compile_value() recurses.
3695 */
3696
3697 # define REUSE_LIST_ENTRY \
3698 case_state.list0 = case_state.list1; \
3699 case_state.list1 = l->next; \
3700 case_state.next_free++;
3701
3702 /* Initialize the globals if it didn't happen yet */
3703 if (!switch_initialized)
3704 {
3705 switch_initialized = MY_TRUE;
3706 if (current_loc.file)
3707 {
3708 /* lambda() is called while the LPC compiler
3709 * was busy compiling a switch(), maybe from
3710 * within the error handling.
3711 */
3712 save_case_free_block = case_state.free_block;
3713 save_case_next_free = case_state.next_free;
3714 save_case_list0 = case_state.list0;
3715 save_case_list1 = case_state.list1;
3716 }
3717 else
3718 {
3719 case_state.free_block = NULL;
3720 case_state.next_free = NULL;
3721 }
3722 }
3723
3724 /* Let's begin */
3725
3726 num_blocks = (block_size) / 3;
3727 if (block_size != 2 + num_blocks * 3)
3728 lambda_error("Bad number of arguments to #'switch\n");
3729
3730 compile_value(++argp, REF_REJECTED);
3731
3732 if (current.code_left < 3)
3733 realloc_code();
3734 current.code_left -= 3;
3735 STORE_CODE(current.codep, F_SWITCH);
3736 current.codep += 2; /* Space for b1 a2 */
3737
3738 /* Save position and prepare to compile the switch() */
3739 switch_pc = current.code_max - current.code_left - 2;
3740
3741 if (++current.break_stack > current.max_break_stack)
3742 current.max_break_stack = current.break_stack;
3743
3744 save_free_block = case_state.free_block;
3745 save_next_free = case_state.next_free;
3746 save_list0 = case_state.list0;
3747 save_list1 = case_state.list1;
3748 case_state.list0 = case_state.list1 = NULL;
3749
3750 /* Collect the cases and compile the associated
3751 * blocks.
3752 */
3753 for (i = num_blocks; --i >= 0;)
3754 {
3755 svalue_t *labels; /* Label value(s) */
3756 mp_int j; /* Number of (remaining) labels */
3757 case_list_entry_t *l;
3758 int opt_used;
3759
3760 /* Compile the case labels */
3761
3762 ++argp;
3763 if (argp->type == T_POINTER) {
3764 labels = argp->u.vec->item;
3765 j = (mp_int)VEC_SIZE(argp->u.vec);
3766 } else {
3767 labels = argp;
3768 j = 1;
3769 }
3770
3771 for (; j--; labels++)
3772 {
3773 l = new_case_entry();
3774 l->addr =
3775 current.code_max - current.code_left - switch_pc;
3776 l->line = 1;
3777
3778 /* Create the case_list_entry for this case label */
3779 if (j && labels[1].type == T_CLOSURE
3780 && labels[1].x.closure_type == F_RANGE +CLOSURE_EFUN )
3781 {
3782 /* It's a ({#'.., <low>, <high>}) range */
3783
3784 if (j < 2) {
3785 lambda_error(
3786 "case label range lacks end\n"
3787 );
3788 }
3789
3790 if (labels[0].type != T_NUMBER
3791 || labels[2].type != T_NUMBER )
3792 {
3793 lambda_error(
3794 "case label range must be numeric\n"
3795 );
3796 }
3797
3798 if (!no_string)
3799 lambda_error(
3800 "mixed case label lists not supported\n"
3801 );
3802
3803 some_numeric = MY_TRUE;
3804 l->key = labels->u.number;
3805
3806 /* Get the upper end of the range */
3807
3808 j -= 2;
3809 labels += 2;
3810 if (labels[-2].u.number == labels->u.number)
3811 continue;
3812 /* Single entry sufficient */
3813
3814 if (labels[-2].u.number > labels->u.number)
3815 {
3816 /* <low> > <high>: invalid case */
3817 REUSE_LIST_ENTRY
3818 continue;
3819 }
3820
3821 l->addr = 1;
3822 l = new_case_entry();
3823 l->addr =
3824 current.code_max - current.code_left -
3825 switch_pc;
3826 l->line = 0;
3827 l->key = labels->u.number;
3828 }
3829 else if (labels->type == T_STRING)
3830 {
3831 /* String label: we have to make the string shared
3832 * and store it in the value table (to keep the
3833 * reference).
3834 */
3835
3836 svalue_t stmp;
3837
3838 if (some_numeric)
3839 lambda_error(
3840 "mixed case label lists not supported\n"
3841 );
3842
3843 if (--current.values_left < 0)
3844 realloc_values();
3845 no_string = MY_FALSE;
3846 put_string(&stmp
3847 , make_tabled_from(labels->u.str));
3848 *--current.valuep = stmp;
3849
3850 l->key = (p_int)stmp.u.str;
3851
3852 }
3853 else if (labels->type == T_NUMBER)
3854 {
3855 /* Numeric label, with special treatment of
3856 * the label 0.
3857 */
3858 if ( 0 != (l->key = labels->u.number) )
3859 {
3860 if (!no_string)
3861 lambda_error(
3862 "mixed case label lists not supported\n"
3863 );
3864 some_numeric = MY_TRUE;
3865 }
3866 else
3867 {
3868 zero = l;
3869 }
3870 }
3871 else if (labels->type == T_CLOSURE
3872 && labels->x.closure_type == F_CSTRING0 +CLOSURE_OPERATOR)
3873 {
3874 /* #'default label */
3875
3876 if (default_addr)
3877 lambda_error("duplicate default\n");
3878 default_addr = l->addr;
3879 REUSE_LIST_ENTRY
3880 continue;
3881 }
3882 else
3883 {
3884 /* Something else - bad wizard! */
3885 lambda_error("bad type of case label\n");
3886 }
3887 } /* for(j over labels) */
3888
3889 /* Compile the code block for this case */
3890 argp++;
3891 opt_used = compile_value(
3892 argp,
3893 argp[1].x.closure_type ==
3894 F_POP_VALUE+CLOSURE_OPERATOR ?
3895 REF_REJECTED | VOID_ACCEPTED :
3896 REF_REJECTED
3897 );
3898
3899 /* Check and compile the delimiter #', or #'break */
3900
3901 if ((++argp)->type != T_CLOSURE
3902 || ( argp->x.closure_type !=
3903 F_BREAK+CLOSURE_OPERATOR
3904 && (!i || argp->x.closure_type !=
3905 F_POP_VALUE+CLOSURE_OPERATOR)) )
3906 {
3907 lambda_error("Bad delimiter in #'switch\n");
3908 }
3909
3910 if ( !(opt_used & VOID_GIVEN) )
3911 {
3912 if (current.code_left < 1)
3913 realloc_code();
3914 current.code_left--;
3915 STORE_CODE(current.codep
3916 , (bytecode_t) argp->x.closure_type);
3917 }
3918 } /* for (i = num_blocks) */
3919
3920 /* If there was not default case, create one. */
3921 if (!default_addr)
3922 {
3923 default_addr =
3924 current.code_max - current.code_left - switch_pc;
3925 if (current.code_left < 2)
3926 realloc_code();
3927 current.code_left -= 2;
3928 STORE_CODE(current.codep, F_CONST0);
3929 STORE_CODE(current.codep, F_BREAK);
3930 }
3931
3932 /* Create the rest of the switch instruction, especially
3933 * the lookup tables.
3934 */
3935 store_case_labels(
3936 current.code_max - current.code_left - switch_pc,
3937 default_addr,
3938 some_numeric || no_string, zero,
3939 lambda_get_space, lambda_move_switch_instructions,
3940 lambda_cerror, lambda_cerrorl
3941 );
3942
3943 /* That's it: restore the previous switch context if any.
3944 */
3945 case_state.free_block = save_free_block;
3946 case_state.next_free = save_next_free;
3947 case_state.list0 = save_list0;
3948 case_state.list1 = save_list1;
3949 current.break_stack--;
3950 break;
3951
3952 # undef REUSE_LIST_ENTRY
3953 }
3954 } /* switch(type - CLOSURE_OPERATOR) */
3955
3956 }
3957 else /* it's an EFUN closure */
3958 {
3959 mp_int block_size; /* Number of entries */
3960
3961 block_size = (mp_int)VEC_SIZE(block);
3962
3963 switch (type - CLOSURE_EFUN)
3964 {
3965 /* ({#'&, <expr1>, ..., <exprn> })
3966 * ({#'&, <lvalue> })
3967 */
3968 case F_AND:
3969 {
3970 int i;
3971
3972 i = block_size - 2;
3973
3974 if ( i > 0 )
3975 {
3976 /* This is compiled as:
3977 *
3978 * <expr1>
3979 * <expr2>
3980 * AND
3981 * ...
3982 * <exprn>
3983 * AND
3984 */
3985 compile_value(++argp, 0);
3986 do {
3987 compile_value(++argp, 0);
3988 if (current.code_left < 1)
3989 realloc_code();
3990 current.code_left--;
3991 STORE_CODE(current.codep, F_AND);
3992 } while (--i);
3993 }
3994 else if (!i)
3995 {
3996 /* This is compiled as:
3997 *
3998 * <lvalue>
3999 *
4000 * (easy, isn't it?)
4001 */
4002 if (opt_flags & REF_REJECTED)
4003 lambda_error("Reference value in bad position\n");
4004 compile_lvalue(++argp, PROTECT_LVALUE|USE_INDEX_LVALUE);
4005 }
4006 else
4007 {
4008 lambda_error("Missing argument(s) to #'&\n");
4009 }
4010 break;
4011 }
4012
4013 /* ({#'|, <expr1>, ..., <exprn> })
4014 * ({#'|, <lvalue> })
4015 */
4016 case F_OR:
4017 {
4018 int i;
4019
4020 i = block_size - 2;
4021
4022 if ( i > 0 )
4023 {
4024 /* This is compiled as:
4025 *
4026 * <expr1>
4027 * <expr2>
4028 * OR
4029 * ...
4030 * <exprn>
4031 * OR
4032 */
4033 compile_value(++argp, 0);
4034 do {
4035 compile_value(++argp, 0);
4036 if (current.code_left < 1)
4037 realloc_code();
4038 current.code_left--;
4039 STORE_CODE(current.codep, F_OR);
4040 } while (--i);
4041 }
4042 else if (!i)
4043 {
4044 /* This is compiled as:
4045 *
4046 * <lvalue>
4047 *
4048 * (easy, isn't it?)
4049 */
4050 if (opt_flags & REF_REJECTED)
4051 lambda_error("Reference value in bad position\n");
4052 compile_lvalue(++argp, PROTECT_LVALUE|USE_INDEX_LVALUE);
4053 }
4054 else
4055 {
4056 lambda_error("Missing argument(s) to #'&\n");
4057 }
4058 break;
4059 }
4060
4061 /* ({#'^, <expr1>, ..., <exprn> })
4062 * ({#'^, <lvalue> })
4063 */
4064 case F_XOR:
4065 {
4066 int i;
4067
4068 i = block_size - 2;
4069
4070 if ( i > 0 )
4071 {
4072 /* This is compiled as:
4073 *
4074 * <expr1>
4075 * <expr2>
4076 * OR
4077 * ...
4078 * <exprn>
4079 * OR
4080 */
4081 compile_value(++argp, 0);
4082 do {
4083 compile_value(++argp, 0);
4084 if (current.code_left < 1)
4085 realloc_code();
4086 current.code_left--;
4087 STORE_CODE(current.codep, F_XOR);
4088 } while (--i);
4089 }
4090 else if (!i)
4091 {
4092 /* This is compiled as:
4093 *
4094 * <lvalue>
4095 *
4096 * (easy, isn't it?)
4097 */
4098 if (opt_flags & REF_REJECTED)
4099 lambda_error("Reference value in bad position\n");
4100 compile_lvalue(++argp, PROTECT_LVALUE|USE_INDEX_LVALUE);
4101 }
4102 else
4103 {
4104 lambda_error("Missing argument(s) to #'&\n");
4105 }
4106 break;
4107 }
4108
4109 /* ({#'!, <expr> })
4110 */
4111 case F_NOT:
4112 {
4113 /* This is compiled as
4114 *
4115 * <expr>
4116 * NOT
4117 *
4118 * If the caller accepts reversed logic, the NOT is
4119 * omitted and the fact is stored in opt_flags:NEGATE_GIVEN.
4120 */
4121
4122 if (block_size != 2)
4123 lambda_error("Wrong number of arguments to #'!\n");
4124
4125 opt_flags |= compile_value(++argp, opt_flags & ~ZERO_ACCEPTED);
4126 if (opt_flags & (NEGATE_ACCEPTED|VOID_GIVEN) )
4127 {
4128 opt_flags ^= NEGATE_GIVEN;
4129 }
4130 else
4131 {
4132 if (current.code_left < 1)
4133 realloc_code();
4134 current.code_left--;
4135 STORE_CODE(current.codep, F_NOT);
4136 }
4137 break;
4138 }
4139
4140 default:
4141 {
4142 /* This is compiled as:
4143 *
4144 * optional <save_arg_frame>
4145 * <arg1>
4146 * <arg2>
4147 * ...
4148 * <argN>
4149 * <efun>
4150 * optional <restore_arg_frame>
4151 */
4152
4153 mp_int i;
4154 bytecode_p p;
4155 int f;
4156 Bool needs_ap;
4157 mp_int num_arg;
4158 mp_int min;
4159 mp_int max;
4160 mp_int def;
4161
4162 /* Get the instruction code */
4163 f = type - CLOSURE_EFUN;
4164 min = instrs[f].min_arg;
4165 max = instrs[f].max_arg;
4166
4167 /* Handle the arg frame for varargs efuns */
4168 needs_ap = MY_FALSE;
4169 if (f >= EFUNV_OFFSET || f == F_CALL_OTHER)
4170 {
4171 needs_ap = MY_TRUE;
4172 if (current.code_left < 1)
4173 realloc_code();
4174 current.code_left--;
4175 STORE_CODE(current.codep, F_SAVE_ARG_FRAME);
4176 }
4177
4178 /* Compile the arguments */
4179 num_arg = (mp_int)VEC_SIZE(block) - 1;
4180 for (i = num_arg; --i >= 0; )
4181 {
4182 compile_value(++argp, 0);
4183 }
4184
4185 /* Get the instruction and check if it received the
4186 * correct number of arguments.
4187 */
4188 argp = block->item;
4189 if (current.code_left < 8)
4190 realloc_code();
4191
4192 #ifdef USE_STRUCTS
4193 /* The 'efun' #'-> needs a hidden argument
4194 * for the struct type index.
4195 */
4196 if (f == F_S_INDEX)
4197 {
4198 current.code_left--;
4199 STORE_CODE(current.codep, (bytecode_t)F_NCONST1);
4200 }
4201 #endif /* USE_STRUCTS */
4202
4203 p = current.codep;
4204 if (num_arg < min)
4205 {
4206 /* Not enough arguments... probably */
4207
4208 int g;
4209
4210 if (num_arg == min-1 && 0 != (def = instrs[f].Default))
4211 {
4212 /* We have a default argument */
4213 if (instrs[def].prefix)
4214 {
4215 STORE_CODE(p, instrs[def].prefix);
4216 current.code_left--;
4217 max--;
4218 min--;
4219 }
4220 STORE_CODE(p, instrs[def].opcode);
4221 current.code_left--;
4222 max--;
4223 min--;
4224 }
4225 else
4226 /* Maybe there is a replacement efun */
4227 if ( (g = proxy_efun(f, num_arg)) < 0
4228 || (f = g, MY_FALSE) )
4229 /* No, there isn't */
4230 lambda_error("Too few arguments to %s\n", instrs[f].name);
4231 }
4232 else if (num_arg > max && max != -1)
4233 {
4234 /* More arguments than the efun can handle */
4235 if (f == F_INDEX && num_arg == 3)
4236 {
4237 /* Exception: indexing of wide mappings */
4238 f = F_MAP_INDEX;
4239 }
4240 else
4241 {
4242 lambda_error(
4243 "Too many arguments to %s\n",
4244 instrs[f].name
4245 );
4246 }
4247 }
4248
4249 /* Store function bytecode. */
4250 if (instrs[f].prefix)
4251 {
4252 STORE_CODE(p, instrs[f].prefix);
4253 current.code_left--;
4254 }
4255 STORE_CODE(p, instrs[f].opcode);
4256 current.code_left--;
4257
4258 /* Note the type of the result, and add a CONST0 if
4259 * the caller expects one from a void efun. Always
4260 * add the CONST0 for void varargs efuns.
4261 */
4262 if ( instrs[f].ret_type.typeflags == TYPE_VOID )
4263 {
4264 if (f < EFUNV_OFFSET
4265 && (opt_flags & (ZERO_ACCEPTED|VOID_ACCEPTED)))
4266 {
4267 opt_flags = VOID_GIVEN;
4268 }
4269 else
4270 {
4271 STORE_CODE(p, F_CONST0);
4272 current.code_left--;
4273 }
4274 }
4275
4276 /* Handle the arg frame for varargs efuns */
4277 if (needs_ap)
4278 {
4279 current.code_left--;
4280 STORE_CODE(p, F_RESTORE_ARG_FRAME);
4281 }
4282
4283 current.codep = p;
4284 } /* case default: */
4285 } /* switch */
4286 break;
4287 }
4288 } /* if (efun or operator closure) */
4289 else switch (type) /* type >= CLOSURE_SIMUL_EFUN */
4290 {
4291 default: /* SIMUL_EFUN closure */
4292 {
4293 /* This is compiled as:
4294 * sefun <= 0xffff sefun > 0xffff
4295 *
4296 * opt. SAVE_ARG_FRAME SAVE_ARG_FRAME
4297 * <sefun_object_name>
4298 * <sefun_name>
4299 * <arg1> <arg1>
4300 * ... ...
4301 * <argN> <argN>
4302 * SIMUL_EFUN <sefun> CALL_DIRECT
4303 * opt. RESTORE_ARG_FRAME RESTORE_ARG_FRAME
4304 */
4305
4306 int simul_efun;
4307 mp_int num_arg;
4308 int i;
4309 Bool needs_ap;
4310 Bool needs_call_direct;
4311
4312 simul_efun = type - CLOSURE_SIMUL_EFUN;
4313
4314 needs_ap = MY_FALSE;
4315 needs_call_direct = (simul_efun >= SEFUN_TABLE_SIZE);
4316
4317 if (needs_call_direct)
4318 {
4319 /* We have to call the sefun by name */
4320 static svalue_t string_sv = { T_STRING };
4321
4322 if (current.code_left < 1)
4323 realloc_code();
4324 current.code_left -= 1;
4325 STORE_CODE(current.codep, F_SAVE_ARG_FRAME);
4326 needs_ap = MY_TRUE;
4327
4328 string_sv.u.str = query_simul_efun_file_name();
4329 compile_value(&string_sv, 0);
4330 string_sv.u.str = simul_efunp[simul_efun].name;
4331 compile_value(&string_sv, 0);
4332 }
4333 else if (simul_efunp[simul_efun].num_arg == SIMUL_EFUN_VARARGS
4334 || 0 != (simul_efunp[simul_efun].flags & TYPE_MOD_XVARARGS)
4335 )
4336 {
4337 /* varargs efuns need the arg frame */
4338
4339 if (current.code_left < 1)
4340 realloc_code();
4341 current.code_left -= 1;
4342 STORE_CODE(current.codep, F_SAVE_ARG_FRAME);
4343 needs_ap = MY_TRUE;
4344 }
4345
4346 /* Compile the arguments */
4347
4348 num_arg = (mp_int)VEC_SIZE(block) - 1;
4349 if (!needs_call_direct)
4350 {
4351 function_t *funp = &simul_efunp[simul_efun];
4352 if (num_arg > funp->num_arg
4353 && !(funp->flags & TYPE_MOD_XVARARGS)
4354 )
4355 {
4356 lambda_error(
4357 "Too many arguments to simul_efun %s\n"
4358 , get_txt(funp->name)
4359 );
4360 num_arg = funp->num_arg;
4361 }
4362 }
4363
4364 for (i = num_arg; --i >= 0; )
4365 {
4366 compile_value(++argp, 0);
4367 }
4368
4369 /* and the simul-efun instruction */
4370
4371 if (current.code_left < 3)
4372 realloc_code();
4373
4374 if (needs_call_direct)
4375 {
4376 /* We need the call_other */
4377 current.code_left -= 1;
4378 STORE_CODE(current.codep, F_CALL_DIRECT);
4379 if (num_arg + 1 > 0xff)
4380 lambda_error("Argument number overflow\n");
4381 }
4382 else
4383 {
4384 /* We can call by index */
4385
4386 function_t *funp = &simul_efunp[simul_efun];
4387
4388 if (!needs_ap)
4389 {
4390 /* The function takes fixed number of args:
4391 * push 0s onto the stack for missing args
4392 */
4393
4394 if (num_arg < funp->num_arg
4395 && funp->num_arg != SIMUL_EFUN_VARARGS
4396 )
4397 {
4398 lambda_error(
4399 "Missing arguments to simul_efun %s\n"
4400 , get_txt(funp->name)
4401 );
4402 }
4403
4404 i = funp->num_arg - num_arg;
4405 if (i > 1 && current.code_left < i + 4)
4406 realloc_code();
4407 current.code_left -= i;
4408 while ( --i >= 0 ) {
4409 STORE_CODE(current.codep, F_CONST0);
4410 }
4411 }
4412
4413 STORE_CODE(current.codep, F_SIMUL_EFUN);
4414 STORE_SHORT(current.codep, (short)simul_efun);
4415 current.code_left -= 3;
4416
4417 if (needs_ap)
4418 {
4419 STORE_UINT8(current.codep, F_RESTORE_ARG_FRAME);
4420 current.code_left--;
4421 }
4422 }
4423 break;
4424 } /* CLOSURE_SIMUL_EFUN */
4425
4426 case CLOSURE_PRELIMINARY:
4427 lambda_error("Unimplemented closure type for lambda()\n");
4428
4429 case CLOSURE_UNBOUND_LAMBDA:
4430 case CLOSURE_BOUND_LAMBDA:
4431 case CLOSURE_LAMBDA:
4432 case CLOSURE_LFUN:
4433 {
4434 /* This is compiled as
4435 * alien-lfun: local lfun:
4436 *
4437 * <lfun_closure>
4438 * <arg1> <arg1>
4439 * ... ...
4440 * <argN> <argN>
4441 * FUNCALL N+1 CALL_FUNCTION <lfun-index> N
4442 *
4443 * alien-lfun: lambda->ob != lambda->function.lfun.ob
4444 *
4445 * Inherited lfun closures, context lfun closures and lambda
4446 * closures are compiled similar to alien lfuns using
4447 * F_CALL_CLOSURE.
4448 */
4449
4450 mp_int i;
4451 lambda_t *l;
4452 mp_int block_size;
4453
4454 block_size = (mp_int)VEC_SIZE(block);
4455 l = argp->u.lambda;
4456 if ((type != CLOSURE_UNBOUND_LAMBDA && l->ob != current.lambda_origin)
4457 || (type == CLOSURE_LFUN && l->ob != l->function.lfun.ob)
4458 )
4459 {
4460 /* Compile it like an alien lfun */
4461
4462 if (current.code_left < 1)
4463 realloc_code();
4464 current.code_left -= 1;
4465 STORE_CODE(current.codep, instrs[F_SAVE_ARG_FRAME].opcode);
4466
4467 insert_value_push(argp); /* Push the closure */
4468 for (i = block_size; --i; )
4469 {
4470 compile_value(++argp, 0);
4471 }
4472 if (current.code_left < 3)
4473 realloc_code();
4474 current.code_left -= 3;
4475 STORE_CODE(current.codep, instrs[F_FUNCALL].prefix);
4476 STORE_CODE(current.codep, instrs[F_FUNCALL].opcode);
4477 STORE_CODE(current.codep, instrs[F_RESTORE_ARG_FRAME].opcode);
4478 }
4479 else if (type != CLOSURE_LFUN
4480 || l->function.lfun.inhProg
4481 #ifdef USE_NEW_INLINES
4482 || l->function.lfun.context_size
4483 #endif
4484 )
4485 {
4486 /* Compile it using F_CALL_CLOSURE. */
4487
4488 if (current.code_left < 1)
4489 realloc_code();
4490 current.code_left -= 1;
4491 STORE_CODE(current.codep, instrs[F_SAVE_ARG_FRAME].opcode);
4492
4493 insert_value_push(argp); /* Push the closure */
4494 for (i = block_size; --i; )
4495 {
4496 compile_value(++argp, 0);
4497 }
4498 if (current.code_left < 3)
4499 realloc_code();
4500 current.code_left -= 3;
4501 STORE_CODE(current.codep, instrs[F_CALL_CLOSURE].opcode);
4502 STORE_CODE(current.codep, instrs[F_POP_SECOND].opcode);
4503 STORE_CODE(current.codep, instrs[F_RESTORE_ARG_FRAME].opcode);
4504 }
4505 else
4506 {
4507 /* Intra-object call: we can call by address */
4508
4509 if (current.code_left < 1)
4510 realloc_code();
4511 current.code_left -= 1;
4512 STORE_CODE(current.codep, instrs[F_SAVE_ARG_FRAME].opcode);
4513
4514 for (i = block_size; --i; )
4515 {
4516 compile_value(++argp, 0);
4517 }
4518
4519 if (current.code_left < 6)
4520 realloc_code();
4521
4522 STORE_CODE(current.codep, F_CALL_FUNCTION);
4523 STORE_SHORT(current.codep, l->function.lfun.index);
4524 STORE_CODE(current.codep, instrs[F_RESTORE_ARG_FRAME].opcode);
4525
4526 current.code_left -= 4;
4527 if (block_size > 0x100)
4528 lambda_error("Too many arguments to lfun closure\n");
4529 }
4530 break;
4531 } /* CLOSURE_LFUN */
4532
4533 case CLOSURE_IDENTIFIER:
4534 {
4535
4536 /* This is compiled as
4537 * alien ident: local ident:
4538 *
4539 * <ident_closure>
4540 * FUNCALL 1 IDENTIFIER <ident-index>
4541 *
4542 * The FUNCALL will call call_lambda() which in turn will
4543 * recognize the CLOSURE_IDENTIFIER and act accordingly.
4544 */
4545
4546 lambda_t *l;
4547
4548 l = argp->u.lambda;
4549 if (VEC_SIZE(block) != 1)
4550 lambda_error("Argument to variable\n");
4551
4552 if (l->ob != current.lambda_origin)
4553 {
4554 /* We need the FUNCALL */
4555
4556 if (current.code_left < 1)
4557 realloc_code();
4558 current.code_left -= 1;
4559 STORE_CODE(current.codep, instrs[F_SAVE_ARG_FRAME].opcode);
4560
4561 insert_value_push(argp);
4562 if (current.code_left < 3)
4563 realloc_code();
4564 current.code_left -= 3;
4565 STORE_CODE(current.codep, instrs[F_FUNCALL].prefix);
4566 STORE_CODE(current.codep, instrs[F_FUNCALL].opcode);
4567 STORE_CODE(current.codep, instrs[F_RESTORE_ARG_FRAME].opcode);
4568 }
4569 else
4570 {
4571 /* We can use the IDENTIFIER */
4572
4573 if (current.code_left < 2)
4574 realloc_code();
4575 current.code_left -= 2;
4576 if ((short)l->function.var_index < 0)
4577 lambda_error("Variable not inherited\n");
4578 STORE_CODE(current.codep, F_IDENTIFIER);
4579 STORE_CODE(current.codep, (bytecode_t)l->function.var_index);
4580 }
4581 break;
4582 } /* CLOSURE_IDENTIFIER */
4583 } /* switch(type) for type >= CLOSURE_SIMUL_EFUN */
4584 break;
4585 } /* end of case T_POINTER (block compiling code) */
4586
4587 case T_QUOTED_ARRAY: /* ----- T_QUOTED_ARRAY ----- */
4588 /* This compiles into the value itself minus one quote.
4589 */
4590
4591 insert_value_push(value);
4592 if (!--current.valuep->x.quotes)
4593 current.valuep->type = T_POINTER;
4594 break;
4595
4596 case T_SYMBOL: /* ----- T_SYMBOL ----- */
4597 /* Symbols with more than one quote compile into the value itself
4598 * minus one quote.
4599 * Symbols with just one quote compile into 'LOCAL <index>'. This may
4600 * create the local variable in the first place.
4601 */
4602
4603 if (value->x.quotes > 1)
4604 {
4605 insert_value_push(value);
4606 --current.valuep->x.quotes;
4607 }
4608 else
4609 {
4610 /* Make/find the local variable to the symbol name and
4611 * compile the LOCAL instruction.
4612 */
4613 symbol_t *sym;
4614
4615 sym = make_symbol(value->u.str);
4616 if (sym->index < 0)
4617 lambda_error("Symbol '%s' not bound\n"
4618 , get_txt(sym->name));
4619 if (current.code_left < 2)
4620 realloc_code();
4621 STORE_CODE(current.codep, F_LOCAL);
4622 STORE_CODE(current.codep, (bytecode_t)sym->index);
4623 current.code_left -= 2;
4624 }
4625 break;
4626
4627 case T_NUMBER: /* ----- T_NUMBER ----- */
4628 {
4629 /* Number are compiled as optimal as possible:
4630 * num == 0: CONST0
4631 * == 1: CONST1
4632 * 1 < num < 0x100: CLIT <num>
4633 * -0x100 < num < 0: NCLIT -<num>
4634 *
4635 * Other numbers are compiled as normal values.
4636 */
4637
4638 mp_int i;
4639
4640 i = value->u.number;
4641 if (i <= -0x100 || i >= 0x100)
4642 {
4643 insert_value_push(value);
4644 }
4645 else if (i >= 0)
4646 {
4647 if (current.code_left < 2)
4648 realloc_code();
4649 if (!i)
4650 {
4651 if (opt_flags & (VOID_ACCEPTED|ZERO_ACCEPTED))
4652 {
4653 /* The caller doesn't really need a value */
4654 opt_flags = VOID_GIVEN;
4655 break;
4656 }
4657 STORE_CODE(current.codep, F_CONST0);
4658 current.code_left--;
4659 break;
4660 }
4661 else if (i == 1)
4662 {
4663 STORE_CODE(current.codep, F_CONST1);
4664 current.code_left--;
4665 break;
4666 }
4667 STORE_CODE(current.codep, F_CLIT);
4668 STORE_UINT8(current.codep, (unsigned char)i);
4669 current.code_left -= 2;
4670 break;
4671 }
4672 else /* -0x100 < i < 0 */
4673 {
4674 if (current.code_left < 2)
4675 realloc_code();
4676 STORE_CODE(current.codep, F_NCLIT);
4677 STORE_UINT8(current.codep, (unsigned char)(-i));
4678 current.code_left -= 2;
4679 break;
4680 }
4681 break;
4682 }
4683
4684 default: /* ----- other value ----- */
4685 /* Generate a LAMBDA_(C)CONSTANT for this value. */
4686 insert_value_push(value);
4687 break;
4688 }
4689
4690 /* Finish up */
4691 current.levels_left++;
4692 return opt_flags;
4693
4694 } /* compile_value() */
4695
4696 /*-------------------------------------------------------------------------*/
4697 static Bool
is_lvalue(svalue_t * argp,int index_lvalue)4698 is_lvalue (svalue_t *argp, int index_lvalue)
4699
4700 /* Test if the value <argp> can be compiled into a lvalue.
4701 * If <index_lvalue> is not zero, arrays compiling into an indexing
4702 * instruction are accepted, too.
4703 */
4704
4705 {
4706 switch(argp->type)
4707 {
4708 case T_SYMBOL:
4709 return argp->x.quotes == 1;
4710
4711 case T_POINTER:
4712 if (index_lvalue)
4713 {
4714 vector_t *block;
4715
4716 block = argp->u.vec;
4717 if (VEC_SIZE(block) != 3)
4718 break;
4719
4720 argp = block->item;
4721 if (argp->type != T_CLOSURE)
4722 {
4723 break;
4724 }
4725
4726 switch (argp->x.closure_type)
4727 {
4728 case F_INDEX +CLOSURE_EFUN:
4729 case F_RINDEX+CLOSURE_EFUN:
4730 case F_AINDEX+CLOSURE_EFUN:
4731 #ifdef USE_STRUCTS
4732 case F_S_INDEX +CLOSURE_EFUN:
4733 #endif /* USE_STRUCTS */
4734 case CLOSURE_IDENTIFIER:
4735 return MY_TRUE;
4736 }
4737 }
4738 break;
4739
4740 case T_CLOSURE:
4741 if (argp->x.closure_type == CLOSURE_IDENTIFIER)
4742 return MY_TRUE;
4743 break;
4744 }
4745
4746 /* Default: it's not. */
4747 return MY_FALSE;
4748 } /* is_lvalue() */
4749
4750 /*-------------------------------------------------------------------------*/
4751 static void
compile_lvalue(svalue_t * argp,int flags)4752 compile_lvalue (svalue_t *argp, int flags)
4753
4754 /* Compile the <argp> into an lvalue, according to the <flags>. The function
4755 * allocates enough space in the code buffer to store the assignment code
4756 * (1 Byte) as well, so on return .code_left >= 1 holds.
4757 */
4758
4759 {
4760 switch(argp->type) {
4761
4762 /* 'a: Symbol of a local variable.
4763 */
4764 case T_SYMBOL:
4765 /* This compiles to:
4766 *
4767 * PUSH_LOCAL_VARIABLE_LVALUE <index>
4768 */
4769
4770 {
4771 symbol_t *sym;
4772
4773 if (argp->x.quotes > 1)
4774 break;
4775
4776 /* Find (or create) the variable for this symbol */
4777 sym = make_symbol(argp->u.str);
4778 if (sym->index < 0)
4779 sym->index = current.num_locals++;
4780
4781 if (current.code_left < 3)
4782 realloc_code();
4783 current.code_left -= 2;
4784 STORE_CODE(current.codep, F_PUSH_LOCAL_VARIABLE_LVALUE);
4785 STORE_UINT8(current.codep, (bytecode_t)sym->index);
4786 return;
4787 }
4788
4789 /* ({ indexing operation })
4790 */
4791 case T_POINTER:
4792 {
4793 vector_t *block;
4794
4795 block = argp->u.vec;
4796 if (block != &null_vector && (argp = block->item)->type == T_CLOSURE)
4797 {
4798 switch (argp->x.closure_type)
4799 {
4800
4801 /* ({ #'[, map|array, index [, index] })
4802 * ({ #'[<, map|array, index })
4803 * ({ #'->, struct, index })
4804 */
4805 case F_INDEX +CLOSURE_EFUN:
4806 case F_RINDEX+CLOSURE_EFUN:
4807 case F_AINDEX+CLOSURE_EFUN:
4808 #ifdef USE_STRUCTS
4809 case F_S_INDEX +CLOSURE_EFUN:
4810 #endif /* USE_STRUCTS */
4811 if (VEC_SIZE(block) == 3)
4812 {
4813 /* Indexing of an array or normal mapping.
4814 */
4815 if (is_lvalue(argp+1, flags & USE_INDEX_LVALUE))
4816 {
4817 compile_value(argp+2, 0);
4818
4819 #ifdef USE_STRUCTS
4820 if (!(flags & PROTECT_LVALUE)
4821 && argp->x.closure_type == F_S_INDEX + CLOSURE_EFUN
4822 )
4823 {
4824 if (current.code_left < 1)
4825 realloc_code();
4826 current.code_left--;
4827 STORE_CODE(current.codep, (bytecode_t) F_NCONST1);
4828 }
4829 #endif /* USE_STRUCTS */
4830
4831 compile_lvalue(argp+1, flags & PROTECT_LVALUE);
4832 if (current.code_left < 3)
4833 realloc_code();
4834 if (flags & PROTECT_LVALUE)
4835 {
4836 current.code_left -= 1;
4837 if (argp->x.closure_type == F_INDEX + CLOSURE_EFUN)
4838 STORE_CODE(current.codep
4839 , (bytecode_t)
4840 (F_PROTECTED_INDEX_LVALUE));
4841 else if (argp->x.closure_type == F_RINDEX + CLOSURE_EFUN)
4842 STORE_CODE(current.codep
4843 , (bytecode_t)
4844 (F_PROTECTED_RINDEX_LVALUE));
4845 else if (argp->x.closure_type == F_AINDEX + CLOSURE_EFUN)
4846 STORE_CODE(current.codep
4847 , (bytecode_t)
4848 (F_PROTECTED_AINDEX_LVALUE));
4849 #ifdef USE_STRUCTS
4850 else if (argp->x.closure_type == F_S_INDEX + CLOSURE_EFUN)
4851 {
4852 current.code_left -= 1;
4853 STORE_CODE(current.codep, (bytecode_t) F_NCONST1);
4854 STORE_CODE(current.codep
4855 , (bytecode_t)
4856 (F_PROTECTED_INDEX_S_LVALUE));
4857 }
4858 #endif /* USE_STRUCTS */
4859 } else {
4860 current.code_left -= 1;
4861 if (argp->x.closure_type == F_INDEX + CLOSURE_EFUN)
4862 STORE_CODE(current.codep
4863 , (bytecode_t)
4864 (F_INDEX_LVALUE));
4865 else if (argp->x.closure_type == F_RINDEX + CLOSURE_EFUN)
4866 STORE_CODE(current.codep
4867 , (bytecode_t)
4868 (F_RINDEX_LVALUE));
4869 else if (argp->x.closure_type == F_AINDEX + CLOSURE_EFUN)
4870 STORE_CODE(current.codep
4871 , (bytecode_t)
4872 (F_AINDEX_LVALUE));
4873 #ifdef USE_STRUCTS
4874 else if (argp->x.closure_type == F_S_INDEX + CLOSURE_EFUN)
4875 {
4876 STORE_CODE(current.codep
4877 , (bytecode_t)
4878 (F_INDEX_S_LVALUE));
4879 }
4880 #endif /* USE_STRUCTS */
4881 }
4882 return;
4883 }
4884
4885 compile_value(argp+1, 0);
4886 compile_value(argp+2, 0);
4887 if (current.code_left < 2)
4888 realloc_code();
4889 if (flags & PROTECT_LVALUE) {
4890 current.code_left -= 1;
4891 if (argp->x.closure_type == F_INDEX + CLOSURE_EFUN)
4892 STORE_CODE(current.codep
4893 , (bytecode_t)
4894 (F_PUSH_PROTECTED_INDEXED_LVALUE));
4895 else if (argp->x.closure_type == F_RINDEX + CLOSURE_EFUN)
4896 STORE_CODE(current.codep
4897 , (bytecode_t)
4898 (F_PUSH_PROTECTED_RINDEXED_LVALUE));
4899 else if (argp->x.closure_type == F_AINDEX + CLOSURE_EFUN)
4900 STORE_CODE(current.codep
4901 , (bytecode_t)
4902 (F_PUSH_PROTECTED_AINDEXED_LVALUE));
4903 #ifdef USE_STRUCTS
4904 else if (argp->x.closure_type == F_S_INDEX + CLOSURE_EFUN)
4905 {
4906 current.code_left -= 1;
4907 STORE_CODE(current.codep, (bytecode_t) F_NCONST1);
4908 STORE_CODE(current.codep
4909 , (bytecode_t)
4910 (F_PUSH_PROTECTED_INDEXED_S_LVALUE));
4911 }
4912 #endif /* USE_STRUCTS */
4913 } else {
4914 current.code_left -= 1;
4915 if (argp->x.closure_type == F_INDEX + CLOSURE_EFUN)
4916 STORE_CODE(current.codep
4917 , (bytecode_t)
4918 (F_PUSH_INDEXED_LVALUE));
4919 else if (argp->x.closure_type == F_RINDEX + CLOSURE_EFUN)
4920 STORE_CODE(current.codep
4921 , (bytecode_t)
4922 (F_PUSH_RINDEXED_LVALUE));
4923 else if (argp->x.closure_type == F_AINDEX + CLOSURE_EFUN)
4924 STORE_CODE(current.codep
4925 , (bytecode_t)
4926 (F_PUSH_AINDEXED_LVALUE));
4927 #ifdef USE_STRUCTS
4928 else if (argp->x.closure_type == F_S_INDEX + CLOSURE_EFUN)
4929 {
4930 current.code_left -= 1;
4931 STORE_CODE(current.codep, (bytecode_t) F_NCONST1);
4932 STORE_CODE(current.codep
4933 , (bytecode_t)
4934 (F_PUSH_INDEXED_S_LVALUE));
4935 }
4936 #endif /* USE_STRUCTS */
4937 }
4938 return;
4939 } /* if (VEC_SIZE(block) == 3) */
4940
4941 if (VEC_SIZE(block) == 4
4942 && argp->x.closure_type == F_INDEX +CLOSURE_EFUN)
4943 {
4944 /* Indexing of a wide mapping.
4945 */
4946 compile_value(argp+1, 0);
4947 compile_value(argp+2, 0);
4948 compile_value(argp+3, 0);
4949
4950 if (current.code_left < 2)
4951 realloc_code();
4952
4953 if (flags & PROTECT_LVALUE)
4954 {
4955 current.code_left -= 1;
4956 STORE_CODE(current.codep,
4957 F_PUSH_PROTECTED_INDEXED_MAP_LVALUE);
4958 }
4959 else
4960 {
4961 current.code_left -= 1;
4962 STORE_CODE(current.codep,
4963 F_PUSH_INDEXED_MAP_LVALUE);
4964 }
4965 return;
4966 } /* if (VEC_SIZE(block) == 4...) */
4967
4968 /* Otherwise: raise an error */
4969 break;
4970
4971 /* ({#'[..], map/array, index, index })
4972 */
4973 case F_RANGE +CLOSURE_EFUN:
4974 if (VEC_SIZE(block) != 4)
4975 break;
4976 compile_value(argp += 2, 0);
4977 compile_value(++argp, 0);
4978 compile_lvalue(argp - 2, flags & PROTECT_LVALUE);
4979
4980 if (current.code_left < 2)
4981 realloc_code();
4982 if (flags & PROTECT_LVALUE)
4983 {
4984 current.code_left -= 1;
4985 STORE_CODE(current.codep, F_PROTECTED_RANGE_LVALUE);
4986 }
4987 else
4988 {
4989 current.code_left -= 1;
4990 STORE_CODE(current.codep, F_RANGE_LVALUE);
4991 }
4992 return;
4993
4994 /* ({#'[..<], map/array, index, index })
4995 * ({#'[<..], map/array, index, index })
4996 * ({#'[<..<], map/array, index, index })
4997 * ({#'[..>], map/array, index, index })
4998 * ({#'[>..], map/array, index, index })
4999 * ({#'[<..>], map/array, index, index })
5000 * ({#'[>..<], map/array, index, index })
5001 * ({#'[>..>], map/array, index, index })
5002 */
5003 case F_NR_RANGE +CLOSURE_EFUN:
5004 case F_RN_RANGE +CLOSURE_EFUN:
5005 case F_RR_RANGE +CLOSURE_EFUN:
5006 case F_NA_RANGE +CLOSURE_EFUN:
5007 case F_AN_RANGE +CLOSURE_EFUN:
5008 case F_RA_RANGE +CLOSURE_EFUN:
5009 case F_AR_RANGE +CLOSURE_EFUN:
5010 case F_AA_RANGE +CLOSURE_EFUN:
5011 {
5012 int code;
5013
5014 if (VEC_SIZE(block) != 4)
5015 break;
5016
5017 code = F_ILLEGAL;
5018 switch(argp->x.closure_type)
5019 {
5020 case F_NR_RANGE+CLOSURE_EFUN:
5021 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_NR_RANGE_LVALUE
5022 : F_NR_RANGE_LVALUE;
5023 break;
5024 case F_RN_RANGE+CLOSURE_EFUN:
5025 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_RN_RANGE_LVALUE
5026 : F_RN_RANGE_LVALUE;
5027 break;
5028 case F_RR_RANGE+CLOSURE_EFUN:
5029 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_RR_RANGE_LVALUE
5030 : F_RR_RANGE_LVALUE;
5031 case F_NA_RANGE+CLOSURE_EFUN:
5032 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_NA_RANGE_LVALUE
5033 : F_NA_RANGE_LVALUE;
5034 break;
5035 case F_AN_RANGE+CLOSURE_EFUN:
5036 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_AN_RANGE_LVALUE
5037 : F_AN_RANGE_LVALUE;
5038 break;
5039 case F_RA_RANGE+CLOSURE_EFUN:
5040 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_RA_RANGE_LVALUE
5041 : F_RA_RANGE_LVALUE;
5042 break;
5043 case F_AR_RANGE+CLOSURE_EFUN:
5044 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_AR_RANGE_LVALUE
5045 : F_AR_RANGE_LVALUE;
5046 break;
5047 case F_AA_RANGE+CLOSURE_EFUN:
5048 code = (flags & PROTECT_LVALUE) ? F_PROTECTED_AA_RANGE_LVALUE
5049 : F_AA_RANGE_LVALUE;
5050 break;
5051 }
5052
5053 compile_value(argp += 2, 0);
5054 compile_value(++argp, 0);
5055 compile_lvalue(argp - 2, flags & PROTECT_LVALUE);
5056
5057 if (current.code_left < 2)
5058 realloc_code();
5059 current.code_left -= 1;
5060 STORE_CODE(current.codep, (bytecode_t)code);
5061 return;
5062 }
5063
5064 /* ({ #'[, mapping, index [,index] })
5065 */
5066 case F_MAP_INDEX +CLOSURE_EFUN:
5067 if (VEC_SIZE(block) != 4)
5068 break;
5069
5070 compile_value(++argp, 0);
5071 compile_value(++argp, 0);
5072 compile_value(++argp, 0);
5073
5074 if (current.code_left < 2)
5075 realloc_code();
5076 if (flags & PROTECT_LVALUE)
5077 {
5078 current.code_left -= 1;
5079 STORE_CODE(current.codep,
5080 F_PUSH_PROTECTED_INDEXED_MAP_LVALUE);
5081 }
5082 else
5083 {
5084 current.code_left -= 1;
5085 STORE_CODE(current.codep, F_PUSH_INDEXED_MAP_LVALUE);
5086 }
5087 return;
5088
5089 /* ({ #'global_var })
5090 */
5091 case CLOSURE_IDENTIFIER:
5092 {
5093 lambda_t *l;
5094
5095 if (VEC_SIZE(block) != 1)
5096 break;
5097 l = argp->u.lambda;
5098 if (l->ob != current.lambda_origin)
5099 break;
5100 if (current.code_left < 3)
5101 realloc_code();
5102 current.code_left -= 2;
5103 if ((short)l->function.var_index < 0)
5104 lambda_error("Variable not inherited\n");
5105 STORE_CODE(current.codep, F_PUSH_IDENTIFIER_LVALUE);
5106 STORE_UINT8(current.codep, (bytecode_t)l->function.var_index);
5107 return;
5108 }
5109 } /* switch(closure_type) */
5110 }
5111 break;
5112 } /* case T_POINTER */
5113
5114 /* precomputed closure: only identifiers in this object are allowed
5115 */
5116 case T_CLOSURE:
5117 {
5118 switch (argp->x.closure_type)
5119 {
5120 case CLOSURE_IDENTIFIER:
5121 {
5122 lambda_t *l;
5123
5124 l = argp->u.lambda;
5125 if (l->ob != current.lambda_origin)
5126 break;
5127 if (current.code_left < 3)
5128 realloc_code();
5129 current.code_left -= 2;
5130 if ((short)l->function.var_index < 0)
5131 lambda_error("Variable not inherited\n");
5132 STORE_CODE(current.codep, F_PUSH_IDENTIFIER_LVALUE);
5133 STORE_CODE(current.codep, (bytecode_t)(l->function.var_index));
5134 return;
5135 }
5136 }
5137 break;
5138 }
5139
5140 } /* switch(argp->type) */
5141
5142 lambda_error("Illegal lvalue\n");
5143 } /* compile_lvalue() */
5144
5145 /*-------------------------------------------------------------------------*/
5146 static lambda_t *
lambda(vector_t * args,svalue_t * block,object_t * origin)5147 lambda (vector_t *args, svalue_t *block, object_t *origin)
5148
5149 /* Compile a lambda closure with the arguments <args>, an array with symbols,
5150 * and the body <block>. If <origin> is given, the created lambda is bound
5151 * that object (with proper respect of scheduled program replacements).
5152 *
5153 * Result is a pointer to the created lambda structure, the size of the code
5154 * generated can be determined as current.code_max - current.code_left before
5155 * lambda() is called again.
5156 */
5157
5158 {
5159 mp_int i, j;
5160 svalue_t *argp;
5161 mp_int num_values; /* number of values needed */
5162 mp_int values_size; /* size of the value block */
5163 mp_int code_size; /* size of the generated code */
5164 char *l0; /* allocated memory for the lambda */
5165 lambda_t *l; /* pointer to the lambda structure */
5166 int void_given; /* result flags from the compiler */
5167
5168 /* Initialize the work area */
5169
5170 current.symbols_left = current.symbol_max =
5171 sizeof current.symbols[0] * SYMTAB_START_SIZE;
5172 current.symbol_mask = (long)(current.symbol_max- sizeof(symbol_t *));
5173 current.code = NULL;
5174 current.values = NULL;
5175 current.symbols = xalloc((size_t)current.symbol_max);
5176 i = SYMTAB_START_SIZE - 1;
5177 do {
5178 current.symbols[i] = 0;
5179 } while (--i >= 0);
5180
5181 switch_initialized = MY_FALSE;
5182
5183 /* Evaluate the args array: check that all entries are symbols,
5184 * enter them into the symbol table and check for duplicates.
5185 */
5186 argp = args->item;
5187 j = (mp_int)VEC_SIZE(args);
5188 for (i = 0; i < j; i++, argp++)
5189 {
5190 symbol_t *sym;
5191
5192 if (argp->type != T_SYMBOL)
5193 {
5194 lambda_error("Illegal argument type to lambda()\n");
5195 }
5196 sym = make_symbol(argp->u.str);
5197 if (sym->index >= 0)
5198 lambda_error("Double symbol name in lambda arguments\n");
5199 sym->index = i;
5200 }
5201
5202 current.num_locals = i; /* Args count as locals, too */
5203
5204 /* Continue initializing the work area */
5205
5206 current.break_stack = current.max_break_stack = 0;
5207
5208 current.code_max = CODE_BUFFER_START_SIZE;
5209 current.code_left = CODE_BUFFER_START_SIZE-3;
5210 current.levels_left = MAX_LAMBDA_LEVELS;
5211 if ( !(current.code = current.codep = xalloc((size_t)current.code_max)) )
5212 lambda_error("Out of memory (%"PRIdMPINT
5213 " bytes) for initial codebuffer\n", current.code_max);
5214
5215 /* Store the lambda code header */
5216 STORE_UINT8(current.codep, 0); /* dummy for num values */
5217 STORE_INT8(current.codep, (char)current.num_locals); /* num arguments */
5218 STORE_UINT8(current.codep, 0); /* dummy for num variables */
5219
5220 current.value_max = current.values_left = VALUE_START_MAX;
5221 if ( !(current.values =
5222 xalloc(current.value_max * sizeof current.values[0])) )
5223 {
5224 lambda_error("Out of memory (%"PRIdMPINT
5225 " bytes) for initial value buffer\n",
5226 current.value_max * sizeof current.values[0]);
5227 }
5228 current.valuep = current.values + current.value_max;
5229
5230 current.lambda_origin = origin;
5231
5232 /* Now compile */
5233
5234 void_given = compile_value(block, ZERO_ACCEPTED|REF_REJECTED);
5235
5236 /* Add the final F_RETURN instruction */
5237 if (current.code_left < 1)
5238 realloc_code();
5239 current.code_left -= 1;
5240 STORE_CODE(current.codep, (bytecode_t)(void_given & VOID_GIVEN
5241 ? F_RETURN0
5242 : F_RETURN));
5243
5244 /* Determine number and size of values needed */
5245 num_values = current.value_max - current.values_left;
5246 values_size = (long)(num_values * sizeof (svalue_t));
5247 code_size = current.code_max - current.code_left;
5248
5249 if (num_values == 0xff)
5250 {
5251 /* Special case: we have exactly 255 values, that means
5252 * we are going to use the indirect way of storing the number
5253 * of values. At the same time, the extra entry to store
5254 * the number of values has not been reserved yet.
5255 * Do it now.
5256 */
5257 num_values++;
5258 values_size += (long)sizeof(svalue_t);
5259 current.values_left--;
5260 (--current.valuep)->type = T_INVALID;
5261 }
5262
5263 /* Allocate the memory for values, lambda_t and code */
5264 #ifndef USE_NEW_INLINES
5265 l0 = xalloc(values_size + sizeof *l - sizeof l->function + code_size);
5266 #else /* USE_NEW_INLINES */
5267 l0 = xalloc(values_size + SIZEOF_LAMBDA(0) - sizeof l->function + code_size);
5268 #endif /* USE_NEW_INLINES */
5269
5270 /* Copy the data */
5271 memcpy(l0, current.valuep, (size_t)values_size);
5272 l0 += values_size;
5273 l = (lambda_t *)l0;
5274 closure_init_lambda(l, origin);
5275
5276 memcpy(l->function.code, current.code, (size_t)code_size);
5277
5278 /* Fix number of constant values */
5279 if (num_values >= 0xff)
5280 {
5281 /* The entry in the value block has been reserved for this */
5282 ((svalue_t *)l)[-0x100].u.number = num_values;
5283 PUT_UINT8(l->function.code, 0xff);
5284 }
5285 else
5286 {
5287 PUT_UINT8(l->function.code, (unsigned char)num_values);
5288 }
5289
5290 /* Fix number of variables */
5291 PUT_UINT8( l->function.code+2
5292 , (unsigned char)(current.num_locals + current.max_break_stack));
5293
5294 /* Clean up */
5295 free_symbols();
5296 xfree(current.code);
5297 xfree(current.values);
5298
5299 /* If the lambda is to be bound to an object, check if the object's program
5300 * is scheduled for replacement. If not, mark the object as referenced.
5301 */
5302 if (origin
5303 && ( !(origin->prog->flags & P_REPLACE_ACTIVE)
5304 || !lambda_ref_replace_program(origin, l, CLOSURE_LAMBDA, code_size, args, block)
5305 ) )
5306 {
5307 origin->flags |= O_LAMBDA_REFERENCED;
5308 }
5309
5310 /* Return the lambda */
5311 return l;
5312 } /* lambda() */
5313
5314 /*-------------------------------------------------------------------------*/
5315 void
free_closure(svalue_t * svp)5316 free_closure (svalue_t *svp)
5317
5318 /* Free the closure value in <svp> and all references it holds.
5319 */
5320
5321 {
5322 lambda_t *l;
5323 int type;
5324
5325 if (!CLOSURE_MALLOCED(type = svp->x.closure_type))
5326 {
5327 /* Simple closure */
5328 free_object(svp->u.ob, "free_closure");
5329 return;
5330 }
5331
5332 /* Lambda closure */
5333
5334 l = svp->u.lambda;
5335 if (--l->ref)
5336 return;
5337
5338 if (l->prog_ob)
5339 free_object(l->prog_ob, "free_closure: lambda creator");
5340
5341 if (CLOSURE_HAS_CODE(type))
5342 {
5343 /* Free all the values for this lambda, then the memory */
5344
5345 mp_int num_values;
5346
5347 if (type != CLOSURE_UNBOUND_LAMBDA)
5348 free_object(l->ob, "free_closure");
5349 svp = (svalue_t *)l;
5350 if ( (num_values = EXTRACT_UCHAR(l->function.code)) == 0xff)
5351 {
5352 num_values = svp[-0x100].u.number;
5353 }
5354 while (--num_values >= 0)
5355 free_svalue(--svp);
5356 xfree(svp);
5357 return;
5358 }
5359
5360 free_object(l->ob, "free_closure: lambda object");
5361 if (type == CLOSURE_BOUND_LAMBDA)
5362 {
5363 /* BOUND_LAMBDAs are indirections to UNBOUND_LAMBDA structures.
5364 * Free the BOUND_LAMBDA and then deref/free the referenced
5365 * UNBOUND_LAMBDA.
5366 */
5367
5368 mp_int num_values;
5369 lambda_t *l2;
5370
5371 l2 = l->function.lambda;
5372 xfree(l);
5373
5374 if (--l2->ref)
5375 return;
5376
5377 if (l2->prog_ob)
5378 free_object(l2->prog_ob, "free_closure: unbound lambda creator");
5379
5380 svp = (svalue_t *)l2;
5381 if ( (num_values = EXTRACT_UCHAR(l2->function.code)) == 0xff)
5382 num_values = svp[-0x100].u.number;
5383 while (--num_values >= 0)
5384 free_svalue(--svp);
5385 xfree(svp);
5386 return;
5387 }
5388
5389 if (type == CLOSURE_LFUN)
5390 {
5391 free_object(l->function.lfun.ob, "free_closure: lfun object");
5392 if(l->function.lfun.inhProg)
5393 free_prog(l->function.lfun.inhProg, MY_TRUE);
5394 }
5395
5396 #ifdef USE_NEW_INLINES
5397 if (type == CLOSURE_LFUN)
5398 {
5399 unsigned short num = l->function.lfun.context_size;
5400
5401 l->function.lfun.context_size = 0; /* ...just in case... */
5402 while (num > 0)
5403 {
5404 num--;
5405 free_svalue(&(l->context[num]));
5406 }
5407 }
5408 #endif /* USE_NEW_INLINES */
5409
5410 /* else CLOSURE_LFUN || CLOSURE_IDENTIFIER || CLOSURE_PRELIMINARY:
5411 * no further references held.
5412 */
5413 xfree(l);
5414 } /* free_closure() */
5415
5416 /*-------------------------------------------------------------------------*/
5417 Bool
is_undef_closure(svalue_t * sp)5418 is_undef_closure (svalue_t *sp)
5419
5420 /* Return TRUE if <sp> is an efun closure to F_UNDEF.
5421 * It's a simple function, but it reduces the couplings to instrs.h .
5422 *
5423 * With the current way closure svalues are handled, no closure should
5424 * be found 'undef', but this check is kept around just in case...
5425 *
5426 * Called by swap.c and efuns.c
5427 */
5428
5429 {
5430 return (sp->type == T_CLOSURE)
5431 && (sp->x.closure_type == F_UNDEF+CLOSURE_EFUN);
5432 } /* is_undef_closure() */
5433
5434 /*-------------------------------------------------------------------------*/
5435 void
closure_lookup_lfun_prog(lambda_t * l,program_t ** pProg,string_t ** pName,Bool * pIsInherited)5436 closure_lookup_lfun_prog ( lambda_t * l
5437 , program_t ** pProg
5438 , string_t ** pName
5439 , Bool * pIsInherited
5440 )
5441
5442 /* For lfun/context closure <l>, lookup the defining program and
5443 * function name, and store the pointers (uncounted) in *<pProg>
5444 * and *<pName>. If the closure is defined in a program inherited
5445 * by <l>->function.lfun.ob, *<pIsInherited> is set to TRUE.
5446 *
5447 * The results are undefined if called for non-lfun/context closures.
5448 *
5449 * The function is used by closure_to_string() and the get_type_info()
5450 * efun.
5451 */
5452
5453 {
5454 object_t *ob;
5455 int ix;
5456 program_t *prog;
5457 fun_hdr_p fun;
5458 funflag_t flags;
5459 inherit_t *inheritp;
5460 Bool is_inherited;
5461
5462 is_inherited = MY_FALSE;
5463
5464 ob = l->function.lfun.ob;
5465 ix = l->function.lfun.index;
5466
5467 /* Get the program resident */
5468 if (O_PROG_SWAPPED(ob)) {
5469 ob->time_of_ref = current_time;
5470 if (load_ob_from_swap(ob) < 0)
5471 errorf("Out of memory\n");
5472 }
5473
5474 /* Find the true definition of the function */
5475 prog = ob->prog;
5476
5477 if (l->function.lfun.inhProg)
5478 {
5479 while (prog != l->function.lfun.inhProg)
5480 {
5481 #ifdef DEBUG
5482 if (!prog->num_inherited)
5483 errorf("(closure_lookup_lfun_prog): Couldn't find "
5484 "program '%s' in object '%s' with function index %ld. "
5485 "Found program '%s' instead.\n"
5486 , get_txt(l->function.lfun.inhProg->name)
5487 , get_txt(ob->name)
5488 , (long) l->function.lfun.index
5489 , get_txt(prog->name)
5490 );
5491 #endif
5492
5493 inheritp = search_function_inherit(prog, ix);
5494 ix -= inheritp->function_index_offset;
5495 prog = inheritp->prog;
5496
5497 #ifdef DEBUG
5498 if (ix >= prog->num_functions)
5499 errorf("(closure_lookup_lfun_prog): ix %ld > number of "
5500 "functions %ld in program '%s'\n"
5501 , (long) ix
5502 , (long) prog->num_functions
5503 , get_txt(prog->name)
5504 );
5505 #endif
5506 }
5507
5508 is_inherited = MY_TRUE;
5509 }
5510
5511 flags = prog->functions[ix];
5512 while (flags & NAME_INHERITED)
5513 {
5514 is_inherited = MY_TRUE;
5515 inheritp = &prog->inherit[flags & INHERIT_MASK];
5516 ix -= inheritp->function_index_offset;
5517 prog = inheritp->prog;
5518 flags = prog->functions[ix];
5519 }
5520
5521 /* Copy the function name pointer (a shared string) */
5522 fun = prog->program + (flags & FUNSTART_MASK);
5523 memcpy(pName, FUNCTION_NAMEP(fun) , sizeof *pName);
5524
5525 /* Copy the other result values */
5526 *pProg = prog;
5527 *pIsInherited = is_inherited;
5528 } /* closure_lookup_lfun_prog() */
5529
5530 /*-------------------------------------------------------------------------*/
5531 const char *
closure_operator_to_string(int type)5532 closure_operator_to_string (int type)
5533
5534 /* <type> is the code for a closure operator (the caller has to make sure
5535 * of that!).
5536 * If <type> denotes one of the non-efun operators, return its textual
5537 * presentation as a pointer to a constant string.
5538 * Otherwise return NULL.
5539 */
5540
5541 {
5542 const char *str = NULL;
5543
5544 if ((type & -0x0800) == CLOSURE_OPERATOR)
5545 {
5546 switch(type - CLOSURE_OPERATOR)
5547 {
5548 case F_POP_VALUE:
5549 str = ",";
5550 break;
5551
5552 case F_BBRANCH_WHEN_NON_ZERO:
5553 str = "do";
5554 break;
5555
5556 case F_BBRANCH_WHEN_ZERO:
5557 str = "while";
5558 break;
5559
5560 case F_BRANCH:
5561 str = "continue";
5562 break;
5563
5564 case F_CSTRING0:
5565 str = "default";
5566 break;
5567
5568 case F_BRANCH_WHEN_ZERO:
5569 str = "?";
5570 break;
5571
5572 case F_BRANCH_WHEN_NON_ZERO:
5573 str = "?!";
5574 break;
5575
5576 case F_POST_INC:
5577 str = "++";
5578 break;
5579
5580 case F_POST_DEC:
5581 str = "--";
5582 break;
5583
5584 } /* switch() */
5585 } /* if() */
5586
5587 return str;
5588 } /* closure_operator_to_string() */
5589
5590 /*-------------------------------------------------------------------------*/
5591 const char *
closure_efun_to_string(int type)5592 closure_efun_to_string (int type)
5593
5594 /* <type> is the code for a closure efun (the caller has to make sure
5595 * of that!), result is the efun name.
5596 * If <type> denotes one of the non-efun operators, return its textual
5597 * presentation as a pointer to a constant string.
5598 *
5599 * Result is NULL if <type> is not an efun.
5600 */
5601
5602 {
5603 const char *str = NULL;
5604
5605 if ((type & -0x0800) == CLOSURE_EFUN)
5606 {
5607 switch(type - CLOSURE_EFUN)
5608 {
5609 case F_INDEX:
5610 str = "[";
5611 break;
5612
5613 case F_RINDEX:
5614 str = "[<";
5615 break;
5616
5617 case F_RANGE:
5618 str = "[..]";
5619 break;
5620
5621 case F_NR_RANGE:
5622 str = "[..<]";
5623 break;
5624
5625 case F_RR_RANGE:
5626 str = "[<..<]";
5627 break;
5628
5629 case F_RN_RANGE:
5630 str = "[<..]";
5631 break;
5632
5633 case F_MAP_INDEX:
5634 str = "[,]";
5635 break;
5636
5637 case F_NX_RANGE:
5638 str = "[..";
5639 break;
5640
5641 case F_RX_RANGE:
5642 str = "[<..";
5643 break;
5644
5645 default:
5646 str = instrs[type - CLOSURE_EFUN].name;
5647 break;
5648 } /* switch() */
5649 } /* if() */
5650
5651 return str;
5652 } /* closure_operator_to_string() */
5653
5654 /*-------------------------------------------------------------------------*/
5655 string_t *
closure_location(lambda_t * l)5656 closure_location (lambda_t *l)
5657
5658 /* Return the location the lambda structure <l> was created as
5659 * the string 'from <filename> line <number>".
5660 */
5661
5662 {
5663 string_t * rc = NULL;
5664
5665 if (l && l->prog_ob && !(l->prog_ob->flags & O_DESTRUCTED))
5666 {
5667
5668 if (l->prog_ob->flags & O_SWAPPED)
5669 {
5670 if (load_ob_from_swap(l->prog_ob) < 0)
5671 errorf("Out of memory\n");
5672 }
5673
5674 do {
5675 int lineno;
5676 char buf[20];
5677 string_t * name = NULL;
5678
5679 program_t * prog = l->prog_ob->prog;
5680 bytecode_p prog_pc = prog->program + l->prog_pc;
5681
5682 if (prog_pc <= prog->program || prog_pc >= PROGRAM_END(*prog))
5683 break;
5684
5685 lineno = get_line_number( l->prog_ob->prog->program + l->prog_pc
5686 , l->prog_ob->prog
5687 , &name
5688 );
5689
5690 sprintf(buf, "%d", lineno);
5691
5692 rc = mstr_add(STR_FROM, name);
5693 free_mstring(name);
5694 rc = mstr_append(rc, STR_LINE);
5695 rc = mstr_append_txt(rc, buf, strlen(buf));
5696 } while(0);
5697 }
5698
5699 if (!rc)
5700 rc = ref_mstring(STR_EMPTY);
5701
5702 return rc;
5703 } /* closure_location() */
5704
5705 /*-------------------------------------------------------------------------*/
5706 string_t *
closure_to_string(svalue_t * sp,Bool compact)5707 closure_to_string (svalue_t * sp, Bool compact)
5708
5709 /* Convert the closure <sp> into a printable string and return it.
5710 * If <compact> is true, a compact (spaceless) representation is used.
5711 */
5712
5713 {
5714 char buf[1024];
5715 string_t *rc;
5716 lambda_t *l;
5717 object_t *ob;
5718
5719 rc = NULL;
5720 buf[sizeof(buf)-1] = '\0';
5721 strcpy(buf, "#'");
5722
5723 if (sp->type != T_CLOSURE)
5724 {
5725 fatal("closure_to_string() called for non-closure value %hd:%hd\n"
5726 , sp->type, sp->x.generic
5727 );
5728 /* NOTREACHED */
5729 return NULL;
5730 }
5731
5732 l = NULL;
5733 /* Will be set to valid pointer if the closure has a lambda_t structure.
5734 */
5735
5736 switch(sp->x.closure_type)
5737 {
5738
5739 case CLOSURE_IDENTIFIER: /* Variable Closure */
5740 {
5741 l = sp->u.lambda;
5742 if (l->ob->flags & O_DESTRUCTED)
5743 {
5744 strcat(buf, compact ? "<dest lvar>"
5745 : "<local variable in destructed object>");
5746 break;
5747 }
5748
5749 if (l->function.var_index == VANISHED_VARCLOSURE_INDEX)
5750 {
5751 strcat(buf, compact ? "<repl lvar>"
5752 : "<local variable from replaced program>");
5753 }
5754
5755 /* We need the program resident */
5756 if (O_PROG_SWAPPED(l->ob))
5757 {
5758 l->ob->time_of_ref = current_time;
5759 if (load_ob_from_swap(l->ob) < 0)
5760 errorf("Out of memory.\n");
5761 }
5762
5763 sprintf(buf, "#'%s->%s"
5764 , get_txt(l->ob->name)
5765 , get_txt(l->ob->prog->variables[l->function.var_index].name)
5766 );
5767 break;
5768 }
5769
5770 case CLOSURE_LFUN: /* Lfun closure */
5771 {
5772 program_t *prog;
5773 string_t *function_name;
5774 Bool is_inherited;
5775
5776 l = sp->u.lambda;
5777
5778 /* For alien lfun closures, prepend the object the closure
5779 * is bound to.
5780 */
5781 if (l->ob != l->function.lfun.ob)
5782 {
5783 ob = l->function.lfun.ob;
5784
5785 if (ob->flags & O_DESTRUCTED)
5786 {
5787 strcat(buf, compact ? "[<dest obj>]" : "[<destructed object>]");
5788 }
5789 else
5790 {
5791 strcat(buf, "[");
5792 strcat(buf, get_txt(ob->name));
5793 strcat(buf, "]");
5794 }
5795 }
5796
5797 ob = l->function.lfun.ob;
5798
5799 closure_lookup_lfun_prog(l, &prog, &function_name, &is_inherited);
5800
5801 if (ob->flags & O_DESTRUCTED)
5802 strcat(buf, compact ? "<dest lfun>"
5803 : "<local function in destructed object>");
5804 else
5805 strcat(buf, get_txt(ob->name));
5806
5807 if (is_inherited)
5808 {
5809 strcat(buf, "(");
5810 strcat(buf, get_txt(prog->name));
5811 buf[strlen(buf)-2] = '\0'; /* Remove the '.c' after the program name */
5812 strcat(buf, ")");
5813 }
5814 strcat(buf, "->");
5815 strcat(buf, get_txt(function_name));
5816 strcat(buf, "()");
5817 break;
5818 }
5819
5820 case CLOSURE_UNBOUND_LAMBDA: /* Unbound-Lambda Closure */
5821 case CLOSURE_PRELIMINARY: /* Preliminary Lambda Closure */
5822 {
5823 l = sp->u.lambda;
5824
5825 if (sp->x.closure_type == CLOSURE_PRELIMINARY)
5826 sprintf(buf, compact ? "<pre %p>" : "<prelim lambda %p>", l);
5827 else
5828 sprintf(buf, compact ? "<free %p>" : "<free lambda %p>", l);
5829 break;
5830 }
5831
5832 case CLOSURE_LAMBDA: /* Lambda Closure */
5833 case CLOSURE_BOUND_LAMBDA: /* Bound-Lambda Closure */
5834 {
5835 l = sp->u.lambda;
5836
5837 if (sp->x.closure_type == CLOSURE_BOUND_LAMBDA)
5838 sprintf(buf, compact ? "<bound %p:" : "<bound lambda %p:", l);
5839 else
5840 sprintf(buf, compact ? "<%p:" : "<lambda %p:", l);
5841
5842 ob = l->ob;
5843
5844 if (!ob)
5845 {
5846 strcat(buf, "{null}>");
5847 }
5848 else
5849 {
5850 if (ob->flags & O_DESTRUCTED)
5851 strcat(buf, "{dest}");
5852 strcat(buf, "/");
5853 strcat(buf, get_txt(ob->name));
5854 strcat(buf, ">");
5855 }
5856 break;
5857 }
5858
5859 default:
5860 {
5861 int type = sp->x.closure_type;
5862
5863 if (type >= 0)
5864 errorf("Bad arg 1 to to_string(): closure type %d.\n"
5865 , sp->x.closure_type);
5866 else
5867 {
5868 switch(type & -0x0800)
5869 {
5870 case CLOSURE_OPERATOR:
5871 {
5872 const char *str = closure_operator_to_string(type);
5873
5874 if (str)
5875 {
5876 strcat(buf, str);
5877 break;
5878 }
5879
5880 type += CLOSURE_EFUN - CLOSURE_OPERATOR;
5881 }
5882 /* default action for operators: FALLTHROUGH */
5883
5884 case CLOSURE_EFUN:
5885 {
5886 const char *str = closure_efun_to_string(type);
5887
5888 if (str)
5889 {
5890 strcat(buf, str);
5891 break;
5892 }
5893 }
5894 /* Shouldn't happen: FALLTHROUGH */
5895
5896 case CLOSURE_SIMUL_EFUN:
5897 strcat(buf, "sefun::");
5898 strcat(buf, get_txt(simul_efunp[type - CLOSURE_SIMUL_EFUN].name));
5899 break;
5900 }
5901 break;
5902 } /* if (type) */
5903 } /* case default */
5904 } /* switch(closure_type) */
5905
5906 memsafe(rc = new_mstring(buf), strlen(buf), "converted lambda");
5907
5908 /* If it's a closure with a lambda structure, we can determine
5909 * where it was created.
5910 */
5911 if (l && l->prog_ob && !(l->prog_ob->flags & O_DESTRUCTED))
5912 {
5913 string_t * rc2 = closure_location(l);
5914 string_t * rc3;
5915
5916 /* Final step: append the created string rc2 to the original
5917 * string rc such that an out of memory condition won't
5918 * destroy rc itself.
5919 */
5920 rc3 = mstr_add(rc, rc2);
5921 if (rc3)
5922 {
5923 free_mstring(rc);
5924 rc = rc3;
5925 }
5926
5927 free_mstring(rc2);
5928 }
5929
5930 return rc;
5931 } /* closure_to_string() */
5932
5933 /*-------------------------------------------------------------------------*/
5934 svalue_t *
v_bind_lambda(svalue_t * sp,int num_arg)5935 v_bind_lambda (svalue_t *sp, int num_arg)
5936
5937 /* EFUN bind_lambda()
5938 *
5939 * closure bind_lambda(closure cl [, object ob ])
5940 *
5941 * Binds an unbound closure <cl> to object <ob> and return the
5942 * bound closure.
5943 *
5944 * If the optional argument ob is not this_object(), the privilege
5945 * violation ("bind_lambda", this_object(), ob) occurs.
5946 *
5947 * If the argument <ob> is omitted, the closure is bound to
5948 * this_object(), and additionally the function accepts unbindable
5949 * closures without complaint.
5950 */
5951
5952 {
5953 object_t *ob;
5954
5955 if (num_arg == 1)
5956 {
5957 /* this_object() is fine */
5958 ob = ref_object(current_object, "bind_lambda");
5959 }
5960 else /* (sp->type == T_OBJECT) */
5961 {
5962 /* If <ob> is given, check for a possible privilege breach */
5963 ob = sp->u.ob;
5964 if (ob != current_object
5965 && !privilege_violation(STR_BIND_LAMBDA, sp, sp))
5966 {
5967 free_object(ob, "bind_lambda");
5968 sp--;
5969 return sp;
5970 }
5971
5972 sp--; /* points to closure now */
5973 }
5974
5975 inter_sp = sp;
5976
5977 switch(sp->x.closure_type)
5978 {
5979 case CLOSURE_LAMBDA:
5980 case CLOSURE_IDENTIFIER:
5981 case CLOSURE_PRELIMINARY:
5982 /* Unbindable closures. Free the ob reference and
5983 * throw an error (unless <ob> has been omitted)
5984 */
5985 free_object(ob, "bind_lambda");
5986 if (num_arg == 1)
5987 break;
5988 errorf("Bad arg 1 to bind_lambda(): unbindable closure\n");
5989 /* NOTREACHED */
5990 return sp;
5991 break;
5992
5993 case CLOSURE_LFUN:
5994 /* Rebind an lfun to the given object */
5995 free_object(sp->u.lambda->ob, "bind_lambda");
5996 sp->u.lambda->ob = ob;
5997 break;
5998
5999 default:
6000 /* efun, simul_efun, operator closures: rebind it */
6001
6002 free_object(sp->u.ob, "bind_lambda");
6003 sp->u.ob = ob;
6004 break;
6005
6006 case CLOSURE_BOUND_LAMBDA:
6007 {
6008 /* Rebind an already bound lambda closure */
6009
6010 lambda_t *l;
6011
6012 if ( (l = sp->u.lambda)->ref == 1)
6013 {
6014 /* We are the only user of the lambda: simply rebind it.
6015 */
6016
6017 object_t **obp;
6018
6019 obp = &l->ob;
6020 free_object(*obp, "bind_lambda");
6021 *obp = ob; /* Adopt the reference */
6022 break;
6023 }
6024 else
6025 {
6026 /* We share the closure with others: create our own
6027 * copy, bind it and put it onto the stack in place of
6028 * the original one.
6029 */
6030 lambda_t *l2;
6031
6032 l->ref--;
6033 #ifndef USE_NEW_INLINES
6034 l2 = closure_new_lambda(ob, /* raise_error: */ MY_TRUE);
6035 #else /* USE_NEW_INLINES */
6036 l2 = closure_new_lambda(ob, 0, /* raise_error: */ MY_TRUE);
6037 #endif /* USE_NEW_INLINES */
6038 l2->function.lambda = l->function.lambda;
6039 l->function.lambda->ref++;
6040 free_object(ob, "bind_lambda"); /* We adopted the reference */
6041 sp->u.lambda = l2;
6042 break;
6043 }
6044 }
6045
6046 case CLOSURE_UNBOUND_LAMBDA:
6047 {
6048 /* Whee, an unbound lambda: create the bound-lambda structure
6049 * and put it onto the stack in place of the unbound one.
6050 */
6051
6052 lambda_t *l;
6053
6054 #ifndef USE_NEW_INLINES
6055 l = closure_new_lambda(ob, /* raise_error: */ MY_TRUE);
6056 #else /* USE_NEW_INLINES */
6057 l = closure_new_lambda(ob, 0, /* raise_error: */ MY_TRUE);
6058 #endif /* USE_NEW_INLINES */
6059 free_object(ob, "bind_lambda"); /* We adopted the reference */
6060 l->function.lambda = sp->u.lambda;
6061 /* The ref to the unbound closure is just transferred from
6062 * sp to l->function.lambda.
6063 */
6064 sp->x.closure_type = CLOSURE_BOUND_LAMBDA;
6065 sp->u.lambda = l;
6066 break;
6067 }
6068 }
6069
6070 return sp;
6071 } /* v_bind_lambda() */
6072
6073 /*-------------------------------------------------------------------------*/
6074 svalue_t *
f_lambda(svalue_t * sp)6075 f_lambda (svalue_t *sp)
6076
6077 /* EFUN lambda()
6078 *
6079 * closure lambda(mixed *arr, mixed)
6080 *
6081 * Constructs a lambda closure, like lambda function in LISP.
6082 * The closure is bound the creating object, and thus can contain
6083 * references to global variables.
6084 *
6085 * The first argument is an array describing the arguments
6086 * (symbols) passed to the closure upon evaluation by funcall()
6087 * or apply(). It may be 0 if no arguments are required.
6088 */
6089
6090 {
6091 lambda_t *l;
6092 vector_t *args;
6093
6094 if (sp[-1].type != T_POINTER)
6095 {
6096 /* If '0' is given for the args array, replace it
6097 * with the null-vector.
6098 */
6099 if (sp[-1].type != T_NUMBER || sp[-1].u.number)
6100 efun_arg_error(1, T_POINTER, sp->type, sp);
6101 args = ref_array(&null_vector);
6102 }
6103 else
6104 {
6105 args = sp[-1].u.vec;
6106 }
6107
6108 /* Create the lambda closure */
6109 l = lambda(args, sp, current_object);
6110
6111 /* Clean up the stack and push the result */
6112 free_svalue(sp--);
6113 free_array(args);
6114
6115 sp->type = T_CLOSURE;
6116 sp->x.closure_type = CLOSURE_LAMBDA;
6117 sp->u.lambda = l;
6118
6119 return sp;
6120 } /* f_lambda() */
6121
6122 /*-------------------------------------------------------------------------*/
6123 svalue_t *
f_symbol_function(svalue_t * sp)6124 f_symbol_function (svalue_t *sp)
6125
6126 /* EFUN symbol_function()
6127 *
6128 * closure symbol_function(symbol arg)
6129 * closure symbol_function(string arg)
6130 * closure symbol_function(string arg, object|string ob)
6131 *
6132 * Constructs a lfun closure, efun closure or operator closure
6133 * from the first arg (string or symbol). For lfuns, the second
6134 * arg is the object that the lfun belongs to, specified by
6135 * the object itself or by its name (the object will be loaded
6136 * in the second case)
6137 *
6138 * Private lfuns can never be accessed this way, static and
6139 * protected lfuns only if <ob> is the current object.
6140 */
6141
6142 {
6143 object_t *ob;
6144 program_t *prog;
6145 int i;
6146
6147 /* If 'arg' is not a symbol, make sure it's a shared string. */
6148 if (sp[-1].type != T_SYMBOL)
6149 {
6150 sp[-1].u.str = make_tabled(sp[-1].u.str);
6151 }
6152
6153 /* If 'ob' is not of type object, it might be the name of
6154 * an object to load, or we need to make an efun symbol.
6155 */
6156 if (sp->type != T_OBJECT)
6157 {
6158 /* If it's the number 0, an efun symbol is desired */
6159 if (sp->type == T_NUMBER && sp->u.number == 0)
6160 {
6161 string_t *name;
6162 sp--;
6163 inter_sp = sp;
6164 name = sp->u.str;
6165 symbol_efun(name, sp);
6166 free_mstring(name);
6167 return sp;
6168 }
6169
6170 /* Find resp. load the object by name */
6171 if (sp->type != T_STRING)
6172 {
6173 efun_exp_arg_error(2, TF_STRING|TF_OBJECT, sp->type, sp);
6174 /* NOTREACHED */
6175 return sp;
6176 }
6177 ob = get_object(sp->u.str);
6178 if (!ob)
6179 errorf("Object '%s' not found.\n", get_txt(sp->u.str));
6180 free_svalue(sp);
6181 put_ref_object(sp, ob, "symbol_function");
6182 }
6183 else
6184 {
6185 ob = sp->u.ob;
6186 }
6187
6188 /* We need the object's program */
6189 if (O_PROG_SWAPPED(ob))
6190 {
6191 ob->time_of_ref = current_time;
6192 if (load_ob_from_swap(ob) < 0)
6193 {
6194 inter_sp = sp;
6195 errorf("Out of memory\n");
6196 }
6197 }
6198
6199 /* Find the function in the program */
6200 prog = ob->prog;
6201 i = find_function(sp[-1].u.str, prog);
6202
6203 /* If the function exists and is visible, create the closure
6204 */
6205 if ( i >= 0
6206 && ( !(prog->functions[i] & (TYPE_MOD_STATIC|TYPE_MOD_PROTECTED|TYPE_MOD_PRIVATE) )
6207 || ( !(prog->functions[i] & TYPE_MOD_PRIVATE)
6208 && current_object == ob)
6209 )
6210 )
6211 {
6212 // check for deprecated functions.
6213 if (prog->functions[i] & TYPE_MOD_DEPRECATED)
6214 {
6215 warnf("Creating lfun closure to deprecated function \'%s\' in object %s (%s).\n",
6216 get_txt(sp[-1].u.str),
6217 get_txt(ob->name),
6218 get_txt(ob->prog->name));
6219 }
6220
6221 /* Clean up the stack */
6222 sp--;
6223 free_mstring(sp->u.str);
6224 inter_sp = sp-1;
6225
6226 #ifndef USE_NEW_INLINES
6227 closure_lfun(sp, ob, NULL, (unsigned short)i
6228 , /* raise_error: */ MY_FALSE);
6229 #else /* USE_NEW_INLINES */
6230 closure_lfun(sp, ob, NULL, (unsigned short)i, 0
6231 , /* raise_error: */ MY_FALSE);
6232 #endif /* USE_NEW_INLINES */
6233 if (sp->type != T_CLOSURE)
6234 {
6235 inter_sp = sp - 1;
6236 #ifndef USE_NEW_INLINES
6237 outofmem(sizeof(lambda_t), "symbol_function");
6238 #else /* USE_NEW_INLINES */
6239 outofmem(SIZEOF_LAMBDA(0), "symbol_function");
6240 #endif /* USE_NEW_INLINES */
6241 }
6242
6243 /* The lambda was bound to the wrong object */
6244 free_object(sp->u.lambda->ob, "symbol_function");
6245 sp->u.lambda->ob = ref_object(current_object, "symbol_function");
6246
6247 free_object(ob, "symbol_function"); /* We adopted the reference */
6248
6249 return sp;
6250 }
6251
6252 /* Symbol can't be created - free the stack and push 0 */
6253 free_object(ob, "symbol_function");
6254 sp--;
6255 free_mstring(sp->u.str);
6256 put_number(sp, 0);
6257
6258 return sp;
6259 } /* f_symbol_function() */
6260
6261 /*-------------------------------------------------------------------------*/
6262 svalue_t *
f_symbol_variable(svalue_t * sp)6263 f_symbol_variable (svalue_t *sp)
6264
6265 /* EFUN symbol_variable()
6266 *
6267 * closure symbol_variable(string arg)
6268 * closure symbol_variable(symbol arg)
6269 * closure symbol_variable(int arg)
6270 *
6271 * Constructs an identifier (lfun) closure from the global
6272 * variable arg of this_object(). The variable may be given as a
6273 * symbol, by name or by its ordinal number in the objects
6274 * variable table.
6275 * If there is no such variable, or if it is not visible outside
6276 * the object, 0 is returned.
6277 *
6278 * If the argument is an integer, and the variable is inherited
6279 * and private in the inherited object (i.e. hidden), then a
6280 * privilege violation ("symbol_variable", this_object(), arg)
6281 * will occur.
6282 *
6283 */
6284
6285 {
6286 object_t *ob;
6287 int n; /* Index of the desired variable */
6288
6289 ob = current_object;
6290 if (!current_variables
6291 || !ob->variables
6292 || current_variables < ob->variables
6293 || current_variables >= ob->variables + ob->prog->num_variables)
6294 {
6295 /* efun closures are called without changing current_prog nor
6296 * current_variables. This keeps the program scope for variables
6297 * for calls inside this_object(), but would give trouble with
6298 * calling from other ones if it were not for this test.
6299 */
6300 current_prog = ob->prog;
6301 current_variables = ob->variables;
6302 }
6303
6304 /* Test and get the arguments; set n to the index of the desired
6305 * variable.
6306 */
6307 switch(sp->type)
6308 {
6309 default:
6310 fatal("Bad arg 1 to symbol_variable(): type %s\n", typename(sp->type));
6311 break;
6312
6313 case T_NUMBER: /* The index is given directly */
6314 n = sp->u.number;
6315 if (n < 0 || n >= current_prog->num_variables)
6316 {
6317 sp->u.number = 0;
6318 return sp;
6319 }
6320
6321 if (current_prog->variables[n].type.typeflags & NAME_HIDDEN)
6322 {
6323 if (!privilege_violation(STR_SYMBOL_VARIABLE, sp, sp))
6324 {
6325 sp->u.number = 0;
6326 return sp;
6327 }
6328 }
6329 break;
6330
6331 case T_STRING: /* Name is given by string */
6332 if (!mstr_tabled(sp->u.str))
6333 {
6334 /* If the variable exists, it must exist as tabled
6335 * string.
6336 */
6337 string_t *str;
6338
6339 str = find_tabled(sp->u.str);
6340 if (!str)
6341 {
6342 free_svalue(sp);
6343 put_number(sp, 0);
6344 return sp;
6345 }
6346
6347 /* Make sp a tabled string value to continue processing */
6348 free_mstring(sp->u.str);
6349 sp->u.str = ref_mstring(str);
6350 }
6351 /* FALL THROUGH */
6352
6353 case T_SYMBOL: /* Name is given as shared string (symbol) */
6354 {
6355 string_t *str;
6356 variable_t *var;
6357 program_t *prog;
6358 int num_var;
6359
6360 str = sp->u.str;
6361 prog = current_prog;
6362 var = prog->variables;
6363 num_var = prog->num_variables;
6364 for (n = num_var; --n >= 0; var++)
6365 {
6366 if (var->name == str && !(var->type.typeflags & NAME_HIDDEN))
6367 break;
6368 }
6369 free_mstring(str);
6370 if (n < 0)
6371 {
6372 put_number(sp, 0);
6373 return sp;
6374 }
6375 n = num_var - n - 1;
6376 }
6377 }
6378 // check for deprecated object / global variable.
6379 if (current_prog->variables[n].type.typeflags & TYPE_MOD_DEPRECATED)
6380 {
6381 warnf("Creating closure to deprecated global variable %s.\n",
6382 get_txt(current_prog->variables[n].name));
6383 }
6384
6385 /* Create the result closure and put it onto the stack */
6386 closure_identifier( sp, current_object
6387 , (unsigned short)(n + (current_variables - current_object->variables))
6388 , /* raise_error: */ MY_FALSE);
6389 if (sp->type != T_CLOSURE)
6390 {
6391 inter_sp = sp - 1;
6392 #ifndef USE_NEW_INLINES
6393 outofmem(sizeof(lambda_t), "variable symbol");
6394 #else /* USE_NEW_INLINES */
6395 outofmem(SIZEOF_LAMBDA(0), "variable symbol");
6396 #endif /* USE_NEW_INLINES */
6397 }
6398
6399 return sp;
6400 } /* f_symbol_variable() */
6401
6402 /*-------------------------------------------------------------------------*/
6403 svalue_t *
f_unbound_lambda(svalue_t * sp)6404 f_unbound_lambda (svalue_t *sp)
6405
6406 /* EFUN closure unbound_lambda()
6407 *
6408 * closure unbound_lambda(mixed *args, mixed)
6409 *
6410 *
6411 * Constructs a lambda closure that is not bound to an object,
6412 * like lambda function in LISP.
6413 * The closure cannot contain references to global variables, and
6414 * all lfun closures are inserted as is, since there is no native
6415 * object for this closure. You need to bind it before it can be
6416 * called. Ordinary objects can only bind to themselves, binding
6417 * to other objects causes a privilege violation(). The point is
6418 * that previous_object for calls done from inside the closure
6419 * will reflect the object doing bind_lambda(), and all object /
6420 * uid based security will also refer to this object.
6421 *
6422 * The first argument is an array describing the arguments
6423 * (symbols) passed to the closure upon evaluation by funcall()
6424 * or apply(), the second arg forms the code of the closure.
6425 */
6426
6427 {
6428 lambda_t *l;
6429 vector_t *args;
6430
6431 /* Get and test the arguments */
6432 if (sp[-1].type != T_POINTER)
6433 {
6434 if (sp[-1].type != T_NUMBER || sp[-1].u.number)
6435 efun_gen_arg_error(1, sp->type, sp);
6436 args = ref_array(&null_vector);
6437 }
6438 else
6439 {
6440 args = sp[-1].u.vec;
6441 }
6442
6443 /* Compile the lambda */
6444 inter_sp = sp;
6445 l = lambda(args, sp, 0);
6446 l->ob = NULL;
6447
6448 /* Clean up the stack and push the result */
6449
6450 free_svalue(sp--);
6451 free_array(args);
6452 sp->type = T_CLOSURE;
6453 sp->x.closure_type = CLOSURE_UNBOUND_LAMBDA;
6454 sp->u.lambda = l;
6455 return sp;
6456 } /* f_unbound_lambda() */
6457
6458 /*=========================================================================*/
6459
6460 /*-------------------------------------------------------------------------*/
6461 case_list_entry_t *
new_case_entry(void)6462 new_case_entry (void)
6463
6464 /* Allocate a new case_list_entry, insert it into the case list
6465 * and return the pointer.
6466 * The memory will be deallocated in the call to free_symbols().
6467 */
6468
6469 {
6470 case_list_entry_t *ret;
6471
6472 /* Get a new case_list_entry from the free_block.
6473 * If the block is empty (or non-existing, the initial state),
6474 * get a new block.
6475 */
6476 if (!case_state.free_block
6477 || (ret = --case_state.next_free) == case_state.free_block)
6478 {
6479 case_list_entry_t *next;
6480
6481 if ( !case_state.free_block
6482 || !(next = case_state.free_block->next)
6483 )
6484 {
6485 /* There was no following free block, so allocate a new
6486 * one and append it to the block list.
6487 */
6488 next = xalloc(sizeof(case_list_entry_t[CASE_BLOCKING_FACTOR]));
6489 next->next = NULL;
6490 if (!case_blocks)
6491 {
6492 /* Initialize the total block list */
6493 case_blocks = next;
6494 case_blocks_last = next;
6495 }
6496 else
6497 {
6498 /* Append the new block to the block list */
6499 case_blocks_last->next = next;
6500 case_blocks_last = next;
6501 }
6502 }
6503
6504 /* Point .free_block to the new one and initialize .next_free */
6505 case_state.free_block = next;
6506 case_state.next_free = ret = next + CASE_BLOCKING_FACTOR - 1;
6507 }
6508
6509 /* Add the new entry to the head of the entry list */
6510 /* DELETED: case_state.next_free->next = case_state.list1; */ /* TODO: ??? */
6511 ret->next = case_state.list1;
6512 case_state.list1 = case_state.list0;
6513 case_state.list0 = ret;
6514
6515 return ret;
6516 } /* new_case_entry() */
6517
6518 /*-------------------------------------------------------------------------*/
6519 void
free_case_blocks(void)6520 free_case_blocks (void)
6521
6522 /* Deallocate all block listed in case_blocks.
6523 */
6524
6525 {
6526 while (case_blocks)
6527 {
6528 case_list_entry_t *tmp;
6529
6530 tmp = case_blocks;
6531 case_blocks = tmp->next;
6532 xfree(tmp);
6533 }
6534 case_blocks_last = NULL;
6535 } /* free_case_blocks() */
6536
6537 /*-------------------------------------------------------------------------*/
6538 void
store_case_labels(p_int total_length,p_int default_addr,Bool numeric,case_list_entry_t * zero,bytecode_p (* get_space)(p_int),void (* move_instructions)(int,p_int),void (* cerror)(const char *),void (* cerrorl)(const char *,const char *,int,int))6539 store_case_labels( p_int total_length
6540 , p_int default_addr
6541 , Bool numeric
6542 , case_list_entry_t *zero
6543 , bytecode_p (*get_space)(p_int)
6544 , void (*move_instructions)(int, p_int)
6545 , void (*cerror)(const char *)
6546 , void (*cerrorl)(const char *, const char *, int, int)
6547 )
6548
6549 /* This function creates the lookup tables for a switch instruction.
6550 * It expects that 'SWITCH b1 a2 <instruction>' has already been created
6551 * (with dummies for b1 and a2). The position of 'b1' is the reference
6552 * point for all addresses and offsets in the arguments. Speaking of arguments:
6553 *
6554 * total_length: length of the generated code so far
6555 * default_addr: address of the default-case code
6556 * numeric: flag if the switch has numeric or string cases.
6557 * zero: the case_list_entry for 'case 0', or NULL if none.
6558 * get_space: function to allocate more code space
6559 * move_instructions: function to move a block of bytecode
6560 * cerror, cerrorl: error functions.
6561 *
6562 * For more detailed information about the argument functions, look at the
6563 * lambda_... implementations in this file.
6564 *
6565 * The created switch is not aligned, because later code generation ops may
6566 * still move this piece of code.
6567 */
6568
6569 {
6570 case_list_entry_t *list0; /* (Sorted) list of case_entries */
6571 case_list_entry_t *list1; /* Current case_entry */
6572 int type; /* The type byte */
6573 mp_int runlength; /* Mergesort runlength */
6574 mp_int key_num; /* Number of keys */
6575 int len;
6576 int i;
6577 int o;
6578 p_int maxspan; /* Max span of one 'l' lookup range */
6579 mp_int current_key; /* Current key */
6580 mp_int last_key = 0; /* Last key a table entry was generated for */
6581 mp_int current_addr; /* Adr of instructions for current_key */
6582 mp_int last_addr; /* Adr of instruction for last_key */
6583 bytecode_p p;
6584 mp_int tablen;
6585 bytecode_t i0;
6586
6587 list0 = case_state.list0;
6588 list1 = case_state.list1;
6589
6590 /* Determine the type of the switch: numeric or string */
6591 if (numeric)
6592 {
6593 type = 0;
6594 }
6595 else
6596 {
6597 type = SWITCH_TYPE;
6598 if (zero)
6599 {
6600 /* 'case 0' in string-switches is special */
6601 zero->key = (p_int)ZERO_AS_STR_CASE_LABEL;
6602 }
6603 }
6604
6605 /* length(list0) >= length(list1) */
6606 if (!list0)
6607 (*cerror)("switch without case not supported");
6608
6609 /* Mergesort the list of case entries by their keys in ascending
6610 * order.
6611 *
6612 * The implementation combines the merge and split phase by
6613 * using two 'out' lists and switching them appropriately.
6614 */
6615
6616 for (runlength = 1; list1; runlength *= 2)
6617 {
6618 case_list_entry_t *out_hook0, *out_hook1;
6619 /* The two out lists */
6620 case_list_entry_t **out0, **out1;
6621 /* Indirect access to the out lists, which also
6622 * helps in creating the single links of the lists.
6623 */
6624 mp_int count0, count1;
6625 /* Number of list elements left to merge in this run */
6626
6627 out0 = &out_hook0;
6628 out1 = &out_hook1;
6629 while (list1)
6630 {
6631 /* Merge the next <runlength> elements from both lists */
6632
6633 count0 = count1 = runlength;
6634 while (1)
6635 {
6636 if (list1->key < list0->key)
6637 {
6638 /* Put element from list1 into out list */
6639 *out0 = list1;
6640 out0 = &list1->next;
6641 list1 = *out0;
6642
6643 if (!--count1 || !list1)
6644 {
6645 /* All elements from list1 processed, now
6646 * append the remaining ones from list0.
6647 */
6648 *out0 = list0;
6649 do {
6650 out0 = &list0->next;
6651 list0 = *out0;
6652 } while (--count0 && list0);
6653 break;
6654 }
6655 }
6656 else
6657 {
6658 /* Put element from list0 into out list */
6659 *out0 = list0;
6660 out0 = &list0->next;
6661 list0 = *out0;
6662
6663 if (!--count0 || !list0)
6664 {
6665 /* All elements from list0 processed, now
6666 * append the remaining ones from list1.
6667 */
6668 *out0 = list1;
6669 do {
6670 out0 = &list1->next;
6671 list1 = *out0;
6672 } while (--count1 && list1);
6673 break;
6674 }
6675 }
6676 } /* while(1) */
6677
6678 /* 2*runlength elements put into out0,
6679 * now switch the roles of out0 and out1.
6680 */
6681 {
6682 case_list_entry_t **temp;
6683
6684 temp = out0;
6685 out0 = out1;
6686 out1 = temp;
6687 }
6688 } /* while (list1) */
6689
6690 *out0 = list0;
6691 *out1 = NULL;
6692 list0 = out_hook0;
6693 list1 = out_hook1;
6694 } /* for (runlength, list1) */
6695
6696 /* list0 now contains all entries, sorted.
6697 * Scan the list and determine the size of the switch, moving
6698 * the so far generated code if necessary.
6699 * For a numeric switch, also compute the range information and
6700 * generate the 'l' lookup table for sparse ranges.
6701 */
6702 key_num = 0;
6703 if (numeric)
6704 {
6705 /* Numeric switch: scan the list for ranges
6706 * (which might have been separated during the sort).
6707 */
6708 case_list_entry_t *table_start;
6709 /* Begin of range to write a 'l' lookup range for */
6710 case_list_entry_t *max_gain_end = NULL;
6711 /* End of range to write a 'l' lookup range for */
6712 case_list_entry_t *previous = NULL;
6713 case_list_entry_t *range_start = NULL;
6714 /* Range currently build */
6715 int last_line = 0; /* Source line of last_key */
6716 p_int keys; /* Number of keys covered by this lookup table entry */
6717 p_int max_gain; /* total gain so far */
6718 p_int cutoff; /* Cutoff point during lookup table generation */
6719
6720 /* Walk the list and join consecutive cases to ranges. Intermediate
6721 * entries are removed from the list, explicite range end entries
6722 * are left in the list.
6723 */
6724 for (last_addr = 0xffffff, list1=list0; list1; list1 = list1->next)
6725 {
6726 int curr_line; /* Source line of current_key */
6727
6728 key_num++;
6729 current_key = list1->key;
6730 curr_line = list1->line;
6731 current_addr = list1->addr;
6732
6733 if (current_key == last_key && list1 != list0)
6734 {
6735 (*cerrorl)("Duplicate case%s", " in line %d and %d",
6736 last_line, curr_line);
6737 }
6738
6739 if (curr_line)
6740 {
6741 /* Not a range end */
6742 if (last_addr == 1)
6743 {
6744 (*cerrorl)(
6745 "Discontinued case label list range%s",
6746 ", line %d by line %d",
6747 last_line, curr_line);
6748 }
6749 else if (current_key == last_key + 1)
6750 {
6751 /* Consecutive keys: maybe a new case, maybe
6752 * a continuation. Look at the code addresses
6753 * to decide.
6754 */
6755 if (current_addr == last_addr)
6756 {
6757 /* range continuation with single value */
6758 if (list1 != range_start->next)
6759 {
6760 range_start->addr = 1;
6761 /* Mark the range start, in case it didn't
6762 * happen already.
6763 */
6764 range_start->next = list1;
6765 /* list1 becomes the new range end, replacing
6766 * the old one.
6767 */
6768 list1->line = 0;
6769 /* lookup table building uses !end->line */
6770 key_num--;
6771 }
6772 }
6773 else if (current_addr == 1
6774 && list1->next->addr == last_addr)
6775 {
6776 /* range continuation with range start */
6777
6778 key_num -= 1 + (list1 != range_start->next);
6779 range_start->addr = 1;
6780 /* Mark the range start, in case it didn't
6781 * happen already.
6782 */
6783 range_start->next = list1->next;
6784 /* list1 becomes the new range end, replacing
6785 * the old one.
6786 */
6787 /* list1->next was range end before, thus
6788 * range_start->next->line == 0 already.
6789 */
6790 list1 = range_start;
6791 /* list1 is now outside the list, therefore
6792 * re-init list1 for proper continuation.
6793 */
6794 }
6795 else
6796 {
6797 /* New range, or a single case */
6798 range_start = list1;
6799 }
6800 }
6801 else
6802 {
6803 /* New range, or a single case */
6804 range_start = list1;
6805 }
6806 }
6807 last_key = current_key;
6808 last_line = curr_line;
6809 last_addr = current_addr;
6810 } /* for() */
6811 /* The list contains now single cases, ranges, and some spurious
6812 * range ends. The following length computation is therefore a bit
6813 * on the big side.
6814 */
6815
6816 /* Compute the needed offset size for the switch */
6817 if ( !( (total_length + key_num*(sizeof(p_int)+1)) & ~0xff) ) {
6818 len = 1;
6819 maxspan = MAXINT/len;
6820 }
6821 else if ( !( (total_length + key_num*(sizeof(p_int)+2) + 1) & ~0xffff) )
6822 {
6823 len = 2;
6824 maxspan = MAXINT/len;
6825 }
6826 else if ( !( (total_length + key_num*(sizeof(p_int)+3) + 2) & ~0xffffff) )
6827 {
6828 len = 3;
6829 maxspan = MAXINT/len;
6830 }
6831 else
6832 {
6833 (*cerror)("offset overflow");
6834 return;
6835 }
6836
6837 /* For bigger offset sizes, move the instruction block to make
6838 * space for the additional bytes after the F_SWITCH.
6839 */
6840 if (len > 1)
6841 {
6842 (*move_instructions)(len-1, total_length);
6843 total_length += len-1;
6844 default_addr += len-1;
6845 }
6846
6847 /* Now generate the 'l' lookup table for sparse ranges.
6848 * For every singular case count up how many bytes a range lookup
6849 * would save, and generate the next 'l' table entry when
6850 * the cutoff point has been reached (dynamic programming).
6851 * If the gain is negative, keep it singular.
6852 */
6853 cutoff =(long)(sizeof(p_int)*2 + len*2);
6854 list1 = list0;
6855 table_start = list1;
6856 for (max_gain = keys = 0; list1; list1 = list1->next)
6857 {
6858 p_int span, gain;
6859
6860 keys++;
6861 if (list1->addr == 1)
6862 {
6863 /* Range case - no gain possible here */
6864 previous = list1;
6865 continue;
6866 }
6867
6868 /* Btw, adapt the .addr to the offset length */
6869 list1->addr += len-1;
6870
6871 span = list1->key - table_start->key + 1;
6872 if ((p_uint)span >= (p_uint)maxspan) /* p_uint to catch span<0, too */
6873 gain = -1;
6874 else
6875 gain = (long)(keys * sizeof(p_int) - (span - keys)* len);
6876
6877 /* If the gain is big enough, write the next l table entry
6878 * for the list from table_start to max_gain_end.
6879 */
6880 if (max_gain - gain > cutoff && max_gain >= cutoff)
6881 {
6882 case_list_entry_t *tmp;
6883 p_int key, addr, size;
6884 bytecode_p p0;
6885
6886 span = max_gain_end->key - table_start->key + 1;
6887 size = span * len;
6888 p0 = (bytecode_p)(*get_space)(size);
6889 tmp = table_start;
6890 key = tmp->key;
6891
6892 if (tmp->addr == 1)
6893 {
6894 /* table_start is a range start: start with
6895 * the associated end.
6896 */
6897 key_num--;
6898 tmp = tmp->next;
6899 }
6900
6901 /* Loop over the partial list, inserting the jump address
6902 * for every singular case and range, and the default_addr
6903 * for every other value without a case.
6904 * The
6905 */
6906 do {
6907 if (tmp->key < key)
6908 {
6909 /* key is beyond the current list entry - move
6910 * on to the next.
6911 */
6912 key_num--;
6913 tmp = tmp->next;
6914 /* This next entry might be the begin of a new range.
6915 * However, we don't want to move tmp to its end
6916 * entry quite yet, since we still have to fill in
6917 * the 'default' jump points for all interim values.
6918 */
6919 }
6920 if (key == tmp->key && tmp->addr == 1)
6921 {
6922 /* tmp is the beginning of a range, and key (finally)
6923 * caught up with it. We can now move tmp to the end
6924 * entry for this range.
6925 * It's .line is 0 which will force the code
6926 * to insert all values for this range.
6927 */
6928 key_num--;
6929 tmp = tmp->next;
6930 }
6931
6932 /* Get the address to insert */
6933 addr = default_addr;
6934 if (key == tmp->key || !tmp->line)
6935 addr = tmp->addr;
6936
6937 /* Insert the address */
6938 p0 += len;
6939 PUT_UINT8(p0-1, (unsigned char)addr);
6940 if (len >= 2)
6941 {
6942 PUT_UINT8(p0-2, (unsigned char)(addr >> 8));
6943 if (len > 2)
6944 {
6945 PUT_UINT8(p0-3, (unsigned char)(addr >> 16));
6946 }
6947 }
6948 } while (++key <= max_gain_end->key);
6949
6950 /* Replace the partial list with singular range, and mark
6951 * it as sparse lookup range.
6952 */
6953 key_num += 1;
6954 max_gain_end->addr = total_length;
6955 total_length += size;
6956 table_start->addr = 0;
6957 table_start->next = max_gain_end;
6958
6959 /* Restart the gain search */
6960 gain = -1;
6961 }
6962
6963 if (gain < 0)
6964 {
6965 /* No gain with this entry - restart search
6966 * from here.
6967 */
6968 if (list1->line)
6969 {
6970 /* Not a range end */
6971 table_start = list1;
6972 keys = 1;
6973 }
6974 else
6975 {
6976 /* A range end: restart from the range start */
6977 table_start = previous;
6978 keys = 2;
6979 }
6980 max_gain = 0;
6981 }
6982 else if (gain > max_gain)
6983 {
6984 /* We gained space: remember this position */
6985 max_gain = gain;
6986 max_gain_end = list1;
6987 }
6988 } /* for (write lookup table) */
6989 }
6990 else
6991 {
6992 /* String case: neither ordinary nor lookup table ranges are viable.
6993 * Thus, don't spend unnecesarily time with calculating them.
6994 * Also, a more accurate calculation of len is possible.
6995 */
6996 int last_line = 0;
6997
6998 /* Compute the number of keys, and check that none are duplicate.
6999 */
7000 for (list1 = list0; list1; list1 = list1->next)
7001 {
7002 int curr_line;
7003
7004 key_num++;
7005 current_key = list1->key ;
7006 curr_line = list1->line ;
7007 if ( current_key == last_key && list1 != list0) {
7008 (*cerrorl)("Duplicate case%s", " in line %d and %d",
7009 last_line, curr_line);
7010 }
7011 last_key = current_key;
7012 last_line = curr_line;
7013 }
7014
7015 if ( !( ( total_length | key_num*sizeof(p_int)) & ~0xff) ) {
7016 len = 1;
7017 } else if ( !( ((total_length+1) | key_num*sizeof(p_int)) & ~0xffff) ) {
7018 len = 2;
7019 } else if ( !( ((total_length+2) | key_num*sizeof(p_int)) & ~0xffffff) ) {
7020 len = 3;
7021 } else {
7022 (*cerror)("offset overflow");
7023 return;
7024 }
7025
7026 if (len > 1)
7027 {
7028 (*move_instructions)(len-1, total_length);
7029 total_length += len-1;
7030 default_addr += len-1;
7031 for (list1 = list0; list1; list1 = list1->next)
7032 {
7033 list1->addr += len-1;
7034 }
7035 }
7036 }
7037
7038 /* calculate starting index for iterative search at execution time */
7039 for (i = 0, o = 2; o <= key_num; )
7040 i++, o<<=1;
7041
7042 /* and store it */
7043 type |= (i & SWITCH_START) | (len << SWITCH_TYPE_VALUELEN_SHIFT);
7044
7045 /* Store the 'type' byte and the table length */
7046 tablen = (long)(key_num * sizeof(p_int));
7047 /* = key_num << SWITCH_TABLEN_SHIFT */
7048 p = (bytecode_p)get_space((long)
7049 (tablen + key_num * len + 2 + len + sizeof(p_int) - 4));
7050
7051 PUT_UINT8(p-total_length, (unsigned char)tablen);
7052 PUT_UINT8(p-total_length+1, (unsigned char)type);
7053
7054 /* Store the total length, and rescue the first instruction byte i0.
7055 */
7056 i0 = GET_UINT8(p-total_length+1+len);
7057 PUT_UINT8(p-total_length+2, (unsigned char)total_length);
7058 if (len >= 2)
7059 {
7060 STORE_UINT8(p, (bytecode_t)(tablen >> 8));
7061 PUT_UINT8(p-total_length+2, (unsigned char)(total_length >> 8));
7062 if (len > 2)
7063 {
7064 STORE_UINT8(p, (bytecode_t)(tablen >> 16));
7065 PUT_UINT8(p-total_length+2, (unsigned char)(total_length >> 16));
7066 }
7067 }
7068
7069 /* Store the default address and the saved instruction byte i0.
7070 */
7071 STORE_SHORT(p, (short)default_addr);
7072 STORE_CODE(p, i0);
7073
7074 /* Dummy bytes for aligning. */
7075 p += sizeof(p_int) - 4;
7076
7077 /* Create the value table 'v' */
7078 for (list1 = list0; list1; list1 = list1->next)
7079 {
7080 memcpy(p, &list1->key, sizeof(list1->key));
7081 p += sizeof(list1->key);
7082 }
7083
7084 /* Create the offset table 'o' */
7085 for (list1 = list0; list1; list1 = list1->next)
7086 {
7087 p += len;
7088 PUT_UINT8(p-1, (unsigned char)list1->addr);
7089 if (len >= 2)
7090 {
7091 PUT_UINT8(p-2, (unsigned char)(list1->addr >> 8));
7092 if (len > 2)
7093 {
7094 PUT_UINT8(p-3, (unsigned char)(list1->addr >> 16));
7095 }
7096 }
7097 }
7098 if (len > 2)
7099 {
7100 p = (*get_space)(1);
7101 PUT_UINT8(p, (unsigned char)(default_addr >> 16));
7102 }
7103 } /* store_case_labels() */
7104
7105 /*-------------------------------------------------------------------------*/
7106 void
align_switch(bytecode_p pc)7107 align_switch (bytecode_p pc)
7108
7109 /* Align the switch instruction starting at <pc> with the byte 'b1'.
7110 * Called from interpret.c when an unaligned switch is encountered
7111 * the first time.
7112 */
7113
7114 {
7115 int len;
7116 int32 tablen, offset, size;
7117 unsigned char a2; /* Alignment byte 2 */
7118 unsigned char abuf[sizeof(p_int)-1]; /* Buffer for the alignment bytes */
7119 bytecode_p off_pc; /* Pointer after the instruction block */
7120 unsigned char *startu; /* Unaligned start address */
7121 unsigned char *starta; /* Aligned start address */
7122
7123 /* Get the valuelength from the 'type' byte and put it into
7124 * the 'b1' byte where it belongs.
7125 */
7126 tablen = GET_UINT8(pc);
7127 a2 = GET_UINT8(pc+1);
7128 len = a2 >> SWITCH_TYPE_VALUELEN_SHIFT;
7129 PUT_UINT8(pc, GET_UINT8(pc) | len);
7130
7131 /* Get the offset, and move the first bytes */
7132 offset = GET_UINT8(pc+2);
7133 PUT_UINT8(pc+1, GET_UINT8(pc+2));
7134 if (len >=2)
7135 {
7136 PUT_UINT8(pc+2, GET_UINT8(pc+3));
7137 offset += GET_UINT8(pc+3) << 8;
7138 if (len > 2)
7139 {
7140 PUT_UINT8(pc+3, GET_UINT8(pc+4));
7141 offset += GET_UINT8(pc+4) << 16;
7142 }
7143 }
7144
7145 if (len >=2)
7146 {
7147 tablen += GET_UINT8(pc+offset) << 8;
7148 if (len > 2)
7149 {
7150 tablen += GET_UINT8(pc+offset+1) << 16;
7151 }
7152 }
7153
7154 /* Now align the tables, moving the alignment bytes around */
7155 off_pc = pc + offset + len;
7156
7157 abuf[0] = off_pc[-1];
7158 abuf[1] = off_pc[0];
7159 abuf[2] = a2;
7160 PUT_UINT8(pc+len+1, GET_UINT8(off_pc+1));
7161 PUT_UINT8(off_pc+1, a2);
7162 startu = off_pc+2 + sizeof(p_int) - 4;
7163 starta = (unsigned char *)((p_int)startu & ~(sizeof(char *)-1));
7164 size = (long)(tablen + tablen / sizeof(char*) * len);
7165 if (starta != startu)
7166 {
7167 move_memory(starta, startu, (size_t)size);
7168 move_memory(starta+size, abuf + sizeof abuf - (startu-starta)
7169 , (size_t)(startu-starta));
7170 }
7171 } /* align_switch() */
7172
7173 /***************************************************************************/
7174