1 /****************************************************************************
2 **
3 ** This file is part of GAP, a system for computational discrete algebra.
4 **
5 ** Copyright of GAP belongs to its developers, whose names are too numerous
6 ** to list here. Please refer to the COPYRIGHT file for details.
7 **
8 ** SPDX-License-Identifier: GPL-2.0-or-later
9 **
10 ** This file contains the functions of variables package.
11 **
12 ** The variables package is the part of the interpreter that executes
13 ** assignments to variables and evaluates references to variables.
14 **
15 ** There are five kinds of variables, local variables (i.e., arguments and
16 ** locals), higher variables (i.e., local variables of enclosing functions),
17 ** global variables, list elements, and record elements.
18 */
19
20 #include "vars.h"
21
22 #include "bool.h"
23 #include "calls.h"
24 #include "code.h"
25 #include "error.h"
26 #include "exprs.h"
27 #include "gap.h"
28 #include "gaputils.h"
29 #include "gvars.h"
30 #include "hookintrprtr.h"
31 #include "io.h"
32 #include "lists.h"
33 #include "modules.h"
34 #include "plist.h"
35 #include "precord.h"
36 #include "records.h"
37 #include "saveload.h"
38 #include "stats.h"
39 #include "stringobj.h"
40
41 #ifdef HPCGAP
42 #include "hpc/aobjects.h"
43 #include "hpc/guards.h"
44 #endif
45
46 /****************************************************************************
47 **
48 *V CurrLVars . . . . . . . . . . . . . . . . . . . . . local variables bag
49 **
50 ** 'CurrLVars' is the bag containing the values of the local variables of
51 ** the currently executing interpreted function.
52 **
53 ** Assignments to the local variables change this bag. We do not call
54 ** 'CHANGED_BAG' for each of such change. Instead we wait until a garbage
55 ** collection begins and then call 'CHANGED_BAG' in 'BeginCollectBags'.
56 */
57 /* TL: Bag CurrLVars; */
58
59
60 /****************************************************************************
61 **
62 *V BottomLVars . . . . . . . . . . . . . . . . . bottom local variables bag
63 **
64 ** 'BottomLVars' is the local variables bag at the bottom of the call stack.
65 ** Without such a dummy frame at the bottom, 'SWITCH_TO_NEW_LVARS' would
66 ** have to check for the bottom, slowing it down.
67 **
68 */
69 /* TL: Bag BottomLVars; */
70
71
72 /****************************************************************************
73 **
74 *V PtrLVars . . . . . . . . . . . . . . . . pointer to local variables bag
75 **
76 ** 'PtrLVars' is a pointer to the 'STATE(CurrLVars)' bag. This makes it faster to
77 ** access local variables.
78 **
79 ** Since a garbage collection may move this bag around, the pointer
80 ** 'PtrLVars' must be recalculated afterwards in 'VarsAfterCollectBags'.
81 */
82 /* TL: Obj * PtrLVars; */
83
84
85 /****************************************************************************
86 **
87 *F ObjLVar(<lvar>) . . . . . . . . . . . . . . . . value of a local variable
88 **
89 ** 'ObjLVar' returns the value of the local variable <lvar>.
90 */
ObjLVar(UInt lvar)91 Obj ObjLVar (
92 UInt lvar )
93 {
94 Obj val; /* value result */
95 val = OBJ_LVAR(lvar);
96 if (val == 0) {
97 ErrorMayQuit("Variable: '%g' must have an assigned value",
98 (Int)NAME_LVAR(lvar), 0);
99 }
100 return val;
101 }
102
103
104 /****************************************************************************
105 **
106 *F NewLVarsBag(<slots>) . . . . . . . . . . . . . . allocate a new LVars bag
107 **
108 ** 'NewLVarsBag' allocates a new 'T_LVAR' bag, with the given number of
109 ** local variable <slots>. It tries to satisfy the request from a pool of
110 ** available LVars with up to 16 slots. If the request cannot be satisfied
111 ** from a pool, a new bag is allocated instead.
112 **
113 ** The pools are stored as single linked lists, for which 'PARENT_LVARS'
114 ** is abused.
115 */
NewLVarsBag(UInt slots)116 Bag NewLVarsBag(UInt slots)
117 {
118 Bag result;
119 if (slots < ARRAY_SIZE(STATE(LVarsPool))) {
120 result = STATE(LVarsPool)[slots];
121 if (result) {
122 STATE(LVarsPool)[slots] = PARENT_LVARS(result);
123 return result;
124 }
125 }
126 return NewBag(T_LVARS, sizeof(LVarsHeader) + sizeof(Obj) * slots);
127 }
128
129
130 /****************************************************************************
131 **
132 *F FreeLVarsBag(<slots>) . . . . . . . . . . . . . . . . . free an LVars bag
133 **
134 ** 'FreeLVarsBag' returns an unused 'T_LVAR' bag to one of the 'LVarsPool',
135 ** assuming its size (resp. number of local variable slots) is not too big.
136 */
FreeLVarsBag(Bag bag)137 void FreeLVarsBag(Bag bag)
138 {
139 GAP_ASSERT(TNUM_OBJ(bag) == T_LVARS);
140 UInt slots = (SIZE_BAG(bag) - sizeof(LVarsHeader)) / sizeof(Obj);
141 if (slots < ARRAY_SIZE(STATE(LVarsPool))) {
142 // clean the bag
143 memset(PTR_BAG(bag), 0, SIZE_BAG(bag));
144 // put it into the linked list of available LVars bags
145 LVarsHeader * hdr = (LVarsHeader *)ADDR_OBJ(bag);
146 hdr->parent = STATE(LVarsPool)[slots];
147 STATE(LVarsPool)[slots] = bag;
148 }
149 }
150
151
152 /****************************************************************************
153 **
154 *F ExecAssLVar(<stat>) . . . . . . . . . assign to local variable
155 **
156 ** 'ExecAssLVar' executes the local variable assignment statement <stat> to
157 ** the local variable that is referenced in <stat>.
158 */
ExecAssLVar(Stat stat)159 static UInt ExecAssLVar(Stat stat)
160 {
161 Obj rhs; /* value of right hand side */
162
163 /* assign the right hand side to the local variable */
164 rhs = EVAL_EXPR(READ_STAT(stat, 1));
165 ASS_LVAR(READ_STAT(stat, 0), rhs);
166
167 /* return 0 (to indicate that no leave-statement was executed) */
168 return 0;
169 }
170
ExecUnbLVar(Stat stat)171 static UInt ExecUnbLVar(Stat stat)
172 {
173 /* unbind the local variable */
174 ASS_LVAR(READ_STAT(stat, 0), (Obj)0);
175
176 /* return 0 (to indicate that no leave-statement was executed) */
177 return 0;
178 }
179
180
EvalIsbLVar(Expr expr)181 static Obj EvalIsbLVar(Expr expr)
182 {
183 Obj val; /* value, result */
184
185 /* get the value of the local variable */
186 val = OBJ_LVAR(READ_EXPR(expr, 0));
187
188 /* return the value */
189 return (val != (Obj)0 ? True : False);
190 }
191
192
193 /****************************************************************************
194 **
195 *F PrintAssLVar(<stat>) . . . . . . print an assignment to a local variable
196 **
197 ** 'PrintAssLVar' prints the local variable assignment statement <stat>.
198 */
PrintAssLVar(Stat stat)199 static void PrintAssLVar(Stat stat)
200 {
201 Pr( "%2>", 0L, 0L );
202 Pr("%H", (Int)NAME_LVAR(READ_STAT(stat, 0)), 0L);
203 Pr( "%< %>:= ", 0L, 0L );
204 PrintExpr(READ_EXPR(stat, 1));
205 Pr( "%2<;", 0L, 0L );
206 }
207
PrintUnbLVar(Stat stat)208 static void PrintUnbLVar(Stat stat)
209 {
210 Pr( "Unbind( ", 0L, 0L );
211 Pr("%H", (Int)NAME_LVAR(READ_STAT(stat, 0)), 0L);
212 Pr( " );", 0L, 0L );
213 }
214
215
216 /****************************************************************************
217 **
218 *F PrintRefLVar(<expr>) . . . . . . . print a reference to a local variable
219 **
220 ** 'PrintRefLVar' prints the local variable reference expression <expr>.
221 */
PrintRefLVar(Expr expr)222 static void PrintRefLVar(Expr expr)
223 {
224 Pr( "%H", (Int)NAME_LVAR( LVAR_REF_LVAR(expr) ), 0L );
225 }
226
PrintIsbLVar(Expr expr)227 static void PrintIsbLVar(Expr expr)
228 {
229 Pr( "IsBound( ", 0L, 0L );
230 Pr("%H", (Int)NAME_LVAR(READ_EXPR(expr, 0)), 0L);
231 Pr( " )", 0L, 0L );
232 }
233
234
235 /****************************************************************************
236 **
237 *F ASS_HVAR(<hvar>,<val>) . . . . . . . . . . . assign to a higher variable
238 *F OBJ_HVAR(<hvar>) . . . . . . . . . . . . . . value of a higher variable
239 *F NAME_HVAR(<hvar>) . . . . . . . . . . . . . . . name of a higher variable
240 **
241 ** 'ASS_HVAR' assigns the value <val> to the higher variable <hvar>.
242 **
243 ** 'OBJ_HVAR' returns the value of the higher variable <hvar>.
244 **
245 ** 'NAME_HVAR' returns the name of the higher variable <hvar>.
246 */
ASS_HVAR(UInt hvar,Obj val)247 void ASS_HVAR(UInt hvar, Obj val)
248 {
249 ASS_HVAR_WITH_CONTEXT(STATE(CurrLVars), hvar, val);
250 }
251
OBJ_HVAR(UInt hvar)252 Obj OBJ_HVAR(UInt hvar)
253 {
254 return OBJ_HVAR_WITH_CONTEXT(STATE(CurrLVars), hvar);
255 }
256
NAME_HVAR(UInt hvar)257 Obj NAME_HVAR(UInt hvar)
258 {
259 return NAME_HVAR_WITH_CONTEXT(STATE(CurrLVars), hvar);
260 }
261
ASS_HVAR_WITH_CONTEXT(Obj context,UInt hvar,Obj val)262 void ASS_HVAR_WITH_CONTEXT(Obj context, UInt hvar, Obj val)
263 {
264 // walk up the environment chain to the correct values bag
265 for (UInt i = 1; i <= (hvar >> MAX_FUNC_LVARS_BITS); i++) {
266 context = ENVI_FUNC(FUNC_LVARS(context));
267 }
268
269 // assign the value
270 ASS_LVAR_WITH_CONTEXT(context, hvar & MAX_FUNC_LVARS_MASK, val);
271 CHANGED_BAG(context);
272 }
273
OBJ_HVAR_WITH_CONTEXT(Obj context,UInt hvar)274 Obj OBJ_HVAR_WITH_CONTEXT(Obj context, UInt hvar)
275 {
276 // walk up the environment chain to the correct values bag
277 for (UInt i = 1; i <= (hvar >> MAX_FUNC_LVARS_BITS); i++) {
278 context = ENVI_FUNC(FUNC_LVARS(context));
279 }
280
281 // get the value
282 Obj val = OBJ_LVAR_WITH_CONTEXT(context, hvar & MAX_FUNC_LVARS_MASK);
283
284 // return the value
285 return val;
286 }
287
NAME_HVAR_WITH_CONTEXT(Obj context,UInt hvar)288 Obj NAME_HVAR_WITH_CONTEXT(Obj context, UInt hvar)
289 {
290 // walk up the environment chain to the correct values bag
291 for (UInt i = 1; i <= (hvar >> MAX_FUNC_LVARS_BITS); i++) {
292 context = ENVI_FUNC(FUNC_LVARS(context));
293 }
294
295 // get the name
296 return NAME_LVAR_WITH_CONTEXT(context, hvar & MAX_FUNC_LVARS_MASK);
297 }
298
299
300 /****************************************************************************
301 **
302 *F ExecAssHVar(<stat>) . . . . . . . . . . . . . . assign to higher variable
303 **
304 ** 'ExecAssHVar' executes the higher variable assignment statement <stat> to
305 ** the higher variable that is referenced in <stat>.
306 */
ExecAssHVar(Stat stat)307 static UInt ExecAssHVar(Stat stat)
308 {
309 Obj rhs; /* value of right hand side */
310
311 /* assign the right hand side to the higher variable */
312 rhs = EVAL_EXPR(READ_STAT(stat, 1));
313 ASS_HVAR(READ_STAT(stat, 0), rhs);
314
315 /* return 0 (to indicate that no leave-statement was executed) */
316 return 0;
317 }
318
ExecUnbHVar(Stat stat)319 static UInt ExecUnbHVar(Stat stat)
320 {
321 /* unbind the higher variable */
322 ASS_HVAR(READ_STAT(stat, 0), 0);
323
324 /* return 0 (to indicate that no leave-statement was executed) */
325 return 0;
326 }
327
328
329 /****************************************************************************
330 **
331 *F EvalRefHVar(<expr>) . . . . . . . . . . . . . . value of higher variable
332 **
333 ** 'EvalRefLVarXX' evaluates the higher variable reference expression <expr>
334 ** to the higher variable that is referenced in <expr>.
335 */
EvalRefHVar(Expr expr)336 static Obj EvalRefHVar(Expr expr)
337 {
338 Obj val; /* value, result */
339 UInt hvar = READ_EXPR(expr, 0);
340
341 /* get and check the value of the higher variable */
342 val = OBJ_HVAR(hvar);
343 if (val == 0) {
344 ErrorMayQuit("Variable: '%g' must have an assigned value",
345 (Int)NAME_HVAR(hvar), 0);
346 }
347
348 /* return the value */
349 return val;
350 }
351
EvalIsbHVar(Expr expr)352 static Obj EvalIsbHVar(Expr expr)
353 {
354 Obj val; /* value, result */
355
356 /* get the value of the higher variable */
357 val = OBJ_HVAR(READ_EXPR(expr, 0));
358
359 /* return the value */
360 return (val != (Obj)0 ? True : False);
361 }
362
363
364 /****************************************************************************
365 **
366 *F PrintAssHVar(<stat>) . . . . . . . . print assignment to higher variable
367 **
368 ** 'PrintAssHVar' prints the higher variable assignment statement <stat>.
369 */
PrintAssHVar(Stat stat)370 static void PrintAssHVar(Stat stat)
371 {
372 Pr( "%2>", 0L, 0L );
373 Pr("%H", (Int)NAME_HVAR(READ_STAT(stat, 0)), 0L);
374 Pr( "%< %>:= ", 0L, 0L );
375 PrintExpr(READ_EXPR(stat, 1));
376 Pr( "%2<;", 0L, 0L );
377 }
378
PrintUnbHVar(Stat stat)379 static void PrintUnbHVar(Stat stat)
380 {
381 Pr( "Unbind( ", 0L, 0L );
382 Pr("%H", (Int)NAME_HVAR(READ_STAT(stat, 0)), 0L);
383 Pr( " );", 0L, 0L );
384 }
385
386
387 /****************************************************************************
388 **
389 *F PrintRefHVar(<expr>) . . . . . . . . . print reference to higher variable
390 **
391 ** 'PrintRefHVar' prints the higher variable reference expression <expr>.
392 */
PrintRefHVar(Expr expr)393 static void PrintRefHVar(Expr expr)
394 {
395 Pr("%H", (Int)NAME_HVAR(READ_EXPR(expr, 0)), 0L);
396 }
397
PrintIsbHVar(Expr expr)398 static void PrintIsbHVar(Expr expr)
399 {
400 Pr( "IsBound( ", 0L, 0L );
401 Pr("%H", (Int)NAME_HVAR(READ_EXPR(expr, 0)), 0L);
402 Pr( " )", 0L, 0L );
403 }
404
405
406 /****************************************************************************
407 **
408 *F ExecAssGVar(<stat>) . . . . . . . . . . . . . assign to a global variable
409 **
410 ** 'ExecAssGVar' executes the global variable assignment statement <stat> to
411 ** the global variable that is referenced in <stat>.
412 */
ExecAssGVar(Stat stat)413 static UInt ExecAssGVar(Stat stat)
414 {
415 Obj rhs; /* value of right hand side */
416
417 /* assign the right hand side to the global variable */
418 rhs = EVAL_EXPR(READ_STAT(stat, 1));
419 AssGVar(READ_STAT(stat, 0), rhs);
420
421 /* return 0 (to indicate that no leave-statement was executed) */
422 return 0;
423 }
424
ExecUnbGVar(Stat stat)425 static UInt ExecUnbGVar(Stat stat)
426 {
427 /* unbind the global variable */
428 AssGVar(READ_STAT(stat, 0), (Obj)0);
429
430 /* return 0 (to indicate that no leave-statement was executed) */
431 return 0;
432 }
433
434
435 /****************************************************************************
436 **
437 *F EvalRefGVar(<expr>) . . . . . . . . . . . . . value of a globale variable
438 **
439 ** 'EvalRefGVar' evaluates the global variable reference expression <expr>
440 ** to the global variable that is referenced in <expr>.
441 */
EvalRefGVar(Expr expr)442 static Obj EvalRefGVar(Expr expr)
443 {
444 Obj val; /* value, result */
445
446 /* get and check the value of the global variable */
447 val = ValAutoGVar(READ_EXPR(expr, 0));
448 if (val == 0) {
449 ErrorMayQuit("Variable: '%g' must have an assigned value",
450 (Int)NameGVar(READ_EXPR(expr, 0)), 0);
451 }
452
453 /* return the value */
454 return val;
455 }
456
EvalIsbGVar(Expr expr)457 static Obj EvalIsbGVar(Expr expr)
458 {
459 Obj val; /* value, result */
460
461 /* get the value of the global variable */
462 val = ValAutoGVar(READ_EXPR(expr, 0));
463
464 /* return the value */
465 return (val != (Obj)0 ? True : False);
466 }
467
468
469 /****************************************************************************
470 **
471 *F PrintAssGVar(<stat>) . . . . . print an assignment to a global variable
472 **
473 ** 'PrVarAss' prints the global variable assignment statement <stat>.
474 */
PrintAssGVar(Stat stat)475 static void PrintAssGVar(Stat stat)
476 {
477 Pr( "%2>", 0L, 0L );
478 Pr("%H", (Int)NameGVar(READ_STAT(stat, 0)), 0L);
479 Pr( "%< %>:= ", 0L, 0L );
480 PrintExpr(READ_EXPR(stat, 1));
481 Pr( "%2<;", 0L, 0L );
482 }
483
PrintUnbGVar(Stat stat)484 static void PrintUnbGVar(Stat stat)
485 {
486 Pr( "Unbind( ", 0L, 0L );
487 Pr("%H", (Int)NameGVar(READ_STAT(stat, 0)), 0L);
488 Pr( " );", 0L, 0L );
489 }
490
491
492 /****************************************************************************
493 **
494 *F PrintRefGVar(<expr>) . . . . . . print a reference to a global variable
495 **
496 ** 'PrintRefGVar' prints the global variable reference expression <expr>.
497 */
PrintRefGVar(Expr expr)498 static void PrintRefGVar(Expr expr)
499 {
500 Pr("%H", (Int)NameGVar(READ_STAT(expr, 0)), 0L);
501 }
502
PrintIsbGVar(Expr expr)503 static void PrintIsbGVar(Expr expr)
504 {
505 Pr( "IsBound( ", 0L, 0L );
506 Pr("%H", (Int)NameGVar(READ_EXPR(expr, 0)), 0L);
507 Pr( " )", 0L, 0L );
508 }
509
510
511 /****************************************************************************
512 **
513 *F ExecAssList(<ass>) . . . . . . . . . . . assign to an element of a list
514 **
515 ** 'ExecAssList' executes the list assignment statement <stat> of the form
516 ** '<list>[<position>] := <rhs>;'.
517 */
ExecAssList(Expr stat)518 static UInt ExecAssList(Expr stat)
519 {
520 Obj list; /* list, left operand */
521 Obj pos; /* position, left operand */
522 Int p; /* position, as C integer */
523 Obj rhs; /* right hand side, right operand */
524
525 /* evaluate the list (checking is done by 'ASS_LIST') */
526 list = EVAL_EXPR(READ_STAT(stat, 0));
527
528 /* evaluate the position */
529 pos = EVAL_EXPR(READ_STAT(stat, 1));
530
531 /* evaluate the right hand side */
532 rhs = EVAL_EXPR(READ_STAT(stat, 2));
533
534 if (IS_POS_INTOBJ(pos)) {
535 p = INT_INTOBJ(pos);
536
537 /* special case for plain list */
538 if ( TNUM_OBJ(list) == T_PLIST ) {
539 if ( LEN_PLIST(list) < p ) {
540 GROW_PLIST( list, p );
541 SET_LEN_PLIST( list, p );
542 }
543 SET_ELM_PLIST( list, p, rhs );
544 CHANGED_BAG( list );
545 }
546
547 /* generic case */
548 else {
549 ASS_LIST( list, p, rhs );
550 }
551 } else {
552 ASSB_LIST(list, pos, rhs);
553 }
554
555 /* return 0 (to indicate that no leave-statement was executed) */
556 return 0;
557 }
558 /****************************************************************************
559 **
560 *F ExecAssMat(<ass>) . . . . . . . . . . . assign to an element of a matrix
561 **
562 ** 'ExecAssMat' executes the matrix assignment statement <stat> of the form
563 ** '<mat>[<row>,<col>] := <rhs>;'.
564 */
ExecAssMat(Expr stat)565 static UInt ExecAssMat(Expr stat)
566 {
567 // evaluate the matrix (checking is done by 'ASS_MAT')
568 Obj mat = EVAL_EXPR(READ_STAT(stat, 0));
569
570 // evaluate and check the row and column
571 Obj row = EVAL_EXPR(READ_STAT(stat, 1));
572 Obj col = EVAL_EXPR(READ_STAT(stat, 2));
573
574 // evaluate the right hand side
575 Obj rhs = EVAL_EXPR(READ_STAT(stat, 3));
576
577 ASS_MAT(mat, row, col, rhs);
578
579 // return 0 (to indicate that no leave-statement was executed)
580 return 0;
581 }
582
583
584 /****************************************************************************
585 **
586 *F ExecAsssList(<stat>) . . . . . . . . assign to several elements of a list
587 **
588 ** 'ExecAsssList' executes the list assignment statement <stat> of the form
589 ** '<list>{<positions>} := <rhss>;'.
590 */
ExecAsssList(Expr stat)591 static UInt ExecAsssList(Expr stat)
592 {
593 Obj list; /* list, left operand */
594 Obj poss; /* positions, left operand */
595 Obj rhss; /* right hand sides, right operand */
596
597 /* evaluate the list (checking is done by 'ASSS_LIST') */
598 list = EVAL_EXPR(READ_STAT(stat, 0));
599
600 /* evaluate and check the positions */
601 poss = EVAL_EXPR(READ_STAT(stat, 1));
602 CheckIsPossList("List Assignments", poss);
603
604 /* evaluate and check right hand sides */
605 rhss = EVAL_EXPR(READ_STAT(stat, 2));
606 RequireDenseList("List Assignments", rhss);
607 RequireSameLength("List Assignments", rhss, poss);
608
609 /* assign the right hand sides to several elements of the list */
610 ASSS_LIST( list, poss, rhss );
611
612 /* return 0 (to indicate that no leave-statement was executed) */
613 return 0;
614 }
615
616
617 /****************************************************************************
618 **
619 *F ExecAssListLevel(<stat>) . . . . . . assign to elements of several lists
620 **
621 ** 'ExecAssListLevel' executes the list assignment statement <stat> of the
622 ** form '<list>...{<positions>}...[<position>] := <rhss>;', where there may
623 ** actually be several '{<positions>}' selections between <list> and
624 ** '[<position>]'. The number of those is called the level.
625 ** 'ExecAssListLevel' goes that deep into the left operand and <rhss> and
626 ** assigns the values from <rhss> to each of those lists. For example, if
627 ** the level is 1, the left operand must be a list of lists, <rhss> must be
628 ** a list, and 'ExecAssListLevel' assigns the element '<rhss>[<i>]' to the
629 ** list '<list>[<i>]' at <position>.
630 */
ExecAssListLevel(Expr stat)631 static UInt ExecAssListLevel(Expr stat)
632 {
633 Obj lists; /* lists, left operand */
634 Obj pos; /* position, left operand */
635 Obj rhss; /* right hand sides, right operand */
636 UInt level; /* level */
637 Int narg,i;
638 Obj ixs;
639
640 /* evaluate lists (if this works, then <lists> is nested <level> deep, */
641 /* checking it is nested <level>+1 deep is done by 'AssListLevel') */
642 lists = EVAL_EXPR(READ_STAT(stat, 0));
643 narg = SIZE_STAT(stat)/sizeof(Stat) -3;
644 ixs = NEW_PLIST(T_PLIST, narg);
645 for (i = 1; i <= narg; i++) {
646 pos = EVAL_EXPR(READ_STAT(stat, i));
647 SET_ELM_PLIST(ixs, i, pos);
648 CHANGED_BAG(ixs);
649 }
650 SET_LEN_PLIST(ixs, narg);
651
652 /* evaluate right hand sides (checking is done by 'AssListLevel') */
653 rhss = EVAL_EXPR(READ_STAT(stat, narg + 1));
654
655 /* get the level */
656 level = READ_STAT(stat, narg + 2);
657
658 /* assign the right hand sides to the elements of several lists */
659 AssListLevel( lists, ixs, rhss, level );
660
661 /* return 0 (to indicate that no leave-statement was executed) */
662 return 0;
663 }
664
665
666 /****************************************************************************
667 **
668 *F ExecAsssListLevel(<stat>) . . assign to several elements of several lists
669 **
670 ** 'ExecAsssListLevel' executes the list assignment statement <stat> of the
671 ** form '<list>...{<positions>}...{<positions>} := <rhss>;', where there may
672 ** actually be several '{<positions>}' selections between <list> and
673 ** '{<positions>}'. The number of those is called the level.
674 ** 'ExecAsssListLevel' goes that deep into the left operand and <rhss> and
675 ** assigns the sublists from <rhss> to each of those lists. For example, if
676 ** the level is 1, the left operand must be a list of lists, <rhss> must be
677 ** a list, and 'ExecAsssListLevel' assigns the elements '<rhss>[<i>]' to the
678 ** list '<list>[<i>]' at the positions <positions>.
679 */
ExecAsssListLevel(Expr stat)680 static UInt ExecAsssListLevel(Expr stat)
681 {
682 Obj lists; /* lists, left operand */
683 Obj poss; /* position, left operand */
684 Obj rhss; /* right hand sides, right operand */
685 UInt level; /* level */
686
687 /* evaluate lists (if this works, then <lists> is nested <level> deep, */
688 /* checking it is nested <level>+1 deep is done by 'AsssListLevel') */
689 lists = EVAL_EXPR(READ_STAT(stat, 0));
690
691 /* evaluate and check the positions */
692 poss = EVAL_EXPR(READ_EXPR(stat, 1));
693 CheckIsPossList("List Assignments", poss);
694
695 /* evaluate right hand sides (checking is done by 'AsssListLevel') */
696 rhss = EVAL_EXPR(READ_STAT(stat, 2));
697
698 /* get the level */
699 level = READ_STAT(stat, 3);
700
701 /* assign the right hand sides to several elements of several lists */
702 AsssListLevel( lists, poss, rhss, level );
703
704 /* return 0 (to indicate that no leave-statement was executed) */
705 return 0;
706 }
707
708
709 /****************************************************************************
710 **
711 *F ExecUnbList(<ass>) . . . . . . . . . . . . . unbind an element of a list
712 **
713 ** 'ExecUnbList' executes the list unbind statement <stat> of the form
714 ** 'Unbind( <list>[<position>] );'.
715 */
ExecUnbList(Expr stat)716 static UInt ExecUnbList(Expr stat)
717 {
718 Obj list; /* list, left operand */
719 Obj pos; /* position, left operand */
720 Obj ixs;
721 Int narg;
722 Int i;
723
724 /* evaluate the list (checking is done by 'LEN_LIST') */
725 list = EVAL_EXPR(READ_STAT(stat, 0));
726 narg = SIZE_STAT(stat)/sizeof(Stat) - 1;
727 if (narg == 1) {
728 pos = EVAL_EXPR( READ_STAT(stat, 1) );
729 /* unbind the element */
730 if (IS_POS_INTOBJ(pos)) {
731 UNB_LIST( list, INT_INTOBJ(pos) );
732 } else {
733 UNBB_LIST( list, pos );
734 }
735 } else {
736 ixs = NEW_PLIST(T_PLIST, narg);
737 for (i = 1; i <= narg; i++) {
738 /* evaluate the position */
739 pos = EVAL_EXPR(READ_STAT(stat, i));
740 SET_ELM_PLIST(ixs,i,pos);
741 CHANGED_BAG(ixs);
742 }
743 SET_LEN_PLIST(ixs, narg);
744 UNBB_LIST(list, ixs);
745 }
746
747
748 /* return 0 (to indicate that no leave-statement was executed) */
749 return 0;
750 }
751
752
753 /****************************************************************************
754 **
755 *F EvalElmList(<expr>) . . . . . . . . . . . . . select an element of a list
756 **
757 ** 'EvalElmList' evaluates the list element expression <expr> of the form
758 ** '<list>[<position>]'.
759 */
EvalElmList(Expr expr)760 static Obj EvalElmList(Expr expr)
761 {
762 Obj elm; /* element, result */
763 Obj list; /* list, left operand */
764 Obj pos; /* position, right operand */
765 Int p; /* position, as C integer */
766
767 /* evaluate the list (checking is done by 'ELM_LIST') */
768 list = EVAL_EXPR(READ_EXPR(expr, 0));
769
770 /* evaluate and check the position */
771 pos = EVAL_EXPR(READ_EXPR(expr, 1));
772
773 if (IS_POS_INTOBJ(pos)) {
774 p = INT_INTOBJ( pos );
775
776 /* special case for plain lists (use generic code to signal errors) */
777 if ( IS_PLIST( list ) ) {
778 if ( LEN_PLIST(list) < p ) {
779 return ELM_LIST( list, p );
780 }
781 elm = ELM_PLIST( list, p );
782 if ( elm == 0 ) {
783 return ELM_LIST( list, p );
784 }
785 }
786 /* generic case */
787 else {
788 elm = ELM_LIST( list, p );
789 }
790 } else {
791 elm = ELMB_LIST(list, pos);
792 }
793
794 /* return the element */
795 return elm;
796 }
797
798 /****************************************************************************
799 **
800 *F EvalElmMat(<expr>) . . . . . . . . . . . . select an element of a matrix
801 **
802 ** 'EvalElmMat' evaluates the matrix element expression <expr> of the form
803 ** '<mat>[<row>,<col>]'.
804 */
EvalElmMat(Expr expr)805 static Obj EvalElmMat(Expr expr)
806 {
807 // evaluate the matrix (checking is done by 'ELM_MAT')
808 Obj mat = EVAL_EXPR(READ_EXPR(expr, 0));
809
810 // evaluate and check the row and column
811 Obj row = EVAL_EXPR(READ_EXPR(expr, 1));
812 Obj col = EVAL_EXPR(READ_EXPR(expr, 2));
813
814 // return the element
815 return ELM_MAT(mat, row, col);
816 }
817
818
819 /****************************************************************************
820 **
821 *F EvalElmsList(<expr>) . . . . . . . . . select several elements of a list
822 **
823 ** 'EvalElmsList' evaluates the list element expression <expr> of the form
824 ** '<list>{<positions>}'.
825 */
EvalElmsList(Expr expr)826 static Obj EvalElmsList(Expr expr)
827 {
828 Obj elms; /* elements, result */
829 Obj list; /* list, left operand */
830 Obj poss; /* positions, right operand */
831
832 /* evaluate the list (checking is done by 'ELMS_LIST') */
833 list = EVAL_EXPR(READ_EXPR(expr, 0));
834
835 /* evaluate and check the positions */
836 poss = EVAL_EXPR(READ_EXPR(expr, 1));
837 CheckIsPossList("List Elements", poss);
838
839 /* select several elements from the list */
840 elms = ELMS_LIST( list, poss );
841
842 /* return the elements */
843 return elms;
844 }
845
846
847 /****************************************************************************
848 **
849 *F EvalElmListLevel(<expr>) . . . . . . . select elements of several lists
850 **
851 ** 'EvalElmListLevel' evaluates the list element expression <expr> of the
852 ** form '<list>...{<positions>}...[<position>]', where there may actually be
853 ** several '{<positions>}' selections between <list> and '[<position>]'.
854 ** The number of those is called the level. 'EvalElmListLevel' goes that
855 ** deep into the left operand and selects the element at <position> from
856 ** each of those lists. For example, if the level is 1, the left operand
857 ** must be a list of lists and 'EvalElmListLevel' selects the element at
858 ** <position> from each of the lists and returns the list of those values.
859 */
EvalElmListLevel(Expr expr)860 static Obj EvalElmListLevel(Expr expr)
861 {
862 Obj lists; /* lists, left operand */
863 Obj pos; /* position, right operand */
864 Obj ixs;
865 UInt level; /* level */
866 Int narg;
867 Int i;
868
869 /* evaluate lists (if this works, then <lists> is nested <level> deep, */
870 /* checking it is nested <level>+1 deep is done by 'ElmListLevel') */
871 lists = EVAL_EXPR(READ_EXPR(expr, 0));
872 narg = SIZE_EXPR(expr)/sizeof(Expr) -2;
873 ixs = NEW_PLIST(T_PLIST, narg);
874 for (i = 1; i <= narg; i++) {
875 pos = EVAL_EXPR( READ_EXPR(expr, i));
876 SET_ELM_PLIST(ixs, i, pos);
877 CHANGED_BAG(ixs);
878 }
879 SET_LEN_PLIST(ixs, narg);
880 /* get the level */
881 level = READ_EXPR(expr, narg + 1);
882
883 /* select the elements from several lists (store them in <lists>) */
884 ElmListLevel( lists, ixs, level );
885
886 /* return the elements */
887 return lists;
888 }
889
890
891 /****************************************************************************
892 **
893 *F EvalElmsListLevel(<expr>) . . . select several elements of several lists
894 **
895 ** 'EvalElmsListLevel' evaluates the list element expression <expr> of the
896 ** form '<list>...{<positions>}...{<positions>}', where there may actually
897 ** be several '{<positions>}' selections between <list> and '{<positions>}'.
898 ** The number of those is called the level. 'EvalElmsListLevel' goes that
899 ** deep into the left operand and selects the elements at <positions> from
900 ** each of those lists. For example, if the level is 1, the left operand
901 ** must be a list of lists and 'EvalElmsListLevel' selects the elements at
902 ** <positions> from each of the lists and returns the list of those
903 ** sublists.
904 */
EvalElmsListLevel(Expr expr)905 static Obj EvalElmsListLevel(Expr expr)
906 {
907 Obj lists; /* lists, left operand */
908 Obj poss; /* positions, right operand */
909 UInt level; /* level */
910
911 /* evaluate lists (if this works, then <lists> is nested <level> deep, */
912 /* checking it is nested <level>+1 deep is done by 'ElmsListLevel') */
913 lists = EVAL_EXPR(READ_EXPR(expr, 0));
914
915 /* evaluate and check the positions */
916 poss = EVAL_EXPR(READ_EXPR(expr, 1));
917 CheckIsPossList("List Elements", poss);
918
919 /* get the level */
920 level = READ_EXPR(expr, 2);
921
922 /* select several elements from several lists (store them in <lists>) */
923 ElmsListLevel( lists, poss, level );
924
925 /* return the elements */
926 return lists;
927 }
928
929
930 /****************************************************************************
931 **
932 *F EvalIsbList(<expr>) . . . . . . . . test if an element of a list is bound
933 **
934 ** 'EvalIsbList' evaluates the list isbound expression <expr> of the form
935 ** 'IsBound( <list>[<position>] )'.
936 */
EvalIsbList(Expr expr)937 static Obj EvalIsbList(Expr expr)
938 {
939 Obj list; /* list, left operand */
940 Obj pos; /* position, right operand */
941 Obj ixs;
942 Int narg, i;
943
944 /* evaluate the list (checking is done by 'ISB_LIST') */
945 list = EVAL_EXPR(READ_EXPR(expr, 0));
946 narg = SIZE_EXPR(expr)/sizeof(Expr) -1;
947 if (narg == 1) {
948 /* evaluate and check the position */
949 pos = EVAL_EXPR(READ_EXPR(expr, 1));
950
951 if (IS_POS_INTOBJ(pos))
952 return ISB_LIST( list, INT_INTOBJ(pos) ) ? True : False;
953 else
954 return ISBB_LIST(list, pos) ? True : False;
955 } else {
956 ixs = NEW_PLIST(T_PLIST, narg);
957 for (i = 1; i <= narg; i++) {
958 pos = EVAL_EXPR( READ_EXPR(expr, i) );
959 SET_ELM_PLIST(ixs,i,pos);
960 CHANGED_BAG(ixs);
961 }
962 SET_LEN_PLIST(ixs, narg);
963 return ISBB_LIST(list, ixs) ? True : False;
964 }
965
966 }
967
968
969 /****************************************************************************
970 **
971 *F PrintAssList(<stat>) . . . . print an assignment to an element of a list
972 **
973 ** 'PrintAssList' prints the list assignment statement <stat> of the form
974 ** '<list>[<position>] := <rhs>;'.
975 **
976 ** Linebreaks are preferred before the ':='.
977 */
PrintAssList(Stat stat)978 static void PrintAssList(Stat stat)
979 {
980 Pr("%4>",0L,0L);
981 PrintExpr(READ_EXPR(stat, 0));
982 Pr("%<[",0L,0L);
983 PrintExpr(READ_EXPR(stat, 1));
984 Pr("%<]",0L,0L);
985 Pr("%< %>:= ",0L,0L);
986 PrintExpr(READ_EXPR(stat, 2));
987 Pr("%2<;",0L,0L);
988 }
989
PrintAssMat(Stat stat)990 static void PrintAssMat(Stat stat)
991 {
992 Pr("%4>",0L,0L);
993 PrintExpr(READ_EXPR(stat, 0));
994 Pr("%<[",0L,0L);
995 PrintExpr(READ_EXPR(stat, 1));
996 Pr("%<, %>",0L,0L);
997 PrintExpr(READ_EXPR(stat, 2));
998 Pr("%<]",0L,0L);
999 Pr("%< %>:= ",0L,0L);
1000 PrintExpr(READ_EXPR(stat, 3));
1001 Pr("%2<;",0L,0L);
1002 }
1003
PrintUnbList(Stat stat)1004 static void PrintUnbList(Stat stat)
1005 {
1006 Int narg = SIZE_STAT(stat)/sizeof(Stat) -1;
1007 Int i;
1008 Pr( "Unbind( ", 0L, 0L );
1009 Pr("%2>",0L,0L);
1010 PrintExpr(READ_EXPR(stat, 0));
1011 Pr("%<[",0L,0L);
1012 PrintExpr(READ_EXPR(stat, 1));
1013 for (i = 2; i <= narg; i++) {
1014 Pr("%<, %>",0L,0L);
1015 PrintExpr(READ_EXPR(stat, i));
1016 }
1017 Pr("%<]",0L,0L);
1018 Pr( " );", 0L, 0L );
1019 }
1020
1021
1022 /****************************************************************************
1023 **
1024 *F PrintAsssList(<stat>) . print an assignment to several elements of a list
1025 **
1026 ** 'PrintAsssList' prints the list assignment statement <stat> of the form
1027 ** '<list>{<positions>} := <rhss>;'.
1028 **
1029 ** Linebreaks are preferred before the ':='.
1030 */
PrintAsssList(Stat stat)1031 static void PrintAsssList(Stat stat)
1032 {
1033 Pr("%4>",0L,0L);
1034 PrintExpr(READ_EXPR(stat, 0));
1035 Pr("%<{",0L,0L);
1036 PrintExpr(READ_EXPR(stat, 1));
1037 Pr("%<}",0L,0L);
1038 Pr("%< %>:= ",0L,0L);
1039 PrintExpr(READ_EXPR(stat, 2));
1040 Pr("%2<;",0L,0L);
1041 }
1042
1043
1044 /****************************************************************************
1045 **
1046 *F PrintElmList(<expr>) . . . . . print a selection of an element of a list
1047 **
1048 ** 'PrintElmList' prints the list element expression <expr> of the form
1049 ** '<list>[<position>]'.
1050 **
1051 ** Linebreaks are preferred after the '['.
1052 */
PrintElmList(Expr expr)1053 static void PrintElmList(Expr expr)
1054 {
1055 Pr("%2>",0L,0L);
1056 PrintExpr(READ_EXPR(expr, 0));
1057 Pr("%<[",0L,0L);
1058 PrintExpr(READ_EXPR(expr, 1));
1059 Pr("%<]",0L,0L);
1060 }
1061
PrintElmMat(Expr expr)1062 static void PrintElmMat(Expr expr)
1063 {
1064 Pr("%2>",0L,0L);
1065 PrintExpr(READ_EXPR(expr, 0));
1066 Pr("%<[",0L,0L);
1067 PrintExpr(READ_EXPR(expr, 1));
1068 Pr("%<, %<",0L,0L);
1069 PrintExpr(READ_EXPR(expr, 2));
1070 Pr("%<]",0L,0L);
1071 }
1072
PrintElmListLevel(Expr expr)1073 static void PrintElmListLevel(Expr expr)
1074 {
1075 Int i;
1076 Int narg = SIZE_EXPR(expr)/sizeof(Expr) -2 ;
1077 Pr("%2>",0L,0L);
1078 PrintExpr(READ_EXPR(expr, 0));
1079 Pr("%<[",0L,0L);
1080 PrintExpr(READ_EXPR(expr, 1));
1081 for (i = 2; i <= narg; i++) {
1082 Pr("%<, %<",0L,0L);
1083 PrintExpr(READ_EXPR(expr, i));
1084 }
1085 Pr("%<]",0L,0L);
1086 }
1087
1088
PrintIsbList(Expr expr)1089 static void PrintIsbList(Expr expr)
1090 {
1091 Int narg = SIZE_EXPR(expr)/sizeof(Expr) - 1;
1092 Int i;
1093 Pr( "IsBound( ", 0L, 0L );
1094 Pr("%2>",0L,0L);
1095 PrintExpr(READ_EXPR(expr, 0));
1096 Pr("%<[",0L,0L);
1097 PrintExpr(READ_EXPR(expr, 1));
1098 for (i = 2; i <= narg; i++) {
1099 Pr("%<, %>", 0L, 0L);
1100 PrintExpr(READ_EXPR(expr, i));
1101 }
1102 Pr("%<]",0L,0L);
1103 Pr( " )", 0L, 0L );
1104 }
1105
1106
1107 /****************************************************************************
1108 **
1109 *F PrintElmsList(<expr>) . . print a selection of several elements of a list
1110 **
1111 ** 'PrintElmsList' prints the list elements expression <expr> of the form
1112 ** '<list>{<positions>}'.
1113 **
1114 ** Linebreaks are preferred after the '{'.
1115 */
PrintElmsList(Expr expr)1116 static void PrintElmsList(Expr expr)
1117 {
1118 Pr("%2>",0L,0L);
1119 PrintExpr(READ_EXPR(expr, 0));
1120 Pr("%<{",0L,0L);
1121 PrintExpr(READ_EXPR(expr, 1));
1122 Pr("%<}",0L,0L);
1123 }
1124
1125
1126 /****************************************************************************
1127 **
1128 *F ExecAssRecName(<stat>) . . . . . . . . assign to an element of a record
1129 **
1130 ** 'ExecAssRecName' executes the record assignment statement <stat> of the
1131 ** form '<record>.<name> := <rhs>;'.
1132 */
ExecAssRecName(Stat stat)1133 static UInt ExecAssRecName(Stat stat)
1134 {
1135 Obj record; /* record, left operand */
1136 UInt rnam; /* name, left operand */
1137 Obj rhs; /* rhs, right operand */
1138
1139 /* evaluate the record (checking is done by 'ASS_REC') */
1140 record = EVAL_EXPR(READ_STAT(stat, 0));
1141
1142 /* get the name (stored immediately in the statement) */
1143 rnam = READ_STAT(stat, 1);
1144
1145 /* evaluate the right hand side */
1146 rhs = EVAL_EXPR(READ_STAT(stat, 2));
1147
1148 /* assign the right hand side to the element of the record */
1149 ASS_REC( record, rnam, rhs );
1150
1151 /* return 0 (to indicate that no leave-statement was executed) */
1152 return 0;
1153 }
1154
1155
1156 /****************************************************************************
1157 **
1158 *F ExecAssRecExpr(<stat>) . . . . . . . . assign to an element of a record
1159 **
1160 ** 'ExecAssRecExpr' executes the record assignment statement <stat> of the
1161 ** form '<record>.(<name>) := <rhs>;'.
1162 */
ExecAssRecExpr(Stat stat)1163 static UInt ExecAssRecExpr(Stat stat)
1164 {
1165 Obj record; /* record, left operand */
1166 UInt rnam; /* name, left operand */
1167 Obj rhs; /* rhs, right operand */
1168
1169 /* evaluate the record (checking is done by 'ASS_REC') */
1170 record = EVAL_EXPR(READ_STAT(stat, 0));
1171
1172 /* evaluate the name and convert it to a record name */
1173 rnam = RNamObj(EVAL_EXPR(READ_STAT(stat, 1)));
1174
1175 /* evaluate the right hand side */
1176 rhs = EVAL_EXPR(READ_STAT(stat, 2));
1177
1178 /* assign the right hand side to the element of the record */
1179 ASS_REC( record, rnam, rhs );
1180
1181 /* return 0 (to indicate that no leave-statement was executed) */
1182 return 0;
1183 }
1184
1185
1186 /****************************************************************************
1187 **
1188 *F ExecUnbRecName(<stat>) . . . . . . . . . . unbind an element of a record
1189 **
1190 ** 'ExecUnbRecName' executes the record unbind statement <stat> of the form
1191 ** 'Unbind( <record>.<name> );'.
1192 */
ExecUnbRecName(Stat stat)1193 static UInt ExecUnbRecName(Stat stat)
1194 {
1195 Obj record; /* record, left operand */
1196 UInt rnam; /* name, left operand */
1197
1198 /* evaluate the record (checking is done by 'UNB_REC') */
1199 record = EVAL_EXPR(READ_STAT(stat, 0));
1200
1201 /* get the name (stored immediately in the statement) */
1202 rnam = READ_STAT(stat, 1);
1203
1204 /* unbind the element of the record */
1205 UNB_REC( record, rnam );
1206
1207 /* return 0 (to indicate that no leave-statement was executed) */
1208 return 0;
1209 }
1210
1211
1212 /****************************************************************************
1213 **
1214 *F ExecUnbRecExpr(<stat>) . . . . . . . . . . unbind an element of a record
1215 **
1216 ** 'ExecUnbRecExpr' executes the record unbind statement <stat> of the form
1217 ** 'Unbind( <record>.(<name>) );'.
1218 */
ExecUnbRecExpr(Stat stat)1219 static UInt ExecUnbRecExpr(Stat stat)
1220 {
1221 Obj record; /* record, left operand */
1222 UInt rnam; /* name, left operand */
1223
1224 /* evaluate the record (checking is done by 'UNB_REC') */
1225 record = EVAL_EXPR(READ_STAT(stat, 0));
1226
1227 /* evaluate the name and convert it to a record name */
1228 rnam = RNamObj(EVAL_EXPR(READ_STAT(stat, 1)));
1229
1230 /* unbind the element of the record */
1231 UNB_REC( record, rnam );
1232
1233 /* return 0 (to indicate that no leave-statement was executed) */
1234 return 0;
1235 }
1236
1237
1238 /****************************************************************************
1239 **
1240 *F EvalElmRecName(<expr>) . . . . . . . . . . . . . select a record element
1241 **
1242 ** 'EvalElmRecName' evaluates the record element expression <expr> of the
1243 ** form '<record>.<name>'.
1244 */
EvalElmRecName(Expr expr)1245 static Obj EvalElmRecName(Expr expr)
1246 {
1247 Obj elm; /* element, result */
1248 Obj record; /* the record, left operand */
1249 UInt rnam; /* the name, right operand */
1250
1251 /* evaluate the record (checking is done by 'ELM_REC') */
1252 record = EVAL_EXPR(READ_EXPR(expr, 0));
1253
1254 /* get the name (stored immediately in the expression) */
1255 rnam = READ_EXPR(expr, 1);
1256
1257 /* select the element of the record */
1258 elm = ELM_REC( record, rnam );
1259
1260 /* return the element */
1261 return elm;
1262 }
1263
1264
1265 /****************************************************************************
1266 **
1267 *F EvalElmRecExpr(<expr>) . . . . . . . . . . . . . select a record element
1268 **
1269 ** 'EvalElmRecExpr' evaluates the record element expression <expr> of the
1270 ** form '<record>.(<name>)'.
1271 */
EvalElmRecExpr(Expr expr)1272 static Obj EvalElmRecExpr(Expr expr)
1273 {
1274 Obj elm; /* element, result */
1275 Obj record; /* the record, left operand */
1276 UInt rnam; /* the name, right operand */
1277
1278 /* evaluate the record (checking is done by 'ELM_REC') */
1279 record = EVAL_EXPR(READ_EXPR(expr, 0));
1280
1281 /* evaluate the name and convert it to a record name */
1282 rnam = RNamObj(EVAL_EXPR(READ_EXPR(expr, 1)));
1283
1284 /* select the element of the record */
1285 elm = ELM_REC( record, rnam );
1286
1287 /* return the element */
1288 return elm;
1289 }
1290
1291
1292 /****************************************************************************
1293 **
1294 *F EvalIsbRecName(<expr>) . . . . . . . . test if a record element is bound
1295 **
1296 ** 'EvalElmRecName' evaluates the record isbound expression <expr> of the
1297 ** form 'IsBound( <record>.<name> )'.
1298 */
EvalIsbRecName(Expr expr)1299 static Obj EvalIsbRecName(Expr expr)
1300 {
1301 Obj record; /* the record, left operand */
1302 UInt rnam; /* the name, right operand */
1303
1304 /* evaluate the record (checking is done by 'ISB_REC') */
1305 record = EVAL_EXPR(READ_EXPR(expr, 0));
1306
1307 /* get the name (stored immediately in the expression) */
1308 rnam = READ_EXPR(expr, 1);
1309
1310 /* return the result */
1311 return (ISB_REC( record, rnam ) ? True : False);
1312 }
1313
1314
1315 /****************************************************************************
1316 **
1317 *F EvalIsbRecExpr(<expr>) . . . . . . . . test if a record element is bound
1318 **
1319 ** 'EvalIsbRecExpr' evaluates the record isbound expression <expr> of the
1320 ** form 'IsBound( <record>.(<name>) )'.
1321 */
EvalIsbRecExpr(Expr expr)1322 static Obj EvalIsbRecExpr(Expr expr)
1323 {
1324 Obj record; /* the record, left operand */
1325 UInt rnam; /* the name, right operand */
1326
1327 /* evaluate the record (checking is done by 'ISB_REC') */
1328 record = EVAL_EXPR(READ_EXPR(expr, 0));
1329
1330 /* evaluate the name and convert it to a record name */
1331 rnam = RNamObj(EVAL_EXPR(READ_EXPR(expr, 1)));
1332
1333 /* return the result */
1334 return (ISB_REC( record, rnam ) ? True : False);
1335 }
1336
1337
1338 /****************************************************************************
1339 **
1340 *F PrintAssRecName(<stat>) . . print an assignment to an element of a record
1341 **
1342 ** 'PrintAssRecName' prints the record assignment statement <stat> of the
1343 ** form '<record>.<name> := <rhs>;'.
1344 */
PrintAssRecName(Stat stat)1345 static void PrintAssRecName(Stat stat)
1346 {
1347 Pr("%4>",0L,0L);
1348 PrintExpr(READ_EXPR(stat, 0));
1349 Pr("%<.",0L,0L);
1350 Pr("%H", (Int)NAME_RNAM(READ_STAT(stat, 1)), 0L);
1351 Pr("%<",0L,0L);
1352 Pr("%< %>:= ",0L,0L);
1353 PrintExpr(READ_EXPR(stat, 2));
1354 Pr("%2<;",0L,0L);
1355 }
1356
PrintUnbRecName(Stat stat)1357 static void PrintUnbRecName(Stat stat)
1358 {
1359 Pr( "Unbind( ", 0L, 0L );
1360 Pr("%2>",0L,0L);
1361 PrintExpr(READ_EXPR(stat, 0));
1362 Pr("%<.",0L,0L);
1363 Pr("%H", (Int)NAME_RNAM(READ_STAT(stat, 1)), 0L);
1364 Pr("%<",0L,0L);
1365 Pr( " );", 0L, 0L );
1366 }
1367
1368
1369 /****************************************************************************
1370 **
1371 *F PrintAssRecExpr(<stat>) . . print an assignment to an element of a record
1372 **
1373 ** 'PrintAssRecExpr' prints the record assignment statement <stat> of the
1374 ** form '<record>.(<name>) := <rhs>;'.
1375 */
PrintAssRecExpr(Stat stat)1376 static void PrintAssRecExpr(Stat stat)
1377 {
1378 Pr("%4>",0L,0L);
1379 PrintExpr(READ_EXPR(stat, 0));
1380 Pr("%<.(",0L,0L);
1381 PrintExpr(READ_EXPR(stat, 1));
1382 Pr(")%<",0L,0L);
1383 Pr("%< %>:= ",0L,0L);
1384 PrintExpr(READ_EXPR(stat, 2));
1385 Pr("%2<;",0L,0L);
1386 }
1387
PrintUnbRecExpr(Stat stat)1388 static void PrintUnbRecExpr(Stat stat)
1389 {
1390 Pr( "Unbind( ", 0L, 0L );
1391 Pr("%2>",0L,0L);
1392 PrintExpr(READ_EXPR(stat, 0));
1393 Pr("%<.(",0L,0L);
1394 PrintExpr(READ_EXPR(stat, 1));
1395 Pr(")%<",0L,0L);
1396 Pr( " );", 0L, 0L );
1397 }
1398
1399
1400 /****************************************************************************
1401 **
1402 *F PrintElmRecName(<expr>) . . . print a selection of an element of a record
1403 **
1404 ** 'PrintElmRecName' prints the record element expression <expr> of the form
1405 ** '<record>.<name>'.
1406 */
PrintElmRecName(Expr expr)1407 static void PrintElmRecName(Expr expr)
1408 {
1409 Pr("%2>",0L,0L);
1410 PrintExpr(READ_EXPR(expr, 0));
1411 Pr("%<.",0L,0L);
1412 Pr("%H", (Int)NAME_RNAM(READ_EXPR(expr, 1)), 0L);
1413 Pr("%<",0L,0L);
1414 }
1415
PrintIsbRecName(Expr expr)1416 static void PrintIsbRecName(Expr expr)
1417 {
1418 Pr( "IsBound( ", 0L, 0L );
1419 Pr("%2>",0L,0L);
1420 PrintExpr(READ_EXPR(expr, 0));
1421 Pr("%<.",0L,0L);
1422 Pr("%H", (Int)NAME_RNAM(READ_EXPR(expr, 1)), 0L);
1423 Pr("%<",0L,0L);
1424 Pr( " )", 0L, 0L );
1425 }
1426
1427
1428 /****************************************************************************
1429 **
1430 *F PrintElmRecExpr(<expr>) . . . print a selection of an element of a record
1431 **
1432 ** 'PrintElmRecExpr' prints the record element expression <expr> of the form
1433 ** '<record>.(<name>)'.
1434 */
PrintElmRecExpr(Expr expr)1435 static void PrintElmRecExpr(Expr expr)
1436 {
1437 Pr("%2>",0L,0L);
1438 PrintExpr(READ_EXPR(expr, 0));
1439 Pr("%<.(",0L,0L);
1440 PrintExpr(READ_EXPR(expr, 1));
1441 Pr(")%<",0L,0L);
1442 }
1443
PrintIsbRecExpr(Expr expr)1444 static void PrintIsbRecExpr(Expr expr)
1445 {
1446 Pr( "IsBound( ", 0L, 0L );
1447 Pr("%2>",0L,0L);
1448 PrintExpr(READ_EXPR(expr, 0));
1449 Pr("%<.(",0L,0L);
1450 PrintExpr(READ_EXPR(expr, 1));
1451 Pr(")%<",0L,0L);
1452 Pr( " )", 0L, 0L );
1453 }
1454
1455
1456 /****************************************************************************
1457 **
1458 *F ExecAssPosObj(<ass>) . . . . . . . . . . . assign to an element of a list
1459 **
1460 ** 'ExecAssPosObj' executes the list assignment statement <stat> of the form
1461 ** '<list>[<position>] := <rhs>;'.
1462 */
ExecAssPosObj(Expr stat)1463 static UInt ExecAssPosObj(Expr stat)
1464 {
1465 Obj list; /* list, left operand */
1466 Obj pos; /* position, left operand */
1467 Int p; /* position, as a C integer */
1468 Obj rhs; /* right hand side, right operand */
1469
1470 /* evaluate the list (checking is done by 'ASS_LIST') */
1471 list = EVAL_EXPR(READ_STAT(stat, 0));
1472
1473 /* evaluate and check the position */
1474 pos = EVAL_EXPR(READ_STAT(stat, 1));
1475 p = GetPositiveSmallIntEx("PosObj Assignment", pos, "<position>");
1476
1477 /* evaluate the right hand side */
1478 rhs = EVAL_EXPR(READ_STAT(stat, 2));
1479
1480 /* special case for plain list */
1481 AssPosObj(list, p, rhs);
1482
1483 /* return 0 (to indicate that no leave-statement was executed) */
1484 return 0;
1485 }
1486
1487
1488 /****************************************************************************
1489 **
1490 *F ExecUnbPosObj(<ass>) . . . . . . . . . . . . . unbind an element of a list
1491 **
1492 ** 'ExecUnbPosObj' executes the list unbind statement <stat> of the form
1493 ** 'Unbind( <list>[<position>] );'.
1494 */
ExecUnbPosObj(Expr stat)1495 static UInt ExecUnbPosObj(Expr stat)
1496 {
1497 Obj list; /* list, left operand */
1498 Obj pos; /* position, left operand */
1499 Int p; /* position, as a C integer */
1500
1501 /* evaluate the list (checking is done by 'LEN_LIST') */
1502 list = EVAL_EXPR(READ_STAT(stat, 0));
1503
1504 /* evaluate and check the position */
1505 pos = EVAL_EXPR(READ_STAT(stat, 1));
1506 p = GetPositiveSmallIntEx("PosObj Assignment", pos, "<position>");
1507
1508 /* unbind the element */
1509 UnbPosObj(list, p);
1510
1511 /* return 0 (to indicate that no leave-statement was executed) */
1512 return 0;
1513 }
1514
1515
1516 /****************************************************************************
1517 **
1518 *F EvalElmPosObj(<expr>) . . . . . . . . . . . . . select an element of a list
1519 **
1520 ** 'EvalElmPosObj' evaluates the list element expression <expr> of the form
1521 ** '<list>[<position>]'.
1522 */
EvalElmPosObj(Expr expr)1523 static Obj EvalElmPosObj(Expr expr)
1524 {
1525 Obj elm; /* element, result */
1526 Obj list; /* list, left operand */
1527 Obj pos; /* position, right operand */
1528 Int p; /* position, as C integer */
1529
1530 /* evaluate the list (checking is done by 'ELM_LIST') */
1531 list = EVAL_EXPR(READ_EXPR(expr, 0));
1532
1533 /* evaluate and check the position */
1534 pos = EVAL_EXPR(READ_EXPR(expr, 1));
1535 p = GetPositiveSmallIntEx("PosObj Element", pos, "<position>");
1536
1537 /* special case for plain lists (use generic code to signal errors) */
1538 elm = ElmPosObj(list, p);
1539
1540 /* return the element */
1541 return elm;
1542 }
1543
1544
1545 /****************************************************************************
1546 **
1547 *F EvalIsbPosObj(<expr>) . . . . . . . . test if an element of a list is bound
1548 **
1549 ** 'EvalElmPosObj' evaluates the list isbound expression <expr> of the form
1550 ** 'IsBound( <list>[<position>] )'.
1551 */
EvalIsbPosObj(Expr expr)1552 static Obj EvalIsbPosObj(Expr expr)
1553 {
1554 Obj isb; /* isbound, result */
1555 Obj list; /* list, left operand */
1556 Obj pos; /* position, right operand */
1557 Int p; /* position, as C integer */
1558
1559 /* evaluate the list (checking is done by 'ISB_LIST') */
1560 list = EVAL_EXPR(READ_EXPR(expr, 0));
1561
1562 /* evaluate and check the position */
1563 pos = EVAL_EXPR(READ_EXPR(expr, 1));
1564 p = GetPositiveSmallIntEx("PosObj Element", pos, "<position>");
1565
1566 /* get the result */
1567 isb = IsbPosObj(list, p) ? True : False;
1568
1569 /* return the result */
1570 return isb;
1571 }
1572
1573
1574 /****************************************************************************
1575 **
1576 *F PrintAssPosObj(<stat>) . . . . print an assignment to an element of a list
1577 **
1578 ** 'PrintAssPosObj' prints the list assignment statement <stat> of the form
1579 ** '<list>[<position>] := <rhs>;'.
1580 **
1581 ** Linebreaks are preferred before the ':='.
1582 */
PrintAssPosObj(Stat stat)1583 static void PrintAssPosObj(Stat stat)
1584 {
1585 Pr("%4>",0L,0L);
1586 PrintExpr(READ_EXPR(stat, 0));
1587 Pr("%<![",0L,0L);
1588 PrintExpr(READ_EXPR(stat, 1));
1589 Pr("%<]",0L,0L);
1590 Pr("%< %>:= ",0L,0L);
1591 PrintExpr(READ_EXPR(stat, 2));
1592 Pr("%2<;",0L,0L);
1593 }
1594
PrintUnbPosObj(Stat stat)1595 static void PrintUnbPosObj(Stat stat)
1596 {
1597 Pr( "Unbind( ", 0L, 0L );
1598 Pr("%2>",0L,0L);
1599 PrintExpr(READ_EXPR(stat, 0));
1600 Pr("%<![",0L,0L);
1601 PrintExpr(READ_EXPR(stat, 1));
1602 Pr("%<]",0L,0L);
1603 Pr( " );", 0L, 0L );
1604 }
1605
1606
1607 /****************************************************************************
1608 **
1609 *F PrintElmPosObj(<expr>) . . . . . print a selection of an element of a list
1610 **
1611 ** 'PrintElmPosObj' prints the list element expression <expr> of the form
1612 ** '<list>[<position>]'.
1613 **
1614 ** Linebreaks are preferred after the '['.
1615 */
PrintElmPosObj(Expr expr)1616 static void PrintElmPosObj(Expr expr)
1617 {
1618 Pr("%2>",0L,0L);
1619 PrintExpr(READ_EXPR(expr, 0));
1620 Pr("%<![",0L,0L);
1621 PrintExpr(READ_EXPR(expr, 1));
1622 Pr("%<]",0L,0L);
1623 }
1624
PrintIsbPosObj(Expr expr)1625 static void PrintIsbPosObj(Expr expr)
1626 {
1627 Pr( "IsBound( ", 0L, 0L );
1628 Pr("%2>",0L,0L);
1629 PrintExpr(READ_EXPR(expr, 0));
1630 Pr("%<![",0L,0L);
1631 PrintExpr(READ_EXPR(expr, 1));
1632 Pr("%<]",0L,0L);
1633 Pr( " )", 0L, 0L );
1634 }
1635
1636
1637 /****************************************************************************
1638 **
1639 *F ExecAssComObjName(<stat>) . . . . . . . . assign to an element of a record
1640 **
1641 ** 'ExecAssComObjName' executes the record assignment statement <stat> of the
1642 ** form '<record>.<name> := <rhs>;'.
1643 */
ExecAssComObjName(Stat stat)1644 static UInt ExecAssComObjName(Stat stat)
1645 {
1646 Obj record; /* record, left operand */
1647 UInt rnam; /* name, left operand */
1648 Obj rhs; /* rhs, right operand */
1649
1650 /* evaluate the record (checking is done by 'ASS_REC') */
1651 record = EVAL_EXPR(READ_STAT(stat, 0));
1652
1653 /* get the name (stored immediately in the statement) */
1654 rnam = READ_STAT(stat, 1);
1655
1656 /* evaluate the right hand side */
1657 rhs = EVAL_EXPR(READ_STAT(stat, 2));
1658
1659 /* assign the right hand side to the element of the record */
1660 AssComObj( record, rnam, rhs );
1661
1662 /* return 0 (to indicate that no leave-statement was executed) */
1663 return 0;
1664 }
1665
1666
1667 /****************************************************************************
1668 **
1669 *F ExecAssComObjExpr(<stat>) . . . . . . . . assign to an element of a record
1670 **
1671 ** 'ExecAssComObjExpr' executes the record assignment statement <stat> of the
1672 ** form '<record>.(<name>) := <rhs>;'.
1673 */
ExecAssComObjExpr(Stat stat)1674 static UInt ExecAssComObjExpr(Stat stat)
1675 {
1676 Obj record; /* record, left operand */
1677 UInt rnam; /* name, left operand */
1678 Obj rhs; /* rhs, right operand */
1679
1680 /* evaluate the record (checking is done by 'ASS_REC') */
1681 record = EVAL_EXPR(READ_STAT(stat, 0));
1682
1683 /* evaluate the name and convert it to a record name */
1684 rnam = RNamObj(EVAL_EXPR(READ_STAT(stat, 1)));
1685
1686 /* evaluate the right hand side */
1687 rhs = EVAL_EXPR(READ_STAT(stat, 2));
1688
1689 /* assign the right hand side to the element of the record */
1690 AssComObj( record, rnam, rhs );
1691
1692 /* return 0 (to indicate that no leave-statement was executed) */
1693 return 0;
1694 }
1695
1696
1697 /****************************************************************************
1698 **
1699 *F ExecUnbComObjName(<stat>) . . . . . . . . . . unbind an element of a record
1700 **
1701 ** 'ExecUnbComObjName' executes the record unbind statement <stat> of the form
1702 ** 'Unbind( <record>.<name> );'.
1703 */
ExecUnbComObjName(Stat stat)1704 static UInt ExecUnbComObjName(Stat stat)
1705 {
1706 Obj record; /* record, left operand */
1707 UInt rnam; /* name, left operand */
1708
1709 /* evaluate the record (checking is done by 'UNB_REC') */
1710 record = EVAL_EXPR(READ_STAT(stat, 0));
1711
1712 /* get the name (stored immediately in the statement) */
1713 rnam = READ_STAT(stat, 1);
1714
1715 /* unbind the element of the record */
1716 UnbComObj( record, rnam );
1717
1718 /* return 0 (to indicate that no leave-statement was executed) */
1719 return 0;
1720 }
1721
1722
1723 /****************************************************************************
1724 **
1725 *F ExecUnbComObjExpr(<stat>) . . . . . . . . . . unbind an element of a record
1726 **
1727 ** 'ExecUnbComObjExpr' executes the record unbind statement <stat> of the form
1728 ** 'Unbind( <record>.(<name>) );'.
1729 */
ExecUnbComObjExpr(Stat stat)1730 static UInt ExecUnbComObjExpr(Stat stat)
1731 {
1732 Obj record; /* record, left operand */
1733 UInt rnam; /* name, left operand */
1734
1735 /* evaluate the record (checking is done by 'UNB_REC') */
1736 record = EVAL_EXPR(READ_STAT(stat, 0));
1737
1738 /* evaluate the name and convert it to a record name */
1739 rnam = RNamObj(EVAL_EXPR(READ_STAT(stat, 1)));
1740
1741 /* unbind the element of the record */
1742 UnbComObj( record, rnam );
1743
1744 /* return 0 (to indicate that no leave-statement was executed) */
1745 return 0;
1746 }
1747
1748
1749 /****************************************************************************
1750 **
1751 *F EvalElmComObjName(<expr>) . . . . . . . . . . . . . select a record element
1752 **
1753 ** 'EvalElmComObjName' evaluates the record element expression <expr> of the
1754 ** form '<record>.<name>'.
1755 */
EvalElmComObjName(Expr expr)1756 static Obj EvalElmComObjName(Expr expr)
1757 {
1758 Obj elm; /* element, result */
1759 Obj record; /* the record, left operand */
1760 UInt rnam; /* the name, right operand */
1761
1762 /* evaluate the record (checking is done by 'ELM_REC') */
1763 record = EVAL_EXPR(READ_EXPR(expr, 0));
1764
1765 /* get the name (stored immediately in the expression) */
1766 rnam = READ_EXPR(expr, 1);
1767
1768 /* select the element of the record */
1769 elm = ElmComObj( record, rnam );
1770
1771 /* return the element */
1772 return elm;
1773 }
1774
1775
1776 /****************************************************************************
1777 **
1778 *F EvalElmComObjExpr(<expr>) . . . . . . . . . . . . . select a record element
1779 **
1780 ** 'EvalElmComObjExpr' evaluates the record element expression <expr> of the
1781 ** form '<record>.(<name>)'.
1782 */
EvalElmComObjExpr(Expr expr)1783 static Obj EvalElmComObjExpr(Expr expr)
1784 {
1785 Obj elm; /* element, result */
1786 Obj record; /* the record, left operand */
1787 UInt rnam; /* the name, right operand */
1788
1789 /* evaluate the record (checking is done by 'ELM_REC') */
1790 record = EVAL_EXPR(READ_EXPR(expr, 0));
1791
1792 /* evaluate the name and convert it to a record name */
1793 rnam = RNamObj(EVAL_EXPR(READ_EXPR(expr, 1)));
1794
1795 /* select the element of the record */
1796 elm = ElmComObj( record, rnam );
1797
1798 /* return the element */
1799 return elm;
1800 }
1801
1802
1803 /****************************************************************************
1804 **
1805 *F EvalIsbComObjName(<expr>) . . . . . . . . test if a record element is bound
1806 **
1807 ** 'EvalIsbComObjName' evaluates the record isbound expression <expr> of the
1808 ** form 'IsBound( <record>.<name> )'.
1809 */
EvalIsbComObjName(Expr expr)1810 static Obj EvalIsbComObjName(Expr expr)
1811 {
1812 Obj isb; /* element, result */
1813 Obj record; /* the record, left operand */
1814 UInt rnam; /* the name, right operand */
1815
1816 /* evaluate the record (checking is done by 'ISB_REC') */
1817 record = EVAL_EXPR(READ_EXPR(expr, 0));
1818
1819 /* get the name (stored immediately in the expression) */
1820 rnam = READ_EXPR(expr, 1);
1821
1822 /* select the element of the record */
1823 isb = IsbComObj( record, rnam ) ? True : False;
1824
1825 /* return the result */
1826 return isb;
1827 }
1828
1829
1830 /****************************************************************************
1831 **
1832 *F EvalIsbComObjExpr(<expr>) . . . . . . . . test if a record element is bound
1833 **
1834 ** 'EvalIsbComObjExpr' evaluates the record isbound expression <expr> of the
1835 ** form 'IsBound( <record>.(<name>) )'.
1836 */
EvalIsbComObjExpr(Expr expr)1837 static Obj EvalIsbComObjExpr(Expr expr)
1838 {
1839 Obj isb; /* element, result */
1840 Obj record; /* the record, left operand */
1841 UInt rnam; /* the name, right operand */
1842
1843 /* evaluate the record (checking is done by 'ISB_REC') */
1844 record = EVAL_EXPR(READ_EXPR(expr, 0));
1845
1846 /* evaluate the name and convert it to a record name */
1847 rnam = RNamObj(EVAL_EXPR(READ_EXPR(expr, 1)));
1848
1849 /* select the element of the record */
1850 isb = IsbComObj( record, rnam ) ? True : False;
1851
1852 /* return the result */
1853 return isb;
1854 }
1855
1856
1857 /****************************************************************************
1858 **
1859 *F PrintAssComObjName(<stat>) . print an assignment to an element of a record
1860 **
1861 ** 'PrintAssComObjName' prints the record assignment statement <stat> of the
1862 ** form '<record>.<name> := <rhs>;'.
1863 */
PrintAssComObjName(Stat stat)1864 static void PrintAssComObjName(Stat stat)
1865 {
1866 Pr("%4>",0L,0L);
1867 PrintExpr(READ_EXPR(stat, 0));
1868 Pr("%<!.",0L,0L);
1869 Pr("%H", (Int)NAME_RNAM(READ_STAT(stat, 1)), 0L);
1870 Pr("%<",0L,0L);
1871 Pr("%< %>:= ",0L,0L);
1872 PrintExpr(READ_EXPR(stat, 2));
1873 Pr("%2<;",0L,0L);
1874 }
1875
PrintUnbComObjName(Stat stat)1876 static void PrintUnbComObjName(Stat stat)
1877 {
1878 Pr( "Unbind( ", 0L, 0L );
1879 Pr("%2>",0L,0L);
1880 PrintExpr(READ_EXPR(stat, 0));
1881 Pr("%<!.",0L,0L);
1882 Pr("%H", (Int)NAME_RNAM(READ_STAT(stat, 1)), 0L);
1883 Pr("%<",0L,0L);
1884 Pr( " );", 0L, 0L );
1885 }
1886
1887
1888 /****************************************************************************
1889 **
1890 *F PrintAssComObjExpr(<stat>) . print an assignment to an element of a record
1891 **
1892 ** 'PrintAssComObjExpr' prints the record assignment statement <stat> of the
1893 ** form '<record>.(<name>) := <rhs>;'.
1894 */
PrintAssComObjExpr(Stat stat)1895 static void PrintAssComObjExpr(Stat stat)
1896 {
1897 Pr("%4>",0L,0L);
1898 PrintExpr(READ_EXPR(stat, 0));
1899 Pr("%<!.(",0L,0L);
1900 PrintExpr(READ_EXPR(stat, 1));
1901 Pr(")%<",0L,0L);
1902 Pr("%< %>:= ",0L,0L);
1903 PrintExpr(READ_EXPR(stat, 2));
1904 Pr("%2<;",0L,0L);
1905 }
1906
PrintUnbComObjExpr(Stat stat)1907 static void PrintUnbComObjExpr(Stat stat)
1908 {
1909 Pr( "Unbind( ", 0L, 0L );
1910 Pr("%2>",0L,0L);
1911 PrintExpr(READ_EXPR(stat, 0));
1912 Pr("%<!.(",0L,0L);
1913 PrintExpr(READ_EXPR(stat, 1));
1914 Pr(")%<",0L,0L);
1915 Pr( " );", 0L, 0L );
1916 }
1917
1918
1919 /****************************************************************************
1920 **
1921 *F PrintElmComObjName(<expr>) . . print a selection of an element of a record
1922 **
1923 ** 'PrintElmComObjName' prints the record element expression <expr> of the
1924 ** form '<record>.<name>'.
1925 */
PrintElmComObjName(Expr expr)1926 static void PrintElmComObjName(Expr expr)
1927 {
1928 Pr("%2>",0L,0L);
1929 PrintExpr(READ_EXPR(expr, 0));
1930 Pr("%<!.",0L,0L);
1931 Pr("%H", (Int)NAME_RNAM(READ_EXPR(expr, 1)), 0L);
1932 Pr("%<",0L,0L);
1933 }
1934
PrintIsbComObjName(Expr expr)1935 static void PrintIsbComObjName(Expr expr)
1936 {
1937 Pr( "IsBound( ", 0L, 0L );
1938 Pr("%2>",0L,0L);
1939 PrintExpr(READ_EXPR(expr, 0));
1940 Pr("%<!.",0L,0L);
1941 Pr("%H", (Int)NAME_RNAM(READ_EXPR(expr, 1)), 0L);
1942 Pr("%<",0L,0L);
1943 Pr( " )", 0L, 0L );
1944 }
1945
1946
1947 /****************************************************************************
1948 **
1949 *F PrintElmComObjExpr(<expr>) . . print a selection of an element of a record
1950 **
1951 ** 'PrintElmComObjExpr' prints the record element expression <expr> of the
1952 ** form '<record>.(<name>)'.
1953 */
PrintElmComObjExpr(Expr expr)1954 static void PrintElmComObjExpr(Expr expr)
1955 {
1956 Pr("%2>",0L,0L);
1957 PrintExpr(READ_EXPR(expr, 0));
1958 Pr("%<!.(",0L,0L);
1959 PrintExpr(READ_EXPR(expr, 1));
1960 Pr(")%<",0L,0L);
1961 }
1962
PrintIsbComObjExpr(Expr expr)1963 static void PrintIsbComObjExpr(Expr expr)
1964 {
1965 Pr( "IsBound( ", 0L, 0L );
1966 Pr("%2>",0L,0L);
1967 PrintExpr(READ_EXPR(expr, 0));
1968 Pr("%<!.(",0L,0L);
1969 PrintExpr(READ_EXPR(expr, 1));
1970 Pr(")%<",0L,0L);
1971 Pr( " )", 0L, 0L );
1972 }
1973
1974
1975 /****************************************************************************
1976 **
1977 *F FuncGetCurrentLVars
1978 *F FuncGetBottomLVars
1979 *F FuncParentLVars
1980 *F FuncContentsLVars
1981 **
1982 ** Provide access to local variable bags at GAP level. Mainly for use in
1983 ** error handling.
1984 **
1985 */
1986
1987
FuncGetCurrentLVars(Obj self)1988 static Obj FuncGetCurrentLVars(Obj self)
1989 {
1990 // Need to promote to High Vars, else bag will be freed when function exits
1991 MakeHighVars(STATE(CurrLVars));
1992 return STATE(CurrLVars);
1993 }
1994
FuncGetBottomLVars(Obj self)1995 static Obj FuncGetBottomLVars(Obj self)
1996 {
1997 return STATE(BottomLVars);
1998 }
1999
FuncParentLVars(Obj self,Obj lvars)2000 static Obj FuncParentLVars(Obj self, Obj lvars)
2001 {
2002 if (!IS_LVARS_OR_HVARS(lvars)) {
2003 RequireArgument("ParentLVars", lvars, "must be an lvars");
2004 }
2005 Obj parent = PARENT_LVARS(lvars);
2006 return parent ? parent : Fail;
2007 }
2008
FuncContentsLVars(Obj self,Obj lvars)2009 static Obj FuncContentsLVars(Obj self, Obj lvars)
2010 {
2011 if (!IS_LVARS_OR_HVARS(lvars)) {
2012 RequireArgument("ContentsLVars", lvars, "must be an lvars");
2013 }
2014 Obj contents = NEW_PREC(0);
2015 Obj func = FUNC_LVARS(lvars);
2016 Obj nams = NAMS_FUNC(func);
2017 UInt len = (SIZE_BAG(lvars) - 2*sizeof(Obj) - sizeof(UInt))/sizeof(Obj);
2018 Obj values = NEW_PLIST_IMM(T_PLIST, len);
2019 if (lvars == STATE(BottomLVars))
2020 return Fail;
2021 AssPRec(contents, RNamName("func"), func);
2022 AssPRec(contents, RNamName("names"), nams);
2023 memcpy(1+ADDR_OBJ(values), 3+CONST_ADDR_OBJ(lvars), len*sizeof(Obj));
2024 while (len > 0 && ELM_PLIST(values, len) == 0)
2025 len--;
2026 SET_LEN_PLIST(values, len);
2027 AssPRec(contents, RNamName("values"), values);
2028 if (ENVI_FUNC(func) != STATE(BottomLVars))
2029 AssPRec(contents, RNamName("higher"), ENVI_FUNC(func));
2030 return contents;
2031 }
2032
FuncENVI_FUNC(Obj self,Obj func)2033 static Obj FuncENVI_FUNC(Obj self, Obj func)
2034 {
2035 RequireFunction("ENVI_FUNC", func);
2036 Obj envi = ENVI_FUNC(func);
2037 return (envi && IS_LVARS_OR_HVARS(envi)) ? envi : Fail;
2038 }
2039
2040 /****************************************************************************
2041 **
2042 *F VarsBeforeCollectBags() . . . . . . . . actions before garbage collection
2043 *F VarsAfterCollectBags() . . . . . . . . actions after garbage collection
2044 */
2045 #ifdef USE_GASMAN
2046
VarsBeforeCollectBags(void)2047 static void VarsBeforeCollectBags(void)
2048 {
2049 // As an optimization, we never call CHANGED_BAG on CurrLVars directly,
2050 // instead thus function is run just before any GC to take care of that.
2051 if (STATE(CurrLVars))
2052 CHANGED_BAG( STATE(CurrLVars) );
2053 }
2054
VarsAfterCollectBags(void)2055 static void VarsAfterCollectBags(void)
2056 {
2057 if (STATE(CurrLVars))
2058 {
2059 STATE(PtrLVars) = PTR_BAG( STATE(CurrLVars) );
2060 STATE(PtrBody) = PTR_BAG( BODY_FUNC( CURR_FUNC() ) );
2061 }
2062 }
2063
2064 #endif
2065
2066 /****************************************************************************
2067 **
2068 *F SaveLVars ( <lvars> )
2069 **
2070 */
2071
SaveLVars(Obj lvars)2072 static void SaveLVars(Obj lvars)
2073 {
2074 UInt len,i;
2075 const Obj *ptr;
2076 const LVarsHeader * hdr = (const LVarsHeader *)CONST_ADDR_OBJ(lvars);
2077 SaveSubObj(hdr->func);
2078 SaveUInt(hdr->stat);
2079 SaveSubObj(hdr->parent);
2080 len = (SIZE_OBJ(lvars) - (2*sizeof(Obj)+sizeof(UInt)))/sizeof(Obj);
2081 ptr = CONST_ADDR_OBJ(lvars)+3;
2082 for (i = 0; i < len; i++)
2083 SaveSubObj(*ptr++);
2084 }
2085
2086 /****************************************************************************
2087 **
2088 *F LoadLVars ( <lvars> )
2089 **
2090 */
2091
LoadLVars(Obj lvars)2092 static void LoadLVars(Obj lvars)
2093 {
2094 UInt len,i;
2095 Obj *ptr;
2096 LVarsHeader * hdr = (LVarsHeader *)ADDR_OBJ(lvars);
2097 hdr->func = LoadSubObj();
2098 hdr->stat = LoadUInt();
2099 hdr->parent = LoadSubObj();
2100 len = (SIZE_OBJ(lvars) - (2*sizeof(Obj)+sizeof(UInt)))/sizeof(Obj);
2101 ptr = ADDR_OBJ(lvars)+3;
2102 for (i = 0; i < len; i++)
2103 *ptr++ = LoadSubObj();
2104 }
2105
2106 static Obj TYPE_LVARS;
2107
TypeLVars(Obj lvars)2108 static Obj TypeLVars(Obj lvars)
2109 {
2110 return TYPE_LVARS;
2111 }
2112
PrintLVars(Obj lvars)2113 static void PrintLVars(Obj lvars)
2114 {
2115 Pr("<lvars bag>", 0,0);
2116 }
2117
2118
2119 /****************************************************************************
2120 **
2121 *F * * * * * * * * * * * * * Initialize Package * * * * * * * * * * * * * * *
2122 */
2123
2124 /****************************************************************************
2125 **
2126 *V BagNames . . . . . . . . . . . . . . . . . . . . . . . list of bag names
2127 */
2128 static StructBagNames BagNames[] = {
2129 { T_LVARS, "values bag" },
2130 { T_HVARS, "high variables bag" },
2131 { -1, "" }
2132 };
2133
2134 /****************************************************************************
2135 **
2136 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
2137 */
2138 static StructGVarFunc GVarFuncs [] = {
2139 GVAR_FUNC(GetCurrentLVars, 0, ""),
2140 GVAR_FUNC(GetBottomLVars, 0, ""),
2141 GVAR_FUNC(ParentLVars, 1, "lvars"),
2142 GVAR_FUNC(ContentsLVars, 1, "lvars"),
2143 GVAR_FUNC(ENVI_FUNC, 1, "func"),
2144 { 0, 0, 0, 0, 0 }
2145 };
2146
2147
2148 /****************************************************************************
2149 **
2150 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
2151 */
InitKernel(StructInitInfo * module)2152 static Int InitKernel (
2153 StructInitInfo * module )
2154 {
2155 #if !defined(HPCGAP)
2156 /* make 'CurrLVars' known to Gasman */
2157 InitGlobalBag( &STATE(CurrLVars), "src/vars.c:CurrLVars" );
2158 InitGlobalBag( &STATE(BottomLVars), "src/vars.c:BottomLVars" );
2159
2160 enum { count = ARRAY_SIZE(STATE(LVarsPool)) };
2161 static char cookies[count][24];
2162 for (int i = 0; i < count; i++) {
2163 snprintf(cookies[i], sizeof(cookies[i]), "src/vars.c:LVarsPool%d", i);
2164 InitGlobalBag(&STATE(LVarsPool[i]), cookies[i]);
2165 }
2166 #endif
2167
2168 // set the bag type names (for error messages and debugging)
2169 InitBagNamesFromTable( BagNames );
2170
2171 /* install the marking functions for local variables bag */
2172 InitMarkFuncBags( T_LVARS, MarkAllButFirstSubBags );
2173 InitMarkFuncBags( T_HVARS, MarkAllButFirstSubBags );
2174
2175 #ifdef HPCGAP
2176 /* Make T_LVARS bags public */
2177 MakeBagTypePublic(T_LVARS);
2178 MakeBagTypePublic(T_HVARS);
2179 #endif
2180
2181 /* and the save restore functions */
2182 SaveObjFuncs[ T_LVARS ] = SaveLVars;
2183 LoadObjFuncs[ T_LVARS ] = LoadLVars;
2184 SaveObjFuncs[ T_HVARS ] = SaveLVars;
2185 LoadObjFuncs[ T_HVARS ] = LoadLVars;
2186
2187 /* and a type */
2188 TypeObjFuncs[ T_LVARS ] = TypeLVars;
2189 TypeObjFuncs[ T_HVARS ] = TypeLVars;
2190 PrintObjFuncs[ T_LVARS ] = PrintLVars;
2191 PrintObjFuncs[ T_HVARS ] = PrintLVars;
2192
2193 /* install executors, evaluators, and printers for local variables */
2194 InstallExecStatFunc( STAT_ASS_LVAR , ExecAssLVar);
2195 InstallExecStatFunc( STAT_UNB_LVAR , ExecUnbLVar);
2196 // no EvalExprFunc for EXPR_REF_LVAR, it is handled immediately by EVAL_EXPR
2197 InstallEvalExprFunc( EXPR_ISB_LVAR , EvalIsbLVar);
2198
2199 InstallPrintStatFunc( STAT_ASS_LVAR , PrintAssLVar);
2200 InstallPrintStatFunc( STAT_UNB_LVAR , PrintUnbLVar);
2201 InstallPrintExprFunc( EXPR_REF_LVAR , PrintRefLVar);
2202 InstallPrintExprFunc( EXPR_ISB_LVAR , PrintIsbLVar);
2203
2204 /* install executors, evaluators, and printers for higher variables */
2205 InstallExecStatFunc( STAT_ASS_HVAR , ExecAssHVar);
2206 InstallExecStatFunc( STAT_UNB_HVAR , ExecUnbHVar);
2207 InstallEvalExprFunc( EXPR_REF_HVAR , EvalRefHVar);
2208 InstallEvalExprFunc( EXPR_ISB_HVAR , EvalIsbHVar);
2209 InstallPrintStatFunc( STAT_ASS_HVAR , PrintAssHVar);
2210 InstallPrintStatFunc( STAT_UNB_HVAR , PrintUnbHVar);
2211 InstallPrintExprFunc( EXPR_REF_HVAR , PrintRefHVar);
2212 InstallPrintExprFunc( EXPR_ISB_HVAR , PrintIsbHVar);
2213
2214 /* install executors, evaluators, and printers for global variables */
2215 InstallExecStatFunc( STAT_ASS_GVAR , ExecAssGVar);
2216 InstallExecStatFunc( STAT_UNB_GVAR , ExecUnbGVar);
2217 InstallEvalExprFunc( EXPR_REF_GVAR , EvalRefGVar);
2218 InstallEvalExprFunc( EXPR_ISB_GVAR , EvalIsbGVar);
2219 InstallPrintStatFunc( STAT_ASS_GVAR , PrintAssGVar);
2220 InstallPrintStatFunc( STAT_UNB_GVAR , PrintUnbGVar);
2221 InstallPrintExprFunc( EXPR_REF_GVAR , PrintRefGVar);
2222 InstallPrintExprFunc( EXPR_ISB_GVAR , PrintIsbGVar);
2223
2224 // install executors, evaluators, and printers for list elements
2225 InstallExecStatFunc( STAT_ASS_LIST , ExecAssList);
2226 InstallExecStatFunc( STAT_ASSS_LIST , ExecAsssList);
2227 InstallExecStatFunc( STAT_ASS_LIST_LEV , ExecAssListLevel);
2228 InstallExecStatFunc( STAT_ASSS_LIST_LEV , ExecAsssListLevel);
2229 InstallExecStatFunc( STAT_UNB_LIST , ExecUnbList);
2230 InstallEvalExprFunc( EXPR_ELM_LIST , EvalElmList);
2231 InstallEvalExprFunc( EXPR_ELMS_LIST , EvalElmsList);
2232 InstallEvalExprFunc( EXPR_ELM_LIST_LEV , EvalElmListLevel);
2233 InstallEvalExprFunc( EXPR_ELMS_LIST_LEV , EvalElmsListLevel);
2234 InstallEvalExprFunc( EXPR_ISB_LIST , EvalIsbList);
2235
2236 InstallPrintStatFunc( STAT_ASS_LIST , PrintAssList);
2237 InstallPrintStatFunc( STAT_ASSS_LIST , PrintAsssList);
2238 InstallPrintStatFunc( STAT_ASS_LIST_LEV , PrintAssList);
2239 InstallPrintStatFunc( STAT_ASSS_LIST_LEV , PrintAsssList);
2240 InstallPrintStatFunc( STAT_UNB_LIST , PrintUnbList);
2241 InstallPrintExprFunc( EXPR_ELM_LIST , PrintElmList);
2242 InstallPrintExprFunc( EXPR_ELMS_LIST , PrintElmsList);
2243 InstallPrintExprFunc( EXPR_ELM_LIST_LEV , PrintElmListLevel);
2244 InstallPrintExprFunc( EXPR_ELMS_LIST_LEV , PrintElmsList);
2245 InstallPrintExprFunc( EXPR_ISB_LIST , PrintIsbList);
2246
2247 // install executors, evaluators, and printers for matrix elements
2248 InstallExecStatFunc(STAT_ASS_MAT, ExecAssMat);
2249 InstallEvalExprFunc(EXPR_ELM_MAT, EvalElmMat);
2250 InstallPrintStatFunc(STAT_ASS_MAT, PrintAssMat);
2251 InstallPrintExprFunc(EXPR_ELM_MAT, PrintElmMat);
2252
2253 // install executors, evaluators, and printers for record elements
2254 InstallExecStatFunc( STAT_ASS_REC_NAME , ExecAssRecName);
2255 InstallExecStatFunc( STAT_ASS_REC_EXPR , ExecAssRecExpr);
2256 InstallExecStatFunc( STAT_UNB_REC_NAME , ExecUnbRecName);
2257 InstallExecStatFunc( STAT_UNB_REC_EXPR , ExecUnbRecExpr);
2258 InstallEvalExprFunc( EXPR_ELM_REC_NAME , EvalElmRecName);
2259 InstallEvalExprFunc( EXPR_ELM_REC_EXPR , EvalElmRecExpr);
2260 InstallEvalExprFunc( EXPR_ISB_REC_NAME , EvalIsbRecName);
2261 InstallEvalExprFunc( EXPR_ISB_REC_EXPR , EvalIsbRecExpr);
2262 InstallPrintStatFunc( STAT_ASS_REC_NAME , PrintAssRecName);
2263 InstallPrintStatFunc( STAT_ASS_REC_EXPR , PrintAssRecExpr);
2264 InstallPrintStatFunc( STAT_UNB_REC_NAME , PrintUnbRecName);
2265 InstallPrintStatFunc( STAT_UNB_REC_EXPR , PrintUnbRecExpr);
2266 InstallPrintExprFunc( EXPR_ELM_REC_NAME , PrintElmRecName);
2267 InstallPrintExprFunc( EXPR_ELM_REC_EXPR , PrintElmRecExpr);
2268 InstallPrintExprFunc( EXPR_ISB_REC_NAME , PrintIsbRecName);
2269 InstallPrintExprFunc( EXPR_ISB_REC_EXPR , PrintIsbRecExpr);
2270
2271 // install executors, evaluators, and printers for positional objects
2272 InstallExecStatFunc( STAT_ASS_POSOBJ , ExecAssPosObj);
2273 InstallExecStatFunc( STAT_UNB_POSOBJ , ExecUnbPosObj);
2274 InstallEvalExprFunc( EXPR_ELM_POSOBJ , EvalElmPosObj);
2275 InstallEvalExprFunc( EXPR_ISB_POSOBJ , EvalIsbPosObj);
2276 InstallPrintStatFunc( STAT_ASS_POSOBJ , PrintAssPosObj);
2277 InstallPrintStatFunc( STAT_UNB_POSOBJ , PrintUnbPosObj);
2278 InstallPrintExprFunc( EXPR_ELM_POSOBJ , PrintElmPosObj);
2279 InstallPrintExprFunc( EXPR_ISB_POSOBJ , PrintIsbPosObj);
2280
2281 // install executors, evaluators, and printers for component objects
2282 InstallExecStatFunc( STAT_ASS_COMOBJ_NAME , ExecAssComObjName);
2283 InstallExecStatFunc( STAT_ASS_COMOBJ_EXPR , ExecAssComObjExpr);
2284 InstallExecStatFunc( STAT_UNB_COMOBJ_NAME , ExecUnbComObjName);
2285 InstallExecStatFunc( STAT_UNB_COMOBJ_EXPR , ExecUnbComObjExpr);
2286 InstallEvalExprFunc( EXPR_ELM_COMOBJ_NAME , EvalElmComObjName);
2287 InstallEvalExprFunc( EXPR_ELM_COMOBJ_EXPR , EvalElmComObjExpr);
2288 InstallEvalExprFunc( EXPR_ISB_COMOBJ_NAME , EvalIsbComObjName);
2289 InstallEvalExprFunc( EXPR_ISB_COMOBJ_EXPR , EvalIsbComObjExpr);
2290 InstallPrintStatFunc( STAT_ASS_COMOBJ_NAME , PrintAssComObjName);
2291 InstallPrintStatFunc( STAT_ASS_COMOBJ_EXPR , PrintAssComObjExpr);
2292 InstallPrintStatFunc( STAT_UNB_COMOBJ_NAME , PrintUnbComObjName);
2293 InstallPrintStatFunc( STAT_UNB_COMOBJ_EXPR , PrintUnbComObjExpr);
2294 InstallPrintExprFunc( EXPR_ELM_COMOBJ_NAME , PrintElmComObjName);
2295 InstallPrintExprFunc( EXPR_ELM_COMOBJ_EXPR , PrintElmComObjExpr);
2296 InstallPrintExprFunc( EXPR_ISB_COMOBJ_NAME , PrintIsbComObjName);
2297 InstallPrintExprFunc( EXPR_ISB_COMOBJ_EXPR , PrintIsbComObjExpr);
2298
2299 #ifdef USE_GASMAN
2300 /* install before and after actions for garbage collections */
2301 RegisterBeforeCollectFuncBags(VarsBeforeCollectBags);
2302 RegisterAfterCollectFuncBags(VarsAfterCollectBags);
2303 #endif
2304
2305 /* init filters and functions */
2306 InitHdlrFuncsFromTable( GVarFuncs );
2307
2308 InitCopyGVar("TYPE_LVARS",&TYPE_LVARS);
2309
2310 /* return success */
2311 return 0;
2312 }
2313
2314
2315 /****************************************************************************
2316 **
2317 *F PostRestore( <module> ) . . . . . . . . . . . . . after restore workspace
2318 */
PostRestore(StructInitInfo * module)2319 static Int PostRestore (
2320 StructInitInfo * module )
2321 {
2322 STATE(CurrLVars) = STATE(BottomLVars);
2323 SWITCH_TO_OLD_LVARS( STATE(BottomLVars) );
2324
2325 /* return success */
2326 return 0;
2327 }
2328
2329
2330 /****************************************************************************
2331 **
2332 *F InitLibrary( <module> ) . . . . . . . initialise library data structures
2333 */
InitLibrary(StructInitInfo * module)2334 static Int InitLibrary (
2335 StructInitInfo * module )
2336 {
2337 /* init filters and functions */
2338 InitGVarFuncsFromTable( GVarFuncs );
2339
2340 /* return success */
2341 return 0;
2342 }
2343
2344
InitModuleState(void)2345 static Int InitModuleState(void)
2346 {
2347 Obj tmpFunc, tmpBody;
2348
2349 STATE(BottomLVars) = NewBag(T_HVARS, 3 * sizeof(Obj));
2350 tmpFunc = NewFunctionC( "bottom", 0, "", 0 );
2351
2352 LVarsHeader * hdr = (LVarsHeader *)ADDR_OBJ(STATE(BottomLVars));
2353 hdr->func = tmpFunc;
2354 hdr->parent = Fail;
2355 tmpBody = NewFunctionBody();
2356 SET_BODY_FUNC( tmpFunc, tmpBody );
2357
2358 STATE(CurrLVars) = STATE(BottomLVars);
2359 SWITCH_TO_OLD_LVARS( STATE(BottomLVars) );
2360
2361 // return success
2362 return 0;
2363 }
2364
2365
2366 /****************************************************************************
2367 **
2368 *F InitInfoVars() . . . . . . . . . . . . . . . . . table of init functions
2369 */
2370 static StructInitInfo module = {
2371 // init struct using C99 designated initializers; for a full list of
2372 // fields, please refer to the definition of StructInitInfo
2373 .type = MODULE_BUILTIN,
2374 .name = "vars",
2375 .initKernel = InitKernel,
2376 .initLibrary = InitLibrary,
2377 .postRestore = PostRestore,
2378 .initModuleState = InitModuleState,
2379 };
2380
InitInfoVars(void)2381 StructInitInfo * InitInfoVars ( void )
2382 {
2383 return &module;
2384 }
2385