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 expressions package.
11 **
12 ** The expressions package is the part of the interpreter that evaluates
13 ** expressions to their values and prints expressions.
14 */
15
16 #include "exprs.h"
17
18 #include "ariths.h"
19 #include "bool.h"
20 #include "calls.h"
21 #include "code.h"
22 #include "error.h"
23 #include "gapstate.h"
24 #include "gvars.h"
25 #include "hookintrprtr.h"
26 #include "integer.h"
27 #include "io.h"
28 #include "lists.h"
29 #include "modules.h"
30 #include "opers.h"
31 #include "permutat.h"
32 #include "plist.h"
33 #include "precord.h"
34 #include "range.h"
35 #include "records.h"
36 #include "stringobj.h"
37 #include "vars.h"
38
39 #ifdef HPCGAP
40 #include "hpc/aobjects.h"
41 #endif
42
43 /****************************************************************************
44 **
45 *V EvalExprFuncs[<type>] . . . . . evaluator for expressions of type <type>
46 **
47 ** 'EvalExprFuncs' is the dispatch table that contains for every type of
48 ** expressions a pointer to the evaluator for expressions of this type,
49 ** i.e., the function that should be called to evaluate expressions of this
50 ** type.
51 */
52 Obj (* EvalExprFuncs [256]) ( Expr expr );
53
54
55 /****************************************************************************
56 **
57 *V EvalBoolFuncs[<type>] . . boolean evaluator for expression of type <type>
58 **
59 ** 'EvalBoolFuncs' is the dispatch table that contains for every type of
60 ** expression a pointer to a boolean evaluator for expressions of this type,
61 ** i.e., a pointer to a function which is guaranteed to return a boolean
62 ** value that should be called to evaluate expressions of this type.
63 */
64 Obj (* EvalBoolFuncs [256]) ( Expr expr );
65
66
67 /****************************************************************************
68 **
69 *F EvalUnknownExpr(<expr>) . . . . . . . evaluate expression of unknown type
70 **
71 ** 'EvalUnknownExpr' is the evaluator that is called if an attempt is made
72 ** to evaluate an expression <expr> of an unknown type. It signals an
73 ** error. If this is ever called, then GAP is in serious trouble, such as
74 ** an overwritten type field of an expression.
75 */
EvalUnknownExpr(Expr expr)76 static Obj EvalUnknownExpr(Expr expr)
77 {
78 Pr( "Panic: tried to evaluate an expression of unknown type '%d'\n",
79 (Int)TNUM_EXPR(expr), 0L );
80 return 0;
81 }
82
83
84 /****************************************************************************
85 **
86 *F EvalUnknownBool(<expr>) . . . . boolean evaluator for general expressions
87 **
88 ** 'EvalUnknownBool' evaluates the expression <expr> (using 'EVAL_EXPR'),
89 ** and checks that the value is either 'true' or 'false'. If the expression
90 ** does not evaluate to 'true' or 'false', then an error is signalled.
91 **
92 ** This is the default function in 'EvalBoolFuncs' used for expressions that
93 ** are not a priori known to evaluate to a boolean value (such as
94 ** function calls).
95 */
EvalUnknownBool(Expr expr)96 static Obj EvalUnknownBool(Expr expr)
97 {
98 Obj val; /* value, result */
99
100 /* evaluate the expression */
101 val = EVAL_EXPR( expr );
102
103 /* check that the value is either 'true' or 'false' */
104 if (val != True && val != False) {
105 RequireArgumentEx(0, val, "<expr>", "must be 'true' or 'false'");
106 }
107
108 /* return the value */
109 return val;
110 }
111
112
113 /****************************************************************************
114 **
115 *F EvalOr(<expr>) . . . . . . . . . . . . . evaluate a boolean or operation
116 **
117 ** 'EvalOr' evaluates the or-expression <expr> and returns its value, i.e.,
118 ** 'true' if either of the operands is 'true', and 'false' otherwise.
119 ** 'EvalOr' is called from 'EVAL_EXPR' to evaluate expressions of type
120 ** 'EXPR_OR'.
121 **
122 ** If '<expr>.left' is already 'true' 'EvalOr' returns 'true' without
123 ** evaluating '<expr>.right'. This allows constructs like
124 **
125 ** if (index > max) or (list[index] = 0) then ... fi;
126 */
EvalOr(Expr expr)127 static Obj EvalOr(Expr expr)
128 {
129 Obj opL; /* evaluated left operand */
130 Expr tmp; /* temporary expression */
131
132 /* evaluate and test the left operand */
133 tmp = READ_EXPR(expr, 0);
134 opL = EVAL_BOOL_EXPR( tmp );
135 if ( opL != False ) {
136 return True;
137 }
138
139 /* evaluate and test the right operand */
140 tmp = READ_EXPR(expr, 1);
141 return EVAL_BOOL_EXPR( tmp );
142 }
143
144
145 /****************************************************************************
146 **
147 *F EvalAnd(<expr>) . . . . . . . . . . . . evaluate a boolean and operation
148 **
149 ** 'EvalAnd' evaluates the and-expression <expr> and returns its value,
150 ** i.e., 'true' if both operands are 'true', and 'false' otherwise.
151 ** 'EvalAnd' is called from 'EVAL_EXPR' to evaluate expressions of type
152 ** 'EXPR_AND'.
153 **
154 ** If '<expr>.left' is already 'false' 'EvalAnd' returns 'false' without
155 ** evaluating '<expr>.right'. This allows constructs like
156 **
157 ** if (index <= max) and (list[index] = 0) then ... fi;
158 */
EvalAnd(Expr expr)159 static Obj EvalAnd(Expr expr)
160 {
161 Obj opL; /* evaluated left operand */
162 Obj opR; /* evaluated right operand */
163 Expr tmp; /* temporary expression */
164
165 /* if the left operand is 'false', this is the result */
166 tmp = READ_EXPR(expr, 0);
167 opL = EVAL_EXPR( tmp );
168 if ( opL == False ) {
169 return opL;
170 }
171
172 /* if the left operand is 'true', the result is the right operand */
173 else if ( opL == True ) {
174 tmp = READ_EXPR(expr, 1);
175 return EVAL_BOOL_EXPR( tmp );
176 }
177
178 /* handle the 'and' of two filters */
179 else if (IS_FILTER(opL)) {
180 tmp = READ_EXPR(expr, 1);
181 opR = EVAL_EXPR( tmp );
182 return NewAndFilter(opL, opR);
183 }
184
185 /* signal an error */
186 else {
187 RequireArgumentEx(0, opL, "<expr>",
188 "must be 'true' or 'false' or a filter");
189 }
190
191 /* please 'lint' */
192 return 0;
193 }
194
195
196 /****************************************************************************
197 **
198 *F EvalNot(<expr>) . . . . . . . . . . . . . . . . . negate a boolean value
199 **
200 ** 'EvalNot' evaluates the not-expression <expr> and returns its value,
201 ** i.e., 'true' if the operand is 'false', and 'false' otherwise. 'EvalNot'
202 ** is called from 'EVAL_EXPR' to evaluate expressions of type 'EXPR_NOT'.
203 */
EvalNot(Expr expr)204 static Obj EvalNot(Expr expr)
205 {
206 Obj val; /* value, result */
207 Obj op; /* evaluated operand */
208 Expr tmp; /* temporary expression */
209
210 /* evaluate the operand to a boolean */
211 tmp = READ_EXPR(expr, 0);
212 op = EVAL_BOOL_EXPR( tmp );
213
214 /* compute the negation */
215 val = (op == False ? True : False);
216
217 /* return the negated value */
218 return val;
219 }
220
221
222 /****************************************************************************
223 **
224 *F EvalEq(<expr>) . . . . . . . . . . . . . . . . . . evaluate a comparison
225 **
226 ** 'EvalEq' evaluates the equality-expression <expr> and returns its value,
227 ** i.e., 'true' if the operand '<expr>.left' is equal to the operand
228 ** '<expr>.right' and 'false' otherwise. 'EvalEq' is called from
229 ** 'EVAL_EXPR' to evaluate expressions of type 'EXPR_EQ'.
230 **
231 ** 'EvalEq' evaluates the operands and then calls the 'EQ' macro.
232 */
EvalEq(Expr expr)233 static Obj EvalEq(Expr expr)
234 {
235 Obj val; /* value, result */
236 Obj opL; /* evaluated left operand */
237 Obj opR; /* evaluated right operand */
238 Expr tmp; /* temporary expression */
239
240 /* get the operands */
241 tmp = READ_EXPR(expr, 0);
242 opL = EVAL_EXPR( tmp );
243 tmp = READ_EXPR(expr, 1);
244 opR = EVAL_EXPR( tmp );
245
246 /* compare the operands */
247 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
248 val = (EQ( opL, opR ) ? True : False);
249
250 /* return the value */
251 return val;
252 }
253
254
255 /****************************************************************************
256 **
257 *F EvalNe(<expr>) . . . . . . . . . . . . . . . . . . evaluate a comparison
258 **
259 ** 'EvalNe' evaluates the comparison-expression <expr> and returns its
260 ** value, i.e., 'true' if the operand '<expr>.left' is not equal to the
261 ** operand '<expr>.right' and 'false' otherwise. 'EvalNe' is called from
262 ** 'EVAL_EXPR' to evaluate expressions of type 'EXPR_LT'.
263 **
264 ** 'EvalNe' is simply implemented as 'not <objL> = <objR>'.
265 */
EvalNe(Expr expr)266 static Obj EvalNe(Expr expr)
267 {
268 Obj val; /* value, result */
269 Obj opL; /* evaluated left operand */
270 Obj opR; /* evaluated right operand */
271 Expr tmp; /* temporary expression */
272
273 /* get the operands */
274 tmp = READ_EXPR(expr, 0);
275 opL = EVAL_EXPR( tmp );
276 tmp = READ_EXPR(expr, 1);
277 opR = EVAL_EXPR( tmp );
278
279 /* compare the operands */
280 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
281 val = (EQ( opL, opR ) ? False : True);
282
283 /* return the value */
284 return val;
285 }
286
287
288 /****************************************************************************
289 **
290 *F EvalLt(<expr>) . . . . . . . . . . . . . . . . . . evaluate a comparison
291 **
292 ** 'EvalLt' evaluates the comparison-expression <expr> and returns its
293 ** value, i.e., 'true' if the operand '<expr>.left' is less than the operand
294 ** '<expr>.right' and 'false' otherwise. 'EvalLt' is called from
295 ** 'EVAL_EXPR' to evaluate expressions of type 'EXPR_LT'.
296 **
297 ** 'EvalLt' evaluates the operands and then calls the 'LT' macro.
298 */
EvalLt(Expr expr)299 static Obj EvalLt(Expr expr)
300 {
301 Obj val; /* value, result */
302 Obj opL; /* evaluated left operand */
303 Obj opR; /* evaluated right operand */
304 Expr tmp; /* temporary expression */
305
306 /* get the operands */
307 tmp = READ_EXPR(expr, 0);
308 opL = EVAL_EXPR( tmp );
309 tmp = READ_EXPR(expr, 1);
310 opR = EVAL_EXPR( tmp );
311
312 /* compare the operands */
313 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
314 val = (LT( opL, opR ) ? True : False);
315
316 /* return the value */
317 return val;
318 }
319
320
321 /****************************************************************************
322 **
323 *F EvalGe(<expr>) . . . . . . . . . . . . . . . . . . evaluate a comparison
324 **
325 ** 'EvalGe' evaluates the comparison-expression <expr> and returns its
326 ** value, i.e., 'true' if the operand '<expr>.left' is greater than or equal
327 ** to the operand '<expr>.right' and 'false' otherwise. 'EvalGe' is called
328 ** from 'EVAL_EXPR' to evaluate expressions of type 'EXPR_GE'.
329 **
330 ** 'EvalGe' is simply implemented as 'not <objL> < <objR>'.
331 */
EvalGe(Expr expr)332 static Obj EvalGe(Expr expr)
333 {
334 Obj val; /* value, result */
335 Obj opL; /* evaluated left operand */
336 Obj opR; /* evaluated right operand */
337 Expr tmp; /* temporary expression */
338
339 /* get the operands */
340 tmp = READ_EXPR(expr, 0);
341 opL = EVAL_EXPR( tmp );
342 tmp = READ_EXPR(expr, 1);
343 opR = EVAL_EXPR( tmp );
344
345 /* compare the operands */
346 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
347 val = (LT( opL, opR ) ? False : True);
348
349 /* return the value */
350 return val;
351 }
352
353
354 /****************************************************************************
355 **
356 *F EvalGt(<expr>) . . . . . . . . . . . . . . . . . . evaluate a comparison
357 **
358 ** 'EvalGt' evaluates the comparison-expression <expr> and returns its
359 ** value, i.e., 'true' if the operand '<expr>.left' is greater than the
360 ** operand '<expr>.right' and 'false' otherwise. 'EvalGt' is called from
361 ** 'EVAL_EXPR' to evaluate expressions of type 'EXPR_GT'.
362 **
363 ** 'EvalGt' is simply implemented as '<objR> < <objL>'.
364 */
EvalGt(Expr expr)365 static Obj EvalGt(Expr expr)
366 {
367 Obj val; /* value, result */
368 Obj opL; /* evaluated left operand */
369 Obj opR; /* evaluated right operand */
370 Expr tmp; /* temporary expression */
371
372 /* get the operands */
373 tmp = READ_EXPR(expr, 0);
374 opL = EVAL_EXPR( tmp );
375 tmp = READ_EXPR(expr, 1);
376 opR = EVAL_EXPR( tmp );
377
378 /* compare the operands */
379 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
380 val = (LT( opR, opL ) ? True : False);
381
382 /* return the value */
383 return val;
384 }
385
386
387 /****************************************************************************
388 **
389 *F EvalLe(<expr>) . . . . . . . . . . . . . . . . . . evaluate a comparison
390 **
391 ** 'EvalLe' evaluates the comparison-expression <expr> and returns its
392 ** value, i.e., 'true' if the operand '<expr>.left' is less or equal to the
393 ** operand '<expr>.right' and 'false' otherwise. 'EvalLe' is called from
394 ** 'EVAL_EXPR' to evaluate expressions of type 'EXPR_LE'.
395 **
396 ** 'EvalLe' is simply implemented as 'not <objR> < <objR>'.
397 */
EvalLe(Expr expr)398 static Obj EvalLe(Expr expr)
399 {
400 Obj val; /* value, result */
401 Obj opL; /* evaluated left operand */
402 Obj opR; /* evaluated right operand */
403 Expr tmp; /* temporary expression */
404
405 /* get the operands */
406 tmp = READ_EXPR(expr, 0);
407 opL = EVAL_EXPR( tmp );
408 tmp = READ_EXPR(expr, 1);
409 opR = EVAL_EXPR( tmp );
410
411 /* compare the operands */
412 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
413 val = (LT( opR, opL ) ? False : True);
414
415 /* return the value */
416 return val;
417 }
418
419
420 /****************************************************************************
421 **
422 *F EvalIn(<in>) . . . . . . . . . . . . . . . test for membership in a list
423 **
424 ** 'EvalIn' evaluates the in-expression <expr> and returns its value, i.e.,
425 ** 'true' if the operand '<expr>.left' is a member of '<expr>.right' and
426 ** 'false' otherwise. 'EvalIn' is called from 'EVAL_EXPR' to evaluate
427 ** expressions of type 'EXPR_IN'.
428 */
EvalIn(Expr expr)429 static Obj EvalIn(Expr expr)
430 {
431 Obj val; /* value, result */
432 Obj opL; /* evaluated left operand */
433 Obj opR; /* evaluated right operand */
434 Expr tmp; /* temporary expression */
435
436 /* evaluate <opL> */
437 tmp = READ_EXPR(expr, 0);
438 opL = EVAL_EXPR( tmp );
439
440 /* evaluate <opR> */
441 tmp = READ_EXPR(expr, 1);
442 opR = EVAL_EXPR( tmp );
443
444 /* perform the test */
445 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
446 val = (IN( opL, opR ) ? True : False);
447
448 /* return the value */
449 return val;
450 }
451
452
453 /****************************************************************************
454 **
455 *F EvalSum(<expr>) . . . . . . . . . . . . . . . . . . . . . evaluate a sum
456 **
457 ** 'EvalSum' evaluates the sum-expression <expr> and returns its value,
458 ** i.e., the sum of the two operands '<expr>.left' and '<expr>.right'.
459 ** 'EvalSum' is called from 'EVAL_EXPR' to evaluate expressions of type
460 ** 'EXPR_SUM'.
461 **
462 ** 'EvalSum' evaluates the operands and then calls the 'SUM' macro.
463 */
EvalSum(Expr expr)464 static Obj EvalSum(Expr expr)
465 {
466 Obj val; /* value, result */
467 Obj opL; /* evaluated left operand */
468 Obj opR; /* evaluated right operand */
469 Expr tmp; /* temporary expression */
470
471 /* get the operands */
472 tmp = READ_EXPR(expr, 0);
473 opL = EVAL_EXPR( tmp );
474 tmp = READ_EXPR(expr, 1);
475 opR = EVAL_EXPR( tmp );
476
477 /* first try to treat the operands as small integers with small result */
478 if ( ! ARE_INTOBJS( opL, opR ) || ! SUM_INTOBJS( val, opL, opR ) ) {
479
480 /* if that doesn't work, dispatch to the addition function */
481 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
482 val = SUM( opL, opR );
483
484 }
485
486 /* return the value */
487 return val;
488 }
489
490
491 /****************************************************************************
492 **
493 *F EvalAInv(<expr>) . . . . . . . . . . . . . . evaluate a additive inverse
494 **
495 ** 'EvalAInv' evaluates the additive inverse-expression and returns its
496 ** value, i.e., the additive inverse of the operand. 'EvalAInv' is called
497 ** from 'EVAL_EXPR' to evaluate expressions of type 'EXPR_AINV'.
498 **
499 ** 'EvalAInv' evaluates the operand and then calls the 'AINV' macro.
500 */
EvalAInv(Expr expr)501 static Obj EvalAInv(Expr expr)
502 {
503 Obj val; /* value, result */
504 Obj opL; /* evaluated left operand */
505 Expr tmp; /* temporary expression */
506
507 /* get the operands */
508 tmp = READ_EXPR(expr, 0);
509 opL = EVAL_EXPR( tmp );
510
511 /* compute the additive inverse */
512 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
513 val = AINV( opL );
514
515 /* return the value */
516 return val;
517 }
518
519
520 /****************************************************************************
521 **
522 *F EvalDiff(<expr>) . . . . . . . . . . . . . . . . . evaluate a difference
523 **
524 ** 'EvalDiff' evaluates the difference-expression <expr> and returns its
525 ** value, i.e., the difference of the two operands '<expr>.left' and
526 ** '<expr>.right'. 'EvalDiff' is called from 'EVAL_EXPR' to evaluate
527 ** expressions of type 'EXPR_DIFF'.
528 **
529 ** 'EvalDiff' evaluates the operands and then calls the 'DIFF' macro.
530 */
EvalDiff(Expr expr)531 static Obj EvalDiff(Expr expr)
532 {
533 Obj val; /* value, result */
534 Obj opL; /* evaluated left operand */
535 Obj opR; /* evaluated right operand */
536 Expr tmp; /* temporary expression */
537
538 /* get the operands */
539 tmp = READ_EXPR(expr, 0);
540 opL = EVAL_EXPR( tmp );
541 tmp = READ_EXPR(expr, 1);
542 opR = EVAL_EXPR( tmp );
543
544 /* first try to treat the operands as small integers with small result */
545 if ( ! ARE_INTOBJS( opL, opR ) || ! DIFF_INTOBJS( val, opL, opR ) ) {
546
547 /* if that doesn't work, dispatch to the subtraction function */
548 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
549 val = DIFF( opL, opR );
550
551 }
552
553 /* return the value */
554 return val;
555 }
556
557
558 /****************************************************************************
559 **
560 *F EvalProd(<expr>) . . . . . . . . . . . . . . . . . . evaluate a product
561 **
562 ** 'EvalProd' evaluates the product-expression <expr> and returns it value,
563 ** i.e., the product of the two operands '<expr>.left' and '<expr>.right'.
564 ** 'EvalProd' is called from 'EVAL_EXPR' to evaluate expressions of type
565 ** 'EXPR_PROD'.
566 **
567 ** 'EvalProd' evaluates the operands and then calls the 'PROD' macro.
568 */
EvalProd(Expr expr)569 static Obj EvalProd(Expr expr)
570 {
571 Obj val; /* result */
572 Obj opL; /* evaluated left operand */
573 Obj opR; /* evaluated right operand */
574 Expr tmp; /* temporary expression */
575
576 /* get the operands */
577 tmp = READ_EXPR(expr, 0);
578 opL = EVAL_EXPR( tmp );
579 tmp = READ_EXPR(expr, 1);
580 opR = EVAL_EXPR( tmp );
581
582 /* first try to treat the operands as small integers with small result */
583 if ( ! ARE_INTOBJS( opL, opR ) || ! PROD_INTOBJS( val, opL, opR ) ) {
584
585 /* if that doesn't work, dispatch to the multiplication function */
586 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
587 val = PROD( opL, opR );
588
589 }
590
591 /* return the value */
592 return val;
593 }
594
595
596 /****************************************************************************
597 **
598 *F EvalQuo(<expr>) . . . . . . . . . . . . . . . . . . . evaluate a quotient
599 **
600 ** 'EvalQuo' evaluates the quotient-expression <expr> and returns its value,
601 ** i.e., the quotient of the two operands '<expr>.left' and '<expr>.right'.
602 ** 'EvalQuo' is called from 'EVAL_EXPR' to evaluate expressions of type
603 ** 'EXPR_QUO'.
604 **
605 ** 'EvalQuo' evaluates the operands and then calls the 'QUO' macro.
606 */
EvalQuo(Expr expr)607 static Obj EvalQuo(Expr expr)
608 {
609 Obj val; /* value, result */
610 Obj opL; /* evaluated left operand */
611 Obj opR; /* evaluated right operand */
612 Expr tmp; /* temporary expression */
613
614 /* get the operands */
615 tmp = READ_EXPR(expr, 0);
616 opL = EVAL_EXPR( tmp );
617 tmp = READ_EXPR(expr, 1);
618 opR = EVAL_EXPR( tmp );
619
620 /* dispatch to the division function */
621 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
622 val = QUO( opL, opR );
623
624 /* return the value */
625 return val;
626 }
627
628
629 /****************************************************************************
630 **
631 *F EvalMod(<expr>) . . . . . . . . . . . . . . . . . . evaluate a remainder
632 **
633 ** 'EvalMod' evaluates the remainder-expression <expr> and returns its
634 ** value, i.e., the remainder of the two operands '<expr>.left' and
635 ** '<expr>.right'. 'EvalMod' is called from 'EVAL_EXPR' to evaluate
636 ** expressions of type 'EXPR_MOD'.
637 **
638 ** 'EvalMod' evaluates the operands and then calls the 'MOD' macro.
639 */
EvalMod(Expr expr)640 static Obj EvalMod(Expr expr)
641 {
642 Obj val; /* value, result */
643 Obj opL; /* evaluated left operand */
644 Obj opR; /* evaluated right operand */
645 Expr tmp; /* temporary expression */
646
647 /* get the operands */
648 tmp = READ_EXPR(expr, 0);
649 opL = EVAL_EXPR( tmp );
650 tmp = READ_EXPR(expr, 1);
651 opR = EVAL_EXPR( tmp );
652
653 /* dispatch to the remainder function */
654 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
655 val = MOD( opL, opR );
656
657 /* return the value */
658 return val;
659 }
660
661
662 /****************************************************************************
663 **
664 *F EvalPow(<expr>) . . . . . . . . . . . . . . . . . . . . evaluate a power
665 **
666 ** 'EvalPow' evaluates the power-expression <expr> and returns its value,
667 ** i.e., the power of the two operands '<expr>.left' and '<expr>.right'.
668 ** 'EvalPow' is called from 'EVAL_EXPR' to evaluate expressions of type
669 ** 'EXPR_POW'.
670 **
671 ** 'EvalPow' evaluates the operands and then calls the 'POW' macro.
672 */
EvalPow(Expr expr)673 static Obj EvalPow(Expr expr)
674 {
675 Obj val; /* value, result */
676 Obj opL; /* evaluated left operand */
677 Obj opR; /* evaluated right operand */
678 Expr tmp; /* temporary expression */
679
680 /* get the operands */
681 tmp = READ_EXPR(expr, 0);
682 opL = EVAL_EXPR( tmp );
683 tmp = READ_EXPR(expr, 1);
684 opR = EVAL_EXPR( tmp );
685
686 /* dispatch to the powering function */
687 SET_BRK_CALL_TO(expr); /* Note possible call for FuncWhere */
688 val = POW( opL, opR );
689
690 /* return the value */
691 return val;
692 }
693
694
695 /****************************************************************************
696 **
697 *F EvalIntExpr(<expr>) . . . . . . . . . evaluate literal integer expression
698 **
699 ** 'EvalIntExpr' evaluates the literal integer expression <expr> and returns
700 ** its value.
701 */
EvalIntExpr(Expr expr)702 static Obj EvalIntExpr(Expr expr)
703 {
704 UInt ix = READ_EXPR(expr, 0);
705 return GET_VALUE_FROM_CURRENT_BODY(ix);
706 }
707
708 /****************************************************************************
709 **
710 *F EvalTildeExpr(<expr>) . . . . . . . . . evaluate tilde expression
711 **
712 ** 'EvalTildeExpr' evaluates the tilde expression and returns its value.
713 */
EvalTildeExpr(Expr expr)714 static Obj EvalTildeExpr(Expr expr)
715 {
716 if( ! (STATE(Tilde)) ) {
717 ErrorQuit("'~' does not have a value here",0L,0L);
718 }
719 return STATE(Tilde);
720 }
721
722 /****************************************************************************
723 **
724 *F EvalTrueExpr(<expr>) . . . . . . . . . evaluate literal true expression
725 **
726 ** 'EvalTrueExpr' evaluates the literal true expression <expr> and returns
727 ** its value (True).
728 */
EvalTrueExpr(Expr expr)729 static Obj EvalTrueExpr(Expr expr)
730 {
731 return True;
732 }
733
734
735 /****************************************************************************
736 **
737 *F EvalFalseExpr(<expr>) . . . . . . . . . evaluate literal false expression
738 **
739 ** 'EvalFalseExpr' evaluates the literal false expression <expr> and returns
740 ** its value (False).
741 */
EvalFalseExpr(Expr expr)742 static Obj EvalFalseExpr(Expr expr)
743 {
744 return False;
745 }
746
747
748 /****************************************************************************
749 **
750 *F EvalCharExpr(<expr>) . . . . . . evaluate a literal character expression
751 **
752 ** 'EvalCharExpr' evaluates the literal character expression <expr> and
753 ** returns its value.
754 */
EvalCharExpr(Expr expr)755 static Obj EvalCharExpr(Expr expr)
756 {
757 return ObjsChar[ READ_EXPR(expr, 0) ];
758 }
759
760
761 /****************************************************************************
762 **
763 *F EvalPermExpr(<expr>) . . . . . . . . . evaluate a permutation expression
764 **
765 ** 'EvalPermExpr' evaluates the permutation expression <expr>.
766 */
GetFromExpr(Obj cycle,Int j)767 static Obj GetFromExpr(Obj cycle, Int j)
768 {
769 return EVAL_EXPR(READ_EXPR((Expr)cycle, j - 1));
770 }
771
EvalPermExpr(Expr expr)772 static Obj EvalPermExpr(Expr expr)
773 {
774 Obj perm; /* permutation, result */
775 UInt m; /* maximal entry in permutation */
776 Expr cycle; /* one cycle of permutation */
777 UInt i; /* loop variable */
778
779 /* special case for identity permutation */
780 if ( SIZE_EXPR(expr) == 0 ) {
781 return IdentityPerm;
782 }
783
784 /* allocate the new permutation */
785 m = 0;
786 perm = NEW_PERM4( 0 );
787
788 /* loop over the cycles */
789 for ( i = 1; i <= SIZE_EXPR(expr)/sizeof(Expr); i++ ) {
790 cycle = READ_EXPR(expr, i - 1);
791
792 // Need to inform profiling this cycle expression is executed, as
793 // we never call EVAL_EXPR on it.
794 VisitStatIfHooked(cycle);
795
796 m = ScanPermCycle(perm, m, (Obj)cycle,
797 SIZE_EXPR(cycle) / sizeof(Expr), GetFromExpr);
798 }
799
800 /* if possible represent the permutation with short entries */
801 TrimPerm(perm, m);
802
803 /* return the permutation */
804 return perm;
805 }
806
807
808 /****************************************************************************
809 **
810 *F EvalListExpr(<expr>) . . . . . evaluate list expression to a list value
811 **
812 ** 'EvalListExpr' evaluates the list expression, i.e., not yet evaluated
813 ** list, <expr> to a list value.
814 */
EvalListExpr(Expr expr)815 static Obj EvalListExpr(Expr expr)
816 {
817 Obj list; /* list value, result */
818 Obj sub; /* value of a subexpression */
819 Int len; /* logical length of the list */
820 Int i; /* loop variable */
821 Int dense; /* track whether list is dense */
822
823 // get the length of the list
824 len = SIZE_EXPR(expr) / sizeof(Expr);
825
826 // handle empty list
827 if (len == 0) {
828 return NewEmptyPlist();
829 }
830
831 // allocate the list value
832 list = NEW_PLIST(T_PLIST, len);
833
834 // set the final list length
835 SET_LEN_PLIST(list, len);
836
837 // initially assume list is dense
838 dense = 1;
839
840 // handle the subexpressions
841 for (i = 1; i <= len; i++) {
842 Expr subExpr = READ_EXPR(expr, i - 1);
843
844 // skip holes
845 if (subExpr == 0) {
846 // there is a hole, hence the list is not dense (note that list
847 // expressions never contain holes at the end, so we do not have
848 // to check if any bound entries follow)
849 dense = 0;
850 continue;
851 }
852
853 sub = EVAL_EXPR(subExpr);
854 SET_ELM_PLIST(list, i, sub);
855 CHANGED_BAG(list);
856 }
857
858 SET_FILT_LIST(list, dense ? FN_IS_DENSE : FN_IS_NDENSE);
859
860 return list;
861 }
862
863
864 /****************************************************************************
865 **
866 *F EvalListTildeExpr(<expr>) . . . . evaluate a list expression with a tilde
867 **
868 ** 'EvalListTildeExpr' evaluates the list expression, i.e., not yet
869 ** evaluated list, <expr> to a list value. The difference to 'EvalListExpr'
870 ** is that in <expr> there are occurrences of '~' referring to this list
871 ** value.
872 **
873 ** Note that we do not track here whether the list is dense, as this can be
874 ** changed by code involving a tilde expression, as in this example:
875 ** x := [1,,3,function(x) x[2]:=2; return 4; end(~)];
876 **
877 ** For similar reasons, we must deal with the possibility that the list we
878 ** are creating changes its representation, and thus must use ASS_LIST
879 ** instead of SET_ELM_PLIST.
880 */
EvalListTildeExpr(Expr expr)881 static Obj EvalListTildeExpr(Expr expr)
882 {
883 Obj list; /* list value, result */
884 Obj tilde; /* old value of tilde */
885 Obj sub; /* value of a subexpression */
886 Int len; /* logical length of the list */
887 Int i; /* loop variable */
888
889 // get the length of the list
890 len = SIZE_EXPR(expr) / sizeof(Expr);
891
892 // list expressions with tilde cannot be empty
893 GAP_ASSERT(len > 0);
894
895 // allocate the list value
896 list = NEW_PLIST(T_PLIST, len);
897
898 // remember the old value of '~'
899 tilde = STATE(Tilde);
900
901 // assign the list to '~'
902 STATE(Tilde) = list;
903
904 // handle the subexpressions
905 for (i = 1; i <= len; i++) {
906 Expr subExpr = READ_EXPR(expr, i - 1);
907
908 // skip holes
909 if (subExpr == 0)
910 continue;
911
912 sub = EVAL_EXPR(subExpr);
913 ASS_LIST(list, i, sub);
914 }
915
916 // restore old value of '~'
917 STATE(Tilde) = tilde;
918
919 return list;
920 }
921
922
923 /****************************************************************************
924 **
925 *F EvalRangeExpr(<expr>) . . . . . eval a range expression to a range value
926 **
927 ** 'EvalRangeExpr' evaluates the range expression <expr> to a range value.
928 */
EvalRangeExpr(Expr expr)929 static Obj EvalRangeExpr(Expr expr)
930 {
931 Obj range; /* range, result */
932 Obj val; /* subvalue of range */
933 Int low; /* low (as C integer) */
934 Int inc; /* increment (as C integer) */
935 Int high; /* high (as C integer) */
936
937 /* evaluate the low value */
938 val = EVAL_EXPR(READ_EXPR(expr, 0));
939 low = GetSmallIntEx("Range", val, "<first>");
940
941 /* evaluate the second value (if present) */
942 if ( SIZE_EXPR(expr) == 3*sizeof(Expr) ) {
943 val = EVAL_EXPR(READ_EXPR(expr, 1));
944 Int ival = GetSmallIntEx("Range", val, "<second>");
945 if (ival == low) {
946 ErrorMayQuit("Range: <second> must not be equal to <first> (%d)",
947 (Int)low, 0);
948 }
949 inc = ival - low;
950 }
951 else {
952 inc = 1;
953 }
954
955 /* evaluate and check the high value */
956 val = EVAL_EXPR(READ_EXPR(expr, SIZE_EXPR(expr) / sizeof(Expr) - 1));
957 high = GetSmallIntEx("Range", val, "<last>");
958 if ((high - low) % inc != 0) {
959 ErrorMayQuit(
960 "Range: <last>-<first> (%d) must be divisible by <inc> (%d)",
961 (Int)(high - low), (Int)inc);
962 }
963
964 /* if <low> is larger than <high> the range is empty */
965 if ( (0 < inc && high < low) || (inc < 0 && low < high) ) {
966 range = NewEmptyPlist();
967 }
968
969 /* if <low> is equal to <high> the range is a singleton list */
970 else if ( low == high ) {
971 range = NEW_PLIST( T_PLIST_CYC_SSORT, 1 );
972 SET_LEN_PLIST( range, 1 );
973 SET_ELM_PLIST( range, 1, INTOBJ_INT(low) );
974 }
975
976 /* else make the range */
977 else {
978 /* the length must be a small integer as well */
979 if ((high-low) / inc + 1 > INT_INTOBJ_MAX) {
980 ErrorQuit("Range: the length of a range must be a small integer",
981 0, 0);
982 }
983 if ( 0 < inc )
984 range = NEW_RANGE_SSORT();
985 else
986 range = NEW_RANGE_NSORT();
987 SET_LEN_RANGE( range, (high-low) / inc + 1 );
988 SET_LOW_RANGE( range, low );
989 SET_INC_RANGE( range, inc );
990 }
991
992 /* return the range */
993 return range;
994 }
995
996
997 /****************************************************************************
998 **
999 *F EvalStringExpr(<expr>) . . . . eval string expressions to a string value
1000 **
1001 ** 'EvalStringExpr' evaluates the string expression <expr> to a string
1002 ** value.
1003 */
EvalStringExpr(Expr expr)1004 static Obj EvalStringExpr(Expr expr)
1005 {
1006 UInt ix = READ_EXPR(expr, 0);
1007 Obj string = GET_VALUE_FROM_CURRENT_BODY(ix);
1008 return SHALLOW_COPY_OBJ(string);
1009 }
1010
1011 /****************************************************************************
1012 **
1013 *F EvalFloatExprLazy(<expr>) . . . . eval float expressions to a float value
1014 **
1015 ** 'EvalFloatExpr' evaluates the float expression <expr> to a float
1016 ** value.
1017 */
1018 static Obj CONVERT_FLOAT_LITERAL;
1019 static Obj FLOAT_LITERAL_CACHE;
1020 static Obj MAX_FLOAT_LITERAL_CACHE_SIZE;
1021
EvalFloatExprLazy(Expr expr)1022 static Obj EvalFloatExprLazy(Expr expr)
1023 {
1024 Obj string; /* string value */
1025 UInt ix;
1026 Obj cache= 0;
1027 Obj fl;
1028
1029 /* This code is safe for threads trying to create or update the
1030 * cache concurrently in that it won't crash, but may occasionally
1031 * result in evaluating a floating point literal twice.
1032 */
1033 ix = READ_EXPR(expr, 0);
1034 if (ix && (!MAX_FLOAT_LITERAL_CACHE_SIZE ||
1035 MAX_FLOAT_LITERAL_CACHE_SIZE == INTOBJ_INT(0) ||
1036 ix <= INT_INTOBJ(MAX_FLOAT_LITERAL_CACHE_SIZE))) {
1037 cache = FLOAT_LITERAL_CACHE;
1038 assert(cache);
1039 fl = ELM0_LIST(cache, ix);
1040 if (fl)
1041 return fl;
1042 }
1043 string = GET_VALUE_FROM_CURRENT_BODY(READ_EXPR(expr, 1));
1044 fl = CALL_1ARGS(CONVERT_FLOAT_LITERAL, string);
1045 if (cache) {
1046 ASS_LIST(cache, ix, fl);
1047 }
1048
1049 return fl;
1050 }
1051
1052 /****************************************************************************
1053 **
1054 *F EvalFloatExprEager(<expr>) . . . . eval float expressions to a float value
1055 **
1056 ** 'EvalFloatExpr' evaluates the float expression <expr> to a float
1057 ** value.
1058 */
EvalFloatExprEager(Expr expr)1059 static Obj EvalFloatExprEager(Expr expr)
1060 {
1061 UInt ix = READ_EXPR(expr, 0);
1062 return GET_VALUE_FROM_CURRENT_BODY(ix);
1063 }
1064
1065
1066 /****************************************************************************
1067 **
1068 *F EvalRecExpr(<expr>) . . . . . . eval record expression to a record value
1069 **
1070 ** 'EvalRecExpr' evaluates the record expression, i.e., not yet evaluated
1071 ** record, <expr> to a record value.
1072 **
1073 ** 'EvalRecExpr' just calls 'RecExpr1' and 'RecExpr2' to evaluate the record
1074 ** expression.
1075 */
1076 static Obj RecExpr1(Expr expr);
1077 static void RecExpr2(Obj rec, Expr expr);
1078
EvalRecExpr(Expr expr)1079 static Obj EvalRecExpr(Expr expr)
1080 {
1081 Obj rec; /* record value, result */
1082
1083 /* evaluate the record expression */
1084 rec = RecExpr1( expr );
1085 RecExpr2( rec, expr );
1086
1087 /* return the result */
1088 return rec;
1089 }
1090
1091
1092 /****************************************************************************
1093 **
1094 *F EvalRecTildeExpr(<expr>) . . . evaluate a record expression with a tilde
1095 **
1096 ** 'EvalRecTildeExpr' evaluates the record expression, i.e., not yet
1097 ** evaluated record, <expr> to a record value. The difference to
1098 ** 'EvalRecExpr' is that in <expr> there are occurrences of '~' referring to
1099 ** this record value.
1100 **
1101 ** 'EvalRecTildeExpr' just calls 'RecExpr1' to create the record, assigns
1102 ** the record to the variable '~', and finally calls 'RecExpr2' to evaluate
1103 ** the subexpressions into the record. Thus subexpressions in the record
1104 ** expression can refer to this variable and its subobjects to create
1105 ** objects that are not trees.
1106 */
EvalRecTildeExpr(Expr expr)1107 static Obj EvalRecTildeExpr(Expr expr)
1108 {
1109 Obj rec; /* record value, result */
1110 Obj tilde; /* old value of tilde */
1111
1112 /* remember the old value of '~' */
1113 tilde = STATE(Tilde);
1114
1115 /* create the record value */
1116 rec = RecExpr1( expr );
1117
1118 /* assign the record value to the variable '~' */
1119 STATE(Tilde) = rec;
1120
1121 /* evaluate the subexpressions into the record value */
1122 RecExpr2( rec, expr );
1123
1124 /* restore the old value of '~' */
1125 STATE(Tilde) = tilde;
1126
1127 /* return the record value */
1128 return rec;
1129 }
1130
1131
1132 /****************************************************************************
1133 **
1134 *F RecExpr1(<expr>) . . . . . . . . . make a record for a record expression
1135 *F RecExpr2(<rec>,<expr>) . . enter the subobjects for a record expression
1136 **
1137 ** 'RecExpr1' and 'RecExpr2' together evaluate the record expression <expr>
1138 ** into the record <rec>.
1139 **
1140 ** 'RecExpr1' allocates a new record of the same size as the record
1141 ** expression <expr> and returns this record.
1142 **
1143 ** 'RecExpr2' evaluates the subexpressions of <expr> and puts the values
1144 ** into the record <rec> (which should be a record of the same size as the
1145 ** record expression <expr>, e.g., the one allocated by 'RecExpr1').
1146 **
1147 ** This two step allocation is necessary, because record expressions such as
1148 ** 'rec( a := 1, ~.a )' requires that the value of one subexpression is
1149 ** entered into the record value before the next subexpression is evaluated.
1150 */
RecExpr1(Expr expr)1151 static Obj RecExpr1(Expr expr)
1152 {
1153 Obj rec; /* record value, result */
1154 Int len; /* number of components */
1155
1156 /* get the number of components */
1157 len = SIZE_EXPR( expr ) / (2*sizeof(Expr));
1158
1159 /* allocate the record value */
1160 rec = NEW_PREC( len );
1161
1162 /* return the record */
1163 return rec;
1164 }
1165
RecExpr2(Obj rec,Expr expr)1166 static void RecExpr2(Obj rec, Expr expr)
1167 {
1168 UInt rnam; /* name of component */
1169 Obj sub; /* value of subexpression */
1170 Int len; /* number of components */
1171 Expr tmp; /* temporary variable */
1172 Int i; /* loop variable */
1173
1174 /* get the number of components */
1175 len = SIZE_EXPR( expr ) / (2*sizeof(Expr));
1176
1177 /* handle the subexpressions */
1178 for ( i = 1; i <= len; i++ ) {
1179
1180 /* handle the name */
1181 tmp = READ_EXPR(expr, 2 * i - 2);
1182 if ( IS_INTEXPR(tmp) ) {
1183 rnam = (UInt)INT_INTEXPR(tmp);
1184 }
1185 else {
1186 rnam = RNamObj( EVAL_EXPR(tmp) );
1187 }
1188
1189 /* if the subexpression is empty (cannot happen for records) */
1190 tmp = READ_EXPR(expr, 2 * i - 1);
1191 if ( tmp == 0 ) {
1192 continue;
1193 }
1194 sub = EVAL_EXPR( tmp );
1195 AssPRec(rec,rnam,sub);
1196 }
1197 SortPRecRNam(rec,0);
1198
1199 }
1200
1201
1202 /****************************************************************************
1203 **
1204 *F PrintExpr(<expr>) . . . . . . . . . . . . . . . . . . print an expression
1205 **
1206 ** 'PrintExpr' prints the expression <expr>.
1207 **
1208 ** 'PrintExpr' simply dispatches through the table 'PrintExprFuncs' to the
1209 ** appropriate printer.
1210 */
PrintExpr(Expr expr)1211 void PrintExpr (
1212 Expr expr )
1213 {
1214 (*PrintExprFuncs[ TNUM_EXPR(expr) ])( expr );
1215 }
1216
1217
1218 /****************************************************************************
1219 **
1220 *V PrintExprFuncs[<type>] . . printing function for objects of type <type>
1221 **
1222 ** 'PrintExprFuncs' is the dispatching table that contains for every type of
1223 ** expressions a pointer to the printer for expressions of this type, i.e.,
1224 ** the function that should be called to print expressions of this type.
1225 */
1226 void (* PrintExprFuncs[256] ) ( Expr expr );
1227
1228
1229 /****************************************************************************
1230 **
1231 *F PrintUnknownExpr(<expr>) . . . . . . . print expression of unknown type
1232 **
1233 ** 'PrintUnknownExpr' is the printer that is called if an attempt is made to
1234 ** print an expression <expr> of an unknown type. It signals an error. If
1235 ** this is ever called, then GAP is in serious trouble, such as an
1236 ** overwritten type field of an expression.
1237 */
PrintUnknownExpr(Expr expr)1238 static void PrintUnknownExpr(Expr expr)
1239 {
1240 Pr( "Panic: tried to print an expression of unknown type '%d'\n",
1241 (Int)TNUM_EXPR(expr), 0L );
1242 }
1243
1244
1245 struct ExprsState {
1246
1247 /****************************************************************************
1248 **
1249 *V PrintPrecedence . . . . . . . . . . . . . . . . current precedence level
1250 **
1251 ** 'PrintPrecedence' contains the current precedence level, i.e., an integer
1252 ** indicating the binding power of the currently printed operator. If one of
1253 ** the operands is an operation that has lower binding power it is printed
1254 ** in parenthesis. If the right operand has the same binding power it is put
1255 ** in parenthesis, since all the operations are left associative.
1256 ** Precedence: 14: ^; 12: mod,/,*; 10: -,+; 8: in,=; 6: not; 4: and; 2: or.
1257 ** This sometimes puts in superfluous parenthesis: 2 * f( (3 + 4) ), since it
1258 ** doesn't know that a function call adds automatically parenthesis.
1259 */
1260 UInt PrintPrecedence;
1261
1262 };
1263
1264 static ModuleStateOffset ExprsStateOffset = -1;
1265
ExprsState(void)1266 extern inline struct ExprsState * ExprsState(void)
1267 {
1268 return (struct ExprsState *)StateSlotsAtOffset(ExprsStateOffset);
1269 }
1270
1271 #define PrintPrecedence ExprsState()->PrintPrecedence
1272
1273 /****************************************************************************
1274 **
1275 *F PrintNot(<expr>) . . . . . . . . . . . . . print a boolean not operator
1276 **
1277 ** 'PrintNot' print a not operation in the following form: 'not <expr>'.
1278 */
PrintNot(Expr expr)1279 static void PrintNot(Expr expr)
1280 {
1281 UInt oldPrec;
1282
1283 oldPrec = PrintPrecedence;
1284 PrintPrecedence = 6;
1285
1286 /* if necessary print the opening parenthesis */
1287 if ( oldPrec >= PrintPrecedence ) Pr("%>(%>",0L,0L);
1288 else Pr("%2>",0L,0L);
1289
1290 Pr("not%> ",0L,0L);
1291 PrintExpr(READ_EXPR(expr, 0));
1292 Pr("%<",0L,0L);
1293
1294 /* if necessary print the closing parenthesis */
1295 if ( oldPrec >= PrintPrecedence ) Pr("%2<)",0L,0L);
1296 else Pr("%2<",0L,0L);
1297
1298 PrintPrecedence = oldPrec;
1299 }
1300
1301
1302 /****************************************************************************
1303 **
1304 *F PrintBinop(<expr>) . . . . . . . . . . . . . . prints a binary operator
1305 **
1306 ** 'PrintBinop' prints the binary operator expression <expr>, using
1307 ** 'PrintPrecedence' for parenthesising.
1308 */
PrintAInv(Expr expr)1309 static void PrintAInv(Expr expr)
1310 {
1311 UInt oldPrec;
1312
1313 oldPrec = PrintPrecedence;
1314 PrintPrecedence = 11;
1315
1316 /* if necessary print the opening parenthesis */
1317 if ( oldPrec >= PrintPrecedence ) Pr("%>(%>",0L,0L);
1318 else Pr("%2>",0L,0L);
1319
1320 Pr("-%> ",0L,0L);
1321 PrintExpr(READ_EXPR(expr, 0));
1322 Pr("%<",0L,0L);
1323
1324 /* if necessary print the closing parenthesis */
1325 if ( oldPrec >= PrintPrecedence ) Pr("%2<)",0L,0L);
1326 else Pr("%2<",0L,0L);
1327
1328 PrintPrecedence = oldPrec;
1329 }
1330
PrintBinop(Expr expr)1331 static void PrintBinop(Expr expr)
1332 {
1333 UInt oldPrec; /* old precedence level */
1334 const Char * op; /* operand */
1335 /* remember the current precedence level */
1336 oldPrec = PrintPrecedence;
1337
1338 /* select the new precedence level */
1339 switch ( TNUM_EXPR(expr) ) {
1340 case EXPR_OR: op = "or"; PrintPrecedence = 2; break;
1341 case EXPR_AND: op = "and"; PrintPrecedence = 4; break;
1342 case EXPR_EQ: op = "="; PrintPrecedence = 8; break;
1343 case EXPR_LT: op = "<"; PrintPrecedence = 8; break;
1344 case EXPR_GT: op = ">"; PrintPrecedence = 8; break;
1345 case EXPR_NE: op = "<>"; PrintPrecedence = 8; break;
1346 case EXPR_LE: op = "<="; PrintPrecedence = 8; break;
1347 case EXPR_GE: op = ">="; PrintPrecedence = 8; break;
1348 case EXPR_IN: op = "in"; PrintPrecedence = 8; break;
1349 case EXPR_SUM: op = "+"; PrintPrecedence = 10; break;
1350 case EXPR_DIFF: op = "-"; PrintPrecedence = 10; break;
1351 case EXPR_PROD: op = "*"; PrintPrecedence = 12; break;
1352 case EXPR_QUO: op = "/"; PrintPrecedence = 12; break;
1353 case EXPR_MOD: op = "mod"; PrintPrecedence = 12; break;
1354 case EXPR_POW: op = "^"; PrintPrecedence = 16; break;
1355 default: op = "<bogus-operator>"; break;
1356 }
1357
1358 /* if necessary print the opening parenthesis */
1359 if ( oldPrec > PrintPrecedence ) Pr("%>(%>",0L,0L);
1360 else Pr("%2>",0L,0L);
1361
1362 /* print the left operand */
1363 if ( TNUM_EXPR(expr) == EXPR_POW
1364 && (( (IS_INTEXPR(READ_EXPR(expr, 0))
1365 && INT_INTEXPR(READ_EXPR(expr, 0)) < 0)
1366 || TNUM_EXPR(READ_EXPR(expr, 0)) == T_INTNEG)
1367 || TNUM_EXPR(READ_EXPR(expr, 0)) == EXPR_POW) ) {
1368 Pr( "(", 0L, 0L );
1369 PrintExpr(READ_EXPR(expr, 0));
1370 Pr( ")", 0L, 0L );
1371 }
1372 else {
1373 PrintExpr(READ_EXPR(expr, 0));
1374 }
1375
1376 /* print the operator */
1377 Pr("%2< %2>%s%> %<",(Int)op,0L);
1378
1379 /* print the right operand */
1380 PrintPrecedence++;
1381 PrintExpr(READ_EXPR(expr, 1));
1382 PrintPrecedence--;
1383
1384 /* if necessary print the closing parenthesis */
1385 if ( oldPrec > PrintPrecedence ) Pr("%2<)",0L,0L);
1386 else Pr("%2<",0L,0L);
1387
1388 /* restore the old precedence level */
1389 PrintPrecedence = oldPrec;
1390 }
1391
1392
1393 /****************************************************************************
1394 **
1395 *F PrintIntExpr(<expr>) . . . . . . . . . . . . print an integer expression
1396 **
1397 ** 'PrintIntExpr' prints the literal integer expression <expr>.
1398 */
PrintIntExpr(Expr expr)1399 static void PrintIntExpr(Expr expr)
1400 {
1401 if ( IS_INTEXPR(expr) ) {
1402 Pr( "%d", INT_INTEXPR(expr), 0L );
1403 }
1404 else {
1405 PrintInt(EvalIntExpr(expr));
1406 }
1407 }
1408
1409
1410 /****************************************************************************
1411 **
1412 *F PrintTildeExpr(<expr>) . . . . . . . . . . . print tilde expression
1413 */
PrintTildeExpr(Expr expr)1414 static void PrintTildeExpr(Expr expr)
1415 {
1416 Pr( "~", 0L, 0L );
1417 }
1418
1419 /****************************************************************************
1420 **
1421 *F PrintTrueExpr(<expr>) . . . . . . . . . . . print literal true expression
1422 */
PrintTrueExpr(Expr expr)1423 static void PrintTrueExpr(Expr expr)
1424 {
1425 Pr( "true", 0L, 0L );
1426 }
1427
1428
1429 /****************************************************************************
1430 **
1431 *F PrintFalseExpr(<expr>) . . . . . . . . . print literal false expression
1432 */
PrintFalseExpr(Expr expr)1433 static void PrintFalseExpr(Expr expr)
1434 {
1435 Pr( "false", 0L, 0L );
1436 }
1437
1438
1439 /****************************************************************************
1440 **
1441 *F PrintCharExpr(<expr>) . . . . . . . . print literal character expression
1442 */
PrintCharExpr(Expr expr)1443 static void PrintCharExpr(Expr expr)
1444 {
1445 UChar chr;
1446
1447 chr = READ_EXPR(expr, 0);
1448 if ( chr == '\n' ) Pr("'\\n'",0L,0L);
1449 else if ( chr == '\t' ) Pr("'\\t'",0L,0L);
1450 else if ( chr == '\r' ) Pr("'\\r'",0L,0L);
1451 else if ( chr == '\b' ) Pr("'\\b'",0L,0L);
1452 else if ( chr == '\03' ) Pr("'\\c'",0L,0L);
1453 else if ( chr == '\'' ) Pr("'\\''",0L,0L);
1454 else if ( chr == '\\' ) Pr("'\\\\'",0L,0L);
1455 else Pr("'%c'",(Int)chr,0L);
1456 }
1457
1458
1459 /****************************************************************************
1460 **
1461 *F PrintPermExpr(<expr>) . . . . . . . . . . print a permutation expression
1462 **
1463 ** 'PrintPermExpr' prints the permutation expression <expr>.
1464 */
PrintPermExpr(Expr expr)1465 static void PrintPermExpr(Expr expr)
1466 {
1467 Expr cycle; /* one cycle of permutation expr. */
1468 UInt i, j; /* loop variables */
1469
1470 /* if there are no cycles, print the identity permutation */
1471 if ( SIZE_EXPR(expr) == 0 ) {
1472 Pr("()",0L,0L);
1473 }
1474
1475 /* print all cycles */
1476 for ( i = 1; i <= SIZE_EXPR(expr)/sizeof(Expr); i++ ) {
1477 cycle = READ_EXPR(expr, i - 1);
1478 Pr("%>(",0L,0L);
1479
1480 /* print all entries of that cycle */
1481 for ( j = 1; j <= SIZE_EXPR(cycle)/sizeof(Expr); j++ ) {
1482 Pr("%>",0L,0L);
1483 PrintExpr(READ_EXPR(cycle, j - 1));
1484 Pr("%<",0L,0L);
1485 if ( j < SIZE_EXPR(cycle)/sizeof(Expr) ) Pr(",",0L,0L);
1486 }
1487
1488 Pr("%<)",0L,0L);
1489 }
1490 }
1491
1492
1493 /****************************************************************************
1494 **
1495 *F PrintListExpr(<expr>) . . . . . . . . . . . . . . print a list expression
1496 **
1497 ** 'PrintListExpr' prints the list expression <expr>.
1498 */
PrintListExpr(Expr expr)1499 static void PrintListExpr(Expr expr)
1500 {
1501 Int len; /* logical length of <list> */
1502 Expr elm; /* one element from <list> */
1503 Int i; /* loop variable */
1504
1505 /* get the logical length of the list */
1506 len = SIZE_EXPR( expr ) / sizeof(Expr);
1507
1508 /* loop over the entries */
1509 Pr("%2>[ %2>",0L,0L);
1510 for ( i = 1; i <= len; i++ ) {
1511 elm = READ_EXPR(expr, i - 1);
1512 if ( elm != 0 ) {
1513 if ( 1 < i ) Pr("%<,%< %2>",0L,0L);
1514 PrintExpr( elm );
1515 }
1516 else {
1517 if ( 1 < i ) Pr("%2<,%2>",0L,0L);
1518 }
1519 }
1520 Pr(" %4<]",0L,0L);
1521 }
1522
1523
1524 /****************************************************************************
1525 **
1526 *F PrintRangeExpr(<expr>) . . . . . . . . . . . . . print range expression
1527 **
1528 ** 'PrintRangeExpr' prints the record expression <expr>.
1529 */
PrintRangeExpr(Expr expr)1530 static void PrintRangeExpr(Expr expr)
1531 {
1532 if ( SIZE_EXPR( expr ) == 2*sizeof(Expr) ) {
1533 Pr("%2>[ %2>",0L,0L); PrintExpr( READ_EXPR(expr, 0) );
1534 Pr("%2< .. %2>",0L,0L); PrintExpr( READ_EXPR(expr, 1) );
1535 Pr(" %4<]",0L,0L);
1536 }
1537 else {
1538 Pr("%2>[ %2>",0L,0L); PrintExpr( READ_EXPR(expr, 0) );
1539 Pr("%<,%< %2>",0L,0L); PrintExpr( READ_EXPR(expr, 1) );
1540 Pr("%2< .. %2>",0L,0L); PrintExpr( READ_EXPR(expr, 2) );
1541 Pr(" %4<]",0L,0L);
1542 }
1543 }
1544
1545
1546 /****************************************************************************
1547 **
1548 *F PrintStringExpr(<expr>) . . . . . . . . . . . . print a string expression
1549 **
1550 ** 'PrintStringExpr' prints the string expression <expr>.
1551 */
PrintStringExpr(Expr expr)1552 static void PrintStringExpr(Expr expr)
1553 {
1554 UInt ix = READ_EXPR(expr, 0);
1555 Obj string = GET_VALUE_FROM_CURRENT_BODY(ix);
1556
1557 PrintString(string);
1558 }
1559
1560 /****************************************************************************
1561 **
1562 *F PrintFloatExpr(<expr>) . . . . . . . . . . . . print a float expression
1563 **
1564 ** 'PrintFloatExpr' prints the float expression <expr>.
1565 */
PrintFloatExprLazy(Expr expr)1566 static void PrintFloatExprLazy(Expr expr)
1567 {
1568 UInt ix = READ_EXPR(expr, 1);
1569 Pr("%g", (Int)GET_VALUE_FROM_CURRENT_BODY(ix), 0L);
1570 }
1571
1572 /****************************************************************************
1573 **
1574 *F PrintFloatExprEager(<expr>) . . . . . . . . . . . . print a float expression
1575 **
1576 ** 'PrintFloatExpr' prints the float expression <expr>.
1577 */
PrintFloatExprEager(Expr expr)1578 static void PrintFloatExprEager(Expr expr)
1579 {
1580 UInt ix = READ_EXPR(expr, 1);
1581 Char mark = (Char)READ_EXPR(expr, 2);
1582 Pr("%g_", (Int)GET_VALUE_FROM_CURRENT_BODY(ix), 0L);
1583 if (mark != '\0') {
1584 Pr("%c", mark, 0);
1585 }
1586 }
1587
1588
1589 /****************************************************************************
1590 **
1591 *F PrintRecExpr(<expr>) . . . . . . . . . . . . . print a record expression
1592 **
1593 ** 'PrintRecExpr' the record expression <expr>.
1594 */
PrintRecExpr1(Expr expr)1595 void PrintRecExpr1 (
1596 Expr expr )
1597 {
1598 Expr tmp; /* temporary variable */
1599 UInt i; /* loop variable */
1600
1601 for ( i = 1; i <= SIZE_EXPR(expr)/(2*sizeof(Expr)); i++ ) {
1602 /* print an ordinary record name */
1603 tmp = READ_EXPR(expr, 2 * i - 2);
1604 if ( IS_INTEXPR(tmp) ) {
1605 Pr( "%H", (Int)NAME_RNAM( INT_INTEXPR(tmp) ), 0L );
1606 }
1607
1608 /* print an evaluating record name */
1609 else {
1610 Pr(" (",0L,0L);
1611 PrintExpr( tmp );
1612 Pr(")",0L,0L);
1613 }
1614
1615 /* print the component */
1616 tmp = READ_EXPR(expr, 2 * i - 1);
1617 Pr("%< := %>",0L,0L);
1618 PrintExpr( tmp );
1619 if ( i < SIZE_EXPR(expr)/(2*sizeof(Expr)) )
1620 Pr("%2<,\n%2>",0L,0L);
1621
1622 }
1623 }
1624
PrintRecExpr(Expr expr)1625 static void PrintRecExpr(Expr expr)
1626 {
1627 Pr("%2>rec(\n%2>",0L,0L);
1628 PrintRecExpr1(expr);
1629 Pr(" %4<)",0L,0L);
1630
1631 }
1632
1633
FuncFLUSH_FLOAT_LITERAL_CACHE(Obj self)1634 static Obj FuncFLUSH_FLOAT_LITERAL_CACHE(Obj self)
1635 {
1636 #ifdef HPCGAP
1637 FLOAT_LITERAL_CACHE = NewAtomicList(T_ALIST, 0);
1638 #else
1639 FLOAT_LITERAL_CACHE = NEW_PLIST(T_PLIST, 0);
1640 #endif
1641 return 0;
1642 }
1643
1644
1645 /****************************************************************************
1646 **
1647 *F * * * * * * * * * * * * * initialize module * * * * * * * * * * * * * * *
1648 */
1649
1650 /****************************************************************************
1651 **
1652 *V GVarFuncs . . . . . . . . . . . . . . . . . . list of functions to export
1653 */
1654 static StructGVarFunc GVarFuncs [] = {
1655
1656 GVAR_FUNC(FLUSH_FLOAT_LITERAL_CACHE, 0, ""),
1657 { 0, 0, 0, 0, 0 }
1658
1659 };
1660
1661
1662 /****************************************************************************
1663 **
1664 *F InitKernel( <module> ) . . . . . . . . initialise kernel data structures
1665 */
InitKernel(StructInitInfo * module)1666 static Int InitKernel (
1667 StructInitInfo * module )
1668 {
1669 UInt type; /* loop variable */
1670
1671 InitFopyGVar("CONVERT_FLOAT_LITERAL",&CONVERT_FLOAT_LITERAL);
1672 InitCopyGVar("MAX_FLOAT_LITERAL_CACHE_SIZE",&MAX_FLOAT_LITERAL_CACHE_SIZE);
1673
1674 InitGlobalBag( &FLOAT_LITERAL_CACHE, "FLOAT_LITERAL_CACHE" );
1675 InitHdlrFuncsFromTable( GVarFuncs );
1676
1677
1678 /* clear the evaluation dispatch table */
1679 for ( type = 0; type < 256; type++ ) {
1680 InstallEvalExprFunc( type , EvalUnknownExpr);
1681 InstallEvalBoolFunc( type , EvalUnknownBool);
1682 }
1683
1684 /* install the evaluators for logical operations */
1685 InstallEvalExprFunc( EXPR_OR , EvalOr);
1686 InstallEvalExprFunc( EXPR_AND , EvalAnd);
1687 InstallEvalExprFunc( EXPR_NOT , EvalNot);
1688
1689 /* the logical operations are guaranteed to return booleans */
1690 InstallEvalBoolFunc( EXPR_OR , EvalOr);
1691 InstallEvalBoolFunc( EXPR_AND , EvalAnd);
1692 InstallEvalBoolFunc( EXPR_NOT , EvalNot);
1693
1694 /* install the evaluators for comparison operations */
1695 InstallEvalExprFunc( EXPR_EQ , EvalEq);
1696 InstallEvalExprFunc( EXPR_NE , EvalNe);
1697 InstallEvalExprFunc( EXPR_LT , EvalLt);
1698 InstallEvalExprFunc( EXPR_GE , EvalGe);
1699 InstallEvalExprFunc( EXPR_GT , EvalGt);
1700 InstallEvalExprFunc( EXPR_LE , EvalLe);
1701 InstallEvalExprFunc( EXPR_IN , EvalIn);
1702
1703 /* the comparison operations are guaranteed to return booleans */
1704 InstallEvalBoolFunc( EXPR_EQ , EvalEq);
1705 InstallEvalBoolFunc( EXPR_NE , EvalNe);
1706 InstallEvalBoolFunc( EXPR_LT , EvalLt);
1707 InstallEvalBoolFunc( EXPR_GE , EvalGe);
1708 InstallEvalBoolFunc( EXPR_GT , EvalGt);
1709 InstallEvalBoolFunc( EXPR_LE , EvalLe);
1710 InstallEvalBoolFunc( EXPR_IN , EvalIn);
1711
1712 /* install the evaluators for binary operations */
1713 InstallEvalExprFunc( EXPR_SUM , EvalSum);
1714 InstallEvalExprFunc( EXPR_AINV , EvalAInv);
1715 InstallEvalExprFunc( EXPR_DIFF , EvalDiff);
1716 InstallEvalExprFunc( EXPR_PROD , EvalProd);
1717 InstallEvalExprFunc( EXPR_QUO , EvalQuo);
1718 InstallEvalExprFunc( EXPR_MOD , EvalMod);
1719 InstallEvalExprFunc( EXPR_POW , EvalPow);
1720
1721 /* install the evaluators for literal expressions */
1722 InstallEvalExprFunc( EXPR_INTPOS , EvalIntExpr);
1723 InstallEvalExprFunc( EXPR_TRUE , EvalTrueExpr);
1724 InstallEvalExprFunc( EXPR_FALSE , EvalFalseExpr);
1725 InstallEvalExprFunc( EXPR_TILDE , EvalTildeExpr);
1726 InstallEvalExprFunc( EXPR_CHAR , EvalCharExpr);
1727 InstallEvalExprFunc( EXPR_PERM , EvalPermExpr);
1728 InstallEvalExprFunc( EXPR_FLOAT_LAZY , EvalFloatExprLazy);
1729 InstallEvalExprFunc( EXPR_FLOAT_EAGER , EvalFloatExprEager);
1730
1731 /* install the evaluators for list and record expressions */
1732 InstallEvalExprFunc( EXPR_LIST , EvalListExpr);
1733 InstallEvalExprFunc( EXPR_LIST_TILDE, EvalListTildeExpr);
1734 InstallEvalExprFunc( EXPR_RANGE , EvalRangeExpr);
1735 InstallEvalExprFunc( EXPR_STRING , EvalStringExpr);
1736 InstallEvalExprFunc( EXPR_REC , EvalRecExpr);
1737 InstallEvalExprFunc( EXPR_REC_TILDE , EvalRecTildeExpr);
1738
1739 /* clear the tables for the printing dispatching */
1740 for ( type = 0; type < 256; type++ ) {
1741 InstallPrintExprFunc( type , PrintUnknownExpr);
1742 }
1743
1744 /* install the printers for logical operations */
1745 InstallPrintExprFunc( EXPR_OR , PrintBinop);
1746 InstallPrintExprFunc( EXPR_AND , PrintBinop);
1747 InstallPrintExprFunc( EXPR_NOT , PrintNot);
1748
1749 /* install the printers for comparison operations */
1750 InstallPrintExprFunc( EXPR_EQ , PrintBinop);
1751 InstallPrintExprFunc( EXPR_LT , PrintBinop);
1752 InstallPrintExprFunc( EXPR_NE , PrintBinop);
1753 InstallPrintExprFunc( EXPR_GE , PrintBinop);
1754 InstallPrintExprFunc( EXPR_GT , PrintBinop);
1755 InstallPrintExprFunc( EXPR_LE , PrintBinop);
1756 InstallPrintExprFunc( EXPR_IN , PrintBinop);
1757
1758 /* install the printers for binary operations */
1759 InstallPrintExprFunc( EXPR_SUM , PrintBinop);
1760 InstallPrintExprFunc( EXPR_AINV , PrintAInv);
1761 InstallPrintExprFunc( EXPR_DIFF , PrintBinop);
1762 InstallPrintExprFunc( EXPR_PROD , PrintBinop);
1763 InstallPrintExprFunc( EXPR_QUO , PrintBinop);
1764 InstallPrintExprFunc( EXPR_MOD , PrintBinop);
1765 InstallPrintExprFunc( EXPR_POW , PrintBinop);
1766
1767 /* install the printers for literal expressions */
1768 InstallPrintExprFunc( EXPR_INT , PrintIntExpr);
1769 InstallPrintExprFunc( EXPR_INTPOS , PrintIntExpr);
1770 InstallPrintExprFunc( EXPR_TRUE , PrintTrueExpr);
1771 InstallPrintExprFunc( EXPR_FALSE , PrintFalseExpr);
1772 InstallPrintExprFunc( EXPR_TILDE , PrintTildeExpr);
1773 InstallPrintExprFunc( EXPR_CHAR , PrintCharExpr);
1774 InstallPrintExprFunc( EXPR_PERM , PrintPermExpr);
1775 InstallPrintExprFunc( EXPR_FLOAT_LAZY , PrintFloatExprLazy);
1776 InstallPrintExprFunc( EXPR_FLOAT_EAGER , PrintFloatExprEager);
1777
1778 /* install the printers for list and record expressions */
1779 InstallPrintExprFunc( EXPR_LIST , PrintListExpr);
1780 InstallPrintExprFunc( EXPR_LIST_TILDE, PrintListExpr);
1781 InstallPrintExprFunc( EXPR_RANGE , PrintRangeExpr);
1782 InstallPrintExprFunc( EXPR_STRING , PrintStringExpr);
1783 InstallPrintExprFunc( EXPR_REC , PrintRecExpr);
1784 InstallPrintExprFunc( EXPR_REC_TILDE , PrintRecExpr);
1785
1786 /* return success */
1787 return 0;
1788 }
1789
1790
InitLibrary(StructInitInfo * module)1791 static Int InitLibrary(StructInitInfo * module)
1792 {
1793 /* init filters and functions */
1794 InitGVarFuncsFromTable( GVarFuncs );
1795
1796 FuncFLUSH_FLOAT_LITERAL_CACHE(0);
1797
1798 return 0;
1799 }
1800
1801 /****************************************************************************
1802 **
1803 *F InitInfoExprs() . . . . . . . . . . . . . . . . . table of init functions
1804 */
1805 static StructInitInfo module = {
1806 // init struct using C99 designated initializers; for a full list of
1807 // fields, please refer to the definition of StructInitInfo
1808 .type = MODULE_BUILTIN,
1809 .name = "exprs",
1810 .initKernel = InitKernel,
1811 .initLibrary = InitLibrary,
1812
1813 .moduleStateSize = sizeof(struct ExprsState),
1814 .moduleStateOffsetPtr = &ExprsStateOffset,
1815 };
1816
InitInfoExprs(void)1817 StructInitInfo * InitInfoExprs ( void )
1818 {
1819 return &module;
1820 }
1821