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 the coder package.
11 **
12 ** The coder package is the part of the interpreter that creates the
13 ** expressions. Its functions are called from the reader.
14 */
15
16 #include "code.h"
17
18 #include "bool.h"
19 #include "calls.h"
20 #include "funcs.h"
21 #include "gap.h"
22 #include "gapstate.h"
23 #include "gvars.h"
24 #include "hookintrprtr.h"
25 #include "io.h"
26 #include "lists.h"
27 #include "modules.h"
28 #include "plist.h"
29 #include "read.h"
30 #include "records.h"
31 #include "saveload.h"
32 #include "stringobj.h"
33 #include "vars.h"
34
35 #include "hpc/thread.h"
36
37 #ifdef HPCGAP
38 #include "hpc/aobjects.h"
39 #endif
40
41
42 /*N 1996/06/16 mschoene func expressions should be different from funcs */
43
44 GAP_STATIC_ASSERT(sizeof(StatHeader) == 8, "StatHeader has wrong size");
45
46
47 /****************************************************************************
48 **
49 *V PtrBody . . . . . . . . . . . . . . . . . . . . . pointer to current body
50 **
51 ** 'PtrBody' is a pointer to the current body.
52 */
53 /* TL: Stat * PtrBody; */
54
55 struct CodeState {
56
57 /****************************************************************************
58 **
59 *V OffsBody . . . . . . . . . . . . . . . . . . . . offset in current body
60 **
61 ** 'OffsBody' is the offset in the current body. It is only valid while
62 ** coding.
63 */
64 Stat OffsBody;
65
66 Stat * OffsBodyStack;
67 UInt OffsBodyCount;
68
69 /****************************************************************************
70 **
71 *V CodeResult . . . . . . . . . . . . . . . . . . . . . . result of coding
72 **
73 ** 'CodeResult' is the result of the coding, i.e., the function that was
74 ** coded.
75 */
76 Obj CodeResult;
77
78 Bag StackStat;
79 Int CountStat;
80
81 Bag StackExpr;
82 Int CountExpr;
83
84 Bag CodeLVars;
85
86 };
87
88 static ModuleStateOffset CodeStateOffset = -1;
89
CodeState(void)90 extern inline struct CodeState * CodeState(void)
91 {
92 return (struct CodeState *)StateSlotsAtOffset(CodeStateOffset);
93 }
94
95 #define CS(x) (CodeState()->x)
96
97
98 /****************************************************************************
99 **
100 *F NewFunctionBody() . . . . . . . . . . . . . . create a new function body
101 */
NewFunctionBody(void)102 Obj NewFunctionBody(void)
103 {
104 return NewBag(T_BODY, sizeof(BodyHeader));
105 }
106
107 /****************************************************************************
108 **
109 *F ADDR_EXPR(<expr>) . . . . . . . . . . . absolute address of an expression
110 **
111 ** 'ADDR_EXPR' returns the absolute address of the memory block of the
112 ** expression <expr>.
113 **
114 ** Note that it is *fatal* to apply 'ADDR_EXPR' to expressions of type
115 ** 'EXPR_REF_LVAR' or 'EXPR_INT'.
116 */
ADDR_EXPR(Expr expr)117 static Expr * ADDR_EXPR(Expr expr)
118 {
119 return (Expr *)STATE(PtrBody) + expr / sizeof(Expr);
120 }
121
122 /****************************************************************************
123 **
124 *F ADDR_STAT(<stat>) . . . . . . . . . . . . absolute address of a statement
125 **
126 ** 'ADDR_STAT' returns the absolute address of the memory block of the
127 ** statement <stat>.
128 */
ADDR_STAT(Stat stat)129 static Stat * ADDR_STAT(Stat stat)
130 {
131 return (Stat *)STATE(PtrBody) + stat / sizeof(Stat);
132 }
133
WRITE_EXPR(Expr expr,UInt idx,UInt val)134 void WRITE_EXPR(Expr expr, UInt idx, UInt val)
135 {
136 GAP_ASSERT(expr / sizeof(Expr) + idx <
137 SIZE_BAG(BODY_FUNC(CURR_FUNC())) / sizeof(Expr));
138
139 ADDR_EXPR(expr)[idx] = val;
140 }
141
WRITE_STAT(Stat stat,UInt idx,UInt val)142 static void WRITE_STAT(Stat stat, UInt idx, UInt val)
143 {
144 GAP_ASSERT(stat / sizeof(Stat) + idx <
145 SIZE_BAG(BODY_FUNC(CURR_FUNC())) / sizeof(Stat));
146
147 ADDR_STAT(stat)[idx] = val;
148 }
149
STAT_HEADER(Stat stat)150 static StatHeader * STAT_HEADER(Stat stat)
151 {
152 return (StatHeader *)ADDR_STAT(stat) - 1;
153 }
154
SET_VISITED_STAT(Stat stat)155 void SET_VISITED_STAT(Stat stat)
156 {
157 STAT_HEADER(stat)->visited = 1;
158 }
159
160
161 #define SET_FUNC_CALL(call,x) WRITE_EXPR(call, 0, x)
162 #define SET_ARGI_CALL(call,i,x) WRITE_EXPR(call, i, x)
163 #define SET_ARGI_INFO(info,i,x) WRITE_STAT(info, (i) - 1, x)
164
165
PushOffsBody(void)166 static inline void PushOffsBody( void ) {
167 GAP_ASSERT(CS(OffsBodyCount) < MAX_FUNC_EXPR_NESTING);
168 CS(OffsBodyStack)[CS(OffsBodyCount)++] = CS(OffsBody);
169 }
170
PopOffsBody(void)171 static inline void PopOffsBody( void ) {
172 GAP_ASSERT(CS(OffsBodyCount));
173 CS(OffsBody) = CS(OffsBodyStack)[--CS(OffsBodyCount)];
174 }
175
176 // filename
177
GET_FILENAME_BODY(Obj body)178 Obj GET_FILENAME_BODY(Obj body)
179 {
180 Obj val = BODY_HEADER(body)->filename_or_id;
181 if (IS_INTOBJ(val)) {
182 UInt gapnameid = INT_INTOBJ(val);
183 val = GetCachedFilename(gapnameid);
184 }
185
186 return val;
187 }
188
SET_FILENAME_BODY(Obj body,Obj val)189 void SET_FILENAME_BODY(Obj body, Obj val)
190 {
191 GAP_ASSERT(IS_STRING_REP(val));
192 MakeImmutable(val);
193 BODY_HEADER(body)->filename_or_id = val;
194 }
195
196 // gapnameid
197
GET_GAPNAMEID_BODY(Obj body)198 UInt GET_GAPNAMEID_BODY(Obj body)
199 {
200 Obj gapnameid = BODY_HEADER(body)->filename_or_id;
201 return IS_POS_INTOBJ(gapnameid) ? INT_INTOBJ(gapnameid) : 0;
202 }
203
SET_GAPNAMEID_BODY(Obj body,UInt val)204 void SET_GAPNAMEID_BODY(Obj body, UInt val)
205 {
206 BODY_HEADER(body)->filename_or_id = INTOBJ_INT(val);
207 }
208
209 // location
210
GET_LOCATION_BODY(Obj body)211 Obj GET_LOCATION_BODY(Obj body)
212 {
213 Obj location = BODY_HEADER(body)->startline_or_location;
214 return IS_STRING_REP(location) ? location : 0;
215 }
216
SET_LOCATION_BODY(Obj body,Obj val)217 void SET_LOCATION_BODY(Obj body, Obj val)
218 {
219 GAP_ASSERT(IS_STRING_REP(val));
220 MakeImmutable(val);
221 BODY_HEADER(body)->startline_or_location = val;
222 }
223
224 // startline
225
GET_STARTLINE_BODY(Obj body)226 UInt GET_STARTLINE_BODY(Obj body)
227 {
228 Obj line = BODY_HEADER(body)->startline_or_location;
229 return IS_POS_INTOBJ(line) ? INT_INTOBJ(line) : 0;
230 }
231
SET_STARTLINE_BODY(Obj body,UInt val)232 void SET_STARTLINE_BODY(Obj body, UInt val)
233 {
234 BODY_HEADER(body)->startline_or_location = val ? INTOBJ_INT(val) : 0;
235 }
236
237 // endline
238
GET_ENDLINE_BODY(Obj body)239 UInt GET_ENDLINE_BODY(Obj body)
240 {
241 Obj line = BODY_HEADER(body)->endline;
242 return IS_POS_INTOBJ(line) ? INT_INTOBJ(line) : 0;
243 }
244
SET_ENDLINE_BODY(Obj body,UInt val)245 void SET_ENDLINE_BODY(Obj body, UInt val)
246 {
247 BODY_HEADER(body)->endline = val ? INTOBJ_INT(val) : 0;
248 }
249
GET_VALUE_FROM_CURRENT_BODY(Int ix)250 Obj GET_VALUE_FROM_CURRENT_BODY(Int ix)
251 {
252 Obj values = ((BodyHeader *)STATE(PtrBody))->values;
253 return ELM_PLIST(values, ix);
254 }
255
NewStatOrExpr(UInt type,UInt size,UInt line)256 Stat NewStatOrExpr (
257 UInt type,
258 UInt size,
259 UInt line)
260 {
261 Stat stat; /* result */
262
263 /* this is where the new statement goes */
264 stat = CS(OffsBody) + sizeof(StatHeader);
265
266 /* increase the offset */
267 CS(OffsBody) = stat + ((size+sizeof(Stat)-1) / sizeof(Stat)) * sizeof(Stat);
268
269 /* make certain that the current body bag is large enough */
270 Obj body = BODY_FUNC(CURR_FUNC());
271 UInt bodySize = SIZE_BAG(body);
272 if (bodySize == 0)
273 bodySize = CS(OffsBody);
274 while (bodySize < CS(OffsBody))
275 bodySize *= 2;
276 ResizeBag(body, bodySize);
277 STATE(PtrBody) = PTR_BAG(body);
278
279 /* enter type and size */
280 STAT_HEADER(stat)->line = line;
281 STAT_HEADER(stat)->size = size;
282 STAT_HEADER(stat)->type = type;
283 RegisterStatWithHook(stat);
284 /* return the new statement */
285 return stat;
286 }
287
NewStat(UInt type,UInt size)288 static Stat NewStat(UInt type, UInt size)
289 {
290 return NewStatOrExpr(type, size, GetInputLineNumber());
291 }
292
293
294 /****************************************************************************
295 **
296 *F NewExpr( <type>, <size> ) . . . . . . . . . . . allocate a new expression
297 **
298 ** 'NewExpr' allocates a new expression memory block of the type <type> and
299 ** <size> bytes. 'NewExpr' returns the identifier of the new expression.
300 */
NewExpr(UInt type,UInt size)301 static Expr NewExpr(UInt type, UInt size)
302 {
303 return NewStat(type, size);
304 }
305
306
307 /****************************************************************************
308 **
309 *V StackStat . . . . . . . . . . . . . . . . . . . . . . . statements stack
310 *V CountStat . . . . . . . . . . . . . . . number of statements on the stack
311 *F PushStat( <stat> ) . . . . . . . . . . . . push statement onto the stack
312 *F PopStat() . . . . . . . . . . . . . . . . . pop statement from the stack
313 **
314 ** 'StackStat' is the stack of statements that have been coded.
315 **
316 ** 'CountStat' is the number of statements currently on the statements
317 ** stack.
318 **
319 ** 'PushStat' pushes the statement <stat> onto the statements stack. The
320 ** stack is automatically resized if necessary.
321 **
322 ** 'PopStat' returns the top statement from the statements stack and pops
323 ** it. It is an error if the stack is empty.
324 */
CapacityStatStack(void)325 static inline UInt CapacityStatStack(void)
326 {
327 return SIZE_BAG(CS(StackStat)) / sizeof(Stat) - 1;
328 }
329
PushStat(Stat stat)330 void PushStat (
331 Stat stat )
332 {
333 /* there must be a stack, it must not be underfull or overfull */
334 GAP_ASSERT(CS(StackStat) != 0);
335 GAP_ASSERT(0 <= CS(CountStat));
336 GAP_ASSERT(CS(CountStat) <= CapacityStatStack());
337 GAP_ASSERT( stat != 0 );
338
339 // count up and put the statement onto the stack
340 if (CS(CountStat) == CapacityStatStack()) {
341 ResizeBag(CS(StackStat), (2 * CS(CountStat) + 1) * sizeof(Stat));
342 }
343
344 // put
345 Stat * data = (Stat *)PTR_BAG(CS(StackStat)) + 1;
346 data[CS(CountStat)] = stat;
347 CS(CountStat)++;
348 }
349
PopStat(void)350 static Stat PopStat ( void )
351 {
352 Stat stat;
353
354 /* there must be a stack, it must not be underfull/empty or overfull */
355 GAP_ASSERT(CS(StackStat) != 0);
356 GAP_ASSERT(1 <= CS(CountStat));
357 GAP_ASSERT(CS(CountStat) <= CapacityStatStack());
358
359 /* get the top statement from the stack, and count down */
360 CS(CountStat)--;
361 Stat * data = (Stat *)PTR_BAG(CS(StackStat)) + 1;
362 stat = data[CS(CountStat)];
363
364 /* return the popped statement */
365 return stat;
366 }
367
PopSeqStat(UInt nr)368 static Stat PopSeqStat (
369 UInt nr )
370 {
371 Stat body; /* sequence, result */
372 Stat stat; /* single statement */
373 UInt i; /* loop variable */
374
375 if (nr == 0 ) {
376 body = NewStat(STAT_EMPTY, 0);
377 }
378 /* special case for a single statement */
379 else if ( nr == 1 ) {
380 body = PopStat();
381 }
382
383 /* general case */
384 else {
385
386 /* allocate the sequence */
387 if ( 2 <= nr && nr <= 7 ) {
388 body = NewStat( STAT_SEQ_STAT+(nr-1), nr * sizeof(Stat) );
389 }
390 else {
391 body = NewStat( STAT_SEQ_STAT, nr * sizeof(Stat) );
392 }
393
394 /* enter the statements into the sequence */
395 for ( i = nr; 1 <= i; i-- ) {
396 stat = PopStat();
397 WRITE_STAT(body, i - 1, stat);
398 }
399 }
400
401 /* return the sequence */
402 return body;
403 }
404
PopLoopStat(UInt baseType,UInt extra,UInt nr)405 static inline Stat PopLoopStat(UInt baseType, UInt extra, UInt nr)
406 {
407 // fix up the case of no statements
408 if (0 == nr) {
409 PushStat(NewStat(STAT_EMPTY, 0));
410 nr = 1;
411 }
412
413 // collect the statements into a statement sequence if necessary
414 else if (3 < nr) {
415 PushStat(PopSeqStat(nr));
416 nr = 1;
417 }
418
419 // allocate the compound statement
420 Stat stat = NewStat(baseType + (nr - 1),
421 extra * sizeof(Expr) + nr * sizeof(Stat));
422
423 // enter the statements
424 for (UInt i = nr; 1 <= i; i--) {
425 Stat stat1 = PopStat();
426 WRITE_STAT(stat, i + extra - 1, stat1);
427 }
428
429 return stat;
430 }
431
432
433 /****************************************************************************
434 **
435 *V StackExpr . . . . . . . . . . . . . . . . . . . . . . . expressions stack
436 *V CountExpr . . . . . . . . . . . . . . number of expressions on the stack
437 *F PushExpr( <expr> ) . . . . . . . . . . . push expression onto the stack
438 *F PopExpr() . . . . . . . . . . . . . . . . pop expression from the stack
439 **
440 ** 'StackExpr' is the stack of expressions that have been coded.
441 **
442 ** 'CountExpr' is the number of expressions currently on the expressions
443 ** stack.
444 **
445 ** 'PushExpr' pushes the expression <expr> onto the expressions stack. The
446 ** stack is automatically resized if necessary.
447 **
448 ** 'PopExpr' returns the top expressions from the expressions stack and pops
449 ** it. It is an error if the stack is empty.
450 */
CapacityStackExpr(void)451 static inline UInt CapacityStackExpr(void)
452 {
453 return SIZE_BAG(CS(StackExpr)) / sizeof(Expr) - 1;
454 }
455
PushExpr(Expr expr)456 static void PushExpr(Expr expr)
457 {
458 /* there must be a stack, it must not be underfull or overfull */
459 GAP_ASSERT(CS(StackExpr) != 0);
460 GAP_ASSERT(0 <= CS(CountExpr));
461 GAP_ASSERT(CS(CountExpr) <= CapacityStackExpr());
462 GAP_ASSERT( expr != 0 );
463
464 /* count up and put the expression onto the stack */
465 if (CS(CountExpr) == CapacityStackExpr()) {
466 ResizeBag(CS(StackExpr), (2 * CS(CountExpr) + 1) * sizeof(Expr));
467 }
468
469 Expr * data = (Expr *)PTR_BAG(CS(StackExpr)) + 1;
470 data[CS(CountExpr)] = expr;
471 CS(CountExpr)++;
472 }
473
PopExpr(void)474 static Expr PopExpr(void)
475 {
476 Expr expr;
477
478 /* there must be a stack, it must not be underfull/empty or overfull */
479 GAP_ASSERT(CS(StackExpr) != 0);
480 GAP_ASSERT(1 <= CS(CountExpr));
481 GAP_ASSERT(CS(CountExpr) <= CapacityStackExpr());
482
483 /* get the top expression from the stack, and count down */
484 CS(CountExpr)--;
485 Expr * data = (Expr *)PTR_BAG(CS(StackExpr)) + 1;
486 expr = data[CS(CountExpr)];
487
488 /* return the popped expression */
489 return expr;
490 }
491
492
493 /****************************************************************************
494 **
495 *F PushUnaryOp( <type> ) . . . . . . . . . . . . . . . . push unary operator
496 **
497 ** 'PushUnaryOp' pushes a unary operator expression onto the expression
498 ** stack. <type> is the type of the operator (currently only 'EXPR_NOT').
499 */
PushUnaryOp(UInt type)500 static void PushUnaryOp(UInt type)
501 {
502 Expr unop; /* unary operator, result */
503 Expr op; /* operand */
504
505 /* allocate the unary operator */
506 unop = NewExpr( type, sizeof(Expr) );
507
508 /* enter the operand */
509 op = PopExpr();
510 WRITE_EXPR(unop, 0, op);
511
512 /* push the unary operator */
513 PushExpr( unop );
514 }
515
516
517 /****************************************************************************
518 **
519 *F PushBinaryOp( <type> ) . . . . . . . . . . . . . . push binary operator
520 **
521 ** 'PushBinaryOp' pushes a binary operator expression onto the expression
522 ** stack. <type> is the type of the operator.
523 */
PushBinaryOp(UInt type)524 static void PushBinaryOp(UInt type)
525 {
526 Expr binop; /* binary operator, result */
527 Expr opL; /* left operand */
528 Expr opR; /* right operand */
529
530 /* allocate the binary operator */
531 binop = NewExpr( type, 2*sizeof(Expr) );
532
533 /* enter the right operand */
534 opR = PopExpr();
535 WRITE_EXPR(binop, 1, opR);
536
537 /* enter the left operand */
538 opL = PopExpr();
539 WRITE_EXPR(binop, 0, opL);
540
541 /* push the binary operator */
542 PushExpr( binop );
543 }
544
545
AddValueToBody(Obj val)546 Int AddValueToBody(Obj val)
547 {
548 BodyHeader * header = (BodyHeader *)STATE(PtrBody);
549 Obj values = header->values;
550 if (!values) {
551 values = NEW_PLIST(T_PLIST, 4);
552 // Recalculate header in case NEW_PLIST caused a GC
553 header = (BodyHeader *)STATE(PtrBody);
554 header->values = values;
555 GAP_ASSERT(STATE(PtrBody) == PTR_BAG(BODY_FUNC(CURR_FUNC())));
556 // This is the bag PtrBody points at
557 CHANGED_BAG(BODY_FUNC(CURR_FUNC()));
558 }
559 return PushPlist(values, val);
560 }
561
562
563 /****************************************************************************
564 **
565 *F * * * * * * * * * * * * * coder functions * * * * * * * * * * * * * * * *
566 */
567
568 /****************************************************************************
569 **
570 *F CodeFuncCallOptionsBegin() . . . . . . . . . . . . . code options, begin
571 *F CodeFuncCallOptionsBeginElmName(<rnam>). . . code options, begin element
572 *F CodeFuncCallOptionsBeginElmExpr() . .. . . . .code options, begin element
573 *F CodeFuncCallOptionsEndElm() . . .. . . . . . . code options, end element
574 *F CodeFuncCallOptionsEndElmEmpty() .. . . . . . .code options, end element
575 *F CodeFuncCallOptionsEnd(<nr>) . . . . . . . . . . . . . code options, end
576 **
577 ** The net effect of all of these is to leave a record expression on the
578 ** stack containing the options record. It will be picked up by
579 ** CodeFuncCallEnd()
580 **
581 */
CodeFuncCallOptionsBegin(void)582 void CodeFuncCallOptionsBegin ( void )
583 {
584 }
585
CodeFuncCallOptionsBeginElmName(UInt rnam)586 void CodeFuncCallOptionsBeginElmName (
587 UInt rnam )
588 {
589 /* push the record name as integer expressions */
590 PushExpr( INTEXPR_INT( rnam ) );
591 }
592
CodeFuncCallOptionsBeginElmExpr(void)593 void CodeFuncCallOptionsBeginElmExpr ( void )
594 {
595 /* The expression is on the stack where we want it */
596 }
597
CodeFuncCallOptionsEndElm(void)598 void CodeFuncCallOptionsEndElm ( void )
599 {
600 }
601
CodeFuncCallOptionsEndElmEmpty(void)602 void CodeFuncCallOptionsEndElmEmpty ( void )
603 {
604 /* The default value is true */
605 PushExpr( NewExpr( EXPR_TRUE, 0L ) );
606 }
607
CodeFuncCallOptionsEnd(UInt nr)608 void CodeFuncCallOptionsEnd ( UInt nr )
609 {
610 Expr record; /* record, result */
611 Expr entry; /* entry */
612 Expr rnam; /* position of an entry */
613 UInt i; /* loop variable */
614
615 /* allocate the record expression */
616 record = NewExpr( EXPR_REC, nr * 2 * sizeof(Expr) );
617
618
619 /* enter the entries */
620 for ( i = nr; 1 <= i; i-- ) {
621 entry = PopExpr();
622 rnam = PopExpr();
623 WRITE_EXPR(record, 2 * (i - 1), rnam);
624 WRITE_EXPR(record, 2 * (i - 1) + 1, entry);
625 }
626
627 /* push the record */
628 PushExpr( record );
629
630 }
631
632
633 /****************************************************************************
634 **
635 *F CodeBegin() . . . . . . . . . . . . . . . . . . . . . . . start the coder
636 *F CodeEnd( <error> ) . . . . . . . . . . . . . . . . . . . stop the coder
637 **
638 ** 'CodeBegin' starts the coder. It is called from the immediate
639 ** interpreter when he encounters a construct that it cannot immediately
640 ** interpret.
641 **
642 ** 'CodeEnd' stops the coder. It is called from the immediate interpreter
643 ** when he is done with the construct that it cannot immediately interpret.
644 ** If <error> is non-zero, a syntax error was detected by the reader, and
645 ** the coder should only clean up.
646 **
647 ** ...only function expressions in between...
648 */
649
CodeBegin(void)650 void CodeBegin ( void )
651 {
652 /* the stacks must be empty */
653 GAP_ASSERT(CS(CountStat) == 0);
654 GAP_ASSERT(CS(CountExpr) == 0);
655
656 /* remember the current frame */
657 CS(CodeLVars) = STATE(CurrLVars);
658
659 /* clear the code result bag */
660 CS(CodeResult) = 0;
661 }
662
CodeEnd(UInt error)663 Obj CodeEnd(UInt error)
664 {
665 /* if everything went fine */
666 if ( ! error ) {
667
668 /* the stacks must be empty */
669 GAP_ASSERT(CS(CountStat) == 0);
670 GAP_ASSERT(CS(CountExpr) == 0);
671 GAP_ASSERT(CS(OffsBodyCount) == 0);
672
673 // we must be back to 'STATE(CurrLVars)'
674 GAP_ASSERT(STATE(CurrLVars) == CS(CodeLVars));
675
676 // 'CodeFuncExprEnd' left the function already in 'CS(CodeResult)'
677 return CS(CodeResult);
678 }
679
680 /* otherwise clean up the mess */
681 else {
682
683 /* empty the stacks */
684 CS(CountStat) = 0;
685 CS(CountExpr) = 0;
686 CS(OffsBodyCount) = 0;
687
688 /* go back to the correct frame */
689 SWITCH_TO_OLD_LVARS(CS(CodeLVars));
690
691 return 0;
692 }
693 }
694
695
696 /****************************************************************************
697 **
698 *F CodeFuncCallBegin() . . . . . . . . . . . . . . code function call, begin
699 *F CodeFuncCallEnd( <funccall>, <options>, <nr> ) code function call, end
700 **
701 ** 'CodeFuncCallBegin' is an action to code a function call. It is called
702 ** by the reader when it encounters the parenthesis '(', i.e., *after* the
703 ** function expression is read.
704 **
705 ** 'CodeFuncCallEnd' is an action to code a function call. It is called by
706 ** the reader when it encounters the parenthesis ')', i.e., *after* the
707 ** argument expressions are read. <funccall> is 1 if this is a function
708 ** call, and 0 if this is a procedure call. <nr> is the number of
709 ** arguments. <options> is 1 if options were present after the ':' in which
710 ** case the options have been read already.
711 */
CodeFuncCallBegin(void)712 void CodeFuncCallBegin ( void )
713 {
714 }
715
CodeFuncCallEnd(UInt funccall,UInt options,UInt nr)716 void CodeFuncCallEnd (
717 UInt funccall,
718 UInt options,
719 UInt nr )
720 {
721 Expr call; /* function call, result */
722 Expr func; /* function expression */
723 Expr arg; /* one argument expression */
724 UInt i; /* loop variable */
725 Expr opts = 0; /* record literal for the options */
726 Expr wrapper; /* wrapper for calls with options */
727
728 /* allocate the function call */
729 if ( funccall && nr <= 6 ) {
730 call = NewExpr( EXPR_FUNCCALL_0ARGS+nr, SIZE_NARG_CALL(nr) );
731 }
732 else if ( funccall /* && 6 < nr */ ) {
733 call = NewExpr( EXPR_FUNCCALL_XARGS, SIZE_NARG_CALL(nr) );
734 }
735 else if ( /* ! funccall && */ nr <=6 ) {
736 call = NewExpr( STAT_PROCCALL_0ARGS+nr, SIZE_NARG_CALL(nr) );
737 }
738 else /* if ( ! funccall && 6 < nr ) */ {
739 call = NewExpr( STAT_PROCCALL_XARGS, SIZE_NARG_CALL(nr) );
740 }
741
742 /* get the options record if any */
743 if (options)
744 opts = PopExpr();
745
746 /* enter the argument expressions */
747 for ( i = nr; 1 <= i; i-- ) {
748 arg = PopExpr();
749 SET_ARGI_CALL(call, i, arg);
750 }
751
752 /* enter the function expression */
753 func = PopExpr();
754 SET_FUNC_CALL(call, func);
755
756 /* wrap up the call with the options */
757 if (options)
758 {
759 wrapper = NewExpr( funccall ? EXPR_FUNCCALL_OPTS : STAT_PROCCALL_OPTS,
760 2*sizeof(Expr));
761 WRITE_EXPR(wrapper, 0, opts);
762 WRITE_EXPR(wrapper, 1, call);
763 call = wrapper;
764 }
765
766 /* push the function call */
767 if ( funccall ) {
768 PushExpr( call );
769 }
770 else {
771 PushStat( call );
772 }
773 }
774
775
776 /****************************************************************************
777 **
778 *F CodeFuncExprBegin( <narg>, <nloc>, <nams> ) . . code function expr, begin
779 *F CodeFuncExprEnd( <nr> ) . . . . . . . . . . code function expression, end
780 **
781 ** 'CodeFuncExprBegin' is an action to code a function expression. It is
782 ** called when the reader encounters the beginning of a function expression.
783 ** <narg> is the number of arguments (-1 if the function takes a variable
784 ** number of arguments), <nloc> is the number of locals, <nams> is a list of
785 ** local variable names.
786 **
787 ** 'CodeFuncExprEnd' is an action to code a function expression. It is
788 ** called when the reader encounters the end of a function expression. <nr>
789 ** is the number of statements in the body of the function.
790 */
CodeFuncExprBegin(Int narg,Int nloc,Obj nams,Int startLine)791 void CodeFuncExprBegin (
792 Int narg,
793 Int nloc,
794 Obj nams,
795 Int startLine)
796 {
797 Obj fexp; /* function expression bag */
798 Bag body; /* function body */
799 Bag old; /* old frame */
800 Stat stat1; /* first statement in body */
801
802 /* remember the current offset */
803 PushOffsBody();
804
805 /* create a function expression */
806 fexp = NewBag( T_FUNCTION, sizeof(FuncBag) );
807 SET_NARG_FUNC( fexp, narg );
808 SET_NLOC_FUNC( fexp, nloc );
809 SET_NAMS_FUNC( fexp, nams );
810 #ifdef HPCGAP
811 if (nams) MakeBagPublic(nams);
812 #endif
813 CHANGED_BAG( fexp );
814
815 /* give it a body */
816 body = NewBag( T_BODY, 1024*sizeof(Stat) );
817 SET_BODY_FUNC( fexp, body );
818 CHANGED_BAG( fexp );
819
820 /* record where we are reading from */
821 SET_GAPNAMEID_BODY(body, GetInputFilenameID());
822 SET_STARTLINE_BODY(body, startLine);
823 CS(OffsBody) = sizeof(BodyHeader);
824
825 /* give it an environment */
826 SET_ENVI_FUNC( fexp, STATE(CurrLVars) );
827 CHANGED_BAG( fexp );
828 MakeHighVars(STATE(CurrLVars));
829
830 /* switch to this function */
831 SWITCH_TO_NEW_LVARS( fexp, (narg >0 ? narg : -narg), nloc, old );
832 (void) old; /* please picky compilers. */
833
834 /* allocate the top level statement sequence */
835 stat1 = NewStat( STAT_SEQ_STAT, 8*sizeof(Stat) );
836 assert( stat1 == OFFSET_FIRST_STAT );
837 }
838
CodeFuncExprEnd(UInt nr,UInt pushExpr)839 Expr CodeFuncExprEnd(UInt nr, UInt pushExpr)
840 {
841 Expr expr; /* function expression, result */
842 Stat stat1; /* single statement of body */
843 Obj fexp; /* function expression bag */
844 UInt len; /* length of func. expr. list */
845 UInt i; /* loop variable */
846
847 /* get the function expression */
848 fexp = CURR_FUNC();
849
850 /* get the body of the function */
851 /* push an additional return-void-statement if necessary */
852 /* the function interpreters depend on each function ``returning'' */
853 if ( nr == 0 ) {
854 CodeReturnVoid();
855 nr++;
856 }
857 else {
858 stat1 = PopStat();
859 PushStat(stat1);
860 // If we code a function where the body is already packed into nested
861 // sequence statements, e.g., from reading in a syntax tree, we need
862 // to find the last `real` statement of the last innermost sequence
863 // statement to determine if there is already a return or not.
864 while (STAT_SEQ_STAT <= TNUM_STAT(stat1) &&
865 TNUM_STAT(stat1) <= STAT_SEQ_STAT7) {
866 UInt size = SIZE_STAT(stat1) / sizeof(Stat);
867 stat1 = READ_STAT(stat1, size - 1);
868 }
869 if (TNUM_STAT(stat1) != STAT_RETURN_VOID &&
870 TNUM_STAT(stat1) != STAT_RETURN_OBJ) {
871 CodeReturnVoidWhichIsNotProfiled();
872 nr++;
873 }
874 }
875
876 /* if the body is a long sequence, pack the other statements */
877 if ( 7 < nr ) {
878 stat1 = PopSeqStat( nr-6 );
879 PushStat( stat1 );
880 nr = 7;
881 }
882
883 /* stuff the first statements into the first statement sequence */
884 /* Making sure to preserve the line number and file name */
885 STAT_HEADER(OFFSET_FIRST_STAT)->line = LINE_STAT(OFFSET_FIRST_STAT);
886 STAT_HEADER(OFFSET_FIRST_STAT)->size = nr*sizeof(Stat);
887 STAT_HEADER(OFFSET_FIRST_STAT)->type = STAT_SEQ_STAT+nr-1;
888 for ( i = 1; i <= nr; i++ ) {
889 stat1 = PopStat();
890 WRITE_STAT(OFFSET_FIRST_STAT, nr - i, stat1);
891 }
892
893 // make the body values list (if any) immutable
894 Obj values = ((BodyHeader *)STATE(PtrBody))->values;
895 if (values)
896 MakeImmutable(values);
897
898 /* make the body smaller */
899 ResizeBag(BODY_FUNC(fexp), CS(OffsBody));
900 SET_ENDLINE_BODY(BODY_FUNC(fexp), GetInputLineNumber());
901
902 /* switch back to the previous function */
903 SWITCH_TO_OLD_LVARS( ENVI_FUNC(fexp) );
904
905 /* restore the remembered offset */
906 PopOffsBody();
907
908 /* if this was inside another function definition, make the expression */
909 /* and store it in the function expression list of the outer function */
910 if (STATE(CurrLVars) != CS(CodeLVars)) {
911 len = AddValueToBody(fexp);
912 expr = NewExpr( EXPR_FUNC, sizeof(Expr) );
913 WRITE_EXPR(expr, 0, len);
914 if (pushExpr) {
915 PushExpr(expr);
916 }
917 return expr;
918 }
919
920 // otherwise, make the function and store it in 'CS(CodeResult)'
921 else {
922 CS(CodeResult) = MakeFunction(fexp);
923 }
924
925 return 0;
926 }
927
928
929 /****************************************************************************
930 **
931 *F CodeIfBegin() . . . . . . . . . . . code if-statement, begin of statement
932 *F CodeIfElif() . . . . . . . . . . code if-statement, begin of elif-branch
933 *F CodeIfElse() . . . . . . . . . . code if-statement, begin of else-branch
934 *F CodeIfBeginBody() . . . . . . . . . . . code if-statement, begin of body
935 *F CodeIfEndBody( <nr> ) . . . . . . . . . . code if-statement, end of body
936 *F CodeIfEnd( <nr> ) . . . . . . . . . . code if-statement, end of statement
937 **
938 ** 'CodeIfBegin' is an action to code an if-statement. It is called when
939 ** the reader encounters the 'if', i.e., *before* the condition is read.
940 **
941 ** 'CodeIfElif' is an action to code an if-statement. It is called when the
942 ** reader encounters an 'elif', i.e., *before* the condition is read.
943 **
944 ** 'CodeIfElse' is an action to code an if-statement. It is called when the
945 ** reader encounters an 'else'.
946 **
947 ** 'CodeIfBeginBody' is an action to code an if-statement. It is called
948 ** when the reader encounters the beginning of the statement body of an
949 ** 'if', 'elif', or 'else' branch, i.e., *after* the condition is read.
950 **
951 ** 'CodeIfEndBody' is an action to code an if-statement. It is called when
952 ** the reader encounters the end of the statements body of an 'if', 'elif',
953 ** or 'else' branch. <nr> is the number of statements in the body.
954 **
955 ** 'CodeIfEnd' is an action to code an if-statement. It is called when the
956 ** reader encounters the end of the statement. <nr> is the number of 'if',
957 ** 'elif', or 'else' branches.
958 */
CodeIfBegin(void)959 void CodeIfBegin ( void )
960 {
961 }
962
CodeIfElif(void)963 void CodeIfElif ( void )
964 {
965 }
966
CodeIfElse(void)967 void CodeIfElse ( void )
968 {
969 CodeTrueExpr();
970 }
971
CodeIfBeginBody(void)972 Int CodeIfBeginBody ( void )
973 {
974 // get and check the condition
975 Expr cond = PopExpr();
976
977 // if the condition is 'false', ignore the body
978 if (TNUM_EXPR(cond) == EXPR_FALSE) {
979 return 1; // signal interpreter to set IntrIgnoring to 1
980 }
981 else {
982 // put the condition expression back on the stack
983 PushExpr(cond);
984 return 0;
985 }
986 }
987
CodeIfEndBody(UInt nr)988 Int CodeIfEndBody (
989 UInt nr )
990 {
991 /* collect the statements in a statement sequence if necessary */
992 PushStat( PopSeqStat( nr ) );
993
994 // get and check the condition
995 Expr cond = PopExpr();
996 PushExpr(cond);
997
998 // if the condition is 'true', signal interpreter to set IntrIgnoring to
999 // 1, so that other branches of the if-statement are ignored
1000 return TNUM_EXPR(cond) == EXPR_TRUE;
1001 }
1002
CodeIfEnd(UInt nr)1003 void CodeIfEnd (
1004 UInt nr )
1005 {
1006 Stat stat; /* if-statement, result */
1007 Expr cond; /* condition of a branch */
1008 UInt hase; /* has else branch */
1009 UInt i; /* loop variable */
1010
1011 // if all conditions were false, the if-statement is an empty statement
1012 if (nr == 0) {
1013 PushStat(NewStat(STAT_EMPTY, 0));
1014 return;
1015 }
1016
1017 // peek at the last condition
1018 cond = PopExpr();
1019 hase = (TNUM_EXPR(cond) == EXPR_TRUE);
1020 PushExpr(cond);
1021
1022 // optimize 'if true then BODY; fi;' to just 'BODY;'
1023 if (nr == 1 && hase) {
1024 // drop the condition expression, leave the body statement
1025 PopExpr();
1026 return;
1027 }
1028
1029 /* allocate the if-statement */
1030 if ( nr == 1 ) {
1031 stat = NewStat( STAT_IF, nr * (sizeof(Expr)+sizeof(Stat)) );
1032 }
1033 else if ( nr == 2 && hase ) {
1034 stat = NewStat( STAT_IF_ELSE, nr * (sizeof(Expr)+sizeof(Stat)) );
1035 }
1036 else if ( ! hase ) {
1037 stat = NewStat( STAT_IF_ELIF, nr * (sizeof(Expr)+sizeof(Stat)) );
1038 }
1039 else {
1040 stat = NewStat( STAT_IF_ELIF_ELSE, nr * (sizeof(Expr)+sizeof(Stat)) );
1041 }
1042
1043 /* enter the branches */
1044 for ( i = nr; 1 <= i; i-- ) {
1045 Stat body = PopStat();
1046 cond = PopExpr();
1047 WRITE_STAT(stat, 2 * (i - 1), cond);
1048 WRITE_STAT(stat, 2 * (i - 1) + 1, body);
1049 }
1050
1051 /* push the if-statement */
1052 PushStat( stat );
1053 }
1054
1055
1056 /****************************************************************************
1057 **
1058 *F CodeForBegin() . . . . . . . . . code for-statement, begin of statement
1059 *F CodeForIn() . . . . . . . . . . . . . . . . code for-statement, 'in' read
1060 *F CodeForBeginBody() . . . . . . . . . . code for-statement, begin of body
1061 *F CodeForEndBody( <nr> ) . . . . . . . . . code for-statement, end of body
1062 *F CodeForEnd() . . . . . . . . . . . code for-statement, end of statement
1063 **
1064 ** 'CodeForBegin' is an action to code a for-statement. It is called when
1065 ** the reader encounters the 'for', i.e., *before* the variable is read.
1066 **
1067 ** 'CodeForIn' is an action to code a for-statement. It is called when the
1068 ** reader encounters the 'in', i.e., *after* the variable is read, but
1069 ** *before* the list expression is read.
1070 **
1071 ** 'CodeForBeginBody' is an action to code a for-statement. It is called
1072 ** when the reader encounters the beginning of the statement body, i.e.,
1073 ** *after* the list expression is read.
1074 **
1075 ** 'CodeForEndBody' is an action to code a for-statement. It is called when
1076 ** the reader encounters the end of the statement body. <nr> is the number
1077 ** of statements in the body.
1078 **
1079 ** 'CodeForEnd' is an action to code a for-statement. It is called when the
1080 ** reader encounters the end of the statement, i.e., immediately after
1081 ** 'CodeForEndBody'.
1082 */
CodeForBegin(void)1083 void CodeForBegin ( void )
1084 {
1085 }
1086
CodeForIn(void)1087 void CodeForIn ( void )
1088 {
1089 Expr var = PopExpr();
1090 if (TNUM_EXPR(var) == EXPR_REF_GVAR)
1091 {
1092 PushGlobalForLoopVariable(READ_EXPR(var, 0));
1093 }
1094 PushExpr(var);
1095 }
1096
CodeForBeginBody(void)1097 void CodeForBeginBody ( void )
1098 {
1099 }
1100
CodeForEndBody(UInt nr)1101 void CodeForEndBody (
1102 UInt nr )
1103 {
1104 Stat stat; /* for-statement, result */
1105 UInt type; /* type of for-statement */
1106 Expr var; /* variable */
1107 Expr list; /* list */
1108
1109 /* get the list expression */
1110 list = PopExpr();
1111
1112 /* get the variable reference */
1113 var = PopExpr();
1114
1115 if (TNUM_EXPR(var) == EXPR_REF_GVAR)
1116 PopGlobalForLoopVariable();
1117
1118 /* select the type of the for-statement */
1119 if ( TNUM_EXPR(list) == EXPR_RANGE && SIZE_EXPR(list) == 2*sizeof(Expr)
1120 && IS_REF_LVAR(var) ) {
1121 type = STAT_FOR_RANGE;
1122 }
1123 else {
1124 type = STAT_FOR;
1125 }
1126
1127 /* allocate the for-statement */
1128 stat = PopLoopStat(type, 2, nr);
1129
1130 /* enter the list expression */
1131 WRITE_STAT(stat, 1, list);
1132
1133 /* enter the variable reference */
1134 WRITE_STAT(stat, 0, var);
1135
1136 /* push the for-statement */
1137 PushStat( stat );
1138 }
1139
CodeForEnd(void)1140 void CodeForEnd ( void )
1141 {
1142 }
1143
1144
1145 /****************************************************************************
1146 **
1147 *F CodeAtomicBegin() . . . . . . . code atomic-statement, begin of statement
1148 *F CodeAtomicBeginBody() . . . . . . . code atomic-statement, begin of body
1149 *F CodeAtomicEndBody( <nr> ) . . . . . . code atomic-statement, end of body
1150 *F CodeAtomicEnd() . . . . . . . . . code atomic-statement, end of statement
1151 **
1152 ** 'CodeAtomicBegin' is an action to code a atomic-statement. It is called
1153 ** when the reader encounters the 'atomic', i.e., *before* the condition is
1154 ** read.
1155 **
1156 ** 'CodeAtomicBeginBody' is an action to code a atomic-statement. It is
1157 ** called when the reader encounters the beginning of the statement body,
1158 ** i.e., *after* the condition is read.
1159 **
1160 ** 'CodeAtomicEndBody' is an action to code a atomic-statement. It is called
1161 ** when the reader encounters the end of the statement body. <nr> is the
1162 ** number of statements in the body.
1163 **
1164 ** 'CodeAtomicEnd' is an action to code a atomic-statement. It is called
1165 ** when the reader encounters the end of the statement, i.e., immediate
1166 ** after 'CodeAtomicEndBody'.
1167 */
CodeAtomicBegin(void)1168 void CodeAtomicBegin ( void )
1169 {
1170 }
1171
CodeAtomicBeginBody(UInt nrexprs)1172 void CodeAtomicBeginBody ( UInt nrexprs )
1173 {
1174 PushExpr(INTEXPR_INT(nrexprs));
1175 }
1176
CodeAtomicEndBody(UInt nrstats)1177 void CodeAtomicEndBody (
1178 UInt nrstats )
1179 {
1180 #ifdef HPCGAP
1181 Stat stat; /* atomic-statement, result */
1182 Stat stat1; /* single statement of body */
1183 UInt i; /* loop variable */
1184 UInt nrexprs;
1185 Expr e,qual;
1186
1187 /* collect the statements into a statement sequence */
1188 stat1 = PopSeqStat( nrstats );
1189
1190 nrexprs = INT_INTEXPR(PopExpr());
1191
1192 /* allocate the atomic-statement */
1193 stat = NewStat( STAT_ATOMIC, sizeof(Stat) + nrexprs*2*sizeof(Stat) );
1194
1195 /* enter the statement sequence */
1196 WRITE_STAT(stat, 0, stat1);
1197
1198 /* enter the expressions */
1199 for ( i = 2*nrexprs; 1 <= i; i -= 2 ) {
1200 e = PopExpr();
1201 qual = PopExpr();
1202 WRITE_STAT(stat, i, e);
1203 WRITE_STAT(stat, i - 1, qual);
1204 }
1205
1206 /* push the atomic-statement */
1207 PushStat( stat );
1208 #else
1209 Stat stat = PopSeqStat( nrstats );
1210 UInt nrexprs = INT_INTEXPR(PopExpr());
1211 while (nrexprs--) {
1212 PopExpr();
1213 PopExpr();
1214 }
1215 PushStat( stat );
1216 #endif
1217 }
1218
CodeAtomicEnd(void)1219 void CodeAtomicEnd ( void )
1220 {
1221 }
1222
1223 /****************************************************************************
1224 **
1225 *F CodeQualifiedExprBegin() . . . . code readonly/readwrite expression start
1226 *F CodeQualifiedExprEnd() . . . . . . code readonly/readwrite expression end
1227 **
1228 ** These functions code the beginning and end of the readonly/readwrite
1229 ** qualified expressions of an atomic statement.
1230 */
CodeQualifiedExprBegin(UInt qual)1231 void CodeQualifiedExprBegin(UInt qual)
1232 {
1233 PushExpr(INTEXPR_INT(qual));
1234 }
1235
CodeQualifiedExprEnd(void)1236 void CodeQualifiedExprEnd(void)
1237 {
1238 }
1239
1240
1241 /****************************************************************************
1242 **
1243 *F CodeWhileBegin() . . . . . . . code while-statement, begin of statement
1244 *F CodeWhileBeginBody() . . . . . . . . code while-statement, begin of body
1245 *F CodeWhileEndBody( <nr> ) . . . . . . . code while-statement, end of body
1246 *F CodeWhileEnd() . . . . . . . . . code while-statement, end of statement
1247 **
1248 ** 'CodeWhileBegin' is an action to code a while-statement. It is called
1249 ** when the reader encounters the 'while', i.e., *before* the condition is
1250 ** read.
1251 **
1252 ** 'CodeWhileBeginBody' is an action to code a while-statement. It is
1253 ** called when the reader encounters the beginning of the statement body,
1254 ** i.e., *after* the condition is read.
1255 **
1256 ** 'CodeWhileEndBody' is an action to code a while-statement. It is called
1257 ** when the reader encounters the end of the statement body. <nr> is the
1258 ** number of statements in the body.
1259 **
1260 ** 'CodeWhileEnd' is an action to code a while-statement. It is called when
1261 ** the reader encounters the end of the statement, i.e., immediate after
1262 ** 'CodeWhileEndBody'.
1263 */
CodeWhileBegin(void)1264 void CodeWhileBegin ( void )
1265 {
1266 }
1267
CodeWhileBeginBody(void)1268 void CodeWhileBeginBody ( void )
1269 {
1270 }
1271
CodeWhileEndBody(UInt nr)1272 void CodeWhileEndBody (
1273 UInt nr )
1274 {
1275 Stat stat; /* while-statement, result */
1276 Expr cond; /* condition */
1277
1278 /* allocate the while-statement */
1279 stat = PopLoopStat(STAT_WHILE, 1, nr);
1280
1281 /* enter the condition */
1282 cond = PopExpr();
1283 WRITE_STAT(stat, 0, cond);
1284
1285 /* push the while-statement */
1286 PushStat( stat );
1287 }
1288
CodeWhileEnd(void)1289 void CodeWhileEnd ( void )
1290 {
1291 }
1292
1293
1294 /****************************************************************************
1295 **
1296 *F CodeRepeatBegin() . . . . . . . code repeat-statement, begin of statement
1297 *F CodeRepeatBeginBody() . . . . . . . code repeat-statement, begin of body
1298 *F CodeRepeatEndBody( <nr> ) . . . . . . code repeat-statement, end of body
1299 *F CodeRepeatEnd() . . . . . . . . . code repeat-statement, end of statement
1300 **
1301 ** 'CodeRepeatBegin' is an action to code a repeat-statement. It is called
1302 ** when the reader encounters the 'repeat'.
1303 **
1304 ** 'CodeRepeatBeginBody' is an action to code a repeat-statement. It is
1305 ** called when the reader encounters the beginning of the statement body,
1306 ** i.e., immediately after 'CodeRepeatBegin'.
1307 **
1308 ** 'CodeRepeatEndBody' is an action to code a repeat-statement. It is
1309 ** called when the reader encounters the end of the statement body, i.e.,
1310 ** *before* the condition is read. <nr> is the number of statements in the
1311 ** body.
1312 **
1313 ** 'CodeRepeatEnd' is an action to code a repeat-statement. It is called
1314 ** when the reader encounters the end of the statement, i.e., *after* the
1315 ** condition is read.
1316 */
CodeRepeatBegin(void)1317 void CodeRepeatBegin ( void )
1318 {
1319 }
1320
CodeRepeatBeginBody(void)1321 void CodeRepeatBeginBody ( void )
1322 {
1323 }
1324
CodeRepeatEndBody(UInt nr)1325 void CodeRepeatEndBody (
1326 UInt nr )
1327 {
1328 /* leave the number of statements in the body on the expression stack */
1329 PushExpr( INTEXPR_INT(nr) );
1330 }
1331
CodeRepeatEnd(void)1332 void CodeRepeatEnd ( void )
1333 {
1334 Stat stat; /* repeat-statement, result */
1335 UInt nr; /* number of statements in body */
1336 Expr cond; /* condition */
1337 Expr tmp; /* temporary */
1338
1339 /* get the condition */
1340 cond = PopExpr();
1341
1342 /* get the number of statements in the body */
1343 /* 'CodeUntil' left this number on the expression stack (hack) */
1344 tmp = PopExpr();
1345 nr = INT_INTEXPR( tmp );
1346
1347 /* allocate the repeat-statement */
1348 stat = PopLoopStat(STAT_REPEAT, 1, nr);
1349
1350 /* enter the condition */
1351 WRITE_STAT(stat, 0, cond);
1352
1353 /* push the repeat-statement */
1354 PushStat( stat );
1355 }
1356
1357
1358 /****************************************************************************
1359 **
1360 *F CodeBreak() . . . . . . . . . . . . . . . . . . . . code break-statement
1361 **
1362 ** 'CodeBreak' is the action to code a break-statement. It is called when
1363 ** the reader encounters a 'break;'.
1364 */
CodeBreak(void)1365 void CodeBreak ( void )
1366 {
1367 Stat stat; /* break-statement, result */
1368
1369 /* allocate the break-statement */
1370 stat = NewStat( STAT_BREAK, 0 * sizeof(Expr) );
1371
1372 /* push the break-statement */
1373 PushStat( stat );
1374 }
1375
1376 /****************************************************************************
1377 **
1378 *F CodeContinue() . . . . . . . . . . . . . . . . . code continue-statement
1379 **
1380 ** 'CodeContinue' is the action to code a continue-statement. It is called
1381 ** when the reader encounters a 'continue;'.
1382 */
CodeContinue(void)1383 void CodeContinue ( void )
1384 {
1385 Stat stat; /* continue-statement, result */
1386
1387 /* allocate the continue-statement */
1388 stat = NewStat( STAT_CONTINUE, 0 * sizeof(Expr) );
1389
1390 /* push the continue-statement */
1391 PushStat( stat );
1392 }
1393
1394
1395 /****************************************************************************
1396 **
1397 *F CodeReturnObj() . . . . . . . . . . . . . . . code return-value-statement
1398 **
1399 ** 'CodeReturnObj' is the action to code a return-value-statement. It is
1400 ** called when the reader encounters a 'return <expr>;', but *after* reading
1401 ** the expression <expr>.
1402 */
CodeReturnObj(void)1403 void CodeReturnObj ( void )
1404 {
1405 Stat stat; /* return-statement, result */
1406 Expr expr; /* expression */
1407
1408 /* allocate the return-statement */
1409 stat = NewStat( STAT_RETURN_OBJ, sizeof(Expr) );
1410
1411 /* enter the expression */
1412 expr = PopExpr();
1413 WRITE_STAT(stat, 0, expr);
1414
1415 /* push the return-statement */
1416 PushStat( stat );
1417 }
1418
1419
1420 /****************************************************************************
1421 **
1422 *F CodeReturnVoid() . . . . . . . . . . . . . . code return-void-statement
1423 **
1424 ** 'CodeReturnVoid' is the action to code a return-void-statement. It is
1425 ** called when the reader encounters a 'return;'.
1426 **
1427 ** 'CodeReturnVoidWhichIsNotProfiled' creates a return which will not
1428 ** be tracked by profiling. This is used for the implicit return put
1429 ** at the end of functions.
1430 */
CodeReturnVoid(void)1431 void CodeReturnVoid ( void )
1432 {
1433 Stat stat; /* return-statement, result */
1434
1435 /* allocate the return-statement */
1436 stat = NewStat( STAT_RETURN_VOID, 0 * sizeof(Expr) );
1437
1438 /* push the return-statement */
1439 PushStat( stat );
1440 }
1441
CodeReturnVoidWhichIsNotProfiled(void)1442 void CodeReturnVoidWhichIsNotProfiled ( void )
1443 {
1444 Stat stat; /* return-statement, result */
1445
1446 /* allocate the return-statement, without profile information */
1447
1448 stat = NewStatOrExpr( STAT_RETURN_VOID, 0 * sizeof(Expr), 0 );
1449
1450 /* push the return-statement */
1451 PushStat( stat );
1452 }
1453
1454
1455 /****************************************************************************
1456 **
1457 *F CodeOr() . . . . . . . . . . . . . . . . . . . . . . code or-expression
1458 *F CodeAnd() . . . . . . . . . . . . . . . . . . . . . . code and-expression
1459 *F CodeNot() . . . . . . . . . . . . . . . . . . . . . . code not-expression
1460 *F CodeEq() . . . . . . . . . . . . . . . . . . . . . . . code =-expression
1461 *F CodeNe() . . . . . . . . . . . . . . . . . . . . . . code <>-expression
1462 *F CodeLt() . . . . . . . . . . . . . . . . . . . . . . . code <-expression
1463 *F CodeGe() . . . . . . . . . . . . . . . . . . . . . . code >=-expression
1464 *F CodeGt() . . . . . . . . . . . . . . . . . . . . . . . code >-expression
1465 *F CodeLe() . . . . . . . . . . . . . . . . . . . . . . code <=-expression
1466 *F CodeIn() . . . . . . . . . . . . . . . . . . . . . . code in-expression
1467 *F CodeSum() . . . . . . . . . . . . . . . . . . . . . . . code +-expression
1468 *F CodeAInv() . . . . . . . . . . . . . . . . . . . code unary --expression
1469 *F CodeDiff() . . . . . . . . . . . . . . . . . . . . . . code --expression
1470 *F CodeProd() . . . . . . . . . . . . . . . . . . . . . . code *-expression
1471 *F CodeQuo() . . . . . . . . . . . . . . . . . . . . . . . code /-expression
1472 *F CodeMod() . . . . . . . . . . . . . . . . . . . . . . code mod-expression
1473 *F CodePow() . . . . . . . . . . . . . . . . . . . . . . . code ^-expression
1474 **
1475 ** 'CodeOr', 'CodeAnd', 'CodeNot', 'CodeEq', 'CodeNe', 'CodeGt', 'CodeGe',
1476 ** 'CodeIn', 'CodeSum', 'CodeDiff', 'CodeProd', 'CodeQuo', 'CodeMod', and
1477 ** 'CodePow' are the actions to code the respective operator expressions.
1478 ** They are called by the reader *after* *both* operands are read.
1479 */
CodeOrL(void)1480 void CodeOrL ( void )
1481 {
1482 }
1483
CodeOr(void)1484 void CodeOr ( void )
1485 {
1486 PushBinaryOp( EXPR_OR );
1487 }
1488
CodeAndL(void)1489 void CodeAndL ( void )
1490 {
1491 }
1492
CodeAnd(void)1493 void CodeAnd ( void )
1494 {
1495 PushBinaryOp( EXPR_AND );
1496 }
1497
CodeNot(void)1498 void CodeNot ( void )
1499 {
1500 // peek at expression
1501 Expr expr = PopExpr();
1502 if ( TNUM_EXPR(expr) == EXPR_TRUE ) {
1503 CodeFalseExpr();
1504 }
1505 else if ( TNUM_EXPR(expr) == EXPR_FALSE ) {
1506 CodeTrueExpr();
1507 }
1508 else {
1509 PushExpr( expr );
1510 PushUnaryOp( EXPR_NOT );
1511 }
1512 }
1513
CodeEq(void)1514 void CodeEq ( void )
1515 {
1516 PushBinaryOp( EXPR_EQ );
1517 }
1518
CodeNe(void)1519 void CodeNe ( void )
1520 {
1521 PushBinaryOp( EXPR_NE );
1522 }
1523
CodeLt(void)1524 void CodeLt ( void )
1525 {
1526 PushBinaryOp( EXPR_LT );
1527 }
1528
CodeGe(void)1529 void CodeGe ( void )
1530 {
1531 PushBinaryOp( EXPR_GE );
1532 }
1533
CodeGt(void)1534 void CodeGt ( void )
1535 {
1536 PushBinaryOp( EXPR_GT );
1537 }
1538
CodeLe(void)1539 void CodeLe ( void )
1540 {
1541 PushBinaryOp( EXPR_LE );
1542 }
1543
CodeIn(void)1544 void CodeIn ( void )
1545 {
1546 PushBinaryOp( EXPR_IN );
1547 }
1548
CodeSum(void)1549 void CodeSum ( void )
1550 {
1551 PushBinaryOp( EXPR_SUM );
1552 }
1553
CodeAInv(void)1554 void CodeAInv ( void )
1555 {
1556 Expr expr;
1557 Int i;
1558
1559 expr = PopExpr();
1560 if ( IS_INTEXPR(expr) && INT_INTEXPR(expr) != INT_INTOBJ_MIN ) {
1561 i = INT_INTEXPR(expr);
1562 PushExpr( INTEXPR_INT( -i ) );
1563 }
1564 else {
1565 PushExpr( expr );
1566 PushUnaryOp( EXPR_AINV );
1567 }
1568 }
1569
CodeDiff(void)1570 void CodeDiff ( void )
1571 {
1572 PushBinaryOp( EXPR_DIFF );
1573 }
1574
CodeProd(void)1575 void CodeProd ( void )
1576 {
1577 PushBinaryOp( EXPR_PROD );
1578 }
1579
CodeQuo(void)1580 void CodeQuo ( void )
1581 {
1582 PushBinaryOp( EXPR_QUO );
1583 }
1584
CodeMod(void)1585 void CodeMod ( void )
1586 {
1587 PushBinaryOp( EXPR_MOD );
1588 }
1589
CodePow(void)1590 void CodePow ( void )
1591 {
1592 PushBinaryOp( EXPR_POW );
1593 }
1594
1595
1596 /****************************************************************************
1597 **
1598 *F CodeIntExpr( <val> ) . . . . . . . . . . code literal integer expression
1599 **
1600 ** 'CodeIntExpr' is the action to code a literal integer expression. <val>
1601 ** is the integer as a GAP object.
1602 */
CodeIntExpr(Obj val)1603 void CodeIntExpr(Obj val)
1604 {
1605 Expr expr; /* expression, result */
1606
1607 /* if it is small enough code it immediately */
1608 if ( IS_INTOBJ(val) ) {
1609 expr = INTEXPR_INT( INT_INTOBJ(val) );
1610 }
1611
1612 /* otherwise stuff the value into the values list */
1613 else {
1614 GAP_ASSERT(TNUM_OBJ(val) == T_INTPOS || TNUM_OBJ(val) == T_INTNEG);
1615 expr = NewExpr( EXPR_INTPOS, sizeof(UInt) );
1616 Int ix = AddValueToBody(val);
1617 WRITE_EXPR(expr, 0, ix);
1618 }
1619
1620 /* push the expression */
1621 PushExpr( expr );
1622 }
1623
1624 /****************************************************************************
1625 **
1626 *F CodeTildeExpr() . . . . . . . . . . . . . . code tilde expression
1627 **
1628 ** 'CodeTildeExpr' is the action to code a tilde expression.
1629 */
CodeTildeExpr(void)1630 void CodeTildeExpr ( void )
1631 {
1632 PushExpr( NewExpr( EXPR_TILDE, 0L ) );
1633 }
1634
1635 /****************************************************************************
1636 **
1637 *F CodeTrueExpr() . . . . . . . . . . . . . . code literal true expression
1638 **
1639 ** 'CodeTrueExpr' is the action to code a literal true expression.
1640 */
CodeTrueExpr(void)1641 void CodeTrueExpr ( void )
1642 {
1643 PushExpr( NewExpr( EXPR_TRUE, 0L ) );
1644 }
1645
1646
1647 /****************************************************************************
1648 **
1649 *F CodeFalseExpr() . . . . . . . . . . . . . . code literal false expression
1650 **
1651 ** 'CodeFalseExpr' is the action to code a literal false expression.
1652 */
CodeFalseExpr(void)1653 void CodeFalseExpr ( void )
1654 {
1655 PushExpr( NewExpr( EXPR_FALSE, 0L ) );
1656 }
1657
1658
1659 /****************************************************************************
1660 **
1661 *F CodeCharExpr( <chr> ) . . . . . . . . code a literal character expression
1662 **
1663 ** 'CodeCharExpr' is the action to code a literal character expression.
1664 ** <chr> is the C character.
1665 */
CodeCharExpr(Char chr)1666 void CodeCharExpr (
1667 Char chr )
1668 {
1669 Expr litr; /* literal expression, result */
1670
1671 /* allocate the character expression */
1672 litr = NewExpr( EXPR_CHAR, sizeof(UChar) );
1673 WRITE_EXPR(litr, 0, chr);
1674
1675 /* push the literal expression */
1676 PushExpr( litr );
1677 }
1678
1679
1680 /****************************************************************************
1681 **
1682 *F CodePermCycle( <nrx>, <nrc> ) . . . . code literal permutation expression
1683 *F CodePerm( <nrc> ) . . . . . . . . . . code literal permutation expression
1684 **
1685 ** 'CodePermCycle' is an action to code a literal permutation expression.
1686 ** It is called when one cycles is read completely. <nrc> is the number of
1687 ** elements in that cycle. <nrx> is the number of that cycles (i.e., 1 for
1688 ** the first cycle, 2 for the second, and so on).
1689 **
1690 ** 'CodePerm' is an action to code a literal permutation expression. It is
1691 ** called when the permutation is read completely. <nrc> is the number of
1692 ** cycles.
1693 */
CodePermCycle(UInt nrx,UInt nrc)1694 void CodePermCycle (
1695 UInt nrx,
1696 UInt nrc )
1697 {
1698 Expr cycle; /* cycle, result */
1699 Expr entry; /* entry of cycle */
1700 UInt j; /* loop variable */
1701
1702 /* allocate the new cycle */
1703 cycle = NewExpr( EXPR_PERM_CYCLE, nrx * sizeof(Expr) );
1704
1705 /* enter the entries */
1706 for ( j = nrx; 1 <= j; j-- ) {
1707 entry = PopExpr();
1708 WRITE_EXPR(cycle, j - 1, entry);
1709 }
1710
1711 /* push the cycle */
1712 PushExpr( cycle );
1713 }
1714
CodePerm(UInt nrc)1715 void CodePerm (
1716 UInt nrc )
1717 {
1718 Expr perm; /* permutation, result */
1719 Expr cycle; /* cycle of permutation */
1720 UInt i; /* loop variable */
1721
1722 /* allocate the new permutation */
1723 perm = NewExpr( EXPR_PERM, nrc * sizeof(Expr) );
1724
1725 /* enter the cycles */
1726 for ( i = nrc; 1 <= i; i-- ) {
1727 cycle = PopExpr();
1728 WRITE_EXPR(perm, i - 1, cycle);
1729 }
1730
1731 /* push the permutation */
1732 PushExpr( perm );
1733
1734 }
1735
1736
1737 /****************************************************************************
1738 **
1739 *F CodeListExprBegin( <top> ) . . . . . . . . . code list expression, begin
1740 *F CodeListExprBeginElm( <pos> ) . . . . code list expression, begin element
1741 *F CodeListExprEndElm() . . . . . . . .. code list expression, end element
1742 *F CodeListExprEnd( <nr>, <range>, <top>, <tilde> ) . . code list expr, end
1743 */
CodeListExprBegin(UInt top)1744 void CodeListExprBegin (
1745 UInt top )
1746 {
1747 }
1748
CodeListExprBeginElm(UInt pos)1749 void CodeListExprBeginElm (
1750 UInt pos )
1751 {
1752 /* push the literal integer value */
1753 PushExpr( INTEXPR_INT(pos) );
1754 }
1755
CodeListExprEndElm(void)1756 void CodeListExprEndElm ( void )
1757 {
1758 }
1759
CodeListExprEnd(UInt nr,UInt range,UInt top,UInt tilde)1760 void CodeListExprEnd (
1761 UInt nr,
1762 UInt range,
1763 UInt top,
1764 UInt tilde )
1765 {
1766 Expr list; /* list, result */
1767 Expr entry; /* entry */
1768 Expr pos; /* position of an entry */
1769 UInt i; /* loop variable */
1770
1771 /* peek at the last position (which is the largest) */
1772 if ( nr != 0 ) {
1773 entry = PopExpr();
1774 pos = PopExpr();
1775 PushExpr( pos );
1776 PushExpr( entry );
1777 }
1778 else {
1779 pos = INTEXPR_INT(0);
1780 }
1781
1782 /* allocate the list expression */
1783 if ( ! range && ! (top && tilde) ) {
1784 list = NewExpr( EXPR_LIST, INT_INTEXPR(pos) * sizeof(Expr) );
1785 }
1786 else if ( ! range && (top && tilde) ) {
1787 list = NewExpr( EXPR_LIST_TILDE, INT_INTEXPR(pos) * sizeof(Expr) );
1788 }
1789 else /* if ( range && ! (top && tilde) ) */ {
1790 list = NewExpr( EXPR_RANGE, INT_INTEXPR(pos) * sizeof(Expr) );
1791 }
1792
1793 /* enter the entries */
1794 for ( i = nr; 1 <= i; i-- ) {
1795 entry = PopExpr();
1796 pos = PopExpr();
1797 WRITE_EXPR(list, INT_INTEXPR(pos) - 1, entry);
1798 }
1799
1800 /* push the list */
1801 PushExpr( list );
1802 }
1803
1804
1805 /****************************************************************************
1806 **
1807 *F CodeStringExpr( <str> ) . . . . . . . . code literal string expression
1808 */
CodeStringExpr(Obj str)1809 void CodeStringExpr (
1810 Obj str )
1811 {
1812 GAP_ASSERT(IS_STRING_REP(str));
1813
1814 Expr string = NewExpr( EXPR_STRING, sizeof(UInt) );
1815 Int ix = AddValueToBody(str);
1816 WRITE_EXPR(string, 0, ix);
1817 PushExpr( string );
1818 }
1819
CodePragma(Obj pragma)1820 void CodePragma(Obj pragma)
1821 {
1822 GAP_ASSERT(IS_STRING_REP(pragma));
1823
1824 Expr pragmaexpr = NewStat(STAT_PRAGMA, sizeof(UInt));
1825 Int ix = AddValueToBody(pragma);
1826 WRITE_EXPR(pragmaexpr, 0, ix);
1827 PushStat(pragmaexpr);
1828 }
1829
1830
1831 /****************************************************************************
1832 **
1833 *F CodeFloatExpr( <str> ) . . . . . . . . code literal float expression
1834 */
1835 enum {
1836 FLOAT_0_INDEX = 1, // reserved for constant 0.0
1837 FLOAT_1_INDEX = 2, // reserved for constant 1.0
1838
1839 // the maximal index must be less than INT_INTOBJ_MAX and INT_MAX, so
1840 // simply hardcode it to 1<<28
1841 MAX_FLOAT_INDEX = (1<<28) - 2,
1842 };
1843 static UInt NextFloatExprNumber = 3;
1844
1845 static Obj CONVERT_FLOAT_LITERAL_EAGER;
1846
1847
getNextFloatExprNumber(void)1848 static UInt getNextFloatExprNumber(void)
1849 {
1850 UInt next;
1851 HashLock(&NextFloatExprNumber);
1852 assert(NextFloatExprNumber < MAX_FLOAT_INDEX);
1853 next = NextFloatExprNumber++;
1854 HashUnlock(&NextFloatExprNumber);
1855 return next;
1856 }
1857
CheckForCommonFloat(const Char * str)1858 static UInt CheckForCommonFloat(const Char * str)
1859 {
1860 /* skip leading zeros */
1861 while (*str == '0')
1862 str++;
1863 /* might be zero literal */
1864 if (*str == '.') {
1865 /* skip point */
1866 str++;
1867 /* skip more zeroes */
1868 while (*str == '0')
1869 str++;
1870 /* if we've got to end of string we've got zero. */
1871 if (!IsDigit(*str))
1872 return FLOAT_0_INDEX;
1873 }
1874 if (*str++ != '1')
1875 return 0;
1876 /* might be one literal */
1877 if (*str++ != '.')
1878 return 0;
1879 /* skip zeros */
1880 while (*str == '0')
1881 str++;
1882 if (*str == '\0')
1883 return FLOAT_1_INDEX;
1884 if (IsDigit(*str))
1885 return 0;
1886 /* must now be an exponent character */
1887 assert(IsAlpha(*str));
1888 /* skip it */
1889 str++;
1890 /*skip + and - in exponent */
1891 if (*str == '+' || *str == '-')
1892 str++;
1893 /* skip leading zeros in the exponent */
1894 while (*str == '0')
1895 str++;
1896 /* if there's anything but leading zeros this isn't
1897 a one literal */
1898 if (*str == '\0')
1899 return FLOAT_1_INDEX;
1900 else
1901 return 0;
1902 }
1903
CodeLazyFloatExpr(Obj str,UInt pushExpr)1904 Expr CodeLazyFloatExpr(Obj str, UInt pushExpr)
1905 {
1906 UInt ix;
1907
1908 /* Lazy case, store the string for conversion at run time */
1909 Expr fl = NewExpr(EXPR_FLOAT_LAZY, 2 * sizeof(UInt));
1910
1911 ix = CheckForCommonFloat(CONST_CSTR_STRING(str));
1912 if (!ix)
1913 ix = getNextFloatExprNumber();
1914 WRITE_EXPR(fl, 0, ix);
1915 WRITE_EXPR(fl, 1, AddValueToBody(str));
1916
1917 /* push the expression */
1918 if (pushExpr) {
1919 PushExpr(fl);
1920 }
1921 return fl;
1922 }
1923
CodeEagerFloatExpr(Obj str,Char mark)1924 static void CodeEagerFloatExpr(Obj str, Char mark)
1925 {
1926 /* Eager case, do the conversion now */
1927 Expr fl = NewExpr(EXPR_FLOAT_EAGER, sizeof(UInt) * 3);
1928 Obj v = CALL_2ARGS(CONVERT_FLOAT_LITERAL_EAGER, str, ObjsChar[(Int)mark]);
1929 WRITE_EXPR(fl, 0, AddValueToBody(v));
1930 WRITE_EXPR(fl, 1, AddValueToBody(str)); // store for printing
1931 WRITE_EXPR(fl, 2, (UInt)mark);
1932 PushExpr(fl);
1933 }
1934
CodeFloatExpr(Obj s)1935 void CodeFloatExpr(Obj s)
1936 {
1937 Char * str = CSTR_STRING(s);
1938
1939 const UInt l = GET_LEN_STRING(s);
1940 UInt l1 = l;
1941 Char mark = '\0'; /* initialize to please compilers */
1942 if (str[l - 1] == '_') {
1943 l1 = l - 1;
1944 mark = '\0';
1945 }
1946 else if (str[l - 2] == '_') {
1947 l1 = l - 2;
1948 mark = str[l - 1];
1949 }
1950 if (l1 < l) {
1951 str[l1] = '\0';
1952 SET_LEN_STRING(s, l1);
1953 CodeEagerFloatExpr(s, mark);
1954 }
1955 else {
1956 CodeLazyFloatExpr(s, 1);
1957 }
1958 }
1959
1960
1961 /****************************************************************************
1962 **
1963 *F CodeRecExprBegin( <top> ) . . . . . . . . . . . . code record expr, begin
1964 *F CodeRecExprBeginElmName( <rnam> ) . . . . code record expr, begin element
1965 *F CodeRecExprBeginElmExpr() . . . . . . . . code record expr, begin element
1966 *F CodeRecExprEndElmExpr() . . . . . . . . . . code record expr, end element
1967 *F CodeRecExprEnd( <nr>, <top>, <tilde> ) . . . . . . code record expr, end
1968 */
CodeRecExprBegin(UInt top)1969 void CodeRecExprBegin (
1970 UInt top )
1971 {
1972 }
1973
CodeRecExprBeginElmName(UInt rnam)1974 void CodeRecExprBeginElmName (
1975 UInt rnam )
1976 {
1977 /* push the record name as integer expressions */
1978 PushExpr( INTEXPR_INT( rnam ) );
1979 }
1980
CodeRecExprBeginElmExpr(void)1981 void CodeRecExprBeginElmExpr ( void )
1982 {
1983 Expr expr;
1984
1985 /* convert an integer expression to a record name */
1986 expr = PopExpr();
1987 if ( IS_INTEXPR(expr) ) {
1988 PushExpr( INTEXPR_INT( RNamIntg( INT_INTEXPR(expr) ) ) );
1989 }
1990 else {
1991 PushExpr( expr );
1992 }
1993 }
1994
CodeRecExprEndElm(void)1995 void CodeRecExprEndElm ( void )
1996 {
1997 }
1998
CodeRecExprEnd(UInt nr,UInt top,UInt tilde)1999 void CodeRecExprEnd (
2000 UInt nr,
2001 UInt top,
2002 UInt tilde )
2003 {
2004 Expr record; /* record, result */
2005 Expr entry; /* entry */
2006 Expr rnam; /* position of an entry */
2007 UInt i; /* loop variable */
2008
2009 /* allocate the record expression */
2010 if ( ! (top && tilde) ) {
2011 record = NewExpr( EXPR_REC, nr * 2 * sizeof(Expr) );
2012 }
2013 else /* if ( (top && tilde) ) */ {
2014 record = NewExpr( EXPR_REC_TILDE, nr * 2 * sizeof(Expr) );
2015 }
2016
2017 /* enter the entries */
2018 for ( i = nr; 1 <= i; i-- ) {
2019 entry = PopExpr();
2020 rnam = PopExpr();
2021 WRITE_EXPR(record, 2 * (i - 1), rnam);
2022 WRITE_EXPR(record, 2 * (i - 1) + 1, entry);
2023 }
2024
2025 /* push the record */
2026 PushExpr( record );
2027 }
2028
2029
2030 /****************************************************************************
2031 **
2032 *F CodeAssLVar( <lvar> ) . . . . . . . . . . . . . code assignment to local
2033 **
2034 ** 'CodeAssLVar' is the action to code an assignment to the local variable
2035 ** <lvar> (given by its index). It is called by the reader *after* the
2036 ** right hand side expression is read.
2037 **
2038 ** An assignment to a local variable is represented by a bag with two
2039 ** subexpressions. The *first* is the local variable, the *second* is the
2040 ** right hand side expression.
2041 */
CodeAssLVar(UInt lvar)2042 void CodeAssLVar (
2043 UInt lvar )
2044 {
2045 Stat ass; /* assignment, result */
2046 Expr rhsx; /* right hand side expression */
2047
2048 /* allocate the assignment */
2049 ass = NewStat( STAT_ASS_LVAR, 2 * sizeof(Stat) );
2050
2051 /* enter the right hand side expression */
2052 rhsx = PopExpr();
2053 WRITE_STAT(ass, 1, rhsx);
2054
2055 /* enter the local variable */
2056 WRITE_STAT(ass, 0, lvar);
2057
2058 /* push the assignment */
2059 PushStat( ass );
2060 }
2061
2062
2063 /****************************************************************************
2064 **
2065 *F CodeUnbLVar( <lvar> ) . . . . . . . . . . . code unbind a local variable
2066 */
CodeUnbLVar(UInt lvar)2067 void CodeUnbLVar (
2068 UInt lvar )
2069 {
2070 Stat ass; /* unbind, result */
2071
2072 /* allocate the unbind */
2073 ass = NewStat( STAT_UNB_LVAR, sizeof(Stat) );
2074
2075 /* enter the local variable */
2076 WRITE_STAT(ass, 0, lvar);
2077
2078 /* push the unbind */
2079 PushStat( ass );
2080 }
2081
2082
2083 /****************************************************************************
2084 **
2085 *F CodeRefLVar( <lvar> ) . . . . . . . . . . . . . . code reference to local
2086 **
2087 ** 'CodeRefLVar' is the action to code a reference to the local variable
2088 ** <lvar> (given by its index). It is called by the reader when it
2089 ** encounters a local variable.
2090 **
2091 ** A reference to a local variable is represented immediately (see
2092 ** 'REF_LVAR_LVAR').
2093 */
CodeRefLVar(UInt lvar)2094 void CodeRefLVar (
2095 UInt lvar )
2096 {
2097 Expr ref; /* reference, result */
2098
2099 /* make the reference */
2100 ref = REF_LVAR_LVAR(lvar);
2101
2102 /* push the reference */
2103 PushExpr( ref );
2104 }
2105
2106
2107 /****************************************************************************
2108 **
2109 *F CodeIsbLVar( <lvar> ) . . . . . . . . . . code bound local variable check
2110 */
CodeIsbLVar(UInt lvar)2111 void CodeIsbLVar (
2112 UInt lvar )
2113 {
2114 Expr ref; /* isbound, result */
2115
2116 /* allocate the isbound */
2117 ref = NewExpr( EXPR_ISB_LVAR, sizeof(Expr) );
2118
2119 /* enter the local variable */
2120 WRITE_EXPR(ref, 0, lvar);
2121
2122 /* push the isbound */
2123 PushExpr( ref );
2124 }
2125
2126
2127 /****************************************************************************
2128 **
2129 *F CodeAssHVar( <hvar> ) . . . . . . . . . . . . . code assignment to higher
2130 **
2131 ** 'CodeAssHVar' is the action to code an assignment to the higher variable
2132 ** <hvar> (given by its level and index). It is called by the reader
2133 ** *after* the right hand side expression is read.
2134 **
2135 ** An assignment to a higher variable is represented by a statement bag with
2136 ** two subexpressions. The *first* is the higher variable, the *second* is
2137 ** the right hand side expression.
2138 */
CodeAssHVar(UInt hvar)2139 void CodeAssHVar (
2140 UInt hvar )
2141 {
2142 Stat ass; /* assignment, result */
2143 Expr rhsx; /* right hand side expression */
2144
2145 /* allocate the assignment */
2146 ass = NewStat( STAT_ASS_HVAR, 2 * sizeof(Stat) );
2147
2148 /* enter the right hand side expression */
2149 rhsx = PopExpr();
2150 WRITE_STAT(ass, 1, rhsx);
2151
2152 /* enter the higher variable */
2153 WRITE_STAT(ass, 0, hvar);
2154
2155 /* push the assignment */
2156 PushStat( ass );
2157 }
2158
2159
2160 /****************************************************************************
2161 **
2162 *F CodeUnbHVar( <hvar> ) . . . . . . . . . . . . . . . code unbind of higher
2163 */
CodeUnbHVar(UInt hvar)2164 void CodeUnbHVar (
2165 UInt hvar )
2166 {
2167 Stat ass; /* unbind, result */
2168
2169 /* allocate the unbind */
2170 ass = NewStat( STAT_UNB_HVAR, sizeof(Stat) );
2171
2172 /* enter the higher variable */
2173 WRITE_STAT(ass, 0, hvar);
2174
2175 /* push the unbind */
2176 PushStat( ass );
2177 }
2178
2179
2180 /****************************************************************************
2181 **
2182 *F CodeRefHVar( <hvar> ) . . . . . . . . . . . . . code reference to higher
2183 **
2184 ** 'CodeRefHVar' is the action to code a reference to the higher variable
2185 ** <hvar> (given by its level and index). It is called by the reader when
2186 ** it encounters a higher variable.
2187 **
2188 ** A reference to a higher variable is represented by an expression bag with
2189 ** one subexpression. This is the higher variable.
2190 */
CodeRefHVar(UInt hvar)2191 void CodeRefHVar (
2192 UInt hvar )
2193 {
2194 Expr ref; /* reference, result */
2195
2196 /* allocate the reference */
2197 ref = NewExpr( EXPR_REF_HVAR, sizeof(Expr) );
2198
2199 /* enter the higher variable */
2200 WRITE_EXPR(ref, 0, hvar);
2201
2202 /* push the reference */
2203 PushExpr( ref );
2204 }
2205
2206
2207 /****************************************************************************
2208 **
2209 *F CodeIsbHVar( <hvar> ) . . . . . . . . . . . . . . code bound higher check
2210 */
CodeIsbHVar(UInt hvar)2211 void CodeIsbHVar (
2212 UInt hvar )
2213 {
2214 Expr ref; /* isbound, result */
2215
2216 /* allocate the isbound */
2217 ref = NewExpr( EXPR_ISB_HVAR, sizeof(Expr) );
2218
2219 /* enter the higher variable */
2220 WRITE_EXPR(ref, 0, hvar);
2221
2222 /* push the isbound */
2223 PushExpr( ref );
2224 }
2225
2226
2227 /****************************************************************************
2228 **
2229 *F CodeAssGVar( <gvar> ) . . . . . . . . . . . . . code assignment to global
2230 **
2231 ** 'CodeAssGVar' is the action to code an assignment to the global variable
2232 ** <gvar>. It is called by the reader *after* the right hand side
2233 ** expression is read.
2234 **
2235 ** An assignment to a global variable is represented by a statement bag with
2236 ** two subexpressions. The *first* is the global variable, the *second* is
2237 ** the right hand side expression.
2238 */
CodeAssGVar(UInt gvar)2239 void CodeAssGVar (
2240 UInt gvar )
2241 {
2242 Stat ass; /* assignment, result */
2243 Expr rhsx; /* right hand side expression */
2244
2245 /* allocate the assignment */
2246 ass = NewStat( STAT_ASS_GVAR, 2 * sizeof(Stat) );
2247
2248 /* enter the right hand side expression */
2249 rhsx = PopExpr();
2250 WRITE_STAT(ass, 1, rhsx);
2251
2252 /* enter the global variable */
2253 WRITE_STAT(ass, 0, gvar);
2254
2255 /* push the assignment */
2256 PushStat( ass );
2257 }
2258
2259
2260 /****************************************************************************
2261 **
2262 *F CodeUnbGVar( <gvar> ) . . . . . . . . . . . . . . . code unbind of global
2263 */
CodeUnbGVar(UInt gvar)2264 void CodeUnbGVar (
2265 UInt gvar )
2266 {
2267 Stat ass; /* unbind, result */
2268
2269 /* allocate the unbind */
2270 ass = NewStat( STAT_UNB_GVAR, sizeof(Stat) );
2271
2272 /* enter the global variable */
2273 WRITE_STAT(ass, 0, gvar);
2274
2275 /* push the unbind */
2276 PushStat( ass );
2277 }
2278
2279
2280 /****************************************************************************
2281 **
2282 *F CodeRefGVar( <gvar> ) . . . . . . . . . . . . . code reference to global
2283 **
2284 ** 'CodeRefGVar' is the action to code a reference to the global variable
2285 ** <gvar>. It is called by the reader when it encounters a global variable.
2286 **
2287 ** A reference to a global variable is represented by an expression bag with
2288 ** one subexpression. This is the global variable.
2289 */
CodeRefGVar(UInt gvar)2290 void CodeRefGVar (
2291 UInt gvar )
2292 {
2293 Expr ref; /* reference, result */
2294
2295 /* allocate the reference */
2296 ref = NewExpr( EXPR_REF_GVAR, sizeof(Expr) );
2297
2298 /* enter the global variable */
2299 WRITE_EXPR(ref, 0, gvar);
2300
2301 /* push the reference */
2302 PushExpr( ref );
2303 }
2304
2305
2306 /****************************************************************************
2307 **
2308 *F CodeIsbGVar( <gvar> ) . . . . . . . . . . . . . . code bound global check
2309 */
CodeIsbGVar(UInt gvar)2310 void CodeIsbGVar (
2311 UInt gvar )
2312 {
2313 Expr ref; /* isbound, result */
2314
2315 /* allocate the isbound */
2316 ref = NewExpr( EXPR_ISB_GVAR, sizeof(Expr) );
2317
2318 /* enter the global variable */
2319 WRITE_EXPR(ref, 0, gvar);
2320
2321 /* push the isbound */
2322 PushExpr( ref );
2323 }
2324
2325
2326 /****************************************************************************
2327 **
2328 *F CodeAssList() . . . . . . . . . . . . . . . . . code assignment to a list
2329 *F CodeAsssList() . . . . . . . . . . . code multiple assignment to a list
2330 *F CodeAssListLevel( <level> ) . . . . . . code assignment to several lists
2331 *F CodeAsssListLevel( <level> ) . code multiple assignment to several lists
2332 */
CodeAssListUniv(Stat ass,Int narg)2333 static void CodeAssListUniv(Stat ass, Int narg)
2334 {
2335 Expr list; /* list expression */
2336 Expr pos; /* position expression */
2337 Expr rhsx; /* right hand side expression */
2338 Int i;
2339
2340 /* enter the right hand side expression */
2341 rhsx = PopExpr();
2342 WRITE_STAT(ass, narg + 1, rhsx);
2343
2344 /* enter the position expression */
2345 for (i = narg; i > 0; i--) {
2346 pos = PopExpr();
2347 WRITE_STAT(ass, i, pos);
2348 }
2349
2350 /* enter the list expression */
2351 list = PopExpr();
2352 WRITE_STAT(ass, 0, list);
2353
2354 /* push the assignment */
2355 PushStat( ass );
2356 }
2357
CodeAssList(Int narg)2358 void CodeAssList ( Int narg )
2359 {
2360 Stat ass; /* assignment, result */
2361
2362 GAP_ASSERT(narg == 1 || narg == 2);
2363
2364 /* allocate the assignment */
2365 if (narg == 1)
2366 ass = NewStat( STAT_ASS_LIST, 3 * sizeof(Stat) );
2367 else /* if (narg == 2) */
2368 ass = NewStat( STAT_ASS_MAT, 4 * sizeof(Stat));
2369
2370 /* let 'CodeAssListUniv' do the rest */
2371 CodeAssListUniv( ass, narg );
2372 }
2373
CodeAsssList(void)2374 void CodeAsssList ( void )
2375 {
2376 Stat ass; /* assignment, result */
2377
2378 /* allocate the assignment */
2379 ass = NewStat( STAT_ASSS_LIST, 3 * sizeof(Stat) );
2380
2381 /* let 'CodeAssListUniv' do the rest */
2382 CodeAssListUniv( ass, 1 );
2383 }
2384
CodeAssListLevel(Int narg,UInt level)2385 void CodeAssListLevel ( Int narg,
2386 UInt level )
2387 {
2388 Stat ass; /* assignment, result */
2389
2390 /* allocate the assignment and enter the level */
2391 ass = NewStat( STAT_ASS_LIST_LEV, (narg + 3) * sizeof(Stat) );
2392 WRITE_STAT(ass, narg + 2, level);
2393
2394 /* let 'CodeAssListUniv' do the rest */
2395 CodeAssListUniv( ass, narg );
2396 }
2397
CodeAsssListLevel(UInt level)2398 void CodeAsssListLevel (
2399 UInt level )
2400 {
2401 Stat ass; /* assignment, result */
2402
2403 /* allocate the assignment and enter the level */
2404 ass = NewStat( STAT_ASSS_LIST_LEV, 4 * sizeof(Stat) );
2405 WRITE_STAT(ass, 3, level);
2406
2407 /* let 'CodeAssListUniv' do the rest */
2408 CodeAssListUniv( ass, 1 );
2409 }
2410
2411
2412 /****************************************************************************
2413 **
2414 *F CodeUnbList() . . . . . . . . . . . . . . . code unbind of list position
2415 */
CodeUnbList(Int narg)2416 void CodeUnbList ( Int narg )
2417 {
2418 Stat ass; /* unbind, result */
2419 Expr list; /* list expression */
2420 Expr pos; /* position expression */
2421 Int i;
2422
2423 /* allocate the unbind */
2424 ass = NewStat( STAT_UNB_LIST, (narg+1) * sizeof(Stat) );
2425
2426 /* enter the position expressions */
2427 for (i = narg; i > 0; i--) {
2428 pos = PopExpr();
2429 WRITE_STAT(ass, i, pos);
2430 }
2431
2432 /* enter the list expression */
2433 list = PopExpr();
2434 WRITE_STAT(ass, 0, list);
2435
2436 /* push the unbind */
2437 PushStat( ass );
2438 }
2439
2440
2441 /****************************************************************************
2442 **
2443 *F CodeElmList() . . . . . . . . . . . . . . . . . code selection of a list
2444 *F CodeElmsList() . . . . . . . . . . . . code multiple selection of a list
2445 *F CodeElmListLevel( <level> ) . . . . . . . code selection of several lists
2446 *F CodeElmsListLevel( <level> ) . code multiple selection of several lists
2447 */
CodeElmListUniv(Expr ref,Int narg)2448 static void CodeElmListUniv (
2449 Expr ref,
2450 Int narg)
2451 {
2452 Expr list; /* list expression */
2453 Expr pos; /* position expression */
2454 Int i;
2455
2456 /* enter the position expression */
2457
2458 for (i = narg; i > 0; i--) {
2459 pos = PopExpr();
2460 WRITE_EXPR(ref, i, pos);
2461 }
2462
2463 /* enter the list expression */
2464 list = PopExpr();
2465 WRITE_EXPR(ref, 0, list);
2466
2467 /* push the reference */
2468 PushExpr( ref );
2469 }
2470
CodeElmList(Int narg)2471 void CodeElmList ( Int narg )
2472 {
2473 Expr ref; /* reference, result */
2474
2475 GAP_ASSERT(narg == 1 || narg == 2);
2476
2477 /* allocate the reference */
2478 if (narg == 1)
2479 ref = NewExpr( EXPR_ELM_LIST, 2 * sizeof(Expr) );
2480 else /* if (narg == 2) */
2481 ref = NewExpr( EXPR_ELM_MAT, 3 * sizeof(Expr) );
2482
2483 /* let 'CodeElmListUniv' to the rest */
2484 CodeElmListUniv( ref, narg );
2485 }
2486
CodeElmsList(void)2487 void CodeElmsList ( void )
2488 {
2489 Expr ref; /* reference, result */
2490
2491 /* allocate the reference */
2492 ref = NewExpr( EXPR_ELMS_LIST, 2 * sizeof(Expr) );
2493
2494 /* let 'CodeElmListUniv' to the rest */
2495 CodeElmListUniv( ref, 1 );
2496 }
2497
CodeElmListLevel(Int narg,UInt level)2498 void CodeElmListLevel ( Int narg,
2499 UInt level )
2500 {
2501 Expr ref; /* reference, result */
2502
2503 /* allocate the reference and enter the level */
2504 ref = NewExpr( EXPR_ELM_LIST_LEV, (narg + 2) * sizeof(Expr));
2505 WRITE_EXPR(ref, narg + 1, level);
2506
2507 /* let 'CodeElmListUniv' do the rest */
2508 CodeElmListUniv( ref, narg );
2509 }
2510
CodeElmsListLevel(UInt level)2511 void CodeElmsListLevel (
2512 UInt level )
2513 {
2514 Expr ref; /* reference, result */
2515
2516 /* allocate the reference and enter the level */
2517 ref = NewExpr( EXPR_ELMS_LIST_LEV, 3 * sizeof(Expr) );
2518 WRITE_EXPR(ref, 2, level);
2519
2520 /* let 'CodeElmListUniv' do the rest */
2521 CodeElmListUniv( ref, 1 );
2522 }
2523
2524
2525 /****************************************************************************
2526 **
2527 *F CodeIsbList() . . . . . . . . . . . . . . code bound list position check
2528 */
CodeIsbList(Int narg)2529 void CodeIsbList ( Int narg )
2530 {
2531 Expr ref; /* isbound, result */
2532 Expr list; /* list expression */
2533 Expr pos; /* position expression */
2534 Int i;
2535
2536 /* allocate the isbound */
2537 ref = NewExpr( EXPR_ISB_LIST, (narg + 1) * sizeof(Expr) );
2538
2539 /* enter the position expression */
2540 for (i = narg; i > 0; i--) {
2541 pos = PopExpr();
2542 WRITE_EXPR(ref, i, pos);
2543 }
2544
2545 /* enter the list expression */
2546 list = PopExpr();
2547 WRITE_EXPR(ref, 0, list);
2548
2549 /* push the isbound */
2550 PushExpr( ref );
2551 }
2552
2553
2554 /****************************************************************************
2555 **
2556 *F CodeAssRecName( <rnam> ) . . . . . . . . . . code assignment to a record
2557 *F CodeAssRecExpr() . . . . . . . . . . . . . . code assignment to a record
2558 */
CodeAssRecName(UInt rnam)2559 void CodeAssRecName (
2560 UInt rnam )
2561 {
2562 Stat stat; /* assignment, result */
2563 Expr rec; /* record expression */
2564 Expr rhsx; /* right hand side expression */
2565
2566 /* allocate the assignment */
2567 stat = NewStat( STAT_ASS_REC_NAME, 3 * sizeof(Stat) );
2568
2569 /* enter the right hand side expression */
2570 rhsx = PopExpr();
2571 WRITE_STAT(stat, 2, rhsx);
2572
2573 /* enter the name */
2574 WRITE_STAT(stat, 1, rnam);
2575
2576 /* enter the record expression */
2577 rec = PopExpr();
2578 WRITE_STAT(stat, 0, rec);
2579
2580 /* push the assignment */
2581 PushStat( stat );
2582 }
2583
CodeAssRecExpr(void)2584 void CodeAssRecExpr ( void )
2585 {
2586 Stat stat; /* assignment, result */
2587 Expr rec; /* record expression */
2588 Expr rnam; /* name expression */
2589 Expr rhsx; /* right hand side expression */
2590
2591 /* allocate the assignment */
2592 stat = NewStat( STAT_ASS_REC_EXPR, 3 * sizeof(Stat) );
2593
2594 /* enter the right hand side expression */
2595 rhsx = PopExpr();
2596 WRITE_STAT(stat, 2, rhsx);
2597
2598 /* enter the name expression */
2599 rnam = PopExpr();
2600 WRITE_STAT(stat, 1, rnam);
2601
2602 /* enter the record expression */
2603 rec = PopExpr();
2604 WRITE_STAT(stat, 0, rec);
2605
2606 /* push the assignment */
2607 PushStat( stat );
2608 }
2609
CodeUnbRecName(UInt rnam)2610 void CodeUnbRecName (
2611 UInt rnam )
2612 {
2613 Stat stat; /* unbind, result */
2614 Expr rec; /* record expression */
2615
2616 /* allocate the unbind */
2617 stat = NewStat( STAT_UNB_REC_NAME, 2 * sizeof(Stat) );
2618
2619 /* enter the name */
2620 WRITE_STAT(stat, 1, rnam);
2621
2622 /* enter the record expression */
2623 rec = PopExpr();
2624 WRITE_STAT(stat, 0, rec);
2625
2626 /* push the unbind */
2627 PushStat( stat );
2628 }
2629
CodeUnbRecExpr(void)2630 void CodeUnbRecExpr ( void )
2631 {
2632 Stat stat; /* unbind, result */
2633 Expr rec; /* record expression */
2634 Expr rnam; /* name expression */
2635
2636 /* allocate the unbind */
2637 stat = NewStat( STAT_UNB_REC_EXPR, 2 * sizeof(Stat) );
2638
2639 /* enter the name expression */
2640 rnam = PopExpr();
2641 WRITE_STAT(stat, 1, rnam);
2642
2643 /* enter the record expression */
2644 rec = PopExpr();
2645 WRITE_STAT(stat, 0, rec);
2646
2647 /* push the unbind */
2648 PushStat( stat );
2649 }
2650
2651
2652 /****************************************************************************
2653 **
2654 *F CodeElmRecName( <rnam> ) . . . . . . . . . . code selection of a record
2655 *F CodeElmRecExpr() . . . . . . . . . . . . . . code selection of a record
2656 */
CodeElmRecName(UInt rnam)2657 void CodeElmRecName (
2658 UInt rnam )
2659 {
2660 Expr expr; /* reference, result */
2661 Expr rec; /* record expression */
2662
2663 /* allocate the reference */
2664 expr = NewExpr( EXPR_ELM_REC_NAME, 2 * sizeof(Expr) );
2665
2666 /* enter the name */
2667 WRITE_EXPR(expr, 1, rnam);
2668
2669 /* enter the record expression */
2670 rec = PopExpr();
2671 WRITE_EXPR(expr, 0, rec);
2672
2673 /* push the reference */
2674 PushExpr( expr );
2675 }
2676
CodeElmRecExpr(void)2677 void CodeElmRecExpr ( void )
2678 {
2679 Expr expr; /* reference, result */
2680 Expr rnam; /* name expression */
2681 Expr rec; /* record expression */
2682
2683 /* allocate the reference */
2684 expr = NewExpr( EXPR_ELM_REC_EXPR, 2 * sizeof(Expr) );
2685
2686 /* enter the expression */
2687 rnam = PopExpr();
2688 WRITE_EXPR(expr, 1, rnam);
2689
2690 /* enter the record expression */
2691 rec = PopExpr();
2692 WRITE_EXPR(expr, 0, rec);
2693
2694 /* push the reference */
2695 PushExpr( expr );
2696 }
2697
2698
2699 /****************************************************************************
2700 **
2701 *F CodeIsbRecName( <rnam> ) . . . . . . . . . . . code bound rec name check
2702 */
CodeIsbRecName(UInt rnam)2703 void CodeIsbRecName (
2704 UInt rnam )
2705 {
2706 Expr expr; /* isbound, result */
2707 Expr rec; /* record expression */
2708
2709 /* allocate the isbound */
2710 expr = NewExpr( EXPR_ISB_REC_NAME, 2 * sizeof(Expr) );
2711
2712 /* enter the name */
2713 WRITE_EXPR(expr, 1, rnam);
2714
2715 /* enter the record expression */
2716 rec = PopExpr();
2717 WRITE_EXPR(expr, 0, rec);
2718
2719 /* push the isbound */
2720 PushExpr( expr );
2721 }
2722
2723
2724 /****************************************************************************
2725 **
2726 *F CodeIsbRecExpr() . . . . . . . . . . . . . . . code bound rec expr check
2727 */
CodeIsbRecExpr(void)2728 void CodeIsbRecExpr ( void )
2729 {
2730 Expr expr; /* reference, result */
2731 Expr rnam; /* name expression */
2732 Expr rec; /* record expression */
2733
2734 /* allocate the isbound */
2735 expr = NewExpr( EXPR_ISB_REC_EXPR, 2 * sizeof(Expr) );
2736
2737 /* enter the expression */
2738 rnam = PopExpr();
2739 WRITE_EXPR(expr, 1, rnam);
2740
2741 /* enter the record expression */
2742 rec = PopExpr();
2743 WRITE_EXPR(expr, 0, rec);
2744
2745 /* push the isbound */
2746 PushExpr( expr );
2747 }
2748
2749
2750 /****************************************************************************
2751 **
2752 *F CodeAssPosObj() . . . . . . . . . . . . . . . . code assignment to a list
2753 */
CodeAssPosObj(void)2754 void CodeAssPosObj ( void )
2755 {
2756 Stat ass; /* assignment, result */
2757 Expr list; /* list expression */
2758 Expr pos; /* position expression */
2759 Expr rhsx; /* right hand side expression */
2760
2761 /* allocate the assignment */
2762 ass = NewStat( STAT_ASS_POSOBJ, 3 * sizeof(Stat) );
2763
2764 /* enter the right hand side expression */
2765 rhsx = PopExpr();
2766 WRITE_STAT(ass, 2, rhsx);
2767
2768 /* enter the position expression */
2769 pos = PopExpr();
2770 WRITE_STAT(ass, 1, pos);
2771
2772 /* enter the list expression */
2773 list = PopExpr();
2774 WRITE_STAT(ass, 0, list);
2775
2776 /* push the assignment */
2777 PushStat( ass );
2778 }
2779
2780
2781 /****************************************************************************
2782 **
2783 *F CodeUnbPosObj() . . . . . . . . . . . . . . . . . code unbind pos object
2784 */
CodeUnbPosObj(void)2785 void CodeUnbPosObj ( void )
2786 {
2787 Expr list; /* list expression */
2788 Expr pos; /* position expression */
2789 Stat ass; /* unbind, result */
2790
2791 /* allocate the unbind */
2792 ass = NewStat( STAT_UNB_POSOBJ, 2 * sizeof(Stat) );
2793
2794 /* enter the position expression */
2795 pos = PopExpr();
2796 WRITE_STAT(ass, 1, pos);
2797
2798 /* enter the list expression */
2799 list = PopExpr();
2800 WRITE_STAT(ass, 0, list);
2801
2802 /* push the unbind */
2803 PushStat( ass );
2804 }
2805
2806
2807 /****************************************************************************
2808 **
2809 *F CodeElmPosObj() . . . . . . . . . . . . . . . . code selection of a list
2810 */
CodeElmPosObj(void)2811 void CodeElmPosObj ( void )
2812 {
2813 Expr ref; /* reference, result */
2814 Expr list; /* list expression */
2815 Expr pos; /* position expression */
2816
2817 /* allocate the reference */
2818 ref = NewExpr( EXPR_ELM_POSOBJ, 2 * sizeof(Expr) );
2819
2820 /* enter the position expression */
2821 pos = PopExpr();
2822 WRITE_EXPR(ref, 1, pos);
2823
2824 /* enter the list expression */
2825 list = PopExpr();
2826 WRITE_EXPR(ref, 0, list);
2827
2828 /* push the reference */
2829 PushExpr( ref );
2830 }
2831
2832
2833 /****************************************************************************
2834 **
2835 *F CodeIsbPosObj() . . . . . . . . . . . . . . . code bound pos object check
2836 */
CodeIsbPosObj(void)2837 void CodeIsbPosObj ( void )
2838 {
2839 Expr ref; /* isbound, result */
2840 Expr list; /* list expression */
2841 Expr pos; /* position expression */
2842
2843 /* allocate the isbound */
2844 ref = NewExpr( EXPR_ISB_POSOBJ, 2 * sizeof(Expr) );
2845
2846 /* enter the position expression */
2847 pos = PopExpr();
2848 WRITE_EXPR(ref, 1, pos);
2849
2850 /* enter the list expression */
2851 list = PopExpr();
2852 WRITE_EXPR(ref, 0, list);
2853
2854 /* push the isbound */
2855 PushExpr( ref );
2856 }
2857
2858
2859 /****************************************************************************
2860 **
2861 *F CodeAssComObjName( <rnam> ) . . . . . . . . . code assignment to a record
2862 *F CodeAssComObjExpr() . . . . . . . . . . . . . code assignment to a record
2863 */
CodeAssComObjName(UInt rnam)2864 void CodeAssComObjName (
2865 UInt rnam )
2866 {
2867 Stat stat; /* assignment, result */
2868 Expr rec; /* record expression */
2869 Expr rhsx; /* right hand side expression */
2870
2871 /* allocate the assignment */
2872 stat = NewStat( STAT_ASS_COMOBJ_NAME, 3 * sizeof(Stat) );
2873
2874 /* enter the right hand side expression */
2875 rhsx = PopExpr();
2876 WRITE_STAT(stat, 2, rhsx);
2877
2878 /* enter the name */
2879 WRITE_STAT(stat, 1, rnam);
2880
2881 /* enter the record expression */
2882 rec = PopExpr();
2883 WRITE_STAT(stat, 0, rec);
2884
2885 /* push the assignment */
2886 PushStat( stat );
2887 }
2888
CodeAssComObjExpr(void)2889 void CodeAssComObjExpr ( void )
2890 {
2891 Stat stat; /* assignment, result */
2892 Expr rec; /* record expression */
2893 Expr rnam; /* name expression */
2894 Expr rhsx; /* right hand side expression */
2895
2896 /* allocate the assignment */
2897 stat = NewStat( STAT_ASS_COMOBJ_EXPR, 3 * sizeof(Stat) );
2898
2899 /* enter the right hand side expression */
2900 rhsx = PopExpr();
2901 WRITE_STAT(stat, 2, rhsx);
2902
2903 /* enter the name expression */
2904 rnam = PopExpr();
2905 WRITE_STAT(stat, 1, rnam);
2906
2907 /* enter the record expression */
2908 rec = PopExpr();
2909 WRITE_STAT(stat, 0, rec);
2910
2911 /* push the assignment */
2912 PushStat( stat );
2913 }
2914
CodeUnbComObjName(UInt rnam)2915 void CodeUnbComObjName (
2916 UInt rnam )
2917 {
2918 Stat stat; /* unbind, result */
2919 Expr rec; /* record expression */
2920
2921 /* allocate the unbind */
2922 stat = NewStat( STAT_UNB_COMOBJ_NAME, 2 * sizeof(Stat) );
2923
2924 /* enter the name */
2925 WRITE_STAT(stat, 1, rnam);
2926
2927 /* enter the record expression */
2928 rec = PopExpr();
2929 WRITE_STAT(stat, 0, rec);
2930
2931 /* push the unbind */
2932 PushStat( stat );
2933 }
2934
CodeUnbComObjExpr(void)2935 void CodeUnbComObjExpr ( void )
2936 {
2937 Stat stat; /* unbind, result */
2938 Expr rec; /* record expression */
2939 Expr rnam; /* name expression */
2940
2941 /* allocate the unbind */
2942 stat = NewStat( STAT_UNB_COMOBJ_EXPR, 2 * sizeof(Stat) );
2943
2944 /* enter the name expression */
2945 rnam = PopExpr();
2946 WRITE_STAT(stat, 1, rnam);
2947
2948 /* enter the record expression */
2949 rec = PopExpr();
2950 WRITE_STAT(stat, 0, rec);
2951
2952 /* push the unbind */
2953 PushStat( stat );
2954 }
2955
2956
2957 /****************************************************************************
2958 **
2959 *F CodeElmComObjName( <rnam> ) . . . . . . . . . code selection of a record
2960 *F CodeElmComObjExpr() . . . . . . . . . . . . . code selection of a record
2961 */
CodeElmComObjName(UInt rnam)2962 void CodeElmComObjName (
2963 UInt rnam )
2964 {
2965 Expr expr; /* reference, result */
2966 Expr rec; /* record expression */
2967
2968 /* allocate the reference */
2969 expr = NewExpr( EXPR_ELM_COMOBJ_NAME, 2 * sizeof(Expr) );
2970
2971 /* enter the name */
2972 WRITE_EXPR(expr, 1, rnam);
2973
2974 /* enter the record expression */
2975 rec = PopExpr();
2976 WRITE_EXPR(expr, 0, rec);
2977
2978 /* push the reference */
2979 PushExpr( expr );
2980 }
2981
CodeElmComObjExpr(void)2982 void CodeElmComObjExpr ( void )
2983 {
2984 Expr expr; /* reference, result */
2985 Expr rnam; /* name expression */
2986 Expr rec; /* record expression */
2987
2988 /* allocate the reference */
2989 expr = NewExpr( EXPR_ELM_COMOBJ_EXPR, 2 * sizeof(Expr) );
2990
2991 /* enter the expression */
2992 rnam = PopExpr();
2993 WRITE_EXPR(expr, 1, rnam);
2994
2995 /* enter the record expression */
2996 rec = PopExpr();
2997 WRITE_EXPR(expr, 0, rec);
2998
2999 /* push the reference */
3000 PushExpr( expr );
3001 }
3002
3003
3004 /****************************************************************************
3005 **
3006 *F CodeIsbComObjName( <rname> ) . . . . . code bound com object name check
3007 */
CodeIsbComObjName(UInt rnam)3008 void CodeIsbComObjName (
3009 UInt rnam )
3010 {
3011 Expr expr; /* isbound, result */
3012 Expr rec; /* record expression */
3013
3014 /* allocate the isbound */
3015 expr = NewExpr( EXPR_ISB_COMOBJ_NAME, 2 * sizeof(Expr) );
3016
3017 /* enter the name */
3018 WRITE_EXPR(expr, 1, rnam);
3019
3020 /* enter the record expression */
3021 rec = PopExpr();
3022 WRITE_EXPR(expr, 0, rec);
3023
3024 /* push the isbound */
3025 PushExpr( expr );
3026 }
3027
3028 /****************************************************************************
3029 **
3030 *F CodeIsbComObjExpr() . . . . . . . . . . code bound com object expr check
3031 */
CodeIsbComObjExpr(void)3032 void CodeIsbComObjExpr ( void )
3033 {
3034 Expr expr; /* reference, result */
3035 Expr rnam; /* name expression */
3036 Expr rec; /* record expression */
3037
3038 /* allocate the isbound */
3039 expr = NewExpr( EXPR_ISB_COMOBJ_EXPR, 2 * sizeof(Expr) );
3040
3041 /* enter the expression */
3042 rnam = PopExpr();
3043 WRITE_EXPR(expr, 1, rnam);
3044
3045 /* enter the record expression */
3046 rec = PopExpr();
3047 WRITE_EXPR(expr, 0, rec);
3048
3049 /* push the isbound */
3050 PushExpr( expr );
3051 }
3052
3053
3054 /****************************************************************************
3055 **
3056 *F CodeEmpty() . . . . code an empty statement
3057 **
3058 */
3059
CodeEmpty(void)3060 void CodeEmpty(void)
3061 {
3062 Stat stat;
3063 stat = NewStat(STAT_EMPTY, 0);
3064 PushStat( stat );
3065 }
3066
3067 /****************************************************************************
3068 **
3069 *F CodeInfoBegin() . . . . . . . . . . . . . start coding of Info statement
3070 *F CodeInfoMiddle() . . . . . . . . . shift to coding printable arguments
3071 *F CodeInfoEnd( <narg> ) . . Info statement complete, <narg> things to print
3072 **
3073 ** These actions deal with the Info statement, which is coded specially,
3074 ** because not all of its arguments are always evaluated.
3075 **
3076 ** Only CodeInfoEnd actually does anything
3077 */
CodeInfoBegin(void)3078 void CodeInfoBegin ( void )
3079 {
3080 }
3081
CodeInfoMiddle(void)3082 void CodeInfoMiddle ( void )
3083 {
3084 }
3085
CodeInfoEnd(UInt narg)3086 void CodeInfoEnd (
3087 UInt narg )
3088 {
3089 Stat stat; /* we build the statement here */
3090 Expr expr; /* expression */
3091 UInt i; /* loop variable */
3092
3093 /* allocate the new statement */
3094 stat = NewStat( STAT_INFO, SIZE_NARG_INFO(2+narg) );
3095
3096 /* narg only counts the printable arguments */
3097 for ( i = narg + 2; 0 < i; i-- ) {
3098 expr = PopExpr();
3099 SET_ARGI_INFO(stat, i, expr);
3100 }
3101
3102 /* push the statement */
3103 PushStat( stat );
3104 }
3105
3106
3107 /****************************************************************************
3108 **
3109 *F CodeAssertBegin() . . . . . . . start interpretation of Assert statement
3110 *F CodeAsseerAfterLevel() . . called after the first argument has been read
3111 *F CodeAssertAfterCondition() called after the second argument has been read
3112 *F CodeAssertEnd2Args() . . . . called after reading the closing parenthesis
3113 *F CodeAssertEnd3Args() . . . . called after reading the closing parenthesis
3114 **
3115 ** Only the End functions actually do anything
3116 */
CodeAssertBegin(void)3117 void CodeAssertBegin ( void )
3118 {
3119 }
3120
CodeAssertAfterLevel(void)3121 void CodeAssertAfterLevel ( void )
3122 {
3123 }
3124
CodeAssertAfterCondition(void)3125 void CodeAssertAfterCondition ( void )
3126 {
3127 }
3128
CodeAssertEnd2Args(void)3129 void CodeAssertEnd2Args ( void )
3130 {
3131 Stat stat; /* we build the statement here */
3132
3133 stat = NewStat( STAT_ASSERT_2ARGS, 2*sizeof(Expr) );
3134
3135 WRITE_STAT(stat, 1, PopExpr()); /* condition */
3136 WRITE_STAT(stat, 0, PopExpr()); /* level */
3137
3138 PushStat( stat );
3139 }
3140
CodeAssertEnd3Args(void)3141 void CodeAssertEnd3Args ( void )
3142 {
3143 Stat stat; /* we build the statement here */
3144
3145 stat = NewStat( STAT_ASSERT_3ARGS, 3*sizeof(Expr) );
3146
3147 WRITE_STAT(stat, 2, PopExpr()); /* message */
3148 WRITE_STAT(stat, 1, PopExpr()); /* condition */
3149 WRITE_STAT(stat, 0, PopExpr()); /* level */
3150
3151 PushStat( stat );
3152 }
3153
3154 /****************************************************************************
3155 **
3156 *F SaveBody( <body> ) . . . . . . . . . . . . . . . workspace saving method
3157 **
3158 ** A body is made up of statements and expressions, and these are all
3159 ** organised to regular boundaries based on the types Stat and Expr, which
3160 ** are currently both UInt
3161 **
3162 ** String literals should really be saved byte-wise, to be safe across
3163 ** machines of different endianness, but this would mean parsing the bag as
3164 ** we save it which it would be nice to avoid just now.
3165 */
SaveBody(Obj body)3166 static void SaveBody(Obj body)
3167 {
3168 UInt i;
3169 const UInt *ptr = (const UInt *) CONST_ADDR_OBJ(body);
3170 /* Save the new information in the body */
3171 for (i =0; i < sizeof(BodyHeader)/sizeof(Obj); i++)
3172 SaveSubObj((Obj)(*ptr++));
3173 /* and the rest */
3174 for (; i < (SIZE_OBJ(body)+sizeof(UInt)-1)/sizeof(UInt); i++)
3175 SaveUInt(*ptr++);
3176 }
3177
3178 /****************************************************************************
3179 **
3180 *F LoadBody( <body> ) . . . . . . . . . . . . . . . workspace loading method
3181 **
3182 ** A body is made up of statements and expressions, and these are all
3183 ** organised to regular boundaries based on the types Stat and Expr, which
3184 ** are currently both UInt
3185 **
3186 */
LoadBody(Obj body)3187 static void LoadBody(Obj body)
3188 {
3189 UInt i;
3190 UInt *ptr;
3191 ptr = (UInt *) ADDR_OBJ(body);
3192 for (i =0; i < sizeof(BodyHeader)/sizeof(Obj); i++)
3193 *(Obj *)(ptr++) = LoadSubObj();
3194 for (; i < (SIZE_OBJ(body)+sizeof(UInt)-1)/sizeof(UInt); i++)
3195 *ptr++ = LoadUInt();
3196 }
3197
3198
3199 /****************************************************************************
3200 **
3201 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
3202 */
3203
3204 /****************************************************************************
3205 **
3206 *V BagNames . . . . . . . . . . . . . . . . . . . . . . . list of bag names
3207 */
3208 static StructBagNames BagNames[] = {
3209 { T_BODY, "function body bag" },
3210 { -1, "" }
3211 };
3212
3213 /****************************************************************************
3214 **
3215 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
3216 */
InitKernel(StructInitInfo * module)3217 static Int InitKernel (
3218 StructInitInfo * module )
3219 {
3220 // set the bag type names (for error messages and debugging)
3221 InitBagNamesFromTable( BagNames );
3222
3223 /* install the marking functions for function body bags */
3224 InitMarkFuncBags( T_BODY, MarkFourSubBags );
3225
3226 SaveObjFuncs[ T_BODY ] = SaveBody;
3227 LoadObjFuncs[ T_BODY ] = LoadBody;
3228
3229 #ifdef HPCGAP
3230 /* Allocate function bodies in the public data space */
3231 MakeBagTypePublic(T_BODY);
3232 #endif
3233
3234 #if !defined(HPCGAP)
3235 /* make the result variable known to Gasman */
3236 InitGlobalBag(&CS(CodeResult), "CodeResult");
3237 #endif
3238
3239 /* allocate the statements and expressions stacks */
3240 InitGlobalBag(&CS(StackStat), "CS(StackStat)");
3241 InitGlobalBag(&CS(StackExpr), "CS(StackExpr)");
3242
3243 /* some functions and globals needed for float conversion */
3244 InitFopyGVar( "CONVERT_FLOAT_LITERAL_EAGER", &CONVERT_FLOAT_LITERAL_EAGER);
3245
3246 /* return success */
3247 return 0;
3248 }
3249
3250
3251 /****************************************************************************
3252 **
3253 *F PostRestore( <module> ) . . . . . . . recover
3254 */
PostRestore(StructInitInfo * module)3255 static Int PostRestore (
3256 StructInitInfo * module )
3257 {
3258 NextFloatExprNumber = INT_INTOBJ(ValGVar(GVarName("SavedFloatIndex")));
3259 return 0;
3260 }
3261
3262
3263 /****************************************************************************
3264 **
3265 *F PreSave( <module> ) . . . . . . . clean up before saving
3266 */
PreSave(StructInitInfo * module)3267 static Int PreSave (
3268 StructInitInfo * module )
3269 {
3270 /* Can't save in mid-parsing */
3271 if (CS(CountExpr) || CS(CountStat))
3272 return 1;
3273
3274 /* push the FP cache index out into a GAP Variable */
3275 AssGVar(GVarName("SavedFloatIndex"), INTOBJ_INT(NextFloatExprNumber));
3276
3277 // clean any old data out of the statement and expression stacks,
3278 // but leave the type field alone
3279 memset(ADDR_OBJ(CS(StackStat)) + 1, 0, SIZE_BAG(CS(StackStat)) - sizeof(Obj));
3280 memset(ADDR_OBJ(CS(StackExpr)) + 1, 0, SIZE_BAG(CS(StackExpr)) - sizeof(Obj));
3281
3282 /* return success */
3283 return 0;
3284 }
3285
InitModuleState(void)3286 static Int InitModuleState(void)
3287 {
3288 CS(OffsBodyCount) = 0;
3289
3290 // allocate the statements and expressions stacks
3291 CS(StackStat) = NewKernelBuffer(sizeof(Obj) + 64 * sizeof(Stat));
3292 CS(StackExpr) = NewKernelBuffer(sizeof(Obj) + 64 * sizeof(Expr));
3293
3294 #ifdef HPCGAP
3295 CS(OffsBodyStack) = AllocateMemoryBlock(MAX_FUNC_EXPR_NESTING*sizeof(Stat));
3296 #else
3297 static Stat MainOffsBodyStack[MAX_FUNC_EXPR_NESTING];
3298 CS(OffsBodyStack) = MainOffsBodyStack;
3299 #endif
3300
3301 // return success
3302 return 0;
3303 }
3304
3305 /****************************************************************************
3306 **
3307 *F InitInfoCode() . . . . . . . . . . . . . . . . . table of init functions
3308 */
3309 static StructInitInfo module = {
3310 // init struct using C99 designated initializers; for a full list of
3311 // fields, please refer to the definition of StructInitInfo
3312 .type = MODULE_BUILTIN,
3313 .name = "code",
3314 .initKernel = InitKernel,
3315 .preSave = PreSave,
3316 .postRestore = PostRestore,
3317
3318 .moduleStateSize = sizeof(struct CodeState),
3319 .moduleStateOffsetPtr = &CodeStateOffset,
3320 .initModuleState = InitModuleState,
3321 };
3322
InitInfoCode(void)3323 StructInitInfo * InitInfoCode ( void )
3324 {
3325 return &module;
3326 }
3327