1 /* GENIUS Calculator
2 * Copyright (C) 1997-2018 Jiri (George) Lebl
3 *
4 * Author: Jiri (George) Lebl
5 *
6 * This file is part of Genius.
7 *
8 * Genius is free software: you can redistribute it and/or modify
9 * it under the terms of the GNU General Public License as published by
10 * the Free Software Foundation, either version 3 of the License, or
11 * (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program. If not, see <http://www.gnu.org/licenses/>.
20 */
21
22 #include "config.h"
23
24 #include <stdio.h>
25 #include <string.h>
26 #include <glib.h>
27 #include "calc.h"
28 #include "mpwrap.h"
29 #include "eval.h"
30 #include "dict.h"
31 #include "util.h"
32 #include "matrix.h"
33 #include "matrixw.h"
34 #include "matop.h"
35 #include "compil.h"
36 #include "utype.h"
37
38 #ifdef EVAL_DEBUG
39 #define EDEBUG(x) puts(x)
40 #else
41 #define EDEBUG(x) ;
42 #endif
43
44 GelETree *gel_free_trees = NULL;
45 static GelEvalStack *free_stack = NULL;
46
47 #ifndef MEM_DEBUG_FRIENDLY
48 static GelEvalLoop *free_evl = NULL;
49 static GelEvalFor *free_evf = NULL;
50 static GelEvalForIn *free_evfi = NULL;
51
52 static void _gel_make_free_evl (void);
53 static void _gel_make_free_evf (void);
54 static void _gel_make_free_evfi (void);
55 #endif /* ! MEM_DEBUG_FRIENDLY */
56
57 #ifdef MEM_DEBUG_FRIENDLY
58 static GelCtx *most_recent_ctx = NULL;
59 #endif
60
61 static void
ge_add_stack_array(GelCtx * ctx)62 ge_add_stack_array(GelCtx *ctx)
63 {
64 GelEvalStack *newstack;
65 #ifdef MEM_DEBUG_FRIENDLY
66 newstack = g_new0 (GelEvalStack, 1);
67 #else
68 if (free_stack == NULL) {
69 newstack = g_new (GelEvalStack, 1);
70 } else {
71 newstack = free_stack;
72 free_stack = free_stack->next;
73 }
74 #endif
75
76 newstack->next = ctx->stack;
77 ctx->stack = newstack;
78 /*the array is at the beginning of the structure*/
79 ctx->topstack = (gpointer *)newstack;
80 EDEBUG("ADDING STACK ARRAY");
81 }
82
83 /*we assume that a stack always exists*/
84 #define GE_PUSH_STACK(thectx,pointer,flag) { \
85 if G_UNLIKELY ((thectx)->topstack == &((thectx)->stack->stack[STACK_SIZE])) \
86 ge_add_stack_array(thectx); \
87 *((thectx)->topstack ++) = (pointer); \
88 *((thectx)->topstack ++) = GINT_TO_POINTER(flag); \
89 }
90
91 static gboolean
ge_remove_stack_array(GelCtx * ctx)92 ge_remove_stack_array(GelCtx *ctx)
93 {
94 GelEvalStack *next = ctx->stack->next;
95 if G_UNLIKELY (!next) return FALSE;
96
97 /*push it onto the list of free stack entries*/
98 #ifdef MEM_DEBUG_FRIENDLY
99 memset (ctx->stack, 0xaa, sizeof (GelEvalStack));
100 # ifndef MEM_DEBUG_SUPER_FRIENDLY
101 g_free (ctx->stack);
102 # endif /* !MEM_DEBUG_SUPER_FRIENDLY */
103 #else /* MEM_DEBUG_FRIENDLY */
104 ctx->stack->next = free_stack;
105 free_stack = ctx->stack;
106 #endif /* MEM_DEBUG_FRIENDLY */
107
108 ctx->stack = next;
109 ctx->topstack = &((ctx)->stack->stack[STACK_SIZE]);
110 EDEBUG("REMOVING STACK ARRAY");
111 return TRUE;
112 }
113
114 #ifdef MEM_DEBUG_FRIENDLY
115 #define GE_POP_STACK(thectx,pointer,flag) { \
116 if((thectx)->topstack != (gpointer *)(thectx)->stack || \
117 ge_remove_stack_array(ctx)) { \
118 (flag) = GPOINTER_TO_INT(*(-- (thectx)->topstack)); \
119 *((thectx)->topstack) = NULL; \
120 (pointer) = *(-- (thectx)->topstack); \
121 *((thectx)->topstack) = NULL; \
122 } else { \
123 (flag) = GE_EMPTY_STACK; \
124 (pointer) = NULL; \
125 } \
126 }
127 #define GE_POP_STACKNF(thectx,pointer) { \
128 if((thectx)->topstack != (gpointer *)(thectx)->stack || \
129 ge_remove_stack_array(ctx)) { \
130 -- (thectx)->topstack; \
131 *((thectx)->topstack) = NULL; \
132 (pointer) = *(-- (thectx)->topstack); \
133 *((thectx)->topstack) = NULL; \
134 } else { \
135 (pointer) = NULL; \
136 } \
137 }
138 #else /* MEM_DEBUG_FRIENDLY */
139 #define GE_POP_STACK(thectx,pointer,flag) { \
140 if G_LIKELY ((thectx)->topstack != (gpointer *)(thectx)->stack || \
141 ge_remove_stack_array(ctx)) { \
142 (flag) = GPOINTER_TO_INT(*(-- (thectx)->topstack)); \
143 (pointer) = *(-- (thectx)->topstack); \
144 } else { \
145 (flag) = GE_EMPTY_STACK; \
146 (pointer) = NULL; \
147 } \
148 }
149 #define GE_POP_STACKNF(thectx,pointer) { \
150 if G_LIKELY ((thectx)->topstack != (gpointer *)(thectx)->stack || \
151 ge_remove_stack_array(ctx)) { \
152 -- (thectx)->topstack; \
153 (pointer) = *(-- (thectx)->topstack); \
154 } else { \
155 (pointer) = NULL; \
156 } \
157 }
158 #endif /* MEM_DEBUG_FRIENDLY */
159
160 #define GE_PEEK_STACK(thectx,pointer,flag) { \
161 if G_LIKELY ((thectx)->topstack != (gpointer *)(thectx)->stack) { \
162 (flag) = GPOINTER_TO_INT(*((thectx)->topstack - 1)); \
163 (pointer) = *((thectx)->topstack - 2); \
164 } else if((thectx)->stack->next) { \
165 gpointer *a = (gpointer) &((thectx)->stack->next->next);\
166 (flag) = GPOINTER_TO_INT(*(--a)); \
167 (pointer) = *(--a); \
168 } else { \
169 (flag) = GE_EMPTY_STACK; \
170 (pointer) = NULL; \
171 } \
172 }
173
174 #ifdef MEM_DEBUG_FRIENDLY
175 #define GE_BLIND_POP_STACK(thectx) { \
176 if((thectx)->topstack != (gpointer *)(thectx)->stack || \
177 ge_remove_stack_array(thectx)) { \
178 *(-- (thectx)->topstack) = NULL; \
179 *(-- (thectx)->topstack) = NULL; \
180 } \
181 }
182 #else /* MEM_DEBUG_FRIENDLY */
183 #define GE_BLIND_POP_STACK(thectx) { \
184 if G_LIKELY ((thectx)->topstack != (gpointer *)(thectx)->stack || \
185 ge_remove_stack_array(thectx)) { \
186 (thectx)->topstack -= 2; \
187 } \
188 }
189 #endif /* MEM_DEBUG_FRIENDLY */
190
191 static void mod_node(GelETree *n, mpw_ptr mod);
192 static void mod_matrix (GelMatrixW *m, mpw_ptr mod);
193 static GelEFunc * get_func_from (GelETree *l, gboolean silent);
194 static int branches (int op) G_GNUC_CONST;
195
196
197 /*returns the number of args for an operator, or -1 if it takes up till
198 exprlist marker or -2 if it takes one more for the first argument*/
199 static int
branches(int op)200 branches (int op)
201 {
202 switch(op) {
203 case GEL_E_SEPAR: return 2;
204 case GEL_E_EQUALS: return 2;
205 case GEL_E_PARAMETER: return 3;
206 case GEL_E_ABS: return 1;
207 case GEL_E_PLUS: return 2;
208 case GEL_E_ELTPLUS: return 2;
209 case GEL_E_MINUS: return 2;
210 case GEL_E_ELTMINUS: return 2;
211 case GEL_E_MUL: return 2;
212 case GEL_E_ELTMUL: return 2;
213 case GEL_E_DIV: return 2;
214 case GEL_E_ELTDIV: return 2;
215 case GEL_E_BACK_DIV: return 2;
216 case GEL_E_ELT_BACK_DIV: return 2;
217 case GEL_E_MOD: return 2;
218 case GEL_E_ELTMOD: return 2;
219 case GEL_E_NEG: return 1;
220 case GEL_E_EXP: return 2;
221 case GEL_E_ELTEXP: return 2;
222 case GEL_E_FACT: return 1;
223 case GEL_E_DBLFACT: return 1;
224 case GEL_E_TRANSPOSE: return 1;
225 case GEL_E_CONJUGATE_TRANSPOSE: return 1;
226 case GEL_E_IF_CONS: return 2;
227 case GEL_E_IFELSE_CONS: return 3;
228 case GEL_E_WHILE_CONS: return 2;
229 case GEL_E_UNTIL_CONS: return 2;
230 case GEL_E_DOWHILE_CONS: return 2;
231 case GEL_E_DOUNTIL_CONS: return 2;
232 case GEL_E_FOR_CONS: return 4;
233 case GEL_E_FORBY_CONS: return 5;
234 case GEL_E_FORIN_CONS: return 3;
235 case GEL_E_SUM_CONS: return 4;
236 case GEL_E_SUMBY_CONS: return 5;
237 case GEL_E_SUMIN_CONS: return 3;
238 case GEL_E_PROD_CONS: return 4;
239 case GEL_E_PRODBY_CONS: return 5;
240 case GEL_E_PRODIN_CONS: return 3;
241 case GEL_E_EQ_CMP: return 2;
242 case GEL_E_NE_CMP: return 2;
243 case GEL_E_CMP_CMP: return 2;
244 case GEL_E_LT_CMP: return 2;
245 case GEL_E_GT_CMP: return 2;
246 case GEL_E_LE_CMP: return 2;
247 case GEL_E_GE_CMP: return 2;
248 case GEL_E_LOGICAL_AND: return 2;
249 case GEL_E_LOGICAL_OR: return 2;
250 case GEL_E_LOGICAL_XOR: return 2;
251 case GEL_E_LOGICAL_NOT: return 1;
252 case GEL_E_REGION_SEP: return 2;
253 case GEL_E_REGION_SEP_BY: return 3;
254 case GEL_E_GET_VELEMENT: return 2;
255 case GEL_E_GET_ELEMENT: return 3;
256 case GEL_E_GET_ROW_REGION: return 2;
257 case GEL_E_GET_COL_REGION: return 2;
258 case GEL_E_QUOTE: return 1;
259 case GEL_E_REFERENCE: return 1;
260 case GEL_E_DEREFERENCE: return 1;
261 case GEL_E_DIRECTCALL: return -2;
262 case GEL_E_CALL: return -2;
263 case GEL_E_RETURN: return 1;
264 case GEL_E_BAILOUT: return 0;
265 case GEL_E_EXCEPTION: return 0;
266 case GEL_E_CONTINUE: return 0;
267 case GEL_E_BREAK: return 0;
268 case GEL_E_MOD_CALC: return 2;
269 case GEL_E_DEFEQUALS: return 2;
270 case GEL_E_SWAPWITH: return 2;
271 case GEL_E_INCREMENT: return 1;
272 case GEL_E_INCREMENT_BY: return 2;
273 default: return 0;
274 }
275 }
276
277 void
gel_init(void)278 gel_init (void)
279 {
280 if (the_zero == NULL)
281 the_zero = gel_makenum_ui (0);
282 }
283
284 mpw_ptr
gel_find_pre_function_modulo(GelCtx * ctx)285 gel_find_pre_function_modulo (GelCtx *ctx)
286 {
287 GelEvalStack *stack = ctx->stack;
288 gpointer *iter = ctx->topstack;
289 gpointer *last = NULL;
290 if ((gpointer)iter == (gpointer)stack) {
291 if (stack->next == NULL)
292 return NULL;
293 stack = stack->next;
294 iter = &(stack->stack[STACK_SIZE]);
295 }
296 while (GPOINTER_TO_INT(*(iter-1)) != GE_FUNCCALL) {
297 last = iter;
298 iter -= 2;
299 if ((gpointer)iter == (gpointer)stack) {
300 if (stack->next == NULL)
301 return NULL;
302 stack = stack->next;
303 iter = &(stack->stack[STACK_SIZE]);
304 }
305 }
306
307 if (last == NULL || GPOINTER_TO_INT(*(last-1)) != GE_SETMODULO) {
308 return NULL;
309 } else {
310 return *(last-2);
311 }
312 }
313
314 /*
315 static gboolean
316 find_on_stack (GelCtx *ctx, GelETree *etree, int *flag)
317 {
318 GelEvalStack *stack = ctx->stack;
319 gpointer *iter = ctx->topstack;
320 gpointer *last = NULL;
321 if ((gpointer)iter == (gpointer)stack) {
322 if (stack->next == NULL)
323 return FALSE;
324 stack = stack->next;
325 iter = &(stack->stack[STACK_SIZE]);
326 }
327 while (TRUE) {
328 last = iter;
329 iter -= 2;
330 if (*iter == etree) {
331 *flag = (int)(*(iter+1));
332 return TRUE;
333 }
334 if ((gpointer)iter == (gpointer)stack) {
335 if (stack->next == NULL)
336 return FALSE;
337 stack = stack->next;
338 iter = &(stack->stack[STACK_SIZE]);
339 }
340 }
341 }
342 */
343
344 GelETree *
gel_makenum_null(void)345 gel_makenum_null (void)
346 {
347 GelETree *n;
348 GEL_GET_NEW_NODE (n);
349 n->type = GEL_NULL_NODE;
350 n->any.next = NULL;
351 return n;
352 }
353
354 GelETree *
gel_makenum_identifier(GelToken * id)355 gel_makenum_identifier (GelToken *id)
356 {
357 GelETree *n;
358 GEL_GET_NEW_NODE (n);
359 n->type = GEL_IDENTIFIER_NODE;
360 n->id.id = id;
361 n->id.uninitialized = FALSE;
362 n->any.next = NULL;
363
364 return n;
365 }
366
367 GelETree *
gel_makenum_string(const char * str)368 gel_makenum_string (const char *str)
369 {
370 GelETree *n;
371 GEL_GET_NEW_NODE (n);
372 n->type = GEL_STRING_NODE;
373 n->str.str = g_strdup (str);
374 n->str.constant = FALSE;
375 n->any.next = NULL;
376
377 return n;
378 }
379
380 GelETree *
gel_makenum_string_use(char * str)381 gel_makenum_string_use (char *str)
382 {
383 GelETree *n;
384 GEL_GET_NEW_NODE (n);
385 n->type = GEL_STRING_NODE;
386 n->str.str = str;
387 n->str.constant = FALSE;
388 n->any.next = NULL;
389
390 return n;
391 }
392
393 GelETree *
gel_makenum_string_constant(const char * str)394 gel_makenum_string_constant (const char *str)
395 {
396 GelETree *n;
397 char *hstr;
398 static GHashTable *constant_strings = NULL;
399
400 if G_UNLIKELY (constant_strings == NULL)
401 constant_strings = g_hash_table_new (g_str_hash, g_str_equal);
402
403 hstr = g_hash_table_lookup (constant_strings, str);
404
405 if (hstr == NULL) {
406 hstr = g_strdup (str);
407 g_hash_table_insert (constant_strings,
408 hstr, hstr);
409 }
410
411 GEL_GET_NEW_NODE (n);
412 n->type = GEL_STRING_NODE;
413 n->str.str = hstr;
414 n->str.constant = TRUE;
415 n->any.next = NULL;
416
417 return n;
418 }
419
420 GelETree *
gel_makenum_ui(unsigned long num)421 gel_makenum_ui(unsigned long num)
422 {
423 GelETree *n;
424 GEL_GET_NEW_NODE(n);
425 n->type=GEL_VALUE_NODE;
426 mpw_init(n->val.value);
427 mpw_set_ui(n->val.value,num);
428 n->any.next = NULL;
429 return n;
430 }
431
432 GelETree *
gel_makenum_si(long num)433 gel_makenum_si(long num)
434 {
435 GelETree *n;
436 GEL_GET_NEW_NODE(n);
437 n->type=GEL_VALUE_NODE;
438 mpw_init(n->val.value);
439 mpw_set_si(n->val.value,num);
440 n->any.next = NULL;
441 return n;
442 }
443
444 GelETree *
gel_makenum_d(double num)445 gel_makenum_d (double num)
446 {
447 GelETree *n;
448 GEL_GET_NEW_NODE (n);
449 n->type = GEL_VALUE_NODE;
450 mpw_init (n->val.value);
451 mpw_set_d (n->val.value, num);
452 n->any.next = NULL;
453 return n;
454 }
455
456 GelETree *
gel_makenum_bool(gboolean bool_)457 gel_makenum_bool (gboolean bool_)
458 {
459 GelETree *n;
460 GEL_GET_NEW_NODE (n);
461 n->type = GEL_BOOL_NODE;
462 n->bool_.bool_ = bool_ ? 1 : 0;
463 n->any.next = NULL;
464 return n;
465 }
466
467 GelETree *
gel_makenum(mpw_t num)468 gel_makenum(mpw_t num)
469 {
470 GelETree *n;
471 GEL_GET_NEW_NODE(n);
472 n->type=GEL_VALUE_NODE;
473 mpw_init_set(n->val.value,num);
474 n->any.next = NULL;
475 return n;
476 }
477
478 /*don't create a new number*/
479 GelETree *
gel_makenum_use(mpw_t num)480 gel_makenum_use (mpw_t num)
481 {
482 GelETree *n;
483 GEL_GET_NEW_NODE (n);
484 n->type = GEL_VALUE_NODE;
485 memcpy (n->val.value, num, sizeof(struct _mpw_t));
486 n->any.next = NULL;
487 return n;
488 }
489
490 void
gel_makenum_null_from(GelETree * n)491 gel_makenum_null_from (GelETree *n)
492 {
493 n->type = GEL_NULL_NODE;
494 }
495
496 void
gel_makenum_ui_from(GelETree * n,unsigned long num)497 gel_makenum_ui_from (GelETree *n, unsigned long num)
498 {
499 n->type = GEL_VALUE_NODE;
500 mpw_init (n->val.value);
501 mpw_set_ui (n->val.value,num);
502 }
503
504 void
gel_makenum_si_from(GelETree * n,long num)505 gel_makenum_si_from (GelETree *n, long num)
506 {
507 n->type = GEL_VALUE_NODE;
508 mpw_init (n->val.value);
509 mpw_set_si (n->val.value, num);
510 }
511
512 void
gel_makenum_from(GelETree * n,mpw_t num)513 gel_makenum_from (GelETree *n, mpw_t num)
514 {
515 n->type = GEL_VALUE_NODE;
516 mpw_init_set (n->val.value, num);
517 }
518
519 void
gel_makenum_bool_from(GelETree * n,gboolean bool_)520 gel_makenum_bool_from (GelETree *n, gboolean bool_)
521 {
522 n->type = GEL_BOOL_NODE;
523 n->bool_.bool_ = bool_ ? 1 : 0;
524 }
525
526 /*don't create a new number*/
527 void
gel_makenum_use_from(GelETree * n,mpw_t num)528 gel_makenum_use_from (GelETree *n, mpw_t num)
529 {
530 n->type = GEL_VALUE_NODE;
531 memcpy (n->val.value, num, sizeof (struct _mpw_t));
532 }
533
534 static void
freetree_full(GelETree * n,gboolean freeargs,gboolean kill)535 freetree_full (GelETree *n, gboolean freeargs, gboolean kill)
536 {
537 if (!n)
538 return;
539 switch(n->type) {
540 case GEL_VALUE_NODE:
541 mpw_clear(n->val.value);
542 break;
543 case GEL_MATRIX_NODE:
544 if(n->mat.matrix)
545 gel_matrixw_free(n->mat.matrix);
546 break;
547 case GEL_OPERATOR_NODE:
548 if(freeargs) {
549 while(n->op.args) {
550 GelETree *a = n->op.args;
551 n->op.args = a->any.next;
552 freetree_full(a,TRUE,TRUE);
553 }
554 }
555 break;
556 case GEL_IDENTIFIER_NODE:
557 /*was this a fake token, to an anonymous function*/
558 if(!n->id.id->token) {
559 /*XXX:where does the function go?*/
560 g_slist_free(n->id.id->refs);
561 g_free(n->id.id);
562 }
563 break;
564 case GEL_STRING_NODE:
565 if ( ! n->str.constant)
566 g_free (n->str.str);
567 break;
568 case GEL_FUNCTION_NODE:
569 d_freefunc(n->func.func);
570 break;
571 case GEL_COMPARISON_NODE:
572 if(freeargs) {
573 while(n->comp.args) {
574 GelETree *a = n->comp.args;
575 n->comp.args = a->any.next;
576 freetree_full(a,TRUE,TRUE);
577 }
578 }
579 g_slist_free(n->comp.comp);
580 break;
581 case GEL_USERTYPE_NODE:
582 gel_free_user_variable_data(n->ut.ttype,n->ut.data);
583 break;
584 case GEL_MATRIX_ROW_NODE:
585 if(freeargs) {
586 while(n->row.args) {
587 GelETree *a = n->row.args;
588 n->row.args = a->any.next;
589 freetree_full(a,TRUE,TRUE);
590 }
591 }
592 break;
593 case GEL_SPACER_NODE:
594 if(freeargs && n->sp.arg)
595 gel_freetree(n->sp.arg);
596 break;
597 case GEL_LOCAL_NODE:
598 if(freeargs && n->loc.arg)
599 gel_freetree(n->loc.arg);
600 g_slist_free (n->loc.idents);
601 break;
602 default:
603 break;
604 }
605 if(kill) {
606 /*
607 int flag;
608 if (most_recent_ctx != NULL &&
609 find_on_stack (most_recent_ctx, n, &flag)) {
610 printf ("FOUND ON STACK (%p)!!!! %d\n", n,
611 flag);
612 }
613 */
614
615 #ifdef MEM_DEBUG_FRIENDLY
616 if (most_recent_ctx != NULL &&
617 most_recent_ctx->current == n) {
618 printf ("FOUND ON CURRENT (%p)!!!!\n", n);
619 }
620
621 # ifdef EVAL_DEBUG
622 printf ("%s WHACKING NODE %p\n", G_STRLOC, n);
623 deregister_tree (n);
624 # endif /* EVAL_DEBUG */
625
626 memset (n, 0xaa, sizeof (GelETree));
627 # ifndef MEM_DEBUG_SUPER_FRIENDLY
628 g_free (n);
629 # endif /* ! MEM_DEBUG_SUPER_FRIENDLY */
630 #else /* ! MEM_DEBUG_FRIENDLY */
631 /*put onto the free list*/
632 n->any.next = gel_free_trees;
633 gel_free_trees = n;
634 #endif
635
636 }
637 #ifdef MEM_DEBUG_FRIENDLY
638 else {
639 GelETree *next = n->any.next;
640 memset (n, 0, sizeof (GelETree));
641 n->any.next = next;
642 }
643 #endif /* MEM_DEBUG_FRIENDLY */
644 }
645
646 void
gel_freetree(GelETree * n)647 gel_freetree(GelETree *n)
648 {
649 /*printf ("freeing: %p\n", n);*/
650 freetree_full(n,TRUE,TRUE);
651 }
652
653 void
gel_emptytree(GelETree * n)654 gel_emptytree(GelETree *n)
655 {
656 /*printf ("freeing: %p\n", n);*/
657 freetree_full(n,TRUE,FALSE);
658 }
659
660 /* Makes a new node and replaces the old one with GEL_NULL_NODE */
661 GelETree *
gel_stealnode(GelETree * n)662 gel_stealnode (GelETree *n)
663 {
664 GelETree *nn;
665
666 if (n == NULL)
667 return NULL;
668
669 GEL_GET_NEW_NODE (nn);
670 memcpy (nn, n, sizeof(GelETree));
671
672 #ifdef MEM_DEBUG_FRIENDLY
673 {
674 GelETree *next = n->any.next;
675 memset (n, 0, sizeof (GelETree));
676 n->any.next = next;
677 }
678 #endif /* MEM_DEBUG_FRIENDLY */
679 n->type = GEL_NULL_NODE;
680 nn->any.next = NULL;
681
682 return nn;
683 }
684
685
686 static inline void
freenode(GelETree * n)687 freenode(GelETree *n)
688 {
689 freetree_full(n,FALSE,TRUE);
690 }
691
692 static void
copynode_to(GelETree * empty,GelETree * o)693 copynode_to(GelETree *empty, GelETree *o)
694 {
695 switch(o->type) {
696 case GEL_NULL_NODE:
697 empty->type = GEL_NULL_NODE;
698 empty->any.next = o->any.next;
699 break;
700 case GEL_VALUE_NODE:
701 empty->type = GEL_VALUE_NODE;
702 empty->any.next = o->any.next;
703 mpw_init_set_no_uncomplex (empty->val.value,o->val.value);
704 break;
705 case GEL_MATRIX_NODE:
706 empty->type = GEL_MATRIX_NODE;
707 empty->any.next = o->any.next;
708 empty->mat.matrix = gel_matrixw_copy(o->mat.matrix);
709 empty->mat.quoted = o->mat.quoted;
710 break;
711 case GEL_OPERATOR_NODE:
712 empty->type = GEL_OPERATOR_NODE;
713 empty->any.next = o->any.next;
714 empty->op.oper = o->op.oper;
715 empty->op.nargs = o->op.nargs;
716 empty->op.args = o->op.args;
717 if(empty->op.args) {
718 GelETree *li;
719 empty->op.args = gel_copynode(empty->op.args);
720 for(li=empty->op.args;li->any.next;li=li->any.next) {
721 li->any.next = gel_copynode(li->any.next);
722 }
723 }
724 break;
725 case GEL_IDENTIFIER_NODE:
726 empty->type = GEL_IDENTIFIER_NODE;
727 empty->any.next = o->any.next;
728 empty->id.id = o->id.id;
729 empty->id.uninitialized = o->id.uninitialized;
730 break;
731 case GEL_STRING_NODE:
732 empty->type = GEL_STRING_NODE;
733 empty->any.next = o->any.next;
734 empty->str.constant = o->str.constant;
735 if (o->str.constant)
736 empty->str.str = o->str.str;
737 else
738 empty->str.str = g_strdup (o->str.str);
739 break;
740 case GEL_FUNCTION_NODE:
741 empty->type = GEL_FUNCTION_NODE;
742 empty->any.next = o->any.next;
743 empty->func.func = d_copyfunc(o->func.func);
744 break;
745 case GEL_COMPARISON_NODE:
746 empty->type = GEL_COMPARISON_NODE;
747 empty->any.next = o->any.next;
748 empty->comp.nargs = o->comp.nargs;
749 empty->comp.args = o->comp.args;
750 if(empty->comp.args) {
751 GelETree *li;
752 empty->comp.args = gel_copynode(empty->comp.args);
753 for(li=empty->comp.args;li->any.next;li=li->any.next) {
754 li->any.next = gel_copynode(li->any.next);
755 }
756 }
757 empty->comp.comp = g_slist_copy(o->comp.comp);
758 break;
759 case GEL_USERTYPE_NODE:
760 empty->type = GEL_USERTYPE_NODE;
761 empty->any.next = o->any.next;
762 empty->ut.ttype = o->ut.ttype;
763 empty->ut.data = gel_copy_user_variable_data(o->ut.ttype,
764 o->ut.data);
765 break;
766 case GEL_BOOL_NODE:
767 empty->type = GEL_BOOL_NODE;
768 empty->any.next = o->any.next;
769 empty->bool_.bool_ = o->bool_.bool_;
770 break;
771 case GEL_MATRIX_ROW_NODE:
772 empty->type = GEL_MATRIX_ROW_NODE;
773 empty->any.next = o->any.next;
774 empty->row.nargs = o->row.nargs;
775 empty->row.args = o->row.args;
776 if(empty->row.args) {
777 GelETree *li;
778 empty->row.args = gel_copynode(empty->row.args);
779 for(li=empty->row.args;li->any.next;li=li->any.next) {
780 li->any.next = gel_copynode(li->any.next);
781 }
782 }
783 break;
784 case GEL_SPACER_NODE:
785 empty->type = GEL_SPACER_NODE;
786 empty->any.next = o->any.next;
787 if(o->sp.arg)
788 empty->sp.arg = gel_copynode(o->sp.arg);
789 else
790 empty->sp.arg = NULL;
791 break;
792 /* GEL_LOCAL_NODE: not needed */
793 default:
794 g_assert_not_reached();
795 break;
796 }
797 }
798
799 GelETree *
gel_copynode(GelETree * o)800 gel_copynode(GelETree *o)
801 {
802 GelETree *n;
803
804 if(!o)
805 return NULL;
806
807 GEL_GET_NEW_NODE(n);
808
809 copynode_to(n,o);
810
811 return n;
812 }
813
814 static void
replacenode(GelETree * to,GelETree * from)815 replacenode(GelETree *to, GelETree *from)
816 {
817 GelETree *next = to->any.next;
818 freetree_full(to,TRUE,FALSE);
819 g_assert(from != NULL);
820 memcpy(to,from,sizeof(GelETree));
821
822 #ifdef MEM_DEBUG_FRIENDLY
823
824 # ifdef EVAL_DEBUG
825 printf ("%s WHACKING NODE %p\n", G_STRLOC, from);
826 deregister_tree (from);
827 # endif
828
829 memset (from, 0xaa, sizeof (GelETree));
830 # ifndef MEM_DEBUG_SUPER_FRIENDLY
831 g_free (from);
832 # endif
833 #else /* MEM_DEBUG_FRIENDLY */
834 /*put onto the free list*/
835 from->any.next = gel_free_trees;
836 gel_free_trees = from;
837 #endif /* MEM_DEBUG_FRIENDLY */
838 to->any.next = next;
839
840 /*printf ("replaced from: %p\n", from);*/
841 }
842 static void
copyreplacenode(GelETree * to,GelETree * from)843 copyreplacenode(GelETree *to, GelETree *from)
844 {
845 GelETree *next = to->any.next;
846 freetree_full(to,TRUE,FALSE);
847 copynode_to(to,from);
848 to->any.next = next;
849 }
850
851 void
gel_replacenode(GelETree * to,GelETree * from,gboolean copy)852 gel_replacenode (GelETree *to, GelETree *from, gboolean copy)
853 {
854 if (copy)
855 copyreplacenode (to, from);
856 else
857 replacenode (to, from);
858 }
859
860 GelETree *
gel_makeoperator(int oper,GSList ** stack)861 gel_makeoperator (int oper, GSList **stack)
862 {
863 GelETree *n;
864 int args;
865 GelETree *list = NULL;
866 args = branches(oper);
867 if(args>=0) {
868 int i;
869 int popargs = args;
870 for (i = 0; i < popargs; i++) {
871 GelETree *tree = gel_stack_pop (stack);
872 if(!tree) {
873 while(list) {
874 GelETree *a = list->any.next;
875 gel_freetree(list);
876 list = a;
877 }
878 return NULL;
879 }
880 /* just reduce the list for separators */
881 if (oper == GEL_E_SEPAR &&
882 tree->type == GEL_OPERATOR_NODE &&
883 tree->op.oper == GEL_E_SEPAR) {
884 int extranum = 1;
885 GelETree *last;
886
887 /* there are at least two arguments */
888 last = tree->op.args->any.next;
889 while (last->any.next != NULL) {
890 last = last->any.next;
891 extranum ++;
892 }
893
894 args += extranum;
895
896 last->any.next = list;
897 list = tree->op.args;
898
899 freenode (tree);
900 } else {
901 tree->any.next = list;
902 list = tree;
903 }
904 }
905 } else {
906 int i=0;
907 for(;;) {
908 GelETree *tree;
909 tree = gel_stack_pop(stack);
910 /*we have gone all the way to the top and haven't
911 found a marker*/
912 if G_UNLIKELY (!tree) {
913 while(list) {
914 GelETree *a = list->any.next;
915 gel_freetree(list);
916 list = a;
917 }
918 return NULL;
919 }
920 if(tree->type==GEL_EXPRLIST_START_NODE) {
921 gel_freetree(tree);
922 /*pop one more in case of -2*/
923 if(args==-2) {
924 GelETree *t;
925 t = gel_stack_pop(stack);
926 /*we have gone all the way to the top
927 whoops!*/
928 if(!t) {
929 while(list) {
930 GelETree *a = list->any.next;
931 gel_freetree(list);
932 list = a;
933 }
934 return NULL;
935 }
936 t->any.next = list;
937 list = t;
938 i++;
939 }
940 break;
941 }
942 tree->any.next = list;
943 list = tree;
944 i++;
945 }
946 args = i;
947 }
948
949 GEL_GET_NEW_NODE(n);
950 n->type = GEL_OPERATOR_NODE;
951 n->op.oper = oper;
952
953 n->op.args = list;
954 n->op.nargs = args;
955
956 /*try_to_precalc_op(n);*/
957
958 return n;
959 }
960
961 /* kind of a hack */
962 static GelETree the_null = {GEL_NULL_NODE};
963
964 /*need_colwise will return if we need column wise expansion*/
965 static int
expand_row(GelMatrix * dest,GelMatrixW * src,int di,int si,gboolean * need_colwise)966 expand_row (GelMatrix *dest, GelMatrixW *src, int di, int si, gboolean *need_colwise)
967 {
968 int i;
969 int height = 0;
970 int roww = gel_matrixw_width(src);
971
972 for(i=0;i<roww;i++) {
973 GelETree *et = gel_matrixw_get_index(src,i,si);
974 if (et == NULL ||
975 (et->type != GEL_NULL_NODE &&
976 et->type != GEL_MATRIX_NODE)) {
977 if (height == 0)
978 height = 1;
979 } else if (et != NULL &&
980 et->type == GEL_MATRIX_NODE &&
981 gel_matrixw_height(et->mat.matrix)>height) {
982 height = gel_matrixw_height(et->mat.matrix);
983 }
984 }
985
986 if (height == 0) {
987 return 0;
988 }
989
990 gel_matrix_set_at_least_size(dest,1,di+height);
991
992 for(i=roww-1;i>=0;i--) {
993 int x;
994 GelETree *et = gel_matrixw_get_index(src,i,si);
995 gel_matrixw_set_index(src,i,si) = NULL;
996
997 /*0 node*/
998 if(!et) {
999 for(x=0;x<height;x++)
1000 gel_matrix_index(dest,i,di+x) = NULL;
1001 /*null node*/
1002 } else if (et->type == GEL_NULL_NODE) {
1003 *need_colwise = TRUE;
1004 gel_matrix_index(dest,i,di) = et;
1005 for(x=1;x<height;x++)
1006 gel_matrix_index(dest,i,di+x) = &the_null;
1007 /*non-matrix node*/
1008 } else if(et->type!=GEL_MATRIX_NODE) {
1009 gel_matrix_index(dest,i,di) = et;
1010 for(x=1;x<height;x++)
1011 gel_matrix_index(dest,i,di+x) = gel_copynode(et);
1012 /*single column matrix, convert to regular nodes*/
1013 } else if(gel_matrixw_width(et->mat.matrix) == 1) {
1014 int xx;
1015 int h = gel_matrixw_height(et->mat.matrix);
1016 gel_matrixw_make_private (et->mat.matrix, FALSE /* kill_type_caches */);
1017 for(x=0;x<h;x++) {
1018 gel_matrix_index(dest,i,di+x) =
1019 gel_matrixw_get_index(et->mat.matrix,0,x);
1020 gel_matrixw_set_index(et->mat.matrix,0,x) = NULL;
1021 }
1022 xx = 0;
1023 for(x=h;x<height;x++) {
1024 gel_matrix_index(dest,i,di+x) =
1025 gel_copynode(gel_matrix_index(dest,i,di+xx));
1026 if((++xx)>=h)
1027 xx=0;
1028 }
1029 gel_freetree(et);
1030 /*non-trivial matrix*/
1031 } else {
1032 int xx;
1033 int h = gel_matrixw_height(et->mat.matrix);
1034 int w = gel_matrixw_width(et->mat.matrix);
1035
1036 gel_matrixw_make_private(et->mat.matrix,
1037 FALSE /* kill_type_caches */);
1038
1039 for(x=0;x<h;x++) {
1040 GelETree *n;
1041 GEL_GET_NEW_NODE(n);
1042 n->type = GEL_MATRIX_ROW_NODE;
1043
1044 n->row.args = NULL;
1045 for(xx=w-1;xx>=0;xx--) {
1046 GelETree *t = gel_matrixw_get_index(et->mat.matrix,xx,x);
1047 if(!t)
1048 t = gel_makenum_ui(0);
1049 t->any.next = n->row.args;
1050 n->row.args = t;
1051 gel_matrixw_set_index(et->mat.matrix,xx,x) = NULL;
1052 }
1053 n->row.nargs = w;
1054
1055 gel_matrix_index(dest,i,di+x) = n;
1056
1057 *need_colwise = TRUE;
1058 }
1059 xx = 0;
1060 for(x=h;x<height;x++) {
1061 gel_matrix_index(dest,i,di+x) =
1062 gel_copynode(gel_matrix_index(dest,i,di+xx));
1063 if((++xx)>=h)
1064 xx=0;
1065 }
1066 gel_freetree(et);
1067 }
1068 }
1069
1070 return height;
1071 }
1072
1073
1074 static int
expand_col(GelMatrix * dest,GelMatrix * src,int si,int di,int w)1075 expand_col (GelMatrix *dest, GelMatrix *src, int si, int di, int w)
1076 {
1077 int i;
1078
1079 for (i = 0; i < src->height; i++) {
1080 GelETree *et = gel_matrix_index (src, si, i);
1081 if (et == NULL) {
1082 ;
1083 } else if (et->type == GEL_NULL_NODE) {
1084 /* Also here we just replace GEL_NULL_NODE's with 0's */
1085 if (et != &the_null)
1086 gel_freetree (et);
1087 } else if (et->type != GEL_MATRIX_ROW_NODE) {
1088 int x;
1089 gel_matrix_index (dest, di, i) = et;
1090 for (x = 1; x < w; x++)
1091 gel_matrix_index (dest, di+x, i) = gel_copynode (et);
1092 } else {
1093 int x;
1094 int xx;
1095 GelETree *iter;
1096
1097 iter = et->row.args;
1098 for (iter = et->row.args, x=0; iter != NULL; x++) {
1099 if (iter->type == GEL_VALUE_NODE &&
1100 MPW_IS_REAL (iter->val.value) &&
1101 mpw_is_integer (iter->val.value) &&
1102 mpw_sgn (iter->val.value) == 0) {
1103 GelETree *next = iter->any.next;
1104 gel_matrix_index (dest, di+x, i) = NULL;
1105 iter->any.next = NULL;
1106 gel_freetree (iter);
1107 iter = next;
1108 } else {
1109 GelETree *old = iter;
1110 gel_matrix_index (dest, di+x, i) = iter;
1111 iter = iter->any.next;
1112 old->any.next = NULL;
1113 }
1114 }
1115
1116 xx = 0;
1117 for (; x < w; x++) {
1118 gel_matrix_index (dest, di+x, i) =
1119 gel_copynode (gel_matrix_index (dest, di+xx, i));
1120 xx++;
1121 if (xx >= (int)et->row.nargs)
1122 xx = 0;
1123 }
1124 freenode (et);
1125 }
1126 }
1127
1128 return w;
1129 }
1130
1131 static int
get_cols(GelMatrix * m,int * colwidths,gboolean * just_denull)1132 get_cols (GelMatrix *m, int *colwidths, gboolean *just_denull)
1133 {
1134 int i,j;
1135 int maxcol;
1136 int cols = 0;
1137
1138 *just_denull = TRUE;
1139
1140 for (i = 0; i < m->width; i++) {
1141 maxcol = 0;
1142 for (j = 0; j < m->height; j++) {
1143 GelETree *et = gel_matrix_index (m, i, j);
1144 if (et == NULL ||
1145 (et->type != GEL_MATRIX_ROW_NODE &&
1146 et->type != GEL_NULL_NODE)) {
1147 if (maxcol == 0)
1148 maxcol = 1;
1149 } else if (et->type != GEL_NULL_NODE) {
1150 /* Must be GEL_MATRIX_ROW_NODE then */
1151 if ((int)et->row.nargs > maxcol)
1152 maxcol = et->row.nargs;
1153 }
1154 }
1155 if (maxcol != 1)
1156 *just_denull = FALSE;
1157 colwidths[i] = maxcol;
1158 cols += maxcol;
1159 }
1160
1161 return cols;
1162 }
1163
1164 static gboolean
mat_need_expand(GelMatrixW * m)1165 mat_need_expand (GelMatrixW *m)
1166 {
1167 int i, j;
1168 for (i = 0; i < gel_matrixw_width (m); i++) {
1169 for (j = 0; j < gel_matrixw_height (m); j++) {
1170 GelETree *et = gel_matrixw_get_index (m, i, j);
1171 if G_UNLIKELY (et != NULL &&
1172 (et->type == GEL_MATRIX_NODE ||
1173 et->type == GEL_NULL_NODE))
1174 return TRUE;
1175 }
1176 }
1177 return FALSE;
1178 }
1179
1180 /* we know we are a row matrix */
1181 static void
quick_wide_expand(GelETree * n)1182 quick_wide_expand (GelETree *n)
1183 {
1184 GelMatrix *m;
1185 int h, w, i, j;
1186 GelMatrixW *nm = n->mat.matrix;
1187
1188 h = 0;
1189 w = 0;
1190 for (i = 0; i < gel_matrixw_width (nm); i++) {
1191 GelETree *et = gel_matrixw_get_index (nm, i, 0);
1192 if (et == NULL) {
1193 if (h <= 0)
1194 h = 1;
1195 w++;
1196 } else if (et->type == GEL_MATRIX_NODE) {
1197 if (gel_matrixw_height (et->mat.matrix) > h)
1198 h = gel_matrixw_height (et->mat.matrix);
1199 w += gel_matrixw_width (et->mat.matrix);
1200 } else if (et->type != GEL_NULL_NODE) {
1201 if (h <= 0)
1202 h = 1;
1203 w++;
1204 }
1205 }
1206
1207 gel_matrixw_make_private (nm, FALSE /* kill_type_caches */);
1208
1209 m = gel_matrix_new();
1210 gel_matrix_set_size(m, w, h, TRUE /* padding */);
1211
1212 j = 0;
1213 for (i = 0; i < gel_matrixw_width (nm); i++) {
1214 GelETree *et = gel_matrixw_get_index (nm, i, 0);
1215 if (et == NULL) {
1216 j++;
1217 } else if (et->type == GEL_MATRIX_NODE) {
1218 int hh = gel_matrixw_height (et->mat.matrix);
1219 int ww = gel_matrixw_width (et->mat.matrix);
1220 int ii, jj;
1221 GelMatrixW *mm = et->mat.matrix;
1222
1223 gel_matrixw_make_private (mm,
1224 FALSE /* kill_type_caches */);
1225
1226 for (ii = 0; ii < ww; ii++) {
1227 int jjj;
1228 for (jj = 0; jj < hh; jj++) {
1229 GelETree *e =
1230 gel_matrixw_get_index (mm, ii, jj);
1231 gel_matrix_index (m, j+ii, jj) = e;
1232 gel_matrixw_set_index (mm, ii, jj) = NULL;
1233 }
1234 jjj = 0;
1235 for (; jj < h; jj++) {
1236 GelETree *e =
1237 gel_matrix_index (m, j+ii, jjj);
1238 if (e != NULL)
1239 gel_matrix_index (m, j+ii, jj) = gel_copynode (e);
1240 if (++jjj >= hh)
1241 jjj = 0;
1242 }
1243 }
1244 j += ww;
1245 } else if (et->type != GEL_NULL_NODE) {
1246 int jj;
1247 gel_matrixw_set_index (nm, i, 0) = NULL;
1248 gel_matrix_index (m, j, 0) = et;
1249 for (jj = 1; jj < h; jj++) {
1250 gel_matrix_index (m, j, jj) = gel_copynode (et);
1251 }
1252 j++;
1253 }
1254 }
1255
1256 freetree_full (n, TRUE, FALSE);
1257
1258 n->type = GEL_MATRIX_NODE;
1259 n->mat.matrix = gel_matrixw_new_with_matrix (m);
1260 n->mat.quoted = FALSE;
1261 }
1262
1263 /*evaluate a matrix (or try to), it will try to expand the matrix and
1264 put 0's into the empty, undefined, spots. For example, a matrix such
1265 as if b = [8,7]; a = [1,2:3,b] should expand to, [1,2,2:3,8,7] */
1266 void
gel_expandmatrix(GelETree * n)1267 gel_expandmatrix (GelETree *n)
1268 {
1269 int i;
1270 int k;
1271 int cols;
1272 GelMatrix *m;
1273 gboolean need_colwise = FALSE;
1274 GelMatrixW *nm;
1275 int h,w;
1276
1277 /* An empty matrix really */
1278 if (n->type == GEL_NULL_NODE)
1279 return;
1280
1281 nm = n->mat.matrix;
1282
1283 g_return_if_fail (n->type == GEL_MATRIX_NODE);
1284
1285 if ( ! mat_need_expand (nm))
1286 return;
1287
1288 w = gel_matrixw_width (nm);
1289 h = gel_matrixw_height (nm);
1290
1291 if (w == 1 && h == 1) {
1292 GelETree *t = gel_matrixw_get_indexii (nm, 0);
1293 if (t != NULL &&
1294 t->type == GEL_MATRIX_NODE) {
1295 if (nm->m->use == 1) {
1296 gel_matrixw_set_indexii (nm, 0) = NULL;
1297 } else {
1298 t = gel_copynode (t);
1299 }
1300 replacenode (n, t);
1301 return;
1302 } else if (t != NULL &&
1303 t->type == GEL_NULL_NODE) {
1304 freetree_full (n, TRUE, FALSE);
1305 n->type = GEL_NULL_NODE;
1306 return;
1307 }
1308 /* never should be reached */
1309 }
1310
1311 if (h == 1) {
1312 quick_wide_expand (n);
1313 return;
1314 }
1315
1316 gel_matrixw_make_private (nm, FALSE /* kill_type_caches */);
1317
1318 m = gel_matrix_new();
1319 gel_matrix_set_size(m, w, h, TRUE /* padding */);
1320
1321 cols = gel_matrixw_width (nm);
1322
1323 for (i = 0, k = 0; i < h; i++) {
1324 int kk;
1325 kk = expand_row (m, nm, k, i, &need_colwise);
1326 k += kk;
1327 }
1328
1329 if (k == 0) {
1330 gel_matrix_free (m);
1331 freetree_full (n, TRUE, FALSE);
1332 n->type = GEL_NULL_NODE;
1333 return;
1334 }
1335
1336 /* If we whacked some rows completely shorten
1337 * the matrix */
1338 if (k < h)
1339 gel_matrix_set_size (m, w, k, TRUE /* padding */);
1340
1341 if (need_colwise) {
1342 gboolean just_denull;
1343 int *colwidths = g_new (int, m->width);
1344
1345 cols = get_cols (m, colwidths, &just_denull);
1346
1347 /* empty matrix, return null */
1348 if (cols == 0) {
1349 gel_matrix_free (m);
1350 g_free (colwidths);
1351 freetree_full (n, TRUE, FALSE);
1352 n->type = GEL_NULL_NODE;
1353 return;
1354 }
1355
1356 if (just_denull) {
1357 int j;
1358 for (j = 0; j < m->height; j++) {
1359 for (i = 0; i < m->width; i++) {
1360 GelETree *et
1361 = gel_matrix_index (m, i, j);
1362 if (et != NULL &&
1363 et->type == GEL_NULL_NODE) {
1364 if (et != &the_null)
1365 gel_freetree (et);
1366 gel_matrix_index (m, i, j)
1367 = NULL;
1368 }
1369 }
1370 }
1371 } else {
1372 int ii;
1373 GelMatrix *tm;
1374
1375 tm = gel_matrix_new ();
1376
1377 gel_matrix_set_size (tm,cols,m->height, TRUE /* padding */);
1378
1379 for (i = 0, ii = 0; i < m->width; ii += colwidths[i], i++) {
1380 if (colwidths[i] > 0) {
1381 expand_col (tm, m, i, ii, colwidths[i]);
1382 } else {
1383 int iii;
1384 for (iii = 0;
1385 iii < m->height;
1386 iii++) {
1387 GelETree *et = gel_matrix_index (m, i, iii);
1388 if (et != NULL) {
1389 if (et != &the_null)
1390 gel_freetree (et);
1391 }
1392 }
1393 }
1394 }
1395 gel_matrix_free (m);
1396 m = tm;
1397 }
1398 g_free (colwidths);
1399 }
1400
1401 freetree_full (n, TRUE, FALSE);
1402
1403 n->type = GEL_MATRIX_NODE;
1404 n->mat.matrix = gel_matrixw_new_with_matrix (m);
1405 n->mat.quoted = FALSE;
1406 }
1407
1408 static GelETree*
get_func_call_node(GelEFunc * func,GelETree ** args,int nargs)1409 get_func_call_node(GelEFunc *func, GelETree **args, int nargs)
1410 {
1411 int i;
1412 GelETree *l;
1413 GelETree *ret;
1414 GelETree *li = NULL;
1415
1416 GEL_GET_NEW_NODE(l);
1417 l->type = GEL_FUNCTION_NODE;
1418 l->func.func = d_copyfunc(func);
1419 /* never copy is_local */
1420 l->func.func->is_local = 0;
1421 l->any.next = NULL;
1422
1423 GEL_GET_NEW_NODE(ret);
1424 ret->type = GEL_OPERATOR_NODE;
1425 ret->op.oper = GEL_E_DIRECTCALL;
1426 ret->op.args = l;
1427
1428 li = l;
1429
1430 for(i=0;i<nargs;i++) {
1431 li = li->any.next = gel_copynode(args[i]);
1432 }
1433 li->any.next = NULL;
1434 ret->op.nargs = nargs+1;
1435 return ret;
1436 }
1437
1438 GelETree *
gel_funccall(GelCtx * ctx,GelEFunc * func,GelETree ** args,int nargs)1439 gel_funccall(GelCtx *ctx, GelEFunc *func, GelETree **args, int nargs)
1440 {
1441 GelETree *ret = NULL;
1442
1443 g_return_val_if_fail(func!=NULL,NULL);
1444
1445 ret = get_func_call_node(func,args,nargs);
1446 return gel_eval_etree(ctx,ret);
1447 }
1448
1449 /*compare nodes, return TRUE if equal */
1450 static gboolean
eqlnodes(GelETree * l,GelETree * r)1451 eqlnodes (GelETree *l, GelETree *r)
1452 {
1453 if (l->type == GEL_BOOL_NODE ||
1454 r->type == GEL_BOOL_NODE) {
1455 gboolean lt = gel_isnodetrue (l, NULL);
1456 gboolean rt = gel_isnodetrue (r, NULL);
1457 if ((lt && ! rt) ||
1458 ( ! lt && rt)) {
1459 return 0;
1460 } else {
1461 return 1;
1462 }
1463 } else {
1464 gboolean n = mpw_eql(l->val.value,r->val.value);
1465 if G_UNLIKELY (gel_error_num) return 0;
1466 return n;
1467 }
1468 }
1469
1470 /*compare nodes, return -1 if first one is smaller, 0 if they are
1471 equal, 1 if the first one is greater
1472 makes them the same type as a side effect*/
1473 static int
cmpnodes(GelETree * l,GelETree * r)1474 cmpnodes(GelETree *l, GelETree *r)
1475 {
1476 int n=0;
1477
1478 n=mpw_cmp(l->val.value,r->val.value);
1479
1480 if G_UNLIKELY (gel_error_num) return 0;
1481
1482 if(n>0) n=1;
1483 else if(n<0) n=-1;
1484 return n;
1485 }
1486
1487
1488 static int
cmpcmpop(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)1489 cmpcmpop(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
1490 {
1491 int ret = cmpnodes(l,r);
1492 if G_UNLIKELY (gel_error_num) {
1493 gel_error_num = GEL_NO_ERROR;
1494 return TRUE;
1495 }
1496 freetree_full(n,TRUE,FALSE);
1497 gel_makenum_si_from(n,ret);
1498 return TRUE;
1499 }
1500
1501 static int
logicalxorop(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)1502 logicalxorop(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
1503 {
1504 gboolean bad_node = FALSE;
1505 gboolean ret = gel_isnodetrue (l, &bad_node) != gel_isnodetrue (r, &bad_node);
1506
1507 if G_UNLIKELY (bad_node || gel_error_num) {
1508 gel_error_num = GEL_NO_ERROR;
1509 return TRUE;
1510 }
1511 freetree_full (n, TRUE, FALSE);
1512
1513 gel_makenum_bool_from (n, ret);
1514
1515 return TRUE;
1516 }
1517
1518 static int
logicalnotop(GelCtx * ctx,GelETree * n,GelETree * l)1519 logicalnotop(GelCtx *ctx, GelETree *n, GelETree *l)
1520 {
1521 gboolean bad_node = FALSE;
1522 gboolean ret = !gel_isnodetrue(l,&bad_node);
1523 if G_UNLIKELY (bad_node || gel_error_num) {
1524 gel_error_num = GEL_NO_ERROR;
1525 return TRUE;
1526 }
1527 freetree_full(n,TRUE,FALSE);
1528 gel_makenum_bool_from (n, ret);
1529 return TRUE;
1530 }
1531
1532 static gboolean
eqstring(GelETree * a,GelETree * b)1533 eqstring(GelETree *a, GelETree *b)
1534 {
1535 int r = 0;
1536 if (a->type == GEL_STRING_NODE &&
1537 b->type == GEL_STRING_NODE) {
1538 r = (strcmp (a->str.str, b->str.str) == 0);
1539 } else if (a->type == GEL_STRING_NODE) {
1540 char *s = gel_string_print_etree (b);
1541 r = (strcmp (a->str.str, s) == 0);
1542 g_free (s);
1543 } else if (b->type == GEL_STRING_NODE) {
1544 char *s = gel_string_print_etree (a);
1545 r = (strcmp (b->str.str, s) == 0);
1546 g_free (s);
1547 } else {
1548 g_assert_not_reached();
1549 }
1550
1551 return r;
1552 }
1553
1554 static gboolean
eqmatrix(GelETree * a,GelETree * b,int * error)1555 eqmatrix(GelETree *a, GelETree *b, int *error)
1556 {
1557 gboolean r = FALSE;
1558 int i,j;
1559 if(a->type == GEL_MATRIX_NODE &&
1560 b->type == GEL_MATRIX_NODE) {
1561 if G_UNLIKELY (!gel_is_matrix_value_or_bool_only(a->mat.matrix) ||
1562 !gel_is_matrix_value_or_bool_only(b->mat.matrix)) {
1563 gel_errorout (_("Cannot compare non value or bool only matrices"));
1564 *error = TRUE;
1565 return 0;
1566 }
1567
1568 if G_UNLIKELY (gel_matrixw_width(a->mat.matrix)!=
1569 gel_matrixw_width(b->mat.matrix) ||
1570 gel_matrixw_height(a->mat.matrix)!=
1571 gel_matrixw_height(b->mat.matrix)) {
1572 r = FALSE;
1573 } else {
1574 GelMatrixW *m1 = a->mat.matrix;
1575 GelMatrixW *m2 = b->mat.matrix;
1576 gboolean pure_values
1577 = (gel_is_matrix_value_only (a->mat.matrix) ||
1578 gel_is_matrix_value_only (b->mat.matrix));
1579
1580 r = TRUE;
1581
1582 for(i=0;i<gel_matrixw_width(m1);i++) {
1583 for(j=0;j<gel_matrixw_height(m1);j++) {
1584 GelETree *t1,*t2;
1585 t1 = gel_matrixw_index(m1,i,j);
1586 t2 = gel_matrixw_index(m2,i,j);
1587
1588 if (pure_values) {
1589 if ( ! mpw_eql (t1->val.value,
1590 t2->val.value)) {
1591 r = FALSE;
1592 break;
1593 }
1594 } else {
1595 gboolean t1t = gel_isnodetrue (t1, NULL);
1596 gboolean t2t = gel_isnodetrue (t2, NULL);
1597 if ((t1t && ! t2t) ||
1598 ( ! t1t && t2t)) {
1599 r = FALSE;
1600 break;
1601 }
1602 }
1603 }
1604 if ( ! r)
1605 break;
1606 }
1607 }
1608 } else if (a->type == GEL_NULL_NODE ||
1609 b->type == GEL_NULL_NODE) {
1610 return a->type == b->type ? 1 : 0;
1611 } else if(a->type == GEL_MATRIX_NODE) {
1612 GelMatrixW *m = a->mat.matrix;
1613 if G_UNLIKELY (gel_matrixw_width(m)>1 ||
1614 gel_matrixw_height(m)>1) {
1615 r = FALSE;
1616 } else {
1617 GelETree *t = gel_matrixw_index(m,0,0);
1618 if G_UNLIKELY (t->type != GEL_VALUE_NODE &&
1619 t->type != GEL_BOOL_NODE) {
1620 gel_errorout (_("Cannot compare non value or bool only matrices"));
1621 *error = TRUE;
1622 return 0;
1623 }
1624 r = eqlnodes (t, b);
1625 }
1626 } else if(b->type == GEL_MATRIX_NODE) {
1627 GelMatrixW *m = b->mat.matrix;
1628 if G_UNLIKELY (gel_matrixw_width(m)>1 ||
1629 gel_matrixw_height(m)>1) {
1630 r = FALSE;
1631 } else {
1632 GelETree *t = gel_matrixw_index(m,0,0);
1633 if G_UNLIKELY (t->type != GEL_VALUE_NODE &&
1634 t->type != GEL_BOOL_NODE) {
1635 gel_errorout (_("Cannot compare non value or bool only matrices"));
1636 *error = TRUE;
1637 return 0;
1638 }
1639 r = eqlnodes (t, a);
1640 }
1641 } else
1642 g_assert_not_reached();
1643
1644 return r;
1645 }
1646
1647 static int
cmpstring(GelETree * a,GelETree * b)1648 cmpstring(GelETree *a, GelETree *b)
1649 {
1650 int r = 0;
1651 if (a->type == GEL_STRING_NODE &&
1652 b->type == GEL_STRING_NODE) {
1653 r = strcmp (a->str.str, b->str.str);
1654 } else if (a->type == GEL_STRING_NODE) {
1655 char *s = gel_string_print_etree (b);
1656 r = strcmp (a->str.str, s);
1657 g_free (s);
1658 } else if (b->type == GEL_STRING_NODE) {
1659 char *s = gel_string_print_etree (a);
1660 r = strcmp (s, b->str.str);
1661 g_free (s);
1662 } else {
1663 g_assert_not_reached();
1664 }
1665
1666 return r;
1667 }
1668
1669 static int
cmpstringop(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)1670 cmpstringop (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
1671 {
1672 int ret;
1673 ret = cmpstring (l, r);
1674
1675 freetree_full (n, TRUE, FALSE);
1676
1677 if (ret > 0)
1678 gel_makenum_ui_from (n, 1);
1679 else if (ret <0 )
1680 gel_makenum_si_from (n, -1);
1681 else
1682 gel_makenum_ui_from (n, 0);
1683 return TRUE;
1684 }
1685
1686 gboolean
gel_mod_integer_rational(mpw_t num,mpw_t mod)1687 gel_mod_integer_rational (mpw_t num, mpw_t mod)
1688 {
1689 if G_UNLIKELY (mpw_is_complex (num)) {
1690 /* also on rationals but as integers */
1691 gel_errorout (_("Modulo arithmetic only works on integers"));
1692 return FALSE;
1693 } else if (mpw_is_integer (num)) {
1694 mpw_mod (num, num, mod);
1695 if (mpw_sgn (num) < 0)
1696 mpw_add (num, mod, num);
1697 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR)
1698 return FALSE;
1699 else
1700 return TRUE;
1701 } else if (mpw_is_rational (num)) {
1702 mpw_t n, d;
1703 mpw_init (n);
1704 mpw_init (d);
1705 mpw_numerator (n, num);
1706 mpw_denominator (d, num);
1707
1708 mpw_mod (n, n, mod);
1709 if (mpw_sgn (n) < 0)
1710 mpw_add (n, mod, n);
1711
1712 mpw_mod (d, d, mod);
1713 if (mpw_sgn (d) < 0)
1714 mpw_add (d, mod, d);
1715
1716 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
1717 mpw_clear (n);
1718 mpw_clear (d);
1719 return FALSE;
1720 }
1721
1722 mpw_invert (num, d, mod);
1723 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
1724 mpw_clear (n);
1725 mpw_clear (d);
1726 return FALSE;
1727 }
1728 mpw_mul (num, num, n);
1729 mpw_mod (num, num, mod);
1730
1731 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR)
1732 return FALSE;
1733 else
1734 return TRUE;
1735 } else {
1736 /* also on rationals but as integers */
1737 gel_errorout (_("Modulo arithmetic only works on integers"));
1738 return FALSE;
1739 }
1740 }
1741
1742 static GelETree *
op_two_nodes(GelCtx * ctx,GelETree * ll,GelETree * rr,int oper,gboolean no_push)1743 op_two_nodes (GelCtx *ctx, GelETree *ll, GelETree *rr, int oper,
1744 gboolean no_push)
1745 {
1746 GelETree *n;
1747 mpw_t res;
1748
1749 if(rr->type == GEL_VALUE_NODE &&
1750 ll->type == GEL_VALUE_NODE) {
1751 gboolean skipmod = FALSE;
1752 mpw_init(res);
1753 switch(oper) {
1754 case GEL_E_PLUS:
1755 case GEL_E_ELTPLUS:
1756 mpw_add(res,ll->val.value,rr->val.value);
1757 break;
1758 case GEL_E_MINUS:
1759 case GEL_E_ELTMINUS:
1760 mpw_sub(res,ll->val.value,rr->val.value);
1761 break;
1762 case GEL_E_MUL:
1763 case GEL_E_ELTMUL:
1764 mpw_mul(res,ll->val.value,rr->val.value);
1765 break;
1766 case GEL_E_DIV:
1767 case GEL_E_ELTDIV:
1768 mpw_div(res,ll->val.value,rr->val.value);
1769 break;
1770 case GEL_E_BACK_DIV:
1771 case GEL_E_ELT_BACK_DIV:
1772 mpw_div(res,rr->val.value,ll->val.value);
1773 break;
1774 case GEL_E_MOD:
1775 case GEL_E_ELTMOD:
1776 mpw_mod(res,ll->val.value,rr->val.value);
1777 break;
1778 case GEL_E_EXP:
1779 case GEL_E_ELTEXP:
1780 if (ctx->modulo != NULL) {
1781 mpw_powm (res, ll->val.value, rr->val.value,
1782 ctx->modulo);
1783 skipmod = TRUE;
1784 } else {
1785 mpw_pow (res, ll->val.value, rr->val.value);
1786 }
1787 break;
1788 default: g_assert_not_reached();
1789 }
1790 if (!skipmod && ctx->modulo != NULL) {
1791 if G_UNLIKELY ( ! gel_mod_integer_rational (res, ctx->modulo)) {
1792 gel_error_num = GEL_NUMERICAL_MPW_ERROR;
1793 }
1794 }
1795 if G_UNLIKELY (gel_error_num == GEL_NUMERICAL_MPW_ERROR) {
1796 GEL_GET_NEW_NODE(n);
1797 n->type = GEL_OPERATOR_NODE;
1798 n->op.oper = oper;
1799 n->op.args = gel_copynode(ll);
1800 n->op.args->any.next = gel_copynode(rr);
1801 n->op.args->any.next->any.next = NULL;
1802 n->op.nargs = 2;
1803 mpw_clear(res);
1804 gel_error_num = GEL_NO_ERROR;
1805 return n;
1806 }
1807 return gel_makenum_use(res);
1808 } else if ((rr->type == GEL_VALUE_NODE || rr->type == GEL_BOOL_NODE) &&
1809 (ll->type == GEL_VALUE_NODE || ll->type == GEL_BOOL_NODE)) {
1810 gboolean lt = gel_isnodetrue (ll, NULL);
1811 gboolean rt = gel_isnodetrue (rr, NULL);
1812 gboolean resbool;
1813 gboolean got_res = FALSE;
1814
1815 switch (oper) {
1816 case GEL_E_PLUS:
1817 case GEL_E_ELTPLUS:
1818 resbool = lt || rt;
1819 got_res = TRUE;
1820 break;
1821 case GEL_E_MINUS:
1822 case GEL_E_ELTMINUS:
1823 resbool = lt || ! rt;
1824 got_res = TRUE;
1825 break;
1826 case GEL_E_MUL:
1827 case GEL_E_ELTMUL:
1828 resbool = lt && rt;
1829 got_res = TRUE;
1830 break;
1831 default:
1832 got_res = FALSE;
1833 resbool = FALSE;
1834 break;
1835 }
1836 if G_UNLIKELY ( ! got_res ||
1837 gel_error_num == GEL_NUMERICAL_MPW_ERROR) {
1838 GEL_GET_NEW_NODE(n);
1839 n->type = GEL_OPERATOR_NODE;
1840 n->op.oper = oper;
1841 n->op.args = gel_copynode(ll);
1842 n->op.args->any.next = gel_copynode(rr);
1843 n->op.args->any.next->any.next = NULL;
1844 n->op.nargs = 2;
1845 gel_error_num = GEL_NO_ERROR;
1846 return n;
1847 }
1848 return gel_makenum_bool (resbool);
1849 } else {
1850 /*this is the less common case so we can get around with a
1851 wierd thing, we'll just make a new fake node and pretend
1852 we want to evaluate that*/
1853 GEL_GET_NEW_NODE(n);
1854 n->type = GEL_OPERATOR_NODE;
1855 n->op.oper = oper;
1856
1857 n->op.args = gel_copynode(ll);
1858 n->op.args->any.next = gel_copynode(rr);
1859 n->op.args->any.next->any.next = NULL;
1860 n->op.nargs = 2;
1861
1862 if ( ! no_push) {
1863 GE_PUSH_STACK (ctx, n, GE_PRE);
1864 }
1865
1866 return n;
1867 }
1868 }
1869
1870
1871 /*eltadd, eltsub, mul, div*/
1872 static gboolean
matrix_scalar_matrix_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)1873 matrix_scalar_matrix_op(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
1874 {
1875 int i,j;
1876 GelMatrixW *m;
1877 GelETree *node;
1878 int order = 0;
1879 if(l->type == GEL_MATRIX_NODE) {
1880 m = l->mat.matrix;
1881 node = r;
1882 } else {
1883 order = 1;
1884 m = r->mat.matrix;
1885 node = l;
1886 }
1887
1888 gel_matrixw_make_private(m, TRUE /* kill_type_caches */);
1889
1890 for(j=0;j<gel_matrixw_height(m);j++) {
1891 for(i=0;i<gel_matrixw_width(m);i++) {
1892 GelETree *t = gel_matrixw_get_index(m,i,j);
1893 if(order == 0) {
1894 gel_matrixw_set_index(m,i,j) =
1895 op_two_nodes(ctx,
1896 t ? t : the_zero,
1897 node, n->op.oper,
1898 FALSE /* no_push */);
1899 } else {
1900 gel_matrixw_set_index(m,i,j) =
1901 op_two_nodes(ctx,node,
1902 t ? t : the_zero,
1903 n->op.oper,
1904 FALSE /* no_push */);
1905 }
1906 if (t != NULL)
1907 gel_freetree (t);
1908 }
1909 }
1910 n->op.args = NULL;
1911
1912 if(l->type == GEL_MATRIX_NODE) {
1913 replacenode(n,l);
1914 gel_freetree(r);
1915 } else {
1916 replacenode(n,r);
1917 gel_freetree(l);
1918 }
1919 return TRUE;
1920 }
1921
1922 /* add and sub using identity for square matrices and eltbyelt for vectors */
1923 static gboolean
matrix_addsub_scalar_matrix_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)1924 matrix_addsub_scalar_matrix_op (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
1925 {
1926 int i;
1927 GelMatrixW *m;
1928 GelETree *node;
1929
1930 if (l->type == GEL_MATRIX_NODE) {
1931 m = l->mat.matrix;
1932 node = r;
1933 } else {
1934 m = r->mat.matrix;
1935 node = l;
1936 }
1937
1938 /* If vector do the normal (element by element) scalar matrix operation */
1939 if (gel_matrixw_width (m) == 1 || gel_matrixw_height (m) == 1)
1940 return matrix_scalar_matrix_op (ctx, n, l, r);
1941
1942 if G_UNLIKELY (gel_matrixw_width (m) != gel_matrixw_height (m)) {
1943 gel_errorout (_("Can't add/subtract a scalar to non-square matrix (A + x is defined as A + x*I)"));
1944 return TRUE;
1945 }
1946
1947 gel_matrixw_make_private(m, TRUE /* kill_type_caches */);
1948
1949 for (i = 0; i < gel_matrixw_width (m); i++) {
1950 GelETree *t = gel_matrixw_get_indexii(m,i);
1951 /* Only for ADD/SUB so order is unimportant */
1952 gel_matrixw_set_indexii (m, i) =
1953 op_two_nodes (ctx,
1954 t ? t : the_zero,
1955 node, n->op.oper,
1956 FALSE /* no_push */);
1957 if (t != NULL)
1958 gel_freetree (t);
1959 }
1960 n->op.args = NULL;
1961
1962 if (l->type == GEL_MATRIX_NODE) {
1963 replacenode (n, l);
1964 gel_freetree (r);
1965 } else {
1966 replacenode (n, r);
1967 gel_freetree (l);
1968 }
1969 return TRUE;
1970 }
1971
1972 static gboolean
matrix_absnegfac_op(GelCtx * ctx,GelETree * n,GelETree * l)1973 matrix_absnegfac_op(GelCtx *ctx, GelETree *n, GelETree *l)
1974 {
1975 int i,j;
1976 GelMatrixW *m = l->mat.matrix;
1977
1978 gel_matrixw_make_private(m, TRUE /* kill_type_caches */);
1979
1980 for(j=0;j<gel_matrixw_height(m);j++) {
1981 for(i=0;i<gel_matrixw_width(m);i++) {
1982 GelETree *t = gel_matrixw_get_index(m,i,j);
1983 if(t == NULL) {
1984 if(n->op.oper == GEL_E_FACT ||
1985 n->op.oper == GEL_E_DBLFACT)
1986 gel_matrixw_set_index(m,i,j) = gel_makenum_ui(1);
1987 } else if(t->type == GEL_VALUE_NODE) {
1988 switch(n->op.oper) {
1989 case GEL_E_ABS:
1990 mpw_abs(t->val.value,t->val.value);
1991 break;
1992 case GEL_E_NEG:
1993 mpw_neg(t->val.value,t->val.value);
1994 break;
1995 case GEL_E_FACT:
1996 mpw_fac(t->val.value,t->val.value);
1997 break;
1998 case GEL_E_DBLFACT:
1999 mpw_dblfac(t->val.value,t->val.value);
2000 break;
2001 default:
2002 g_assert_not_reached();
2003 }
2004 } else if (t->type == GEL_BOOL_NODE &&
2005 n->op.oper == GEL_E_NEG) {
2006 t->bool_.bool_ = ! t->bool_.bool_;
2007 } else {
2008 GelETree *nn;
2009 GEL_GET_NEW_NODE(nn);
2010 nn->type = GEL_OPERATOR_NODE;
2011 nn->op.oper = n->op.oper;
2012 nn->op.args = t;
2013 t->any.next = NULL;
2014 nn->op.nargs = 1;
2015 gel_matrixw_set_index(m,i,j) = nn;
2016 GE_PUSH_STACK(ctx,nn,GE_PRE);
2017 }
2018 }
2019 }
2020 /*remove l from argument list*/
2021 n->op.args = NULL;
2022 replacenode(n,l);
2023 return TRUE;
2024 }
2025
2026 static gboolean
pure_matrix_eltbyelt_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2027 pure_matrix_eltbyelt_op(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2028 {
2029 int i,j;
2030 GelMatrixW *m1,*m2;
2031 m1 = l->mat.matrix;
2032 m2 = r->mat.matrix;
2033 if G_UNLIKELY ((gel_matrixw_width(m1) != gel_matrixw_width(m2)) ||
2034 (gel_matrixw_height(m1) != gel_matrixw_height(m2))) {
2035 if (n->op.oper == GEL_E_PLUS ||
2036 n->op.oper == GEL_E_ELTPLUS ||
2037 n->op.oper == GEL_E_MINUS ||
2038 n->op.oper == GEL_E_ELTMINUS)
2039 gel_errorout (_("Can't add/subtract two matrices of different sizes"));
2040 else
2041 gel_errorout (_("Can't do element by element operations on two matrices of different sizes"));
2042 return TRUE;
2043 }
2044 l->mat.quoted = l->mat.quoted || r->mat.quoted;
2045 gel_matrixw_make_private(m1, TRUE /* kill_type_caches */);
2046 for(j=0;j<gel_matrixw_height(m1);j++) {
2047 for(i=0;i<gel_matrixw_width(m1);i++) {
2048 GelETree *t = gel_matrixw_get_index (m1, i, j);
2049 gel_matrixw_set_index (m1, i, j)
2050 = op_two_nodes (ctx, t ? t : the_zero,
2051 gel_matrixw_index (m2, i, j),
2052 n->op.oper,
2053 FALSE /* no_push */);
2054 if (t != NULL)
2055 freetree_full (t, TRUE, TRUE);
2056 }
2057 }
2058 /*remove l from arglist*/
2059 n->op.args = n->op.args->any.next;
2060 /*replace n with l*/
2061 replacenode(n,l);
2062 return TRUE;
2063 }
2064
2065 static void
expensive_matrix_multiply(GelCtx * ctx,GelMatrixW * res,GelMatrixW * m1,GelMatrixW * m2)2066 expensive_matrix_multiply(GelCtx *ctx, GelMatrixW *res, GelMatrixW *m1, GelMatrixW *m2)
2067 {
2068 int i,j,k;
2069 for(i=0;i<gel_matrixw_width(res);i++) { /* columns M2 */
2070 for(j=0;j<gel_matrixw_height(res);j++) { /* rows M1 */
2071 GelETree *a = NULL;
2072 for(k=0;k<gel_matrixw_width(m1);k++) { /* columns M1,
2073 rows M2 */
2074 GelETree *t;
2075 GelETree *t2;
2076 t = op_two_nodes (ctx,
2077 gel_matrixw_index (m1, k, j),
2078 gel_matrixw_index (m2, i, k),
2079 GEL_E_MUL,
2080 TRUE /* no_push */);
2081 if (a == NULL) {
2082 a = t;
2083 } else {
2084 t2 = op_two_nodes (ctx, a, t, GEL_E_PLUS,
2085 TRUE /* no_push */);
2086 gel_freetree (t);
2087 gel_freetree (a);
2088 a = t2;
2089 }
2090 }
2091 gel_matrixw_set_index (res, i, j) = a;
2092 if (a->type == GEL_OPERATOR_NODE) {
2093 GE_PUSH_STACK (ctx, a, GE_PRE);
2094 }
2095 }
2096 }
2097 }
2098
2099 static gboolean
pure_matrix_mul_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2100 pure_matrix_mul_op(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2101 {
2102 GelMatrixW *m, *m1,*m2;
2103 gboolean quote;
2104 m1 = l->mat.matrix;
2105 m2 = r->mat.matrix;
2106 if G_UNLIKELY ((gel_matrixw_width(m1) != gel_matrixw_height(m2))) {
2107 gel_errorout (_("Can't multiply matrices of wrong sizes"));
2108 return TRUE;
2109 }
2110 m = gel_matrixw_new();
2111 quote = l->mat.quoted || r->mat.quoted;
2112 gel_matrixw_set_size(m,gel_matrixw_width(m2),gel_matrixw_height(m1));
2113
2114 /* for the puproses of cache optimization, it is more likely that
2115 * we are not in modulo mode and have a value only matrix */
2116 if G_UNLIKELY (ctx->modulo != NULL) {
2117 if (gel_is_matrix_value_only_integer (m1) &&
2118 gel_is_matrix_value_only_integer (m2)) {
2119 gel_value_matrix_multiply (m, m1, m2, ctx->modulo);
2120 } else {
2121 expensive_matrix_multiply (ctx, m, m1, m2);
2122 }
2123 } else {
2124 if G_LIKELY (gel_is_matrix_value_only(m1) &&
2125 gel_is_matrix_value_only(m2)) {
2126 gel_value_matrix_multiply (m, m1, m2, NULL);
2127 } else {
2128 expensive_matrix_multiply(ctx,m,m1,m2);
2129 }
2130 }
2131 freetree_full(n,TRUE,FALSE);
2132 n->type = GEL_MATRIX_NODE;
2133 n->mat.matrix = m;
2134 n->mat.quoted = quote;
2135 return TRUE;
2136 }
2137
2138 static gboolean
matrix_pow_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2139 matrix_pow_op(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2140 {
2141 int i;
2142 long power;
2143 gboolean quote;
2144 GelMatrixW *res = NULL;
2145 GelMatrixW *m;
2146 gboolean free_m = FALSE;
2147 mpw_ptr old_modulo;
2148
2149 m = l->mat.matrix;
2150 quote = l->mat.quoted;
2151
2152 if G_UNLIKELY (r->type != GEL_VALUE_NODE ||
2153 mpw_is_complex(r->val.value) ||
2154 !mpw_is_integer(r->val.value) ||
2155 (gel_matrixw_width(m) !=
2156 gel_matrixw_height(m)) ||
2157 !gel_is_matrix_value_only(m)) {
2158 gel_errorout (_("Powers are defined on (square matrix)^(integer) only"));
2159 return TRUE;
2160 }
2161
2162 if G_UNLIKELY (ctx->modulo != NULL &&
2163 ! gel_is_matrix_value_only_integer (m)) {
2164 gel_errorout (_("Powers on matrices in modulo mode are defined on integer matrices only"));
2165 return TRUE;
2166 }
2167
2168 gel_error_num = GEL_NO_ERROR;
2169 power = mpw_get_long(r->val.value);
2170 if G_UNLIKELY (gel_error_num) {
2171 gel_error_num = GEL_NO_ERROR;
2172 gel_errorout (_("Exponent too large"));
2173 return TRUE;
2174 }
2175
2176 if(power<=0) {
2177 GelMatrixW *mi;
2178 mi = gel_matrixw_new();
2179 gel_matrixw_set_size(mi,gel_matrixw_width(m),
2180 gel_matrixw_height(m));
2181 /* width == height */
2182 for(i=0;i<gel_matrixw_width(m);i++)
2183 gel_matrixw_set_indexii(mi,i) =
2184 gel_makenum_ui(1);
2185 if(power==0) {
2186 freetree_full(n,TRUE,FALSE);
2187 n->type = GEL_MATRIX_NODE;
2188 n->mat.matrix = mi;
2189 n->mat.quoted = quote;
2190 return TRUE;
2191 }
2192
2193 m = gel_matrixw_copy(m);
2194 /* FIXME: unfortunately the modulo logic of gauss is fucked */
2195 old_modulo = ctx->modulo;
2196 ctx->modulo = NULL;
2197 if G_UNLIKELY (!gel_value_matrix_gauss(ctx,m,TRUE,FALSE,TRUE,FALSE,NULL,mi)) {
2198 ctx->modulo = old_modulo;
2199 gel_errorout (_("Matrix appears singular and can't be inverted"));
2200 gel_matrixw_free(m);
2201 gel_matrixw_free(mi);
2202 return TRUE;
2203 }
2204 ctx->modulo = old_modulo;
2205 gel_matrixw_free(m);
2206 m = mi;
2207 free_m = TRUE;
2208
2209 /* Mod if in modulo mode */
2210 if (ctx->modulo != NULL)
2211 mod_matrix (m, ctx->modulo);
2212
2213 power = -power;
2214 }
2215
2216 if(power==1) {
2217 if(!free_m)
2218 l->mat.matrix = NULL;
2219 freetree_full(n,TRUE,FALSE);
2220 n->type = GEL_MATRIX_NODE;
2221 n->mat.matrix = m;
2222 n->mat.quoted = quote;
2223 return TRUE;
2224 }
2225
2226 while(power>0) {
2227 /*if odd*/
2228 if(power & 0x1) {
2229 if(res) {
2230 GelMatrixW *ml = gel_matrixw_new();
2231 gel_matrixw_set_size(ml,gel_matrixw_width(m),
2232 gel_matrixw_height(m));
2233 gel_value_matrix_multiply(ml,res,m,ctx->modulo);
2234 gel_matrixw_free(res);
2235 res = ml;
2236 } else
2237 res = gel_matrixw_copy(m);
2238 power--;
2239 } else { /*even*/
2240 GelMatrixW *ml = gel_matrixw_new();
2241 gel_matrixw_set_size(ml,gel_matrixw_width(m),
2242 gel_matrixw_height(m));
2243 gel_value_matrix_multiply(ml,m,m,ctx->modulo);
2244 if(free_m)
2245 gel_matrixw_free(m);
2246 m = ml;
2247 free_m = TRUE;
2248
2249 power >>= 1; /*divide by two*/
2250 }
2251 }
2252
2253 freetree_full(n,TRUE,FALSE);
2254 n->type = GEL_MATRIX_NODE;
2255 if(!res) {
2256 if(free_m)
2257 n->mat.matrix = m;
2258 else
2259 n->mat.matrix = gel_matrixw_copy(m);
2260 } else {
2261 n->mat.matrix = res;
2262 if(free_m)
2263 gel_matrixw_free(m);
2264 }
2265 n->mat.quoted = quote;
2266 return TRUE;
2267 }
2268
2269 static gboolean
pure_matrix_div_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2270 pure_matrix_div_op(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2271 {
2272 int i;
2273 gboolean quote;
2274 GelMatrixW *m1,*m2;
2275 GelMatrixW *mi,*toinvert;
2276 GelMatrixW *res;
2277 mpw_ptr old_modulo;
2278
2279 m1 = l->mat.matrix;
2280 m2 = r->mat.matrix;
2281 quote = l->mat.quoted || r->mat.quoted;
2282
2283 if G_UNLIKELY ((gel_matrixw_width(m1) !=
2284 gel_matrixw_height(m1)) ||
2285 (gel_matrixw_width(m2) !=
2286 gel_matrixw_height(m2)) ||
2287 (gel_matrixw_width(m1) !=
2288 gel_matrixw_width(m2)) ||
2289 !gel_is_matrix_value_only(m1) ||
2290 !gel_is_matrix_value_only(m2)) {
2291 gel_errorout (_("Can't divide matrices of different sizes or non-square matrices"));
2292 return TRUE;
2293 }
2294
2295 mi = gel_matrixw_new();
2296 gel_matrixw_set_size(mi,gel_matrixw_width(m1),
2297 gel_matrixw_height(m1));
2298 /* width == height */
2299 for(i=0;i<gel_matrixw_width(m1);i++)
2300 gel_matrixw_set_indexii(mi,i) =
2301 gel_makenum_ui(1);
2302
2303 if(n->op.oper == GEL_E_BACK_DIV)
2304 toinvert = m1;
2305 else
2306 toinvert = m2;
2307
2308 toinvert = gel_matrixw_copy(toinvert);
2309 /* FIXME: unfortunately the modulo logic of gauss is fucked */
2310 old_modulo = ctx->modulo;
2311 ctx->modulo = NULL;
2312 if G_UNLIKELY (!gel_value_matrix_gauss(ctx,toinvert,TRUE,FALSE,TRUE,FALSE,NULL,mi)) {
2313 ctx->modulo = old_modulo;
2314 gel_errorout (_("Matrix appears singular and can't be inverted"));
2315 gel_matrixw_free(mi);
2316 gel_matrixw_free(toinvert);
2317 return TRUE;
2318 }
2319 ctx->modulo = old_modulo;
2320 gel_matrixw_free(toinvert);
2321
2322 /* Mod if in modulo mode */
2323 if (ctx->modulo != NULL)
2324 mod_matrix (mi, ctx->modulo);
2325
2326 if(n->op.oper == GEL_E_BACK_DIV)
2327 m1 = mi;
2328 else
2329 m2 = mi;
2330
2331 res = gel_matrixw_new();
2332 gel_matrixw_set_size(res,gel_matrixw_width(m1),
2333 gel_matrixw_height(m1));
2334 gel_value_matrix_multiply(res,m1,m2,ctx->modulo);
2335 if(n->op.oper == GEL_E_BACK_DIV)
2336 gel_matrixw_free(m1);
2337 else
2338 gel_matrixw_free(m2);
2339
2340 freetree_full(n,TRUE,FALSE);
2341 n->type = GEL_MATRIX_NODE;
2342 n->mat.matrix = res;
2343 n->mat.quoted = quote;
2344 return TRUE;
2345 }
2346
2347 static gboolean
value_matrix_div_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2348 value_matrix_div_op(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2349 {
2350 int i,j;
2351 gboolean quote;
2352 GelMatrixW *m;
2353 GelMatrixW *mi;
2354 mpw_ptr old_modulo;
2355
2356 m = r->mat.matrix;
2357 quote = r->mat.quoted;
2358
2359 if G_UNLIKELY ((gel_matrixw_width(m) !=
2360 gel_matrixw_height(m)) ||
2361 !gel_is_matrix_value_only(m)) {
2362 gel_errorout (_("Can't divide by a non-square matrix"));
2363 return TRUE;
2364 }
2365
2366 mi = gel_matrixw_new();
2367 gel_matrixw_set_size(mi,gel_matrixw_width(m),
2368 gel_matrixw_height(m));
2369 /* width == height */
2370 for(i=0;i<gel_matrixw_width(m);i++)
2371 gel_matrixw_set_indexii(mi,i) =
2372 gel_makenum_ui(1);
2373
2374 m = gel_matrixw_copy(m);
2375 /* FIXME: unfortunately the modulo logic of gauss is fucked */
2376 old_modulo = ctx->modulo;
2377 ctx->modulo = NULL;
2378 if G_UNLIKELY (!gel_value_matrix_gauss(ctx,m,TRUE,FALSE,TRUE,FALSE,NULL,mi)) {
2379 ctx->modulo = old_modulo;
2380 gel_errorout (_("Matrix appears singular and can't be inverted"));
2381 gel_matrixw_free(mi);
2382 gel_matrixw_free(m);
2383 return TRUE;
2384 }
2385 ctx->modulo = old_modulo;
2386 gel_matrixw_free(m);
2387 m = mi;
2388
2389 /* Mod if in modulo mode */
2390 if (ctx->modulo != NULL)
2391 mod_matrix (mi, ctx->modulo);
2392
2393 for(j=0;j<gel_matrixw_width(m);j++) {
2394 for(i=0;i<gel_matrixw_width(m);i++) {
2395 GelETree *t = gel_matrixw_get_index(m,i,j);
2396 if(t)
2397 mpw_mul(t->val.value,t->val.value,
2398 l->val.value);
2399 }
2400 }
2401
2402 freetree_full(n,TRUE,FALSE);
2403 n->type = GEL_MATRIX_NODE;
2404 n->mat.matrix = m;
2405 n->mat.quoted = quote;
2406 return TRUE;
2407 }
2408
2409 /*add, sub */
2410 static gboolean
polynomial_add_sub_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2411 polynomial_add_sub_op (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2412 {
2413 #if 0
2414 if (l->type == GEL_VALUE_NODE) {
2415 /* r->type == GEL_POLYNOMIAL_NODE */
2416 /* FIXME implement */
2417 } else if (r->type == GEL_VALUE_NODE) {
2418 /* l->type == GEL_POLYNOMIAL_NODE */
2419 /* FIXME implement */
2420 } else {
2421 /* FIXME implement */
2422 }
2423 #endif
2424
2425 return TRUE;
2426 }
2427
2428 static void
mod_matrix(GelMatrixW * m,mpw_ptr mod)2429 mod_matrix (GelMatrixW *m, mpw_ptr mod)
2430 {
2431 int i,j;
2432 int w,h;
2433
2434 /*make us a private copy!*/
2435 gel_matrixw_make_private(m, TRUE /* kill_type_caches */);
2436
2437 w = gel_matrixw_width (m);
2438 h = gel_matrixw_height (m);
2439 for (j = 0; j < h; j++) {
2440 for (i = 0; i < w; i++) {
2441 GelETree *t = gel_matrixw_get_index (m, i, j);
2442 if (t != NULL) {
2443 mod_node (t, mod);
2444 }
2445 }
2446 }
2447 }
2448
2449 static void
mod_node(GelETree * n,mpw_ptr mod)2450 mod_node (GelETree *n, mpw_ptr mod)
2451 {
2452 if(n->type == GEL_VALUE_NODE) {
2453 if ( ! gel_mod_integer_rational (n->val.value, mod)) {
2454 GelETree *nn;
2455 GEL_GET_NEW_NODE(nn);
2456 nn->type = GEL_OPERATOR_NODE;
2457 nn->op.oper = GEL_E_MOD_CALC;
2458 nn->op.args = gel_copynode (n);
2459 nn->op.args->any.next = gel_makenum (mod);
2460 nn->op.args->any.next->any.next = NULL;
2461 nn->op.nargs = 2;
2462 gel_error_num = GEL_NO_ERROR;
2463 replacenode (n, nn);
2464 }
2465 } else if(n->type == GEL_MATRIX_NODE) {
2466 if (n->mat.matrix != NULL)
2467 mod_matrix (n->mat.matrix, mod);
2468 }
2469 }
2470
2471 void
gel_mod_node(GelCtx * ctx,GelETree * n)2472 gel_mod_node (GelCtx *ctx, GelETree *n)
2473 {
2474 if (ctx->modulo != NULL)
2475 mod_node (n, ctx->modulo);
2476 }
2477
2478 /*return TRUE if node is true (a number node !=0), false otherwise*/
2479 gboolean
gel_isnodetrue(GelETree * n,gboolean * bad_node)2480 gel_isnodetrue (GelETree *n, gboolean *bad_node)
2481 {
2482 switch (n->type) {
2483 case GEL_NULL_NODE:
2484 return FALSE;
2485 case GEL_VALUE_NODE:
2486 return ! mpw_zero_p (n->val.value);
2487 case GEL_STRING_NODE:
2488 if(n->str.str && *n->str.str)
2489 return TRUE;
2490 else
2491 return FALSE;
2492 case GEL_BOOL_NODE:
2493 return n->bool_.bool_;
2494 default:
2495 if (bad_node)
2496 *bad_node = TRUE;
2497 return FALSE;
2498 }
2499 }
2500
2501 static gboolean
transpose_matrix(GelCtx * ctx,GelETree * n,GelETree * l)2502 transpose_matrix (GelCtx *ctx, GelETree *n, GelETree *l)
2503 {
2504 l->mat.matrix->tr = !(l->mat.matrix->tr);
2505 /*remove from arglist*/
2506 n->op.args = NULL;
2507 replacenode(n,l);
2508 return TRUE;
2509 }
2510
2511 static gboolean
conjugate_transpose_matrix(GelCtx * ctx,GelETree * n,GelETree * l)2512 conjugate_transpose_matrix (GelCtx *ctx, GelETree *n, GelETree *l)
2513 {
2514 /* handles real case nicely */
2515 gel_matrix_conjugate_transpose (l->mat.matrix);
2516
2517 /*remove from arglist*/
2518 n->op.args = NULL;
2519 replacenode(n,l);
2520 return TRUE;
2521 }
2522
2523 static gboolean
string_concat(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2524 string_concat (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2525 {
2526 char *s = NULL;
2527
2528 if (l->type == GEL_STRING_NODE &&
2529 r->type == GEL_STRING_NODE) {
2530 s = g_strconcat (l->str.str, r->str.str, NULL);
2531 } else if (l->type == GEL_STRING_NODE &&
2532 r->type == GEL_IDENTIFIER_NODE) {
2533 s = g_strconcat (l->str.str, r->id.id->token, NULL);
2534 } else if (r->type == GEL_STRING_NODE &&
2535 l->type == GEL_IDENTIFIER_NODE) {
2536 s = g_strconcat (l->id.id->token, r->str.str, NULL);
2537 } else if (l->type == GEL_STRING_NODE) {
2538 char *t = gel_string_print_etree (r);
2539 s = g_strconcat (l->str.str, t, NULL);
2540 g_free (t);
2541 } else if (r->type == GEL_STRING_NODE) {
2542 char *t = gel_string_print_etree (l);
2543 s = g_strconcat (t, r->str.str, NULL);
2544 g_free (t);
2545 } else {
2546 g_assert_not_reached();
2547 }
2548
2549 freetree_full (n, TRUE, FALSE);
2550 n->type = GEL_STRING_NODE;
2551 n->str.str = s;
2552 n->str.constant = FALSE;
2553
2554 return TRUE;
2555 }
2556
2557
2558 /*for numbers*/
2559 static void
my_mpw_back_div(mpw_ptr rop,mpw_ptr op1,mpw_ptr op2)2560 my_mpw_back_div (mpw_ptr rop, mpw_ptr op1, mpw_ptr op2)
2561 {
2562 mpw_div (rop, op2, op1);
2563 }
2564
2565
2566 #define PRIM_NUM_FUNC_1(funcname,mpwfunc) \
2567 static gboolean \
2568 funcname(GelCtx *ctx, GelETree *n, GelETree *l) \
2569 { \
2570 mpw_t res; \
2571 \
2572 mpw_init(res); \
2573 mpwfunc(res,l->val.value); \
2574 if G_UNLIKELY (gel_error_num == GEL_NUMERICAL_MPW_ERROR) { \
2575 mpw_clear(res); \
2576 gel_error_num = GEL_NO_ERROR; \
2577 return TRUE; \
2578 } \
2579 \
2580 freetree_full(n,TRUE,FALSE); \
2581 gel_makenum_use_from(n,res); \
2582 return TRUE; \
2583 }
2584 #define PRIM_NUM_FUNC_2(funcname,mpwfunc) \
2585 static gboolean \
2586 funcname(GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r) \
2587 { \
2588 mpw_t res; \
2589 \
2590 mpw_init(res); \
2591 mpwfunc(res,l->val.value,r->val.value); \
2592 if G_UNLIKELY (gel_error_num == GEL_NUMERICAL_MPW_ERROR) { \
2593 mpw_clear(res); \
2594 gel_error_num = GEL_NO_ERROR; \
2595 return TRUE; \
2596 } \
2597 \
2598 freetree_full(n,TRUE,FALSE); \
2599 gel_makenum_use_from(n,res); \
2600 return TRUE; \
2601 }
2602
PRIM_NUM_FUNC_1(numerical_abs,mpw_abs)2603 PRIM_NUM_FUNC_1(numerical_abs,mpw_abs)
2604 PRIM_NUM_FUNC_1(numerical_neg,mpw_neg)
2605 PRIM_NUM_FUNC_1(numerical_fac,mpw_fac)
2606 PRIM_NUM_FUNC_1(numerical_dblfac,mpw_dblfac)
2607 PRIM_NUM_FUNC_2(numerical_add,mpw_add)
2608 PRIM_NUM_FUNC_2(numerical_sub,mpw_sub)
2609 PRIM_NUM_FUNC_2(numerical_mul,mpw_mul)
2610 PRIM_NUM_FUNC_2(numerical_div,mpw_div)
2611 PRIM_NUM_FUNC_2(numerical_mod,mpw_mod)
2612 PRIM_NUM_FUNC_2(numerical_back_div,my_mpw_back_div)
2613
2614 static gboolean
2615 numerical_pow (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2616 {
2617 mpw_t res;
2618
2619 mpw_init(res);
2620 if (ctx->modulo != NULL)
2621 mpw_powm (res, l->val.value, r->val.value, ctx->modulo);
2622 else
2623 mpw_pow (res, l->val.value, r->val.value);
2624 if G_UNLIKELY (gel_error_num == GEL_NUMERICAL_MPW_ERROR) {
2625 mpw_clear (res);
2626 gel_error_num = GEL_NO_ERROR;
2627 return TRUE;
2628 }
2629
2630 freetree_full (n, TRUE, FALSE);
2631 gel_makenum_use_from (n, res);
2632 return TRUE;
2633 }
2634
2635 static gboolean
boolean_add(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2636 boolean_add (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2637 {
2638 gboolean lt = gel_isnodetrue (l, NULL);
2639 gboolean rt = gel_isnodetrue (r, NULL);
2640
2641 freetree_full (n, TRUE, FALSE);
2642 gel_makenum_bool_from (n, lt || rt);
2643 return TRUE;
2644 }
2645
2646 static gboolean
boolean_sub(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2647 boolean_sub (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2648 {
2649 gboolean lt = gel_isnodetrue (l, NULL);
2650 gboolean rt = gel_isnodetrue (r, NULL);
2651
2652 freetree_full (n, TRUE, FALSE);
2653 gel_makenum_bool_from (n, lt || ! rt);
2654 return TRUE;
2655 }
2656
2657 static gboolean
boolean_mul(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2658 boolean_mul (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2659 {
2660 gboolean lt = gel_isnodetrue (l, NULL);
2661 gboolean rt = gel_isnodetrue (r, NULL);
2662
2663 freetree_full (n, TRUE, FALSE);
2664 gel_makenum_bool_from (n, lt && rt);
2665 return TRUE;
2666 }
2667
2668 static gboolean
boolean_neg(GelCtx * ctx,GelETree * n,GelETree * l)2669 boolean_neg (GelCtx *ctx, GelETree *n, GelETree *l)
2670 {
2671 gboolean lt = gel_isnodetrue (l, NULL);
2672
2673 freetree_full (n, TRUE, FALSE);
2674 gel_makenum_bool_from (n, ! lt);
2675 return TRUE;
2676 }
2677
2678 static GelToken *
get_fake_token(int i)2679 get_fake_token (int i)
2680 {
2681 static GelToken *ids[10] = { NULL, };
2682 if G_UNLIKELY (i >= 10) {
2683 GelToken *id;
2684 char *s = g_strdup_printf ("_x%d", i);
2685 id = d_intern (s);
2686 g_free (s);
2687 return id;
2688 }
2689
2690 if G_UNLIKELY (ids[i] == NULL) {
2691 char *s = g_strdup_printf ("_x%d", i);
2692 ids[i] = d_intern (s);
2693 g_free (s);
2694 }
2695
2696 return ids[i];
2697 }
2698
2699 static GelETree *
make_funccall(GelEFunc * a)2700 make_funccall (GelEFunc *a)
2701 {
2702 int i;
2703 GelETree *n;
2704 GelETree *nn;
2705
2706 GEL_GET_NEW_NODE (n);
2707 n->type = GEL_OPERATOR_NODE;
2708 n->op.oper = GEL_E_DIRECTCALL;
2709 n->op.nargs = a->nargs+1;
2710
2711 GEL_GET_NEW_NODE (nn);
2712 nn->type = GEL_FUNCTION_NODE;
2713 nn->func.func = d_copyfunc (a);
2714 /* never copy is_local */
2715 nn->func.func->is_local = 0;
2716 if ( ! nn->func.func->on_subst_list)
2717 nn->func.func->context = -1;
2718
2719 n->op.args = nn;
2720
2721 for (i = 0; i < a->nargs; i++) {
2722 GelETree *nnn;
2723 nnn = gel_makenum_identifier (get_fake_token (i));
2724 nn->any.next = nnn;
2725 nn = nnn;
2726 }
2727 nn->any.next = NULL;
2728
2729 return n;
2730 }
2731
2732 static gboolean
function_finish_bin_op(GelCtx * ctx,GelETree * n,int nargs,GelETree * la,GelETree * lb)2733 function_finish_bin_op (GelCtx *ctx, GelETree *n, int nargs, GelETree *la, GelETree *lb)
2734 {
2735 int i;
2736 GSList *args;
2737 GelETree *nn;
2738 GelEFunc *f;
2739
2740 GEL_GET_NEW_NODE (nn);
2741 nn->type = GEL_OPERATOR_NODE;
2742 nn->op.oper = n->op.oper;
2743 nn->op.args = la;
2744 nn->op.args->any.next = lb;
2745 nn->op.args->any.next->any.next = NULL;
2746 nn->op.nargs = 2;
2747
2748 args = NULL;
2749 for (i = nargs -1; i >= 0; i--) {
2750 args = g_slist_prepend (args, get_fake_token (i));
2751 }
2752
2753 f = d_makeufunc (NULL /* id */,
2754 nn /* value */,
2755 args, nargs,
2756 NULL /* extra_dict */);
2757 freetree_full (n, TRUE /* free args */, FALSE /* kill */);
2758 n->type = GEL_FUNCTION_NODE;
2759 n->func.func = f;
2760 n->func.func->context = -1;
2761
2762 /* FIXME: never on subst list maybe? but only when not adding random expression! */
2763
2764 return TRUE;
2765 }
2766
2767 static gboolean
function_bin_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2768 function_bin_op (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2769 {
2770 GelETree *la, *lb;
2771 GelEFunc *a, *b;
2772
2773 a = get_func_from (l, FALSE /* silent */);
2774 b = get_func_from (r, FALSE /* silent */);
2775 if (a == NULL || b == NULL) {
2776 return TRUE;
2777 }
2778
2779 if G_UNLIKELY (a->vararg || b->vararg) {
2780 gel_errorout (_("Operations on functions with variable argument list not supported"));
2781 return TRUE;
2782 }
2783
2784 if G_UNLIKELY (a->nargs != b->nargs) {
2785 gel_errorout (_("Operations on functions with different number of arguments not supported"));
2786 return TRUE;
2787 }
2788
2789 la = make_funccall (a);
2790 lb = make_funccall (b);
2791
2792 return function_finish_bin_op (ctx, n, a->nargs, la, lb);
2793 }
2794
2795 static gboolean
function_something_bin_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2796 function_something_bin_op (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2797 {
2798 GelETree *la;
2799 GelEFunc *a;
2800
2801 a = get_func_from (l, FALSE /* silent */);
2802 if (a == NULL) {
2803 return TRUE;
2804 }
2805
2806 if G_UNLIKELY (a->vararg) {
2807 gel_errorout (_("Operations on functions with variable argument list not supported"));
2808 return TRUE;
2809 }
2810
2811 la = make_funccall (a);
2812
2813 return function_finish_bin_op (ctx, n, a->nargs, la, gel_copynode (r));
2814 }
2815
2816 static gboolean
something_function_bin_op(GelCtx * ctx,GelETree * n,GelETree * l,GelETree * r)2817 something_function_bin_op (GelCtx *ctx, GelETree *n, GelETree *l, GelETree *r)
2818 {
2819 GelETree *lb;
2820 GelEFunc *b;
2821
2822 b = get_func_from (r, FALSE /* silent */);
2823 if (b == NULL) {
2824 return TRUE;
2825 }
2826
2827 if G_UNLIKELY (b->vararg) {
2828 gel_errorout (_("Operations on functions with variable argument list not supported"));
2829 return TRUE;
2830 }
2831
2832 lb = make_funccall (b);
2833
2834 return function_finish_bin_op (ctx, n, b->nargs, gel_copynode (l), lb);
2835 }
2836
2837 static gboolean
function_uni_op(GelCtx * ctx,GelETree * n,GelETree * l)2838 function_uni_op (GelCtx *ctx, GelETree *n, GelETree *l)
2839 {
2840 int i;
2841 GSList *args;
2842 GelETree *la;
2843 GelETree *nn;
2844 GelEFunc *f, *a;
2845
2846 a = get_func_from (l, FALSE /* silent */);
2847 if (a == NULL) {
2848 return TRUE;
2849 }
2850
2851 if G_UNLIKELY (a->vararg) {
2852 gel_errorout (_("Operations on functions with variable argument list not supported"));
2853 return TRUE;
2854 }
2855
2856 la = make_funccall (a);
2857
2858 GEL_GET_NEW_NODE (nn);
2859 nn->type = GEL_OPERATOR_NODE;
2860 nn->op.oper = n->op.oper;
2861 nn->op.args = la;
2862 nn->op.args->any.next = NULL;
2863 nn->op.nargs = 1;
2864
2865 args = NULL;
2866 for (i = a->nargs -1; i >= 0; i--) {
2867 args = g_slist_prepend (args, get_fake_token (i));
2868 }
2869
2870 f = d_makeufunc (NULL /* id */,
2871 nn /* value */,
2872 args, a->nargs,
2873 NULL /* extra_dict */);
2874 freetree_full (n, TRUE /* free args */, FALSE /* kill */);
2875 n->type = GEL_FUNCTION_NODE;
2876 n->func.func = f;
2877 n->func.func->context = -1;
2878
2879 n->func.func->never_on_subst_list = 1;
2880
2881 return TRUE;
2882 }
2883
2884 GelETree *
gel_function_from_function(GelEFunc * func,GelETree * l)2885 gel_function_from_function (GelEFunc *func, GelETree *l)
2886 {
2887 int i;
2888 GSList *args;
2889 GelETree *la;
2890 GelETree *n;
2891 GelETree *nn;
2892 GelEFunc *f, *a;
2893
2894 a = get_func_from (l, FALSE /* silent */);
2895 if (a == NULL) {
2896 return NULL;
2897 }
2898
2899 if G_UNLIKELY (a->vararg) {
2900 gel_errorout (_("Operations on functions with variable argument list not supported"));
2901 return NULL;
2902 }
2903
2904 if G_UNLIKELY (func->nargs != 1) {
2905 gel_errorout (_("Function creation with wrong number of arguments"));
2906 return NULL;
2907 }
2908
2909 la = make_funccall (a);
2910
2911 GEL_GET_NEW_NODE (n);
2912 n->type = GEL_FUNCTION_NODE;
2913 n->func.func = d_copyfunc (func);
2914 /* never copy is_local */
2915 n->func.func->is_local = 0;
2916 if ( ! n->func.func->on_subst_list)
2917 n->func.func->context = -1;
2918
2919 GEL_GET_NEW_NODE (nn);
2920 nn->type = GEL_OPERATOR_NODE;
2921 nn->op.oper = GEL_E_DIRECTCALL;
2922 nn->op.args = n;
2923 nn->op.args->any.next = la;
2924 nn->op.args->any.next->any.next = NULL;
2925 nn->op.nargs = 2;
2926
2927 args = NULL;
2928 for (i = a->nargs -1; i >= 0; i--) {
2929 args = g_slist_prepend (args, get_fake_token (i));
2930 }
2931
2932 f = d_makeufunc (NULL /* id */,
2933 nn /* value */,
2934 args, a->nargs,
2935 NULL /* extra_dict */);
2936 GEL_GET_NEW_NODE (n);
2937 n->type = GEL_FUNCTION_NODE;
2938 n->func.func = f;
2939 n->func.func->context = -1;
2940
2941 n->func.func->never_on_subst_list = 1;
2942
2943 return n;
2944 }
2945
2946
2947 #define EMPTY_PRIM {{{{0}}}}
2948 /* May have to raise OP_TABLE_LEN in eval.h if you add entries below */
2949
2950 static const GelOper prim_table[GEL_E_OPER_LAST] = {
2951 /*GEL_E_SEPAR*/ EMPTY_PRIM,
2952 /*GEL_E_EQUALS*/ EMPTY_PRIM,
2953 /*GEL_E_PARAMETER*/ EMPTY_PRIM,
2954 /*GEL_E_ABS*/
2955 {{
2956 {{GO_VALUE,0,0},(GelEvalFunc)numerical_abs},
2957 {{GO_MATRIX,0,0},(GelEvalFunc)matrix_absnegfac_op},
2958 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
2959 (GelEvalFunc)function_uni_op},
2960 }},
2961 /*GEL_E_PLUS*/
2962 {{
2963 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_add},
2964 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
2965 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
2966 (GelEvalFunc)matrix_addsub_scalar_matrix_op},
2967 {{GO_VALUE|GO_MATRIX|GO_FUNCTION|GO_IDENTIFIER|GO_STRING,GO_STRING,0},
2968 (GelEvalFunc)string_concat},
2969 {{GO_STRING,GO_VALUE|GO_MATRIX|GO_FUNCTION|GO_IDENTIFIER|GO_STRING,0},
2970 (GelEvalFunc)string_concat},
2971 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
2972 (GelEvalFunc)function_bin_op},
2973 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
2974 (GelEvalFunc)function_something_bin_op},
2975 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
2976 (GelEvalFunc)something_function_bin_op},
2977 {{GO_VALUE|GO_POLYNOMIAL,GO_VALUE|GO_POLYNOMIAL,0},
2978 (GelEvalFunc)polynomial_add_sub_op},
2979 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},(GelEvalFunc)boolean_add},
2980 }},
2981 /*GEL_E_ELTPLUS*/
2982 {{
2983 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_add},
2984 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
2985 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
2986 (GelEvalFunc)matrix_scalar_matrix_op},
2987 {{GO_VALUE|GO_MATRIX|GO_FUNCTION|GO_STRING,GO_STRING,0},
2988 (GelEvalFunc)string_concat},
2989 {{GO_STRING,GO_VALUE|GO_MATRIX|GO_FUNCTION|GO_STRING,0},
2990 (GelEvalFunc)string_concat},
2991 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
2992 (GelEvalFunc)function_bin_op},
2993 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
2994 (GelEvalFunc)function_something_bin_op},
2995 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
2996 (GelEvalFunc)something_function_bin_op},
2997 {{GO_VALUE|GO_POLYNOMIAL,GO_VALUE|GO_POLYNOMIAL,0},
2998 (GelEvalFunc)polynomial_add_sub_op},
2999 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},(GelEvalFunc)boolean_add},
3000 }},
3001 /*GEL_E_MINUS*/
3002 {{
3003 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_sub},
3004 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3005 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3006 (GelEvalFunc)matrix_addsub_scalar_matrix_op},
3007 {{GO_VALUE|GO_POLYNOMIAL,GO_VALUE|GO_POLYNOMIAL,0},
3008 (GelEvalFunc)polynomial_add_sub_op},
3009 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3010 (GelEvalFunc)function_bin_op},
3011 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3012 (GelEvalFunc)function_something_bin_op},
3013 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3014 (GelEvalFunc)something_function_bin_op},
3015 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},(GelEvalFunc)boolean_sub},
3016 }},
3017 /*GEL_E_ELTMINUS*/
3018 {{
3019 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_sub},
3020 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3021 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3022 (GelEvalFunc)matrix_scalar_matrix_op},
3023 {{GO_VALUE|GO_POLYNOMIAL,GO_VALUE|GO_POLYNOMIAL,0},
3024 (GelEvalFunc)polynomial_add_sub_op},
3025 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3026 (GelEvalFunc)function_bin_op},
3027 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3028 (GelEvalFunc)function_something_bin_op},
3029 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3030 (GelEvalFunc)something_function_bin_op},
3031 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},(GelEvalFunc)boolean_sub},
3032 }},
3033 /*GEL_E_MUL*/
3034 {{
3035 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_mul},
3036 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_mul_op},
3037 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3038 (GelEvalFunc)matrix_scalar_matrix_op},
3039 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3040 (GelEvalFunc)function_bin_op},
3041 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3042 (GelEvalFunc)function_something_bin_op},
3043 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3044 (GelEvalFunc)something_function_bin_op},
3045 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},(GelEvalFunc)boolean_mul},
3046 }},
3047 /*GEL_E_ELTMUL*/
3048 {{
3049 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_mul},
3050 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3051 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3052 (GelEvalFunc)matrix_scalar_matrix_op},
3053 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3054 (GelEvalFunc)function_bin_op},
3055 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3056 (GelEvalFunc)function_something_bin_op},
3057 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3058 (GelEvalFunc)something_function_bin_op},
3059 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},(GelEvalFunc)boolean_mul},
3060 }},
3061 /*GEL_E_DIV*/
3062 {{
3063 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_div},
3064 {{GO_MATRIX,GO_VALUE,0}, (GelEvalFunc)matrix_scalar_matrix_op},
3065 {{GO_VALUE,GO_MATRIX,0}, (GelEvalFunc)value_matrix_div_op},
3066 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_div_op},
3067 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3068 (GelEvalFunc)function_bin_op},
3069 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3070 (GelEvalFunc)function_something_bin_op},
3071 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3072 (GelEvalFunc)something_function_bin_op},
3073 }},
3074 /*GEL_E_ELTDIV*/
3075 {{
3076 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_div},
3077 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3078 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3079 (GelEvalFunc)matrix_scalar_matrix_op},
3080 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3081 (GelEvalFunc)function_bin_op},
3082 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3083 (GelEvalFunc)function_something_bin_op},
3084 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3085 (GelEvalFunc)something_function_bin_op},
3086 }},
3087 /*GEL_E_BACK_DIV*/
3088 {{
3089 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_back_div},
3090 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_div_op},
3091 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3092 (GelEvalFunc)function_bin_op},
3093 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3094 (GelEvalFunc)function_something_bin_op},
3095 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3096 (GelEvalFunc)something_function_bin_op},
3097 }},
3098 /*GEL_E_ELT_BACK_DIV*/
3099 {{
3100 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_back_div},
3101 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3102 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3103 (GelEvalFunc)matrix_scalar_matrix_op},
3104 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3105 (GelEvalFunc)function_bin_op},
3106 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3107 (GelEvalFunc)function_something_bin_op},
3108 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3109 (GelEvalFunc)something_function_bin_op},
3110 }},
3111 /*GEL_E_MOD*/
3112 {{
3113 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_mod},
3114 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3115 (GelEvalFunc)function_bin_op},
3116 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE,0},
3117 (GelEvalFunc)function_something_bin_op},
3118 {{GO_VALUE,GO_FUNCTION|GO_IDENTIFIER,0},
3119 (GelEvalFunc)something_function_bin_op},
3120 }},
3121 /*GEL_E_ELTMOD*/
3122 {{
3123 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_mod},
3124 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3125 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3126 (GelEvalFunc)matrix_scalar_matrix_op},
3127 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3128 (GelEvalFunc)function_bin_op},
3129 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3130 (GelEvalFunc)function_something_bin_op},
3131 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3132 (GelEvalFunc)something_function_bin_op},
3133 }},
3134 /*GEL_E_NEG*/
3135 {{
3136 {{GO_VALUE,0,0},(GelEvalFunc)numerical_neg},
3137 {{GO_MATRIX,0,0},(GelEvalFunc)matrix_absnegfac_op},
3138 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
3139 (GelEvalFunc)function_uni_op},
3140 {{GO_BOOL,0,0},(GelEvalFunc)boolean_neg},
3141 }},
3142 /*GEL_E_EXP*/
3143 {{
3144 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_pow},
3145 {{GO_MATRIX,GO_VALUE,0},(GelEvalFunc)matrix_pow_op},
3146 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3147 (GelEvalFunc)function_bin_op},
3148 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3149 (GelEvalFunc)function_something_bin_op},
3150 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3151 (GelEvalFunc)something_function_bin_op},
3152 }},
3153 /*GEL_E_ELTEXP*/
3154 {{
3155 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)numerical_pow},
3156 {{GO_MATRIX,GO_MATRIX,0},(GelEvalFunc)pure_matrix_eltbyelt_op},
3157 {{GO_VALUE|GO_MATRIX,GO_VALUE|GO_MATRIX,0},
3158 (GelEvalFunc)matrix_scalar_matrix_op},
3159 {{GO_FUNCTION|GO_IDENTIFIER,GO_FUNCTION|GO_IDENTIFIER,0},
3160 (GelEvalFunc)function_bin_op},
3161 {{GO_FUNCTION|GO_IDENTIFIER,GO_VALUE|GO_MATRIX,0},
3162 (GelEvalFunc)function_something_bin_op},
3163 {{GO_VALUE|GO_MATRIX,GO_FUNCTION|GO_IDENTIFIER,0},
3164 (GelEvalFunc)something_function_bin_op},
3165 }},
3166 /*GEL_E_FACT*/
3167 {{
3168 {{GO_VALUE,0,0},(GelEvalFunc)numerical_fac},
3169 {{GO_MATRIX,0,0},(GelEvalFunc)matrix_absnegfac_op},
3170 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
3171 (GelEvalFunc)function_uni_op},
3172 }},
3173 /*GEL_E_DBLFACT*/
3174 {{
3175 {{GO_VALUE,0,0},(GelEvalFunc)numerical_dblfac},
3176 {{GO_MATRIX,0,0},(GelEvalFunc)matrix_absnegfac_op},
3177 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
3178 (GelEvalFunc)function_uni_op},
3179 }},
3180 /*GEL_E_TRANSPOSE*/
3181 {{
3182 {{GO_MATRIX,0,0},(GelEvalFunc)transpose_matrix},
3183 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
3184 (GelEvalFunc)function_uni_op},
3185 }},
3186 /*GEL_E_CONJUGATE_TRANSPOSE*/
3187 {{
3188 {{GO_MATRIX,0,0},(GelEvalFunc)conjugate_transpose_matrix},
3189 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
3190 (GelEvalFunc)function_uni_op},
3191 }},
3192 /*GEL_E_IF_CONS*/ EMPTY_PRIM,
3193 /*GEL_E_IFELSE_CONS*/ EMPTY_PRIM,
3194 /*GEL_E_WHILE_CONS*/ EMPTY_PRIM,
3195 /*GEL_E_UNTIL_CONS*/ EMPTY_PRIM,
3196 /*GEL_E_DOWHILE_CONS*/ EMPTY_PRIM,
3197 /*GEL_E_DOUNTIL_CONS*/ EMPTY_PRIM,
3198 /*GEL_E_FOR_CONS*/ EMPTY_PRIM,
3199 /*GEL_E_FORBY_CONS*/ EMPTY_PRIM,
3200 /*GEL_E_FORIN_CONS*/ EMPTY_PRIM,
3201 /*GEL_E_SUM_CONS*/ EMPTY_PRIM,
3202 /*GEL_E_SUMBY_CONS*/ EMPTY_PRIM,
3203 /*GEL_E_SUMIN_CONS*/ EMPTY_PRIM,
3204 /*GEL_E_PROD_CONS*/ EMPTY_PRIM,
3205 /*GEL_E_PRODBY_CONS*/ EMPTY_PRIM,
3206 /*GEL_E_PRODIN_CONS*/ EMPTY_PRIM,
3207 /*GEL_E_EQ_CMP*/ EMPTY_PRIM,
3208 /*GEL_E_NE_CMP*/ EMPTY_PRIM,
3209 /*GEL_E_CMP_CMP*/
3210 {{
3211 {{GO_VALUE,GO_VALUE,0},(GelEvalFunc)cmpcmpop},
3212 {{GO_VALUE|GO_MATRIX|GO_FUNCTION|GO_STRING,GO_STRING,0},
3213 (GelEvalFunc)cmpstringop},
3214 {{GO_STRING,GO_VALUE|GO_MATRIX|GO_FUNCTION|GO_STRING,0},
3215 (GelEvalFunc)cmpstringop},
3216 }},
3217 /*GEL_E_LT_CMP*/ EMPTY_PRIM,
3218 /*GEL_E_GT_CMP*/ EMPTY_PRIM,
3219 /*GEL_E_LE_CMP*/ EMPTY_PRIM,
3220 /*GEL_E_GE_CMP*/ EMPTY_PRIM,
3221 /*GEL_E_LOGICAL_AND*/ EMPTY_PRIM,
3222 /*GEL_E_LOGICAL_OR*/ EMPTY_PRIM,
3223 /*GEL_E_LOGICAL_XOR*/
3224 {{
3225 {{GO_VALUE|GO_STRING|GO_BOOL,GO_VALUE|GO_STRING|GO_BOOL,0},
3226 (GelEvalFunc)logicalxorop},
3227 }},
3228 /*GEL_E_LOGICAL_NOT*/
3229 {{
3230 {{GO_VALUE|GO_STRING|GO_BOOL,0,0},(GelEvalFunc)logicalnotop},
3231 {{GO_FUNCTION|GO_IDENTIFIER,0,0},
3232 (GelEvalFunc)function_uni_op},
3233 }},
3234 /*GEL_E_REGION_SEP*/ EMPTY_PRIM,
3235 /*GEL_E_REGION_SEP_BY*/ EMPTY_PRIM,
3236 /*GEL_E_GET_VELEMENT*/ EMPTY_PRIM,
3237 /*GEL_E_GET_ELEMENT*/ EMPTY_PRIM,
3238 /*GEL_E_GET_ROW_REGION*/ EMPTY_PRIM,
3239 /*GEL_E_GET_COL_REGION*/ EMPTY_PRIM,
3240 /*GEL_E_QUOTE*/ EMPTY_PRIM,
3241 /*GEL_E_REFERENCE*/ EMPTY_PRIM,
3242 /*GEL_E_DEREFERENCE*/ EMPTY_PRIM,
3243 /*GEL_E_DIRECTCALL*/ EMPTY_PRIM,
3244 /*GEL_E_CALL*/ EMPTY_PRIM,
3245 /*GEL_E_RETURN*/ EMPTY_PRIM,
3246 /*GEL_E_BAILOUT*/ EMPTY_PRIM,
3247 /*GEL_E_EXCEPTION*/ EMPTY_PRIM,
3248 /*GEL_E_CONTINUE*/ EMPTY_PRIM,
3249 /*GEL_E_BREAK*/ EMPTY_PRIM,
3250 /*GEL_E_MOD_CALC*/ EMPTY_PRIM,
3251 /*GEL_E_DEFEQUALS*/ EMPTY_PRIM,
3252 /*GEL_E_SWAPWITH*/ EMPTY_PRIM,
3253 /*GEL_E_INCREMENT*/ EMPTY_PRIM,
3254 /*GEL_E_INCREMENT_BY*/ EMPTY_PRIM,
3255 /*GEL_E_OPER_LAST*/
3256 };
3257
3258 #undef EMPTY_PRIM
3259
3260
3261 /*pure free lists*/
3262 static void
purge_free_lists(void)3263 purge_free_lists(void)
3264 {
3265 while(free_stack) {
3266 GelEvalStack *evs = free_stack;
3267 free_stack = free_stack->next;
3268 g_free(evs);
3269 }
3270 /* FIXME: we should have some sort of compression stuff, but
3271 we allocate these in chunks, so normally we can never free
3272 them again. We could use the type field to mark things
3273 and then do some compression. */
3274 #if 0
3275 while(free_evl) {
3276 GelEvalLoop *evl = free_evl;
3277 free_evl = (GelEvalLoop *)free_evl->condition;
3278 g_free(evl);
3279 }
3280 while(free_evf) {
3281 GelEvalFor *evf = free_evf;
3282 free_evf = (GelEvalFor *)free_evf->body;
3283 g_free(evf);
3284 }
3285 while(free_evfi) {
3286 GelEvalForIn *evfi = free_evfi;
3287 free_evfi = (GelEvalForIn *)free_evfi->body;
3288 g_free(evfi);
3289 }
3290 while(gel_free_trees) {
3291 GelETree *et = gel_free_trees;
3292 gel_free_trees = gel_free_trees->any.next;
3293 g_free(et);
3294 }
3295 #endif
3296 }
3297
3298 static GelEvalLoop *
evl_new(GelETree * cond,GelETree * body,gboolean is_while,gboolean body_first)3299 evl_new (GelETree *cond, GelETree *body, gboolean is_while, gboolean body_first)
3300 {
3301 GelEvalLoop *evl;
3302 #ifdef MEM_DEBUG_FRIENDLY
3303 evl = g_new0 (GelEvalLoop, 1);
3304 #else
3305 if G_UNLIKELY (free_evl == NULL)
3306 _gel_make_free_evl ();
3307 evl = free_evl;
3308 free_evl = (GelEvalLoop *)free_evl->condition;
3309 #endif
3310 evl->condition = cond;
3311 evl->body = body;
3312 evl->is_while = is_while ? 1 : 0;
3313 evl->body_first = body_first ? 1 : 0;
3314 return evl;
3315 }
3316
3317 static void
evl_free(GelEvalLoop * evl)3318 evl_free(GelEvalLoop *evl)
3319 {
3320 #ifdef MEM_DEBUG_FRIENDLY
3321 memset (evl, 0xaa, sizeof (GelEvalLoop));
3322 # ifndef MEM_DEBUG_SUPER_FRIENDLY
3323 g_free (evl);
3324 # endif
3325 #else
3326 evl->condition = (gpointer)free_evl;
3327 free_evl = evl;
3328 #endif
3329 }
3330
3331 static void
evl_free_with_cond(GelEvalLoop * evl)3332 evl_free_with_cond(GelEvalLoop *evl)
3333 {
3334 gel_freetree(evl->condition);
3335 evl_free (evl);
3336 }
3337
3338 static GelEvalFor *
evf_new(GelEvalForType type,mpw_ptr x,mpw_ptr to,mpw_ptr by,gint8 init_cmp,GelETree * body,GelETree * orig_body,GelToken * id)3339 evf_new (GelEvalForType type,
3340 mpw_ptr x,
3341 mpw_ptr to,
3342 mpw_ptr by,
3343 gint8 init_cmp,
3344 GelETree *body,
3345 GelETree *orig_body,
3346 GelToken *id)
3347 {
3348 GelEvalFor *evf;
3349 #ifdef MEM_DEBUG_FRIENDLY
3350 evf = g_new0 (GelEvalFor, 1);
3351 #else
3352 if G_UNLIKELY (free_evf == NULL)
3353 _gel_make_free_evf ();
3354 evf = free_evf;
3355 free_evf = (GelEvalFor *)free_evf->body;
3356 #endif
3357 evf->type = type;
3358 evf->x = x;
3359 evf->to = to;
3360 evf->by = by;
3361 evf->init_cmp = init_cmp;
3362 evf->result = NULL;
3363 evf->body = body;
3364 evf->orig_body = orig_body;
3365 evf->id = id;
3366 return evf;
3367 }
3368
3369 static void
evf_free(GelEvalFor * evf)3370 evf_free(GelEvalFor *evf)
3371 {
3372 #ifdef MEM_DEBUG_FRIENDLY
3373 memset (evf, 0xaa, sizeof (GelEvalFor));
3374 # ifndef MEM_DEBUG_SUPER_FRIENDLY
3375 g_free (evf);
3376 # endif
3377 #else
3378 evf->body = (gpointer)free_evf;
3379 free_evf = evf;
3380 #endif
3381 }
3382
3383 static GelEvalForIn *
evfi_new(GelEvalForType type,GelMatrixW * mat,GelETree * body,GelETree * orig_body,GelToken * id)3384 evfi_new (GelEvalForType type, GelMatrixW *mat, GelETree *body, GelETree *orig_body, GelToken *id)
3385 {
3386 GelEvalForIn *evfi;
3387 #ifdef MEM_DEBUG_FRIENDLY
3388 evfi = g_new0 (GelEvalForIn, 1);
3389 #else
3390 if G_UNLIKELY (free_evfi == NULL)
3391 _gel_make_free_evfi ();
3392 evfi = free_evfi;
3393 free_evfi = (GelEvalForIn *)free_evfi->body;
3394 #endif
3395 evfi->type = type;
3396 evfi->i = evfi->j = 0;
3397 evfi->mat = mat;
3398 evfi->result = NULL;
3399 evfi->body = body;
3400 evfi->orig_body = orig_body;
3401 evfi->id = id;
3402 return evfi;
3403 }
3404
3405 static void
evfi_free(GelEvalForIn * evfi)3406 evfi_free(GelEvalForIn *evfi)
3407 {
3408 #ifdef MEM_DEBUG_FRIENDLY
3409 memset (evfi, 0xaa, sizeof (GelEvalForIn));
3410 # ifndef MEM_DEBUG_SUPER_FRIENDLY
3411 g_free (evfi);
3412 # endif
3413 #else
3414 evfi->body = (gpointer)free_evfi;
3415 free_evfi = evfi;
3416 #endif
3417 }
3418
3419 static gboolean
iter_do_var(GelCtx * ctx,GelETree * n,GelEFunc * f)3420 iter_do_var(GelCtx *ctx, GelETree *n, GelEFunc *f)
3421 {
3422 if(f->type == GEL_VARIABLE_FUNC) {
3423 D_ENSURE_USER_BODY (f);
3424 copyreplacenode(n,f->data.user);
3425 } else if(f->type == GEL_USER_FUNC) {
3426 D_ENSURE_USER_BODY (f);
3427 freetree_full(n,TRUE,FALSE);
3428
3429 n->type = GEL_FUNCTION_NODE;
3430 /* FIXME: are we ok with passing the token as well? */
3431 n->func.func = d_copyfunc (f);
3432 /* The function can no longer be local */
3433 n->func.func->is_local = 0;
3434 if ( ! f->on_subst_list)
3435 n->func.func->context = -1;
3436 } else if(f->type == GEL_BUILTIN_FUNC) {
3437 GelETree *ret;
3438 gboolean exception = FALSE;
3439
3440 if(f->nargs != 0) {
3441 freetree_full(n,TRUE,FALSE);
3442 n->type = GEL_FUNCTION_NODE;
3443 /* FIXME: are we ok with passing the token (f->id) as well? */
3444 n->func.func = d_makerealfunc(f,f->id,FALSE);
3445 if ( ! n->func.func->on_subst_list)
3446 n->func.func->context = -1;
3447 /* FIXME: no need for extra_dict right? */
3448 return TRUE;
3449 }
3450 ret = (*f->data.func)(ctx,NULL,&exception);
3451 /* interruption happened during the function, which
3452 means an exception */
3453 if G_UNLIKELY (gel_interrupted) {
3454 exception = TRUE;
3455 }
3456 if G_UNLIKELY (exception) {
3457 if(ret)
3458 gel_freetree(ret);
3459 return FALSE;
3460 } else if G_LIKELY (ret) {
3461 replacenode(n,ret);
3462 }
3463 } else if(f->type == GEL_REFERENCE_FUNC) {
3464 GelETree *i;
3465 f = f->data.ref;
3466
3467 GEL_GET_NEW_NODE(i);
3468 i->type = GEL_IDENTIFIER_NODE;
3469 i->id.uninitialized = FALSE;
3470 if(f->id) {
3471 i->id.id = f->id;
3472 } else {
3473 /*make up a new fake id*/
3474 GelToken *tok = g_new0(GelToken,1);
3475 tok->refs = g_slist_append(NULL,f);
3476 i->id.id = tok;
3477 }
3478 i->any.next = NULL;
3479
3480 freetree_full(n,TRUE,FALSE);
3481 n->type = GEL_OPERATOR_NODE;
3482 n->op.oper = GEL_E_REFERENCE;
3483
3484 n->op.args = i;
3485 n->op.nargs = 1;
3486 } else
3487 gel_errorout (_("Unevaluatable function type encountered!"));
3488 return TRUE;
3489 }
3490
3491 char *
gel_similar_possible_ids(const char * id)3492 gel_similar_possible_ids (const char *id)
3493 {
3494 GSList *similar, *li;
3495 GString *sim;
3496
3497 similar = d_find_similar_globals (id);
3498
3499 if (similar == NULL)
3500 return NULL;
3501
3502 sim = g_string_new ("'");
3503
3504 for (li = similar; li != NULL; li = li->next) {
3505 const char *lid = li->data;
3506
3507 if (li->next == NULL &&
3508 li != similar) {
3509 g_string_append (sim, "' ");
3510 g_string_append (sim, _("or"));
3511 g_string_append (sim, " '");
3512 } else if (li != similar) {
3513 g_string_append (sim, "', '");
3514 }
3515
3516 g_string_append (sim, lid);
3517
3518 li->data = NULL; /* paranoia */
3519 }
3520 g_slist_free (similar);
3521
3522 g_string_append (sim, "'");
3523
3524 return g_string_free (sim, FALSE);
3525 }
3526
3527 static gboolean
iter_variableop(GelCtx * ctx,GelETree * n)3528 iter_variableop(GelCtx *ctx, GelETree *n)
3529 {
3530 GelEFunc *f;
3531
3532 if (n->id.id->built_in_parameter) {
3533 GelETree *r = NULL;
3534 ParameterGetFunc getfunc = n->id.id->data2;
3535 if (getfunc != NULL)
3536 r = getfunc ();
3537 else
3538 r = gel_makenum_null ();
3539 replacenode (n, r);
3540 return TRUE;
3541 }
3542
3543 f = d_lookup_global(n->id.id);
3544 if G_UNLIKELY (f == NULL) {
3545 char *similar;
3546 if ( ! n->id.uninitialized) {
3547 if (strcmp (n->id.id->token, "i") == 0) {
3548 gel_errorout (_("Variable 'i' used uninitialized. "
3549 "Perhaps you meant to write '1i' for "
3550 "the imaginary number (square root of "
3551 "-1)."));
3552 } else if ((similar = gel_similar_possible_ids (n->id.id->token))
3553 != NULL) {
3554 gel_errorout (_("Variable '%s' used uninitialized, "
3555 "perhaps you meant %s."),
3556 n->id.id->token,
3557 similar);
3558
3559 g_free (similar);
3560 } else {
3561 gel_errorout (_("Variable '%s' used uninitialized"),
3562 n->id.id->token);
3563 }
3564 }
3565 /* save that we have determined that this was
3566 * uninitialized */
3567 n->id.uninitialized = TRUE;
3568 return TRUE;
3569 } else {
3570 return iter_do_var(ctx,n,f);
3571 }
3572 }
3573
3574 static gboolean
iter_derefvarop(GelCtx * ctx,GelETree * n)3575 iter_derefvarop(GelCtx *ctx, GelETree *n)
3576 {
3577 GelEFunc *f;
3578 GelETree *l;
3579
3580 GEL_GET_L(n,l);
3581
3582 f = d_lookup_global(l->id.id);
3583 if G_UNLIKELY (f == NULL) {
3584 char *similar = gel_similar_possible_ids (l->id.id->token);
3585 if ( ! l->id.uninitialized) {
3586 if (similar != NULL) {
3587 gel_errorout (_("Variable '%s' used uninitialized, "
3588 "perhaps you meant %s."),
3589 l->id.id->token,
3590 similar);
3591
3592 g_free (similar);
3593 } else {
3594 gel_errorout (_("Variable '%s' used uninitialized"),
3595 l->id.id->token);
3596 }
3597 }
3598 /* save that we have determined that this was
3599 * uninitialized */
3600 l->id.uninitialized = TRUE;
3601 } else if G_UNLIKELY (f->nargs != 0) {
3602 gel_errorout (_("Call of '%s' with the wrong number of arguments!\n"
3603 "(should be %d)"), f->id ? f->id->token : "anonymous", f->nargs);
3604 } else if G_UNLIKELY (f->type != GEL_REFERENCE_FUNC) {
3605 gel_errorout (_("Trying to dereference '%s' which is not a reference!\n"),
3606 f->id ? f->id->token : "anonymous");
3607 } else /*if(f->type == GEL_REFERENCE_FUNC)*/ {
3608 f = f->data.ref;
3609 if G_UNLIKELY (f == NULL)
3610 gel_errorout (_("NULL reference encountered!"));
3611 else
3612 return iter_do_var(ctx,n,f);
3613 }
3614 return TRUE;
3615 }
3616
3617 #define RET_RES(x) \
3618 freetree_full(n,TRUE,FALSE); \
3619 gel_makenum_bool_from(n,x); \
3620 return;
3621
3622 /*returns 0 if all numeric (or bool if bool_ok), 1 if numeric/matrix/null, 2 if contains string, 3 otherwise*/
3623 static int arglevel (GelETree *r, int cnt, gboolean bool_ok) G_GNUC_PURE;
3624 static int
arglevel(GelETree * r,int cnt,gboolean bool_ok)3625 arglevel (GelETree *r, int cnt, gboolean bool_ok)
3626 {
3627 int i;
3628 int level = 0;
3629 for(i=0;i<cnt;i++,r = r->any.next) {
3630 if (r->type == GEL_VALUE_NODE)
3631 continue;
3632 else if (bool_ok && r->type == GEL_BOOL_NODE)
3633 continue;
3634 else if (r->type == GEL_MATRIX_NODE ||
3635 r->type == GEL_NULL_NODE)
3636 level = level < 1 ? 1 : level;
3637 else if (r->type == GEL_STRING_NODE)
3638 level = 2;
3639 else
3640 return 3;
3641 }
3642 return level;
3643 }
3644
3645 static void
evalcomp(GelETree * n)3646 evalcomp(GelETree *n)
3647 {
3648 GSList *oli;
3649 GelETree *ali;
3650
3651 for(ali=n->comp.args,oli=n->comp.comp;oli;ali=ali->any.next,oli=oli->next) {
3652 int oper = GPOINTER_TO_INT(oli->data);
3653 gboolean err = FALSE;
3654 GelETree *l = ali,*r = ali->any.next;
3655 gboolean bool_ok = (oper == GEL_E_EQ_CMP ||
3656 oper == GEL_E_NE_CMP);
3657
3658 switch (arglevel (ali,
3659 2,
3660 bool_ok)) {
3661 case 0:
3662 switch(oper) {
3663 case GEL_E_EQ_CMP:
3664 if ( ! eqlnodes (l, r)) {
3665 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
3666 gel_error_num = GEL_NO_ERROR;
3667 return;
3668 }
3669 RET_RES(0)
3670 }
3671 break;
3672 case GEL_E_NE_CMP:
3673 if (eqlnodes (l, r)) {
3674 RET_RES(0)
3675 } else if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
3676 gel_error_num = GEL_NO_ERROR;
3677 return;
3678 }
3679 break;
3680 case GEL_E_LT_CMP:
3681 if(cmpnodes(l,r)>=0) {
3682 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
3683 gel_error_num = GEL_NO_ERROR;
3684 return;
3685 }
3686 RET_RES(0)
3687 }
3688 break;
3689 case GEL_E_GT_CMP:
3690 if(cmpnodes(l,r)<=0) {
3691 if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
3692 gel_error_num = GEL_NO_ERROR;
3693 return;
3694 }
3695 RET_RES(0)
3696 }
3697 break;
3698 case GEL_E_LE_CMP:
3699 if(cmpnodes(l,r)>0) {
3700 RET_RES(0)
3701 } else if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
3702 gel_error_num = GEL_NO_ERROR;
3703 return;
3704 }
3705 break;
3706 case GEL_E_GE_CMP:
3707 if(cmpnodes(l,r)<0) {
3708 RET_RES(0)
3709 } else if G_UNLIKELY (gel_error_num != GEL_NO_ERROR) {
3710 gel_error_num = GEL_NO_ERROR;
3711 return;
3712 }
3713 break;
3714 default:
3715 g_assert_not_reached();
3716 }
3717 break;
3718 case 1:
3719 switch(oper) {
3720 case GEL_E_EQ_CMP:
3721 if(!eqmatrix(l,r,&err)) {
3722 if G_UNLIKELY (err) {
3723 gel_error_num = GEL_NO_ERROR;
3724 return;
3725 }
3726 RET_RES(0)
3727 }
3728 break;
3729 case GEL_E_NE_CMP:
3730 if(eqmatrix(l,r,&err)) {
3731 RET_RES(0)
3732 } else if G_UNLIKELY (err) {
3733 gel_error_num = GEL_NO_ERROR;
3734 return;
3735 }
3736 break;
3737 default:
3738 gel_errorout (_("Cannot compare matrices"));
3739 gel_error_num = GEL_NO_ERROR;
3740 return;
3741 }
3742 break;
3743 case 2:
3744 switch(oper) {
3745 case GEL_E_EQ_CMP:
3746 if(!eqstring(l,r)) {
3747 RET_RES(0)
3748 }
3749 break;
3750 case GEL_E_NE_CMP:
3751 if(eqstring(l,r)) {
3752 RET_RES(0)
3753 }
3754 break;
3755 case GEL_E_LT_CMP:
3756 if(cmpstring(l,r)>=0) {
3757 RET_RES(0)
3758 }
3759 break;
3760 case GEL_E_GT_CMP:
3761 if(cmpstring(l,r)<=0) {
3762 RET_RES(0)
3763 }
3764 break;
3765 case GEL_E_LE_CMP:
3766 if(cmpstring(l,r)>0) {
3767 RET_RES(0)
3768 }
3769 break;
3770 case GEL_E_GE_CMP:
3771 if(cmpstring(l,r)<0) {
3772 RET_RES(0)
3773 }
3774 break;
3775 default:
3776 g_assert_not_reached();
3777 }
3778 break;
3779 default:
3780 gel_errorout (_("Primitives must get numeric/matrix/string arguments"));
3781 gel_error_num = GEL_NO_ERROR;
3782 return;
3783 }
3784 }
3785 RET_RES(1)
3786 }
3787
3788 #undef RET_RES
3789
3790 static void
pop_stack_with_whack(GelCtx * ctx)3791 pop_stack_with_whack (GelCtx *ctx)
3792 {
3793 gpointer data;
3794 int flag;
3795
3796 GE_POP_STACK (ctx, data, flag);
3797 if (flag == (GE_POST | GE_WHACKARG) ||
3798 flag == (GE_PRE | GE_WHACKARG)) {
3799 gel_freetree (data);
3800 }
3801 }
3802
3803
3804 /* free a special stack entry */
3805 static void
ev_free_special_data(GelCtx * ctx,gpointer data,int flag)3806 ev_free_special_data(GelCtx *ctx, gpointer data, int flag)
3807 {
3808 switch(flag) {
3809 case (GE_POST | GE_WHACKARG):
3810 case (GE_PRE | GE_WHACKARG):
3811 /* WHACKWHACK */
3812 gel_freetree (data);
3813 break;
3814 case GE_FUNCCALL:
3815 /*we are crossing a boundary, we need to free a context*/
3816 d_popcontext ();
3817 gel_freetree (data);
3818 pop_stack_with_whack (ctx);
3819 break;
3820 case GE_LOOP_COND:
3821 case GE_LOOP_LOOP:
3822 {
3823 GelEvalLoop *evl = data;
3824 gel_freetree (evl->condition);
3825 gel_freetree (evl->body);
3826 evl_free (evl);
3827 pop_stack_with_whack (ctx);
3828 }
3829 break;
3830 case GE_FOR:
3831 {
3832 GelEvalFor *evf = data;
3833 gel_freetree(evf->body);
3834 gel_freetree(evf->result);
3835 evf_free(evf);
3836 pop_stack_with_whack (ctx);
3837 }
3838 break;
3839 case GE_FORIN:
3840 {
3841 GelEvalForIn *evfi = data;
3842 gel_freetree(evfi->body);
3843 gel_freetree(evfi->result);
3844 evfi_free(evfi);
3845 pop_stack_with_whack (ctx);
3846 }
3847 break;
3848 case GE_SETMODULO:
3849 if (ctx->modulo != NULL) {
3850 mpw_clear (ctx->modulo);
3851 g_free (ctx->modulo);
3852 }
3853 ctx->modulo = data;
3854 break;
3855 default:
3856 break;
3857 }
3858 }
3859
3860 static gboolean
push_setmod(GelCtx * ctx,GelETree * n,gboolean whackarg)3861 push_setmod (GelCtx *ctx, GelETree *n, gboolean whackarg)
3862 {
3863 GelETree *l, *r;
3864
3865 GEL_GET_LR (n, l, r);
3866
3867 if G_UNLIKELY (r->type != GEL_VALUE_NODE ||
3868 mpw_is_complex (r->val.value) ||
3869 ! mpw_is_integer (r->val.value) ||
3870 mpw_sgn (r->val.value) <= 0) {
3871 gel_errorout (_("Bad argument to modular operation"));
3872 return FALSE;
3873 }
3874
3875 GE_PUSH_STACK (ctx, n, GE_ADDWHACKARG (GE_POST, whackarg));
3876 GE_PUSH_STACK (ctx, ctx->modulo, GE_SETMODULO);
3877
3878 ctx->modulo = g_new (struct _mpw_t, 1);
3879 mpw_init_set_no_uncomplex (ctx->modulo, r->val.value);
3880
3881 ctx->post = FALSE;
3882 ctx->current = l;
3883 ctx->whackarg = FALSE;
3884
3885 return TRUE;
3886 }
3887
3888 static void
iter_pop_stack(GelCtx * ctx)3889 iter_pop_stack(GelCtx *ctx)
3890 {
3891 gpointer data;
3892 int flag;
3893 EDEBUG("---- iter_pop_stack ----");
3894
3895 #ifdef MEM_DEBUG_FRIENDLY
3896 ctx->current = NULL;
3897 ctx->post = FALSE;
3898 ctx->whackarg = FALSE;
3899 #endif
3900
3901 for(;;) {
3902 GE_POP_STACK(ctx,data,flag);
3903 #ifdef EVAL_DEBUG
3904 printf (" ---- stack pop %p %d ----", data, flag);
3905 #endif
3906 switch(flag & GE_MASK) {
3907 case GE_EMPTY_STACK:
3908 EDEBUG(" POPPED AN EMPTY STACK");
3909 ctx->current = NULL;
3910 ctx->whackarg = FALSE;
3911 return;
3912 case GE_PRE:
3913 ctx->post = FALSE;
3914 ctx->current = data;
3915 ctx->whackarg = (flag & GE_WHACKARG);
3916 #ifdef EVAL_DEBUG
3917 printf(" POPPED A PRE NODE(%d) whack %d\n",
3918 ctx->current->type, ctx->whackarg);
3919 #endif
3920 return;
3921 case GE_POST:
3922 ctx->post = TRUE;
3923 ctx->current = data;
3924 ctx->whackarg = (flag & GE_WHACKARG);
3925 #ifdef EVAL_DEBUG
3926 printf(" POPPED A POST NODE(%d) whack %d\n",
3927 ctx->current->type, ctx->whackarg);
3928 #endif
3929 return;
3930 case GE_AND:
3931 case GE_OR:
3932 {
3933 GelETree *li = data;
3934 gboolean ret;
3935 gboolean bad_node = FALSE;
3936 EDEBUG(" POPPED AN OR or AND");
3937 ret = gel_isnodetrue(li,&bad_node);
3938 if G_UNLIKELY (bad_node || gel_error_num) {
3939 int n_flag;
3940 EDEBUG(" AND/OR BAD BAD NODE");
3941 gel_error_num = GEL_NO_ERROR;
3942
3943 GE_POP_STACK (ctx, data, n_flag);
3944 if (n_flag & GE_WHACKARG) {
3945 gel_freetree (data);
3946 }
3947 break;
3948 }
3949 if((flag==GE_AND && !ret) ||
3950 (flag==GE_OR && ret)) {
3951 int n_flag;
3952 GE_POP_STACK(ctx,data,n_flag);
3953 g_assert((n_flag & GE_MASK) == GE_POST);
3954 if (n_flag & GE_WHACKARG) {
3955 gel_freetree (data);
3956 } else {
3957 freetree_full (data, TRUE, FALSE);
3958 if(flag==GE_AND)
3959 gel_makenum_bool_from(data,0);
3960 else
3961 gel_makenum_bool_from(data,1);
3962 }
3963 EDEBUG(" AND/OR EARLY DONE");
3964 break;
3965 }
3966 li = li->any.next;
3967 if(!li) {
3968 int n_flag;
3969 GE_POP_STACK(ctx,data,n_flag);
3970 g_assert((n_flag & GE_MASK) == GE_POST);
3971 if (n_flag & GE_WHACKARG) {
3972 gel_freetree (data);
3973 } else {
3974 freetree_full (data, TRUE, FALSE);
3975 if(flag==GE_AND)
3976 gel_makenum_bool_from(data,1);
3977 else
3978 gel_makenum_bool_from(data,0);
3979 }
3980 EDEBUG(" AND/OR ALL THE WAY DONE");
3981 break;
3982 }
3983 GE_PUSH_STACK(ctx,li,flag);
3984 ctx->post = FALSE;
3985 ctx->current = li;
3986 ctx->whackarg = FALSE;
3987 EDEBUG(" JUST PUT THE NEXT ONE");
3988 return;
3989 }
3990 case GE_FUNCCALL:
3991 {
3992 gpointer call;
3993
3994 /*pop the context*/
3995 d_popcontext ();
3996
3997 GE_POP_STACK(ctx,call,flag);
3998
3999 /*replace the call with the result of
4000 the function*/
4001 g_assert (call != NULL);
4002 if (flag & GE_WHACKARG) {
4003 /* WHACKWHACK */
4004 gel_freetree (call);
4005 gel_freetree (data);
4006 } else {
4007 if (ctx->modulo != NULL)
4008 mod_node (data, ctx->modulo);
4009 replacenode(call,data);
4010 }
4011 }
4012 break;
4013 case GE_LOOP_COND:
4014 /*this was the condition of a while or until loop*/
4015 {
4016 GelEvalLoop *evl = data;
4017 GelETree *n;
4018 gboolean ret, bad_node = FALSE;
4019 int n_flag;
4020 g_assert(evl->condition);
4021
4022 /*next MUST be the original node*/
4023 GE_PEEK_STACK(ctx,n,n_flag);
4024 g_assert ((n_flag & GE_MASK) == GE_POST);
4025
4026 EDEBUG(" LOOP CONDITION CHECK");
4027 ret = gel_isnodetrue(evl->condition,&bad_node);
4028 if G_UNLIKELY (bad_node || gel_error_num) {
4029 EDEBUG(" LOOP CONDITION BAD BAD NODE");
4030 gel_error_num = GEL_NO_ERROR;
4031 replacenode (n->op.args, evl->condition);
4032 gel_freetree (evl->body);
4033 evl_free (evl);
4034 GE_BLIND_POP_STACK(ctx);
4035 if (n_flag & GE_WHACKARG) {
4036 /* WHACKWHACK */
4037 gel_freetree (n);
4038 }
4039 break;
4040 }
4041 /*check if we should continue the loop*/
4042 if((evl->is_while && ret) ||
4043 (!evl->is_while && !ret)) {
4044 GelETree *l,*r;
4045 EDEBUG(" LOOP CONDITION MET");
4046 GEL_GET_LR(n,l,r);
4047 gel_freetree (evl->condition);
4048 evl->condition = NULL;
4049 gel_freetree (evl->body);
4050 if (evl->body_first)
4051 evl->body = gel_copynode (l);
4052 else
4053 evl->body = gel_copynode (r);
4054 ctx->current = evl->body;
4055 ctx->post = FALSE;
4056 ctx->whackarg = FALSE;
4057 GE_PUSH_STACK(ctx,evl,GE_LOOP_LOOP);
4058 return;
4059 } else {
4060 GelETree *b;
4061 EDEBUG(" LOOP CONDITION NOT MET");
4062 /*condition not met, so return the body*/
4063 gel_freetree (evl->condition);
4064 b = evl->body;
4065 evl_free (evl);
4066 GE_BLIND_POP_STACK (ctx);
4067 if (n_flag & GE_WHACKARG) {
4068 /* WHACKWHACK */
4069 gel_freetree (n);
4070 gel_freetree (b);
4071 } else if (b == NULL) {
4072 EDEBUG(" NULL BODY");
4073 freetree_full (n, TRUE, FALSE);
4074 n->type = GEL_NULL_NODE;
4075 } else {
4076 replacenode (n, b);
4077 }
4078 break;
4079 }
4080 }
4081 case GE_LOOP_LOOP:
4082 {
4083 GelEvalLoop *evl = data;
4084 GelETree *n,*l,*r;
4085 int n_flag;
4086 g_assert(evl->body);
4087
4088 /*next MUST be the original node*/
4089 GE_PEEK_STACK(ctx,n,n_flag);
4090 g_assert ((n_flag & GE_MASK) == GE_POST);
4091
4092 EDEBUG(" LOOP LOOP BODY FINISHED");
4093
4094 GEL_GET_LR(n,l,r);
4095 gel_freetree (evl->condition);
4096 if (evl->body_first)
4097 evl->condition = gel_copynode (r);
4098 else
4099 evl->condition = gel_copynode (l);
4100 ctx->current = evl->condition;
4101 ctx->post = FALSE;
4102 ctx->whackarg = FALSE;
4103 GE_PUSH_STACK(ctx,evl,GE_LOOP_COND);
4104 return;
4105 }
4106 case GE_FOR:
4107 {
4108 GelEvalFor *evf = data;
4109 gboolean done = FALSE;
4110 if (evf->by)
4111 mpw_add (evf->x, evf->x, evf->by);
4112 else
4113 mpw_add_ui (evf->x, evf->x, 1);
4114 /* we know we aren't dealing with complexes */
4115 if (mpw_is_real_part_float (evf->x)) {
4116 if (mpw_cmp (evf->x, evf->to) == -evf->init_cmp) {
4117 /* maybe we just missed it, let's look back within 2^-20 of the by and see */
4118 mpw_t tmp;
4119 if (evf->by != NULL) {
4120 mpfr_ptr f;
4121 /* by is definitely mpfr */
4122 mpw_init_set (tmp, evf->by);
4123 mpw_make_copy_real (tmp);
4124 f = mpw_peek_real_mpf (tmp);
4125 mpfr_mul_2si (f, f, -20, GMP_RNDN);
4126 } else {
4127 mpw_init (tmp);
4128 mpw_set_d (tmp, 1.0/1048576.0 /* 2^-20 */);
4129 }
4130
4131 mpw_sub (tmp, evf->x, tmp);
4132
4133 done = (mpw_cmp(tmp,evf->to) == -evf->init_cmp);
4134
4135 /* don't use x, but use the to, x might be too far */
4136 if ( ! done) {
4137 mpw_set (evf->x, evf->to);
4138 }
4139
4140 mpw_clear (tmp);
4141 } else {
4142 done = FALSE;
4143 }
4144 } else {
4145 /*if done*/
4146 done = (mpw_cmp(evf->x,evf->to) == -evf->init_cmp);
4147 }
4148
4149 if (done) {
4150 GelETree *res;
4151 GE_POP_STACK(ctx,data,flag);
4152 g_assert ((flag & GE_MASK) == GE_POST);
4153 if (evf->type == GEL_EVAL_FOR) {
4154 res = evf->body;
4155 evf->body = NULL;
4156 } else if (evf->type == GEL_EVAL_SUM) {
4157 if (evf->result != NULL) {
4158 res = op_two_nodes (ctx,
4159 evf->result,
4160 evf->body,
4161 GEL_E_PLUS,
4162 TRUE /* no_push */);
4163 gel_freetree (evf->result);
4164 evf->result = NULL;
4165 } else {
4166 res = evf->body;
4167 evf->body = NULL;
4168 }
4169 gel_freetree (evf->body);
4170 evf->body = NULL;
4171 } else /* if (evf->type == GEL_EVAL_PROD) */ {
4172 if (evf->result != NULL) {
4173 res = op_two_nodes (ctx,
4174 evf->result,
4175 evf->body,
4176 GEL_E_MUL,
4177 TRUE /* no_push */);
4178 gel_freetree (evf->result);
4179 evf->result = NULL;
4180 } else {
4181 res = evf->body;
4182 evf->body = NULL;
4183 }
4184 gel_freetree (evf->body);
4185 evf->body = NULL;
4186 }
4187 if (res->type == GEL_VALUE_NODE ||
4188 res->type == GEL_NULL_NODE ||
4189 res->type == GEL_BOOL_NODE ||
4190 res->type == GEL_STRING_NODE) {
4191 if (flag & GE_WHACKARG) {
4192 /* WHACKWHACK */
4193 gel_freetree (data);
4194 gel_freetree (res);
4195 } else {
4196 replacenode (data, res);
4197 }
4198 evf_free (evf);
4199 break;
4200 } else {
4201 replacenode (data, res);
4202 ctx->current = data;
4203 ctx->post = FALSE;
4204 ctx->whackarg =
4205 (flag & GE_WHACKARG);
4206 evf_free (evf);
4207 return;
4208 }
4209 /*if we should continue*/
4210 } else {
4211 if (evf->type == GEL_EVAL_SUM) {
4212 if (evf->result != NULL) {
4213 GelETree *old = evf->result;
4214 evf->result =
4215 op_two_nodes (ctx,
4216 old,
4217 evf->body,
4218 GEL_E_PLUS,
4219 TRUE /* no_push */);
4220 gel_freetree (old);
4221 } else {
4222 evf->result = evf->body;
4223 evf->body = NULL;
4224 }
4225 } else if (evf->type == GEL_EVAL_PROD) {
4226 if (evf->result != NULL) {
4227 GelETree *old = evf->result;
4228 evf->result =
4229 op_two_nodes (ctx,
4230 old,
4231 evf->body,
4232 GEL_E_MUL,
4233 TRUE /* no_push */);
4234 gel_freetree (old);
4235 } else {
4236 evf->result = evf->body;
4237 evf->body = NULL;
4238 }
4239 }
4240 GE_PUSH_STACK (ctx, evf, GE_FOR);
4241 d_addfunc (d_makevfunc (evf->id,
4242 gel_makenum (evf->x)));
4243 if (evf->body != NULL) {
4244 gel_freetree (evf->body);
4245 }
4246 evf->body = gel_copynode (evf->orig_body);
4247 ctx->current = evf->body;
4248 ctx->post = FALSE;
4249 ctx->whackarg = FALSE;
4250 return;
4251 }
4252 }
4253 case GE_FORIN:
4254 {
4255 GelEvalForIn *evfi = data;
4256 if(evfi->mat &&
4257 (++evfi->i)>=gel_matrixw_width(evfi->mat)) {
4258 evfi->i=0;
4259 if((++evfi->j)>=gel_matrixw_height(evfi->mat))
4260 evfi->mat = NULL;
4261 }
4262 /*if we should continue*/
4263 if(evfi->mat) {
4264 if (evfi->type == GEL_EVAL_SUM) {
4265 if (evfi->result != NULL) {
4266 GelETree *old = evfi->result;
4267 evfi->result =
4268 op_two_nodes (ctx,
4269 old,
4270 evfi->body,
4271 GEL_E_PLUS,
4272 TRUE /* no_push */);
4273 gel_freetree (old);
4274 } else {
4275 evfi->result = evfi->body;
4276 evfi->body = NULL;
4277 }
4278 } else if (evfi->type == GEL_EVAL_PROD) {
4279 if (evfi->result != NULL) {
4280 GelETree *old = evfi->result;
4281 evfi->result =
4282 op_two_nodes (ctx,
4283 old,
4284 evfi->body,
4285 GEL_E_MUL,
4286 TRUE /* no_push */);
4287 gel_freetree (old);
4288 } else {
4289 evfi->result = evfi->body;
4290 evfi->body = NULL;
4291 }
4292 }
4293 GE_PUSH_STACK(ctx,evfi,GE_FORIN);
4294 d_addfunc(d_makevfunc(evfi->id,
4295 gel_copynode(gel_matrixw_index(evfi->mat,
4296 evfi->i,evfi->j))));
4297 gel_freetree(evfi->body);
4298 evfi->body = gel_copynode(evfi->orig_body);
4299 ctx->current = evfi->body;
4300 ctx->post = FALSE;
4301 ctx->whackarg = FALSE;
4302 return;
4303 /*if we are done*/
4304 } else {
4305 GelETree *res;
4306 GE_POP_STACK(ctx,data,flag);
4307 g_assert ((flag & GE_MASK) == GE_POST);
4308 if (evfi->type == GEL_EVAL_FOR) {
4309 res = evfi->body;
4310 evfi->body = NULL;
4311 } else if (evfi->type == GEL_EVAL_SUM) {
4312 if (evfi->result != NULL) {
4313 res = op_two_nodes (ctx,
4314 evfi->result,
4315 evfi->body,
4316 GEL_E_PLUS,
4317 TRUE /* no_push */);
4318 gel_freetree (evfi->result);
4319 evfi->result = NULL;
4320 } else {
4321 res = evfi->body;
4322 evfi->body = NULL;
4323 }
4324 gel_freetree (evfi->body);
4325 evfi->body = NULL;
4326 } else /* if (evfi->type == GEL_EVAL_PROD) */ {
4327 if (evfi->result != NULL) {
4328 res = op_two_nodes (ctx,
4329 evfi->result,
4330 evfi->body,
4331 GEL_E_MUL,
4332 TRUE /* no_push */);
4333 gel_freetree (evfi->result);
4334 evfi->result = NULL;
4335 } else {
4336 res = evfi->body;
4337 evfi->body = NULL;
4338 }
4339 gel_freetree (evfi->body);
4340 evfi->body = NULL;
4341 }
4342 if (res->type == GEL_VALUE_NODE ||
4343 res->type == GEL_NULL_NODE ||
4344 res->type == GEL_BOOL_NODE ||
4345 res->type == GEL_STRING_NODE) {
4346 if (flag & GE_WHACKARG) {
4347 /* WHACKWHACK */
4348 gel_freetree (data);
4349 gel_freetree (res);
4350 } else {
4351 replacenode (data, res);
4352 }
4353 evfi_free (evfi);
4354 break;
4355 } else {
4356 replacenode (data, res);
4357 ctx->current = data;
4358 ctx->post = FALSE;
4359 ctx->whackarg =
4360 (flag & GE_WHACKARG);
4361 evfi_free (evfi);
4362 return;
4363 }
4364 }
4365 }
4366 case GE_MODULOOP:
4367 if (push_setmod (ctx, data, flag & GE_WHACKARG))
4368 return;
4369 break;
4370 case GE_SETMODULO:
4371 if (ctx->modulo != NULL) {
4372 mpw_clear (ctx->modulo);
4373 g_free (ctx->modulo);
4374 }
4375 ctx->modulo = data;
4376 break;
4377 default:
4378 g_assert_not_reached();
4379 break;
4380 }
4381 }
4382 }
4383
4384 /*make first argument the "current",
4385 go into "pre" mode and push all other ones,
4386 and adds the GE_WHACKARG so that we free unused thingies
4387 earlier from separators, expects at least two arguments!!!!,
4388 else first argument will be whacked */
4389 static GelETree *
iter_push_args_whack(GelCtx * ctx,GelETree * args,int n)4390 iter_push_args_whack(GelCtx *ctx, GelETree *args, int n)
4391 {
4392 GelETree *t = args;
4393
4394 ctx->post = FALSE;
4395 ctx->current = args;
4396 ctx->whackarg = TRUE;
4397
4398 switch (n) {
4399 case 0:
4400 case 1:
4401 g_assert_not_reached ();
4402 case 2:
4403 t = args->any.next;
4404 GE_PUSH_STACK (ctx, args->any.next, GE_PRE);
4405 break;
4406 case 3:
4407 t = args->any.next->any.next;
4408 GE_PUSH_STACK (ctx, args->any.next->any.next, GE_PRE);
4409 GE_PUSH_STACK (ctx, args->any.next, GE_PRE | GE_WHACKARG);
4410 break;
4411 case 4:
4412 t = args->any.next->any.next->any.next;
4413 GE_PUSH_STACK (ctx, args->any.next->any.next->any.next, GE_PRE);
4414 GE_PUSH_STACK (ctx, args->any.next->any.next,
4415 GE_PRE | GE_WHACKARG);
4416 GE_PUSH_STACK (ctx, args->any.next, GE_PRE | GE_WHACKARG);
4417 break;
4418 case 5:
4419 t = args->any.next->any.next->any.next->any.next;
4420 GE_PUSH_STACK (ctx, args->any.next->any.next->any.next->any.next, GE_PRE);
4421 GE_PUSH_STACK (ctx, args->any.next->any.next->any.next,
4422 GE_PRE | GE_WHACKARG);
4423 GE_PUSH_STACK (ctx, args->any.next->any.next,
4424 GE_PRE | GE_WHACKARG);
4425 GE_PUSH_STACK (ctx, args->any.next, GE_PRE | GE_WHACKARG);
4426 break;
4427 default:
4428 {
4429 int i;
4430 GelETree *li;
4431 GSList *list = NULL, *sli;
4432
4433 li = args->any.next;
4434 for (i = 1; i < n; i++) {
4435 list = g_slist_prepend (list, li);
4436 li = li->any.next;
4437 }
4438
4439 #if defined __GNUC__ && 7 <= __GNUC__
4440 # pragma GCC diagnostic push
4441 # pragma GCC diagnostic ignored "-Wnull-dereference"
4442 #endif
4443 t = list->data;
4444 #if defined __GNUC__ && 7 <= __GNUC__
4445 # pragma GCC diagnostic pop
4446 #endif
4447 GE_PUSH_STACK (ctx, t, GE_PRE);
4448 #ifdef MEM_DEBUG_FRIENDLY
4449 list->data = NULL;
4450 #endif
4451
4452 for (sli = list->next; sli != NULL; sli = sli->next) {
4453 GE_PUSH_STACK (ctx, sli->data,
4454 GE_PRE | GE_WHACKARG);
4455 #ifdef MEM_DEBUG_FRIENDLY
4456 sli->data = NULL;
4457 #endif
4458 }
4459 g_slist_free (list);
4460 }
4461 break;
4462 }
4463
4464 return t;
4465 }
4466
4467 /* push n of the arguments on the stack */
4468 static void
pushstack_n_args(GelCtx * ctx,GelETree * args,int n)4469 pushstack_n_args (GelCtx *ctx, GelETree *args, int n)
4470 {
4471 switch (n) {
4472 case 0: break;
4473 case 1:
4474 GE_PUSH_STACK (ctx, args, GE_PRE);
4475 break;
4476 case 2:
4477 GE_PUSH_STACK (ctx, args->any.next, GE_PRE);
4478 GE_PUSH_STACK (ctx, args, GE_PRE);
4479 break;
4480 case 3:
4481 GE_PUSH_STACK (ctx, args->any.next->any.next, GE_PRE);
4482 GE_PUSH_STACK (ctx, args->any.next, GE_PRE);
4483 GE_PUSH_STACK (ctx, args, GE_PRE);
4484 break;
4485 case 4:
4486 GE_PUSH_STACK (ctx, args->any.next->any.next->any.next, GE_PRE);
4487 GE_PUSH_STACK (ctx, args->any.next->any.next, GE_PRE);
4488 GE_PUSH_STACK (ctx, args->any.next, GE_PRE);
4489 GE_PUSH_STACK (ctx, args, GE_PRE);
4490 break;
4491 default:
4492 {
4493 int i;
4494 GelETree *li;
4495 GSList *list = NULL, *sli;
4496
4497 li = args;
4498 for (i = 0; i < n; i++) {
4499 list = g_slist_prepend (list, li);
4500 li = li->any.next;
4501 }
4502
4503 for (sli = list; sli != NULL; sli = sli->next) {
4504 GE_PUSH_STACK (ctx, sli->data, GE_PRE);
4505 #ifdef MEM_DEBUG_FRIENDLY
4506 sli->data = NULL;
4507 #endif
4508 }
4509 g_slist_free (list);
4510 }
4511 break;
4512 }
4513 }
4514
4515
4516 /*make first argument the "current",
4517 go into "pre" mode and push all other ones*/
4518 static void
iter_push_args(GelCtx * ctx,GelETree * args,int n)4519 iter_push_args(GelCtx *ctx, GelETree *args, int n)
4520 {
4521 ctx->post = FALSE;
4522 ctx->current = args;
4523 ctx->whackarg = FALSE;
4524
4525 pushstack_n_args (ctx, args->any.next, n-1);
4526 }
4527
4528 /*make first argument the "current",
4529 *and push all other args. evaluate with no modulo. */
4530 static void
iter_push_args_no_modulo(GelCtx * ctx,GelETree * args,int n)4531 iter_push_args_no_modulo (GelCtx *ctx, GelETree *args, int n)
4532 {
4533 ctx->post = FALSE;
4534 ctx->current = args;
4535 ctx->whackarg = FALSE;
4536
4537 if (ctx->modulo != NULL) {
4538 GE_PUSH_STACK (ctx, ctx->modulo, GE_SETMODULO);
4539
4540 /* Make modulo NULL */
4541 ctx->modulo = NULL;
4542 }
4543
4544 pushstack_n_args (ctx, args->any.next, n-1);
4545 }
4546
4547 /*make first argument the "current",
4548 push no modulo on the second argument */
4549 static void
iter_push_two_args_no_modulo_on_2(GelCtx * ctx,GelETree * args)4550 iter_push_two_args_no_modulo_on_2 (GelCtx *ctx, GelETree *args)
4551 {
4552 ctx->post = FALSE;
4553 ctx->current = args;
4554 ctx->whackarg = FALSE;
4555
4556 if (ctx->modulo != NULL) {
4557 mpw_ptr ptr = g_new (struct _mpw_t, 1);
4558 mpw_init_set_no_uncomplex (ptr, ctx->modulo);
4559
4560 GE_PUSH_STACK (ctx, ptr, GE_SETMODULO);
4561 }
4562 GE_PUSH_STACK(ctx, args->any.next, GE_PRE);
4563 g_assert (args->any.next->any.next == NULL);
4564 if (ctx->modulo != NULL) {
4565 GE_PUSH_STACK (ctx, NULL, GE_SETMODULO);
4566 }
4567 }
4568
4569 /*when a matrix contains other things than NULLs, VALUEs, and STRINGs,
4570 make a copy of it and evaluate it's nodes*/
4571 static void
iter_push_matrix(GelCtx * ctx,GelETree * n,GelMatrixW * m)4572 iter_push_matrix(GelCtx *ctx, GelETree *n, GelMatrixW *m)
4573 {
4574 int x,y;
4575 int w,h;
4576 GelETree *t;
4577 gboolean pushed = FALSE;
4578
4579 w = gel_matrixw_width(m);
4580 h = gel_matrixw_height(m);
4581 for (y = h-1; y >= 0; y--) {
4582 for (x = w-1; x >= 0; x--) {
4583 t = gel_matrixw_get_index (m, x, y);
4584 if (t != NULL &&
4585 t->type != GEL_NULL_NODE &&
4586 t->type != GEL_BOOL_NODE &&
4587 t->type != GEL_VALUE_NODE &&
4588 t->type != GEL_STRING_NODE &&
4589 t->type != GEL_USERTYPE_NODE) {
4590 if ( ! pushed) {
4591 /*make us a private copy!*/
4592 gel_matrixw_make_private (m, TRUE /* kill_type_caches */);
4593
4594 /* it will be a copy */
4595 t = gel_matrixw_get_index (m, x, y);
4596
4597 GE_PUSH_STACK (ctx, n,
4598 GE_ADDWHACKARG (GE_POST,
4599 ctx->whackarg));
4600 pushed = TRUE;
4601 }
4602 GE_PUSH_STACK(ctx,t,GE_PRE);
4603 }
4604 }
4605 }
4606 if (pushed) {
4607 ctx->post = FALSE;
4608 /* will pop the last thing which was t in PRE mode */
4609 GE_POP_STACKNF (ctx, ctx->current);
4610 ctx->whackarg = FALSE;
4611 } else {
4612 /*if we haven't pushed ourselves,
4613 * then just put us in post mode*/
4614 ctx->post = TRUE;
4615 }
4616 }
4617
4618 static GelEFunc *
get_func_from(GelETree * l,gboolean silent)4619 get_func_from (GelETree *l, gboolean silent)
4620 {
4621 GelEFunc *f;
4622
4623 if(l->type == GEL_IDENTIFIER_NODE) {
4624 f = d_lookup_global(l->id.id);
4625 if (f == NULL) {
4626 if G_UNLIKELY ( ! silent &&
4627 ! l->id.uninitialized) {
4628 char * similar =
4629 gel_similar_possible_ids (l->id.id->token);
4630 if (similar != NULL) {
4631 gel_errorout (_("Function '%s' used uninitialized, "
4632 "perhaps you meant %s."),
4633 l->id.id->token,
4634 similar);
4635
4636 g_free (similar);
4637 } else {
4638 gel_errorout (_("Function '%s' used uninitialized"),
4639 l->id.id->token);
4640 }
4641 /* save that we have determined that this was
4642 * uninitialized */
4643 l->id.uninitialized = TRUE;
4644 }
4645 return NULL;
4646 }
4647 } else if(l->type == GEL_FUNCTION_NODE) {
4648 f = l->func.func;
4649 } else if(l->type == GEL_OPERATOR_NODE &&
4650 l->op.oper == GEL_E_DEREFERENCE) {
4651 GelETree *ll;
4652 GEL_GET_L(l,ll);
4653 f = d_lookup_global(ll->id.id);
4654 if (f == NULL) {
4655 if G_UNLIKELY ( ! silent &&
4656 ! ll->id.uninitialized) {
4657 gel_errorout (_("Variable '%s' used uninitialized"),
4658 ll->id.id->token);
4659 /* save that we have determined that this was
4660 * uninitialized */
4661 ll->id.uninitialized = TRUE;
4662 }
4663 return NULL;
4664 } else if (f->type != GEL_REFERENCE_FUNC) {
4665 if G_UNLIKELY ( ! silent) {
4666 gel_errorout (_("Can't dereference '%s'!"),
4667 ll->id.id->token);
4668 }
4669 return NULL;
4670 }
4671 f = f->data.ref;
4672 } else {
4673 if G_UNLIKELY ( ! silent)
4674 gel_errorout (_("Can't call a non-function!"));
4675 return NULL;
4676 }
4677 return f;
4678 }
4679
4680 static GelEFunc *
get_func_from_arg(GelETree * n,gboolean silent)4681 get_func_from_arg (GelETree *n, gboolean silent)
4682 {
4683 GelETree *l;
4684
4685 GEL_GET_L (n,l);
4686 return get_func_from (l, silent);
4687 }
4688
4689 static gboolean
iter_funccallop(GelCtx * ctx,GelETree * n,gboolean * repushed)4690 iter_funccallop(GelCtx *ctx, GelETree *n, gboolean *repushed)
4691 {
4692 GelEFunc *f;
4693
4694 EDEBUG(" FUNCCALL");
4695
4696 f = get_func_from_arg (n, FALSE /* silent */);
4697 if (f == NULL)
4698 goto funccall_done_ok;
4699
4700 if G_UNLIKELY ((f->vararg && f->nargs > n->op.nargs) ||
4701 (! f->vararg && f->nargs != n->op.nargs - 1)) {
4702 if ( ! f->vararg)
4703 gel_errorout (_("Call of '%s' with the wrong number of arguments!\n"
4704 "(should be %d)"),
4705 f->id != NULL ? f->id->token : "anonymous",
4706 f->nargs);
4707 else
4708 gel_errorout (_("Call of '%s' with the wrong number of arguments!\n"
4709 "(should be greater than %d)"),
4710 f->id != NULL ? f->id->token : "anonymous",
4711 f->nargs-2);
4712 goto funccall_done_ok;
4713 }
4714
4715 switch (f->type) {
4716 case GEL_USER_FUNC:
4717 case GEL_VARIABLE_FUNC:
4718 {
4719 GSList *li;
4720 GelETree *ali;
4721 GelToken *last_arg = NULL;
4722
4723 EDEBUG(" USER FUNC PUSHING CONTEXT");
4724
4725 d_addcontext (f);
4726
4727 EDEBUG(" USER FUNC TO ADD ARGS TO DICT");
4728
4729 /*add arguments to dictionary*/
4730 li = f->named_args;
4731 for(ali = n->op.args->any.next;
4732 ali != NULL;
4733 ali = ali->any.next) {
4734 if (li->next == NULL) {
4735 last_arg = li->data;
4736 if (f->vararg)
4737 break;
4738 }
4739 if (ali->type == GEL_FUNCTION_NODE) {
4740 d_addfunc(d_makerealfunc(ali->func.func,li->data,FALSE));
4741 } else if(ali->type == GEL_OPERATOR_NODE &&
4742 ali->op.oper == GEL_E_REFERENCE) {
4743 GelETree *t = ali->op.args;
4744 GelEFunc *rf = d_lookup_global_up1(t->id.id);
4745 if G_UNLIKELY (rf == NULL) {
4746 d_popcontext ();
4747 gel_errorout (_("Referencing an undefined variable %s!"), t->id.id->token);
4748 goto funccall_done_ok;
4749 }
4750 d_addfunc(d_makereffunc(li->data,rf));
4751 } else {
4752 d_addfunc(d_makevfunc(li->data,gel_copynode(ali)));
4753 }
4754 li = li->next;
4755 if (li == NULL)
4756 break;
4757 }
4758
4759 EDEBUG(" USER FUNC ABOUT TO HANDLE VARARG");
4760
4761 if (f->vararg) {
4762 if (last_arg == NULL) {
4763 li = g_slist_last (f->named_args);
4764 g_assert (li != NULL);
4765 last_arg = li->data;
4766 }
4767 /* no extra argument */
4768 if (n->op.nargs == f->nargs) {
4769 d_addfunc (d_makevfunc (last_arg, gel_makenum_null ()));
4770 } else {
4771 GelETree *nn;
4772 GelMatrix *m;
4773 int i;
4774
4775 m = gel_matrix_new ();
4776 gel_matrix_set_size (m, n->op.nargs - f->nargs, 1, FALSE /* padding */);
4777
4778 /* continue with ali */
4779 i = 0;
4780 for (; ali != NULL; ali = ali->any.next) {
4781 gel_matrix_index (m, i++, 0) = gel_copynode (ali);
4782 }
4783
4784 GEL_GET_NEW_NODE (nn);
4785 nn->type = GEL_MATRIX_NODE;
4786 nn->mat.quoted = FALSE;
4787 nn->mat.matrix = gel_matrixw_new_with_matrix (m);
4788
4789 d_addfunc (d_makevfunc (last_arg, nn));
4790 }
4791 }
4792
4793 EDEBUG(" USER FUNC CONTEXT PUSHED TO ADD EXTRA DICT");
4794
4795 /* add extra dictionary stuff */
4796 for (li = f->extra_dict; li != NULL; li = li->next) {
4797 GelEFunc *func = d_copyfunc (li->data);
4798 func->context = d_curcontext ();
4799 d_addfunc (func);
4800 }
4801
4802
4803 EDEBUG(" CREATING LOCAL VARS");
4804
4805 for (li = f->local_idents;
4806 li != NULL;
4807 li = li->next) {
4808 GelToken *tok = li->data;
4809 GelEFunc *vf = d_lookup_local (tok);
4810 if (vf == NULL) {
4811 vf = d_addfunc (d_makevfunc
4812 (tok, gel_makenum_null ()));
4813 }
4814 vf->is_local = 1;
4815 }
4816
4817 EDEBUG(" USER FUNC ABOUT TO ENSURE BODY");
4818
4819 D_ENSURE_USER_BODY (f);
4820
4821 /*push self as post AGAIN*/
4822 GE_PUSH_STACK (ctx, ctx->current,
4823 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
4824 *repushed = TRUE;
4825
4826 /*the next to be evaluated is the body*/
4827 ctx->post = FALSE;
4828 ctx->current = gel_copynode(f->data.user);
4829 ctx->whackarg = FALSE;
4830 /*printf("copying: %p\n", ctx->current);*/
4831
4832 GE_PUSH_STACK(ctx,ctx->current,GE_FUNCCALL);
4833
4834 /* push current modulo if we are not propagating it
4835 * to the function */
4836 if ( ! f->propagate_mod &&
4837 ctx->modulo != NULL) {
4838 GE_PUSH_STACK (ctx, ctx->modulo, GE_SETMODULO);
4839 ctx->modulo = NULL;
4840 }
4841
4842 /*exit without popping the stack as we don't want to do that*/
4843 return TRUE;
4844 }
4845 case GEL_BUILTIN_FUNC:
4846 {
4847 gboolean exception = FALSE;
4848 GelETree *ret;
4849 mpw_ptr old_modulo;
4850
4851 old_modulo = ctx->modulo;
4852 if ( ! f->propagate_mod) {
4853 ctx->modulo = NULL;
4854 }
4855
4856 if (n->op.nargs > 1) {
4857 GelETree **r;
4858 GelETree *li;
4859 int i;
4860 r = g_alloca (sizeof (GelETree *) * n->op.nargs);
4861 for(i=0,li=n->op.args->any.next;li;i++,li=li->any.next)
4862 r[i] = li;
4863 r[i] = NULL;
4864
4865 /*
4866 * Note that we ARE allowing for the function to modify
4867 * the arguments. This can be used for optimization
4868 * such as the Identity function. The function should
4869 * however not just steal the GelETree, it should replace
4870 * it with a GEL_NULL_NODE or some such.
4871 */
4872
4873 ret = (*f->data.func)(ctx,r,&exception);
4874 } else {
4875 ret = (*f->data.func)(ctx,NULL,&exception);
4876 }
4877 if ( ! f->propagate_mod) {
4878 g_assert (ctx->modulo == NULL);
4879 ctx->modulo = old_modulo;
4880 }
4881 /* interruption happened during the function, which
4882 means an exception */
4883 if G_UNLIKELY (gel_interrupted) {
4884 exception = TRUE;
4885 }
4886 if G_UNLIKELY (exception) {
4887 if(ret)
4888 gel_freetree(ret);
4889 return FALSE;
4890 } else if(ret) {
4891 if (ctx->modulo != NULL)
4892 mod_node (ret, ctx->modulo);
4893 replacenode (n, ret);
4894 }
4895 break;
4896 }
4897 case GEL_REFERENCE_FUNC:
4898 {
4899 GelETree *id;
4900 if G_UNLIKELY (f->nargs > 0) {
4901 gel_errorout (_("Reference function with arguments encountered!"));
4902 goto funccall_done_ok;
4903 }
4904 f = f->data.ref;
4905 if G_UNLIKELY (f->id == NULL) {
4906 gel_errorout (_("Unnamed reference function encountered!"));
4907 goto funccall_done_ok;
4908 }
4909
4910 GEL_GET_NEW_NODE(id);
4911 id->type = GEL_IDENTIFIER_NODE;
4912 id->id.id = f->id; /*this WILL have an id*/
4913 id->id.uninitialized = FALSE;
4914 id->any.next = NULL;
4915
4916 freetree_full(n,TRUE,FALSE);
4917 n->type = GEL_OPERATOR_NODE;
4918 n->op.oper = GEL_E_REFERENCE;
4919
4920 n->op.args = id;
4921 n->op.nargs = 1;
4922 break;
4923 }
4924 default:
4925 gel_errorout (_("Unevaluatable function type encountered!"));
4926 break;
4927 }
4928 funccall_done_ok:
4929 iter_pop_stack(ctx);
4930 return TRUE;
4931 }
4932
4933 static void
iter_returnop(GelCtx * ctx,GelETree * n)4934 iter_returnop(GelCtx *ctx, GelETree *n)
4935 {
4936 GelETree *r;
4937 /*r was already evaluated*/
4938 /*now take it out of the argument list*/
4939 r = n->op.args;
4940 n->op.args = NULL;
4941 #ifdef MEM_DEBUG_FRIENDLY
4942 ctx->current = NULL;
4943 #endif
4944 EDEBUG(" RETURN");
4945 for(;;) {
4946 int flag;
4947 gpointer data;
4948 GE_POP_STACK(ctx,data,flag);
4949 EDEBUG(" POPPED STACK");
4950 if((flag & GE_MASK) == GE_EMPTY_STACK) {
4951 EDEBUG(" EMPTY");
4952 break;
4953 } else if((flag & GE_MASK) == GE_FUNCCALL) {
4954 GelETree *fn;
4955 GE_POP_STACK(ctx,fn,flag);
4956 g_assert(fn);
4957 EDEBUG(" FOUND FUNCCCALL");
4958 gel_freetree(data);
4959 if (flag & GE_WHACKARG) {
4960 EDEBUG(" WHACKING RETURN STUFF");
4961 /* WHACKWHACK */
4962 gel_freetree (fn);
4963 gel_freetree (r);
4964 } else {
4965 if (ctx->modulo != NULL)
4966 mod_node (r, ctx->modulo);
4967 replacenode(fn,r);
4968 }
4969
4970 d_popcontext ();
4971
4972 iter_pop_stack(ctx);
4973 return;
4974 } else
4975 ev_free_special_data(ctx,data,flag);
4976 }
4977 EDEBUG(" GOT TO TOP OF THE STACK, SO JUST JUMP OUT OF GLOBAL CONTEXT");
4978 /*we were at the top so substitute result for
4979 the return value*/
4980 ctx->current = NULL;
4981 ctx->post = FALSE;
4982 ctx->whackarg = FALSE;
4983 replacenode(ctx->res,r);
4984 }
4985
4986 static void
iter_forloop(GelCtx * ctx,GelETree * n,gboolean * repushed)4987 iter_forloop (GelCtx *ctx, GelETree *n, gboolean *repushed)
4988 {
4989 GelEvalFor *evf;
4990 GelEvalForType type = GEL_EVAL_FOR;
4991 GelETree *from=NULL,*to=NULL,*by=NULL,*body=NULL,*ident=NULL;
4992 gint8 init_cmp;
4993
4994 switch (n->op.oper) {
4995 case GEL_E_FOR_CONS:
4996 type = GEL_EVAL_FOR;
4997 GEL_GET_ABCD(n,ident,from,to,body);
4998 break;
4999 case GEL_E_SUM_CONS:
5000 type = GEL_EVAL_SUM;
5001 GEL_GET_ABCD(n,ident,from,to,body);
5002 break;
5003 case GEL_E_PROD_CONS:
5004 type = GEL_EVAL_PROD;
5005 GEL_GET_ABCD(n,ident,from,to,body);
5006 break;
5007 case GEL_E_FORBY_CONS:
5008 type = GEL_EVAL_FOR;
5009 GEL_GET_ABCDE(n,ident,from,to,by,body);
5010 break;
5011 case GEL_E_SUMBY_CONS:
5012 type = GEL_EVAL_SUM;
5013 GEL_GET_ABCDE(n,ident,from,to,by,body);
5014 break;
5015 case GEL_E_PRODBY_CONS:
5016 type = GEL_EVAL_PROD;
5017 GEL_GET_ABCDE(n,ident,from,to,by,body);
5018 break;
5019 default:
5020 g_assert_not_reached ();
5021 break;
5022 }
5023
5024 EDEBUG(" ITER FOR LOOP");
5025
5026 if G_UNLIKELY ((by && (by->type != GEL_VALUE_NODE ||
5027 mpw_is_complex(by->val.value))) ||
5028 from->type != GEL_VALUE_NODE || mpw_is_complex(from->val.value) ||
5029 to->type != GEL_VALUE_NODE || mpw_is_complex(to->val.value)) {
5030 gel_errorout (_("Bad type for 'for/sum/prod' loop!"));
5031 iter_pop_stack(ctx);
5032 return;
5033 }
5034 if G_UNLIKELY (by && mpw_zero_p (by->val.value)) {
5035 gel_errorout (_("'for/sum/prod' loop increment can't be 0"));
5036 iter_pop_stack(ctx);
5037 return;
5038 }
5039
5040 init_cmp = mpw_cmp(from->val.value,to->val.value);
5041
5042 if(!by) {
5043 /*if no iterations*/
5044 if(init_cmp>0) {
5045 d_addfunc(d_makevfunc(ident->id.id,gel_copynode(from)));
5046 freetree_full(n,TRUE,FALSE);
5047 if (type == GEL_EVAL_FOR) {
5048 n->type = GEL_NULL_NODE;
5049 } else if (type == GEL_EVAL_SUM) {
5050 gel_makenum_ui_from (n, 0);
5051 } else /* if (type == GEL_EVAL_PROD) */ {
5052 gel_makenum_ui_from (n, 1);
5053 }
5054 iter_pop_stack(ctx);
5055 return;
5056 } else if(init_cmp==0) {
5057 init_cmp = -1;
5058 }
5059 if (mpw_is_real_part_float (from->val.value) ||
5060 mpw_is_real_part_float (to->val.value)) {
5061 /* ensure all float */
5062 mpw_make_float (to->val.value);
5063 mpw_make_float (from->val.value);
5064 }
5065 evf = evf_new(type, from->val.value,to->val.value,NULL,init_cmp,
5066 gel_copynode(body),body,ident->id.id);
5067 } else {
5068 int sgn = mpw_sgn(by->val.value);
5069 /*if no iterations*/
5070 if((sgn>0 && init_cmp>0) || (sgn<0 && init_cmp<0)) {
5071 d_addfunc(d_makevfunc(ident->id.id,gel_copynode(from)));
5072 freetree_full(n,TRUE,FALSE);
5073 if (type == GEL_EVAL_FOR) {
5074 n->type = GEL_NULL_NODE;
5075 } else if (type == GEL_EVAL_SUM) {
5076 gel_makenum_ui_from (n, 0);
5077 } else /* if (type == GEL_EVAL_PROD) */ {
5078 gel_makenum_ui_from (n, 1);
5079 }
5080 iter_pop_stack(ctx);
5081 return;
5082 }
5083 if(init_cmp == 0)
5084 init_cmp = -sgn;
5085 if (mpw_is_real_part_float (from->val.value) ||
5086 mpw_is_real_part_float (to->val.value) ||
5087 mpw_is_real_part_float (by->val.value)) {
5088 /* ensure all float */
5089 mpw_make_float (to->val.value);
5090 mpw_make_float (from->val.value);
5091 mpw_make_float (by->val.value);
5092 }
5093 evf = evf_new(type, from->val.value,to->val.value,by->val.value,
5094 init_cmp,gel_copynode(body),body,ident->id.id);
5095 }
5096
5097 d_addfunc(d_makevfunc(ident->id.id,gel_makenum(evf->x)));
5098
5099 GE_PUSH_STACK (ctx, n,
5100 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
5101 *repushed = TRUE;
5102 GE_PUSH_STACK (ctx, evf, GE_FOR);
5103
5104 ctx->current = evf->body;
5105 ctx->post = FALSE;
5106 ctx->whackarg = FALSE;
5107 }
5108
5109 static void
iter_forinloop(GelCtx * ctx,GelETree * n,gboolean * repushed)5110 iter_forinloop(GelCtx *ctx, GelETree *n, gboolean *repushed)
5111 {
5112 GelEvalForIn *evfi;
5113 GelEvalForType type = GEL_EVAL_FOR;
5114 GelETree *from,*body,*ident;
5115
5116 switch (n->op.oper) {
5117 case GEL_E_FORIN_CONS:
5118 type = GEL_EVAL_FOR;
5119 break;
5120 case GEL_E_SUMIN_CONS:
5121 type = GEL_EVAL_SUM;
5122 break;
5123 case GEL_E_PRODIN_CONS:
5124 type = GEL_EVAL_PROD;
5125 break;
5126 default:
5127 g_assert_not_reached ();
5128 break;
5129 }
5130
5131 GEL_GET_LRR(n,ident,from,body);
5132
5133 EDEBUG(" ITER FORIN LOOP");
5134
5135 /* If there is nothing to sum */
5136 if (from->type == GEL_NULL_NODE) {
5137 /* replace n with the appropriate nothingness */
5138 freetree_full (n, TRUE, FALSE);
5139 switch (type) {
5140 case GEL_EVAL_FOR:
5141 n->type = GEL_NULL_NODE;
5142 break;
5143 case GEL_EVAL_SUM:
5144 gel_makenum_ui_from (n, 0);
5145 break;
5146 case GEL_EVAL_PROD:
5147 gel_makenum_ui_from (n, 1);
5148 break;
5149 default:
5150 g_assert_not_reached ();
5151 break;
5152 }
5153 iter_pop_stack (ctx);
5154 return;
5155 }
5156
5157 /* FIXME: string should go through all the characters I suppose */
5158 if G_UNLIKELY (from->type != GEL_VALUE_NODE &&
5159 from->type != GEL_BOOL_NODE &&
5160 from->type != GEL_MATRIX_NODE) {
5161 gel_errorout (_("Bad type for 'for in' loop!"));
5162 iter_pop_stack(ctx);
5163 return;
5164 }
5165
5166 if(from->type == GEL_MATRIX_NODE) {
5167 evfi = evfi_new (type, from->mat.matrix,
5168 gel_copynode (body), body, ident->id.id);
5169 d_addfunc(d_makevfunc(ident->id.id,
5170 gel_copynode(gel_matrixw_index(from->mat.matrix,
5171 evfi->i,
5172 evfi->j))));
5173 } else {
5174 evfi = evfi_new (type, NULL, gel_copynode(body), body, ident->id.id);
5175 d_addfunc(d_makevfunc(ident->id.id,gel_copynode(from)));
5176 }
5177
5178 GE_PUSH_STACK (ctx, n,
5179 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
5180 *repushed = TRUE;
5181 GE_PUSH_STACK(ctx,evfi,GE_FORIN);
5182
5183 ctx->current = evfi->body;
5184 ctx->post = FALSE;
5185 ctx->whackarg = FALSE;
5186 }
5187
5188 static void
iter_loop(GelCtx * ctx,GelETree * n,gboolean body_first,gboolean is_while)5189 iter_loop (GelCtx *ctx, GelETree *n, gboolean body_first, gboolean is_while)
5190 {
5191 GelEvalLoop *evl;
5192 GelETree *l;
5193
5194 GEL_GET_L(n,l);
5195
5196 EDEBUG(" ITER LOOP");
5197
5198 GE_PUSH_STACK (ctx, ctx->current,
5199 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
5200 if (body_first) {
5201 EDEBUG (" BODY FIRST");
5202 evl = evl_new (NULL, gel_copynode (l), is_while, body_first);
5203 GE_PUSH_STACK (ctx, evl, GE_LOOP_LOOP);
5204 ctx->current = evl->body;
5205 ctx->post = FALSE;
5206 ctx->whackarg = FALSE;
5207 } else {
5208 EDEBUG(" CHECK FIRST");
5209 evl = evl_new (gel_copynode(l), NULL, is_while, body_first);
5210 GE_PUSH_STACK (ctx, evl, GE_LOOP_COND);
5211 ctx->current = evl->condition;
5212 ctx->post = FALSE;
5213 ctx->whackarg = FALSE;
5214 }
5215 }
5216
5217 static void
iter_ifop(GelCtx * ctx,GelETree * n,gboolean has_else,gboolean * repushed)5218 iter_ifop(GelCtx *ctx, GelETree *n, gboolean has_else, gboolean *repushed)
5219 {
5220 GelETree *l,*r,*rr = NULL;
5221 gboolean ret;
5222 gboolean bad_node = FALSE;
5223
5224 EDEBUG(" IF/IFELSE ITER OP");
5225
5226 if(has_else) {
5227 GEL_GET_LRR(n,l,r,rr);
5228 } else {
5229 GEL_GET_LR(n,l,r);
5230 }
5231
5232
5233 ret = gel_isnodetrue(l,&bad_node);
5234 if G_UNLIKELY (bad_node || gel_error_num) {
5235 EDEBUG(" IF/IFELSE BAD BAD NODE");
5236 gel_error_num = GEL_NO_ERROR;
5237 iter_pop_stack(ctx);
5238 return;
5239 }
5240
5241 if(ret) {
5242 #ifdef EVAL_DEBUG
5243 printf (" IF TRUE EVAL BODY n %p l %p r %p\n", n, l, r);
5244 #endif
5245 /*remove from arglist so that it doesn't get freed on
5246 replace node*/
5247 n->op.args->any.next = n->op.args->any.next->any.next;
5248 replacenode (n, r);
5249 ctx->post = FALSE;
5250 g_assert (ctx->current == n);
5251 /* whackarg stays the same */
5252 *repushed = TRUE;
5253 } else if(has_else) {
5254 EDEBUG(" IF FALSE EVAL ELSE BODY");
5255 /*remove from arglist so that it doesn't get freed on
5256 replace node*/
5257 n->op.args->any.next->any.next = NULL;
5258 replacenode (n, rr);
5259 ctx->post = FALSE;
5260 g_assert (ctx->current == n);
5261 /* whackarg stays the same */
5262 *repushed = TRUE;
5263 } else {
5264 EDEBUG(" IF FALSE RETURN NULL");
5265 /*just return NULL*/
5266 freetree_full(n,TRUE,FALSE);
5267 n->type = GEL_NULL_NODE;
5268 iter_pop_stack(ctx);
5269 }
5270 }
5271
5272 /*the breakout logic is almost identical for the different loops,
5273 but the code differs slightly so we just make a macro that subsitutes
5274 the right types, values and free functions*/
5275 #define LOOP_BREAK_CONT(structtype,freefunc,pushflag) { \
5276 structtype *e = data; \
5277 if(cont) { \
5278 freetree_full(e->body,TRUE,FALSE); \
5279 e->body->type = GEL_NULL_NODE; \
5280 GE_PUSH_STACK(ctx,e,pushflag); \
5281 /*we have already killed the body, so \
5282 this will continue as if the body \
5283 was evaluated to null*/ \
5284 iter_pop_stack(ctx); \
5285 } else { \
5286 GelETree *n; \
5287 \
5288 /* makes debugging happy */ \
5289 ctx->current = NULL; \
5290 \
5291 gel_freetree(e->body); \
5292 freefunc(e); \
5293 \
5294 /*pop loop call tree*/ \
5295 GE_POP_STACK(ctx,n,flag); \
5296 \
5297 /* just for sanity */ \
5298 if G_LIKELY (n != NULL) { \
5299 if (flag & GE_WHACKARG) { \
5300 gel_freetree (n); \
5301 } else { \
5302 /*null the tree*/ \
5303 freetree_full(n,TRUE,FALSE); \
5304 n->type = GEL_NULL_NODE; \
5305 } \
5306 } \
5307 \
5308 /*go on with the computation*/ \
5309 iter_pop_stack(ctx); \
5310 } \
5311 return; \
5312 }
5313
5314 static void
iter_continue_break_op(GelCtx * ctx,gboolean cont)5315 iter_continue_break_op(GelCtx *ctx, gboolean cont)
5316 {
5317 EDEBUG(" CONTINUE/BREAK");
5318 for(;;) {
5319 int flag;
5320 gpointer data;
5321 GE_POP_STACK(ctx,data,flag);
5322 EDEBUG(" POPPED STACK");
5323 switch(flag & GE_MASK) {
5324 case GE_EMPTY_STACK:
5325 EDEBUG(" EMPTY");
5326 goto iter_continue_break_done;
5327 case GE_FUNCCALL:
5328 EDEBUG(" FOUND FUNCCCALL MAKE IT NULL THEN");
5329 gel_errorout (_("Continue or break outside a loop, "
5330 "assuming \"return null\""));
5331 gel_freetree(data);
5332
5333 d_popcontext ();
5334
5335 /*pop the function call*/
5336 GE_POP_STACK(ctx,data,flag);
5337
5338 g_assert ((flag & GE_MASK) == GE_POST);
5339 if (flag & GE_WHACKARG) {
5340 /* WHACKWHACK */
5341 gel_freetree (data);
5342 } else {
5343 freetree_full(data,TRUE,FALSE);
5344 ((GelETree *)data)->type = GEL_NULL_NODE;
5345 }
5346
5347 iter_pop_stack(ctx);
5348 return;
5349 case GE_LOOP_LOOP:
5350 LOOP_BREAK_CONT (GelEvalLoop, evl_free_with_cond, GE_LOOP_LOOP);
5351 case GE_FOR:
5352 LOOP_BREAK_CONT (GelEvalFor, evf_free, GE_FOR);
5353 case GE_FORIN:
5354 LOOP_BREAK_CONT (GelEvalForIn, evfi_free, GE_FORIN);
5355 default:
5356 ev_free_special_data(ctx,data,flag);
5357 break;
5358 }
5359 }
5360 iter_continue_break_done:
5361 EDEBUG(" GOT TO TOP OF THE STACK, SO JUST JUMP OUT OF GLOBAL CONTEXT");
5362 gel_errorout (_("Continue or break outside a loop, "
5363 "assuming \"return null\""));
5364 /*we were at the top so substitute result for a NULL*/
5365 ctx->current = NULL;
5366 ctx->post = FALSE;
5367 ctx->whackarg = FALSE;
5368 freetree_full(ctx->res,TRUE,FALSE);
5369 ctx->res->type = GEL_NULL_NODE;
5370 }
5371
5372 #undef LOOP_BREAK_CONT
5373
5374 static void
iter_bailout_op(GelCtx * ctx)5375 iter_bailout_op(GelCtx *ctx)
5376 {
5377 EDEBUG(" BAILOUT");
5378
5379 #ifdef MEM_DEBUG_FRIENDLY
5380 /* Current will be changed and possibly whacked */
5381 ctx->current = NULL;
5382 #endif
5383 for(;;) {
5384 int flag;
5385 gpointer data;
5386 GE_POP_STACK(ctx,data,flag);
5387 EDEBUG(" POPPED STACK");
5388 if ((flag & GE_MASK) == GE_EMPTY_STACK) {
5389 EDEBUG(" EMPTY");
5390 break;
5391 } else if ((flag & GE_MASK) == GE_FUNCCALL) {
5392 EDEBUG(" FOUND FUNCCCALL");
5393 gel_freetree(data);
5394
5395 d_popcontext ();
5396
5397 /*pop the function call off the stack*/
5398 GE_POP_STACK(ctx,data,flag);
5399 if (flag & GE_WHACKARG) {
5400 /* WHACKWHACK */
5401 gel_freetree (data);
5402 }
5403
5404 iter_pop_stack(ctx);
5405 return;
5406 } else
5407 ev_free_special_data(ctx,data,flag);
5408 }
5409 EDEBUG(" GOT TO TOP OF THE STACK, SO JUST JUMP OUT OF GLOBAL CONTEXT");
5410 /*we were at the top so substitute result for
5411 the return value*/
5412 ctx->current = NULL;
5413 ctx->post = FALSE;
5414 ctx->whackarg = FALSE;
5415 }
5416
5417 static int
iter_get_ui_index(GelETree * num)5418 iter_get_ui_index (GelETree *num)
5419 {
5420 long i;
5421 if G_UNLIKELY (num->type != GEL_VALUE_NODE ||
5422 !mpw_is_integer(num->val.value)) {
5423 gel_errorout (_("Wrong argument type as matrix index"));
5424 return -1;
5425 }
5426
5427 i = mpw_get_long(num->val.value);
5428 if G_UNLIKELY (gel_error_num) {
5429 gel_error_num = GEL_NO_ERROR;
5430 return -1;
5431 }
5432 if G_UNLIKELY (i > INT_MAX) {
5433 gel_errorout (_("Matrix index too large"));
5434 return -1;
5435 } else if G_UNLIKELY (i <= 0) {
5436 gel_errorout (_("Matrix index less than 1"));
5437 return -1;
5438 }
5439 return i;
5440 }
5441
5442 static int *
iter_get_matrix_index_vector(GelETree * index,int maxsize,int * vlen)5443 iter_get_matrix_index_vector (GelETree *index, int maxsize, int *vlen)
5444 {
5445 int i;
5446 int reglen = gel_matrixw_elements (index->mat.matrix);
5447 int *reg = g_new (int, reglen);
5448
5449 *vlen = reglen;
5450
5451 for (i = 0; i < reglen; i++) {
5452 GelETree *it = gel_matrixw_vindex (index->mat.matrix, i);
5453 reg[i] = iter_get_ui_index (it) - 1;
5454 if G_UNLIKELY (reg[i] < 0) {
5455 g_free (reg);
5456 return NULL;
5457 } else if G_UNLIKELY (reg[i] >= maxsize) {
5458 g_free (reg);
5459 gel_errorout (_("Matrix index out of range"));
5460 return NULL;
5461 }
5462 }
5463 return reg;
5464 }
5465
5466 /* assumes index->type == GEL_VALUE_NODE */
5467 static int
iter_get_matrix_index_num(GelETree * index,int maxsize)5468 iter_get_matrix_index_num (GelETree *index, int maxsize)
5469 {
5470 int i = iter_get_ui_index (index) - 1;
5471 if G_UNLIKELY (i < 0) {
5472 return -1;
5473 } else if G_UNLIKELY (i >= maxsize) {
5474 gel_errorout (_("Matrix index out of range"));
5475 return -1;
5476 }
5477 return i;
5478 }
5479
5480 static gboolean
iter_get_index_region(GelETree * index,int maxsize,int ** reg,int * l)5481 iter_get_index_region (GelETree *index, int maxsize, int **reg, int *l)
5482 {
5483 if (index->type == GEL_VALUE_NODE) {
5484 int i = iter_get_matrix_index_num (index, maxsize);
5485 if G_UNLIKELY (i < 0)
5486 return FALSE;
5487 *reg = g_new (int, 1);
5488 (*reg)[0] = i;
5489 *l = 1;
5490 } else /* GEL_MATRIX_NODE */ {
5491 *reg = iter_get_matrix_index_vector (index, maxsize, l);
5492 if G_UNLIKELY (*reg == NULL)
5493 return FALSE;
5494 }
5495 return TRUE;
5496 }
5497
5498 /* correct types already (value or matrix) */
5499 static gboolean
iter_get_index_regions(GelETree * i1,GelETree * i2,int max1,int max2,int ** reg1,int ** reg2,int * l1,int * l2)5500 iter_get_index_regions (GelETree *i1, GelETree *i2,
5501 int max1, int max2,
5502 int **reg1, int **reg2,
5503 int *l1, int *l2)
5504 {
5505 if G_UNLIKELY ( ! iter_get_index_region (i1, max1, reg1, l1))
5506 return FALSE;
5507 if G_UNLIKELY ( ! iter_get_index_region (i2, max2, reg2, l2)) {
5508 g_free (reg1);
5509 return FALSE;
5510 }
5511 return TRUE;
5512 }
5513
5514 static GelMatrixW *
iter_get_matrix_p(GelETree * m)5515 iter_get_matrix_p (GelETree *m)
5516 {
5517 GelMatrixW *mat = NULL;
5518
5519 if(m->type == GEL_IDENTIFIER_NODE) {
5520 GelEFunc *f;
5521 if G_UNLIKELY (d_curcontext()==0 &&
5522 m->id.id->protected_) {
5523 gel_errorout (_("Trying to set a protected id '%s'"),
5524 m->id.id->token);
5525 return NULL;
5526 }
5527 f = d_lookup_local(m->id.id);
5528 if (f == NULL) {
5529 GelEFunc *fg = d_lookup_global (m->id.id);
5530
5531 if (fg != NULL) {
5532 f = d_addfunc (d_makerealfunc (fg,
5533 m->id.id,
5534 FALSE));
5535 } else {
5536 GelETree *t;
5537 GEL_GET_NEW_NODE(t);
5538 t->type = GEL_MATRIX_NODE;
5539 t->mat.matrix = gel_matrixw_new();
5540 t->mat.quoted = FALSE;
5541 gel_matrixw_set_size(t->mat.matrix,1,1);
5542
5543 f = d_makevfunc(m->id.id,t);
5544 d_addfunc(f);
5545 }
5546 } else if G_UNLIKELY (f->type != GEL_USER_FUNC &&
5547 f->type != GEL_VARIABLE_FUNC) {
5548 gel_errorout (_("Indexed Lvalue not user function"));
5549 return NULL;
5550 }
5551 D_ENSURE_USER_BODY (f);
5552 if(f->data.user->type != GEL_MATRIX_NODE) {
5553 GelETree *t;
5554 GEL_GET_NEW_NODE(t);
5555 t->type = GEL_MATRIX_NODE;
5556 t->mat.matrix = gel_matrixw_new();
5557 t->mat.quoted = FALSE;
5558 gel_matrixw_set_size(t->mat.matrix,1,1);
5559
5560 d_set_value(f,t);
5561 }
5562 mat = f->data.user->mat.matrix;
5563 } else if(m->type == GEL_OPERATOR_NODE ||
5564 m->op.oper == GEL_E_DEREFERENCE) {
5565 GelETree *l;
5566 GelEFunc *f;
5567 GEL_GET_L(m,l);
5568
5569 if G_UNLIKELY (l->type != GEL_IDENTIFIER_NODE) {
5570 gel_errorout (_("Dereference of non-identifier!"));
5571 return NULL;
5572 }
5573
5574 f = d_lookup_global(l->id.id);
5575 if G_UNLIKELY (f == NULL) {
5576 gel_errorout (_("Dereference of undefined variable!"));
5577 return NULL;
5578 }
5579 if G_UNLIKELY (f->type != GEL_REFERENCE_FUNC) {
5580 gel_errorout (_("Dereference of non-reference!"));
5581 return NULL;
5582 }
5583
5584 if G_UNLIKELY (f->data.ref->type != GEL_USER_FUNC &&
5585 f->data.ref->type != GEL_VARIABLE_FUNC) {
5586 gel_errorout (_("Indexed Lvalue not user function"));
5587 return NULL;
5588 }
5589 if G_UNLIKELY (f->data.ref->context == 0 &&
5590 f->data.ref->id->protected_) {
5591 gel_errorout (_("Trying to set a protected id '%s'"),
5592 f->data.ref->id->token);
5593 return NULL;
5594 }
5595 D_ENSURE_USER_BODY (f->data.ref);
5596 if(f->data.ref->data.user->type != GEL_MATRIX_NODE) {
5597 GelETree *t;
5598 GEL_GET_NEW_NODE(t);
5599 t->type = GEL_MATRIX_NODE;
5600 t->mat.matrix = gel_matrixw_new();
5601 t->mat.quoted = FALSE;
5602 gel_matrixw_set_size(t->mat.matrix,1,1);
5603
5604 d_set_value(f->data.ref,t);
5605 }
5606 mat = f->data.ref->data.user->mat.matrix;
5607 } else {
5608 gel_errorout (_("Indexed Lvalue not an identifier or a dereference"));
5609 return NULL;
5610 }
5611 return mat;
5612 }
5613
5614 static GelETree *
set_parameter(GelToken * token,GelETree * val)5615 set_parameter (GelToken *token, GelETree *val)
5616 {
5617 GelEFunc *func;
5618
5619 if (token->built_in_parameter) {
5620 ParameterSetFunc setfunc = token->data1;
5621 if (setfunc != NULL)
5622 return setfunc (val);
5623 return gel_makenum_null ();
5624 } else {
5625 func = d_makevfunc (token, gel_copynode (val));
5626 /* make function global */
5627 func->context = 0;
5628 d_addfunc_global (func);
5629 return gel_copynode (val);
5630 }
5631 }
5632
5633 gboolean
_gel_iter_set_velement(GelMatrixW * mat,GelETree * r,GelETree * index)5634 _gel_iter_set_velement(GelMatrixW *mat, GelETree *r, GelETree *index)
5635 {
5636 if (index->type == GEL_VALUE_NODE) {
5637 int i;
5638
5639 i = iter_get_matrix_index_num (index, INT_MAX);
5640 if G_UNLIKELY (i < 0)
5641 return FALSE;
5642
5643 if (r->type == GEL_VALUE_NODE &&
5644 mpw_exact_zero_p (r->val.value))
5645 gel_matrixw_set_velement (mat, i, NULL);
5646 else
5647 gel_matrixw_set_velement (mat, i, gel_copynode (r));
5648 } else if (index->type == GEL_MATRIX_NODE) {
5649 int *reg;
5650 int len;
5651
5652 if G_UNLIKELY( ! iter_get_index_region (index, INT_MAX,
5653 ®, &len))
5654 return FALSE;
5655
5656 if (r->type == GEL_MATRIX_NODE)
5657 gel_matrixw_set_vregion (mat, r->mat.matrix, reg, len);
5658 else
5659 gel_matrixw_set_vregion_etree (mat, r, reg, len);
5660 g_free (reg);
5661 } else {
5662 gel_errorout (_("Matrix index not an integer or a vector"));
5663 return FALSE;
5664 }
5665
5666 return TRUE;
5667 }
5668
5669 gboolean
_gel_iter_set_element(GelMatrixW * mat,GelETree * r,GelETree * index1,GelETree * index2)5670 _gel_iter_set_element(GelMatrixW *mat, GelETree *r, GelETree *index1, GelETree *index2)
5671 {
5672 if (index1->type == GEL_VALUE_NODE &&
5673 index2->type == GEL_VALUE_NODE) {
5674 int x, y;
5675
5676 x = iter_get_matrix_index_num (index2, INT_MAX);
5677 if G_UNLIKELY (x < 0)
5678 return FALSE;
5679 y = iter_get_matrix_index_num (index1, INT_MAX);
5680 if G_UNLIKELY (y < 0)
5681 return FALSE;
5682
5683 if (r->type == GEL_VALUE_NODE &&
5684 mpw_exact_zero_p (r->val.value))
5685 gel_matrixw_set_element (mat, x, y, NULL);
5686 else
5687 gel_matrixw_set_element (mat, x, y, gel_copynode (r));
5688 } else if ((index1->type == GEL_VALUE_NODE ||
5689 index1->type == GEL_MATRIX_NODE) &&
5690 (index2->type == GEL_VALUE_NODE ||
5691 index2->type == GEL_MATRIX_NODE)) {
5692 int *regx, *regy;
5693 int lx, ly;
5694
5695 if ( ! iter_get_index_regions (index1, index2,
5696 INT_MAX, INT_MAX,
5697 ®y, ®x,
5698 &ly, &lx))
5699 return FALSE;
5700
5701 if G_UNLIKELY (r->type == GEL_MATRIX_NODE &&
5702 (gel_matrixw_width (r->mat.matrix) != lx ||
5703 gel_matrixw_height (r->mat.matrix) != ly)) {
5704 g_free (regx);
5705 g_free (regy);
5706 gel_errorout (_("Wrong matrix dimensions when setting"));
5707 return FALSE;
5708 }
5709
5710 if (r->type == GEL_MATRIX_NODE)
5711 gel_matrixw_set_region (mat, r->mat.matrix, regx, regy, lx, ly);
5712 else
5713 gel_matrixw_set_region_etree (mat, r, regx, regy, lx, ly);
5714 g_free (regx);
5715 g_free (regy);
5716 } else {
5717 gel_errorout (_("Matrix index not an integer or a vector"));
5718 return FALSE;
5719 }
5720
5721 return TRUE;
5722 }
5723
5724 static void
iter_equalsop(GelETree * n)5725 iter_equalsop(GelETree *n)
5726 {
5727 GelETree *l,*r;
5728
5729 GEL_GET_LR(n,l,r);
5730
5731 if G_UNLIKELY (l->type != GEL_IDENTIFIER_NODE &&
5732 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_VELEMENT) &&
5733 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_ELEMENT) &&
5734 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_COL_REGION) &&
5735 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_ROW_REGION) &&
5736 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_DEREFERENCE)) {
5737 gel_errorout (_("Lvalue not an identifier/dereference/matrix location!"));
5738 return;
5739 }
5740
5741 if(l->type == GEL_IDENTIFIER_NODE) {
5742 if (l->id.id->parameter) {
5743 GelETree *ret = set_parameter (l->id.id, r);
5744 if (ret != NULL)
5745 replacenode (n, ret);
5746 return;
5747 } else if G_UNLIKELY (d_curcontext() == 0 &&
5748 l->id.id->protected_) {
5749 gel_errorout (_("Trying to set a protected id '%s'"),
5750 l->id.id->token);
5751 return;
5752 } else if(r->type == GEL_FUNCTION_NODE) {
5753 d_addfunc (d_makerealfunc (r->func.func,
5754 l->id.id,
5755 FALSE));
5756 } else if(r->type == GEL_OPERATOR_NODE &&
5757 r->op.oper == GEL_E_REFERENCE) {
5758 GelETree *t = r->op.args;
5759 GelEFunc *rf = d_lookup_global(t->id.id);
5760 if G_UNLIKELY (rf == NULL) {
5761 gel_errorout (_("Referencing an undefined variable!"));
5762 return;
5763 }
5764 d_addfunc(d_makereffunc(l->id.id,rf));
5765 } else {
5766 d_addfunc(d_makevfunc(l->id.id,gel_copynode(r)));
5767 }
5768 } else if(l->op.oper == GEL_E_DEREFERENCE) {
5769 GelEFunc *f;
5770 GelETree *ll;
5771 GEL_GET_L(l,ll);
5772
5773 if G_UNLIKELY (ll->type != GEL_IDENTIFIER_NODE) {
5774 gel_errorout (_("Dereference of non-identifier!"));
5775 return;
5776 }
5777
5778 f = d_lookup_global(ll->id.id);
5779 if G_UNLIKELY (f == NULL) {
5780 gel_errorout (_("Dereference of undefined variable!"));
5781 return;
5782 }
5783 if G_UNLIKELY (f->type!=GEL_REFERENCE_FUNC) {
5784 gel_errorout (_("Dereference of non-reference!"));
5785 return;
5786 }
5787
5788 if G_UNLIKELY (f->data.ref->context == 0 &&
5789 f->data.ref->id->protected_) {
5790 gel_errorout (_("Trying to set a protected id '%s'"),
5791 f->data.ref->id->token);
5792 return;
5793 }
5794
5795 if(r->type == GEL_FUNCTION_NODE) {
5796 d_setrealfunc(f->data.ref,r->func.func,FALSE);
5797 } else if(r->type == GEL_OPERATOR_NODE &&
5798 r->op.oper == GEL_E_REFERENCE) {
5799 GelETree *t = r->op.args;
5800 GelEFunc *rf = d_lookup_global(t->id.id);
5801 if G_UNLIKELY (rf == NULL) {
5802 gel_errorout (_("Referencing an undefined variable!"));
5803 return;
5804 }
5805 d_set_ref(f->data.ref,rf);
5806 } else {
5807 d_set_value(f->data.ref,gel_copynode(r));
5808 }
5809 } else if(l->op.oper == GEL_E_GET_ELEMENT) {
5810 GelMatrixW *mat;
5811 GelETree *index1, *index2;
5812 GEL_GET_XRR (l, index1, index2);
5813
5814 mat = iter_get_matrix_p (l->op.args);
5815 if G_UNLIKELY (mat == NULL)
5816 return;
5817
5818 if ( ! _gel_iter_set_element (mat, r, index1, index2))
5819 return;
5820 } else if(l->op.oper == GEL_E_GET_VELEMENT) {
5821 GelMatrixW *mat;
5822 GelETree *index;
5823 GEL_GET_XR (l, index);
5824
5825 mat = iter_get_matrix_p (l->op.args);
5826 if G_UNLIKELY (mat == NULL)
5827 return;
5828
5829 if G_UNLIKELY ( ! _gel_iter_set_velement (mat, r, index))
5830 return;
5831 } else /*l->data.oper == GEL_E_GET_COL_REGION GEL_E_GET_ROW_REGION*/ {
5832 GelMatrixW *mat;
5833 GelETree *index;
5834 GEL_GET_XR (l, index);
5835
5836 if (index->type == GEL_VALUE_NODE ||
5837 index->type == GEL_MATRIX_NODE) {
5838 int *regx = NULL, *regy = NULL;
5839 int lx, ly;
5840 int i;
5841
5842 if (l->op.oper == GEL_E_GET_COL_REGION) {
5843 if G_UNLIKELY ( ! iter_get_index_region (index, INT_MAX, ®x, &lx))
5844 return;
5845 if G_UNLIKELY (r->type == GEL_MATRIX_NODE &&
5846 gel_matrixw_width (r->mat.matrix) != lx) {
5847 g_free (regx);
5848 gel_errorout (_("Wrong matrix dimensions when setting"));
5849 return;
5850 }
5851 } else {
5852 if G_UNLIKELY ( ! iter_get_index_region (index, INT_MAX, ®y, &ly))
5853 return;
5854 if G_UNLIKELY (r->type == GEL_MATRIX_NODE &&
5855 gel_matrixw_height (r->mat.matrix) != ly) {
5856 g_free (regy);
5857 gel_errorout (_("Wrong matrix dimensions when setting"));
5858 return;
5859 }
5860 }
5861
5862 mat = iter_get_matrix_p (l->op.args);
5863 if G_UNLIKELY (mat == NULL) {
5864 g_free (regx);
5865 g_free (regy);
5866 return;
5867 }
5868
5869 if (l->op.oper == GEL_E_GET_COL_REGION) {
5870 ly = gel_matrixw_height (mat);
5871 if (r->type == GEL_MATRIX_NODE &&
5872 ly < gel_matrixw_height (r->mat.matrix))
5873 ly = gel_matrixw_height (r->mat.matrix);
5874 regy = g_new (int, ly);
5875 for (i = 0; i < ly; i++)
5876 regy[i] = i;
5877 } else {
5878 lx = gel_matrixw_width (mat);
5879 if (r->type == GEL_MATRIX_NODE &&
5880 lx < gel_matrixw_width (r->mat.matrix))
5881 lx = gel_matrixw_width (r->mat.matrix);
5882 regx = g_new (int, lx);
5883 for (i = 0; i < lx; i++)
5884 regx[i] = i;
5885 }
5886
5887 if (r->type == GEL_MATRIX_NODE)
5888 gel_matrixw_set_region (mat, r->mat.matrix, regx, regy, lx, ly);
5889 else
5890 gel_matrixw_set_region_etree (mat, r, regx, regy, lx, ly);
5891 g_free (regx);
5892 g_free (regy);
5893 } else {
5894 gel_errorout (_("Matrix index not an integer or a vector"));
5895 return;
5896 }
5897 }
5898 /*remove from arglist so that it doesn't get freed on replacenode*/
5899 n->op.args->any.next = NULL;
5900 replacenode(n,r);
5901 }
5902
5903 static GelEFunc *
get_functoset(GelETree * l)5904 get_functoset (GelETree *l)
5905 {
5906 if(l->type == GEL_IDENTIFIER_NODE) {
5907 if G_UNLIKELY (l->id.id->parameter) {
5908 gel_errorout (_("Increment/Swapwith does not work on parameters (trying to increment '%s')"),
5909 l->id.id->token);
5910 return NULL;
5911 } else if G_UNLIKELY (d_curcontext() == 0 &&
5912 l->id.id->protected_) {
5913 gel_errorout (_("Trying to set a protected id '%s'"),
5914 l->id.id->token);
5915 return NULL;
5916 } else {
5917 GelEFunc *f;
5918
5919 f = d_lookup_local (l->id.id);
5920 if (f == NULL) {
5921 GelEFunc *fg = d_lookup_global (l->id.id);
5922 if (fg != NULL)
5923 f = d_addfunc (d_makerealfunc (fg,
5924 l->id.id,
5925 FALSE));
5926 else
5927 f = d_addfunc (d_makevfunc (l->id.id, gel_makenum_ui (0)));
5928 }
5929 return f;
5930 }
5931 } else if(l->op.oper == GEL_E_DEREFERENCE) {
5932 GelEFunc *f;
5933 GelETree *ll;
5934 GEL_GET_L(l,ll);
5935
5936 if G_UNLIKELY (ll->type != GEL_IDENTIFIER_NODE) {
5937 gel_errorout (_("Dereference of non-identifier!"));
5938 return NULL;
5939 }
5940
5941 f = d_lookup_global (ll->id.id);
5942 if G_UNLIKELY (f == NULL) {
5943 gel_errorout (_("Dereference of undefined variable!"));
5944 return NULL;
5945 }
5946 if G_UNLIKELY (f->type!=GEL_REFERENCE_FUNC) {
5947 gel_errorout (_("Dereference of non-reference!"));
5948 return NULL;
5949 }
5950
5951 if G_UNLIKELY (f->data.ref->context == 0 &&
5952 f->data.ref->id->protected_) {
5953 gel_errorout (_("Trying to set a protected id '%s'"),
5954 f->data.ref->id->token);
5955 return NULL;
5956 }
5957
5958 return f->data.ref;
5959 }
5960
5961 return NULL;
5962 }
5963
5964 static void
iter_incrementop(GelETree * n)5965 iter_incrementop (GelETree *n)
5966 {
5967 GelETree *l;
5968 mpw_ptr by;
5969
5970 if (n->op.args->any.next == NULL) {
5971 GEL_GET_L(n,l);
5972 by = NULL;
5973 } else {
5974 GelETree *r;
5975 GEL_GET_LR(n,l,r);
5976 if (r->type != GEL_VALUE_NODE) {
5977 gel_errorout (_("Increment not a value!"));
5978 return;
5979 }
5980 by = r->val.value;
5981 }
5982
5983 if G_UNLIKELY (l->type != GEL_IDENTIFIER_NODE &&
5984 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_VELEMENT) &&
5985 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_ELEMENT) &&
5986 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_COL_REGION) &&
5987 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_ROW_REGION) &&
5988 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_DEREFERENCE)) {
5989 gel_errorout (_("Lvalue not an identifier/dereference/matrix location!"));
5990 return;
5991 }
5992
5993 if (l->type == GEL_IDENTIFIER_NODE ||
5994 l->op.oper == GEL_E_DEREFERENCE) {
5995 GelEFunc *f = get_functoset (l);
5996 if G_UNLIKELY (f == NULL) {
5997 return;
5998 } else if G_UNLIKELY (f->type != GEL_VARIABLE_FUNC ||
5999 ! (f->data.user->type == GEL_VALUE_NODE ||
6000 f->data.user->type == GEL_MATRIX_NODE)) {
6001 gel_errorout (_("Trying to increment non-value id '%s'"),
6002 l->id.id->token);
6003 return;
6004 }
6005
6006 if (f->data.user->type == GEL_VALUE_NODE) {
6007 if (by == NULL)
6008 mpw_add_ui (f->data.user->val.value, f->data.user->val.value, 1);
6009 else
6010 mpw_add (f->data.user->val.value, f->data.user->val.value, by);
6011 } else if (f->data.user->type == GEL_MATRIX_NODE) {
6012 gel_matrixw_incr (f->data.user->mat.matrix, by);
6013 }
6014 } else if(l->op.oper == GEL_E_GET_ELEMENT) {
6015 GelMatrixW *mat;
6016 GelETree *index1, *index2;
6017 GEL_GET_XRR (l, index1, index2);
6018
6019 if (index1->type == GEL_VALUE_NODE &&
6020 index2->type == GEL_VALUE_NODE) {
6021 int x, y;
6022
6023 x = iter_get_matrix_index_num (index2, INT_MAX);
6024 if G_UNLIKELY (x < 0)
6025 return;
6026 y = iter_get_matrix_index_num (index1, INT_MAX);
6027 if G_UNLIKELY (y < 0)
6028 return;
6029
6030 mat = iter_get_matrix_p (l->op.args);
6031 if G_UNLIKELY (mat == NULL)
6032 return;
6033
6034 gel_matrixw_incr_element (mat, x, y, by);
6035 } else if ((index1->type == GEL_VALUE_NODE ||
6036 index1->type == GEL_MATRIX_NODE) &&
6037 (index2->type == GEL_VALUE_NODE ||
6038 index2->type == GEL_MATRIX_NODE)) {
6039 int *regx, *regy;
6040 int lx, ly;
6041
6042 if ( ! iter_get_index_regions (index1, index2,
6043 INT_MAX, INT_MAX,
6044 ®y, ®x,
6045 &ly, &lx))
6046 return;
6047
6048 mat = iter_get_matrix_p (l->op.args);
6049 if G_UNLIKELY (mat == NULL) {
6050 g_free (regx);
6051 g_free (regy);
6052 return;
6053 }
6054
6055 gel_matrixw_incr_region (mat, regx, regy, lx, ly, by);
6056 g_free (regx);
6057 g_free (regy);
6058 } else {
6059 gel_errorout (_("Matrix index not an integer or a vector"));
6060 return;
6061 }
6062 } else if(l->op.oper == GEL_E_GET_VELEMENT) {
6063 GelMatrixW *mat;
6064 GelETree *index;
6065 GEL_GET_XR (l, index);
6066
6067 if (index->type == GEL_VALUE_NODE) {
6068 int i;
6069
6070 i = iter_get_matrix_index_num (index, INT_MAX);
6071 if G_UNLIKELY (i < 0)
6072 return;
6073
6074 mat = iter_get_matrix_p (l->op.args);
6075 if G_UNLIKELY (mat == NULL)
6076 return;
6077
6078 gel_matrixw_incr_velement (mat, i, by);
6079 } else if (index->type == GEL_MATRIX_NODE) {
6080 int *reg;
6081 int len;
6082
6083 if G_UNLIKELY ( ! iter_get_index_region (index, INT_MAX,
6084 ®, &len))
6085 return;
6086
6087 mat = iter_get_matrix_p (l->op.args);
6088 if G_UNLIKELY (mat == NULL) {
6089 g_free (reg);
6090 return;
6091 }
6092
6093 gel_matrixw_incr_vregion (mat, reg, len, by);
6094 g_free (reg);
6095 } else {
6096 gel_errorout (_("Matrix index not an integer or a vector"));
6097 return;
6098 }
6099 } else /*l->data.oper == GEL_E_GET_COL_REGION GEL_E_GET_ROW_REGION*/ {
6100 GelMatrixW *mat;
6101 GelETree *index;
6102 GEL_GET_XR (l, index);
6103
6104 if (index->type == GEL_VALUE_NODE ||
6105 index->type == GEL_MATRIX_NODE) {
6106 int *regx = NULL, *regy = NULL;
6107 int lx, ly;
6108 int i;
6109
6110 if (l->op.oper == GEL_E_GET_COL_REGION) {
6111 if G_UNLIKELY ( ! iter_get_index_region (index, INT_MAX, ®x, &lx))
6112 return;
6113 } else {
6114 if G_UNLIKELY ( ! iter_get_index_region (index, INT_MAX, ®y, &ly))
6115 return;
6116 }
6117
6118 mat = iter_get_matrix_p (l->op.args);
6119 if G_UNLIKELY (mat == NULL) {
6120 g_free (regx);
6121 g_free (regy);
6122 return;
6123 }
6124
6125 if (l->op.oper == GEL_E_GET_COL_REGION) {
6126 ly = gel_matrixw_height (mat);
6127 regy = g_new (int, ly);
6128 for (i = 0; i < ly; i++)
6129 regy[i] = i;
6130 } else {
6131 lx = gel_matrixw_width (mat);
6132 regx = g_new (int, lx);
6133 for (i = 0; i < lx; i++)
6134 regx[i] = i;
6135 }
6136
6137 gel_matrixw_incr_region (mat, regx, regy, lx, ly, by);
6138 g_free (regx);
6139 g_free (regy);
6140 } else {
6141 gel_errorout (_("Matrix index not an integer or a vector"));
6142 return;
6143 }
6144 }
6145 replacenode(n,gel_makenum_null ());
6146 }
6147
6148 static void
do_swapwithop(GelETree * l,GelETree * r)6149 do_swapwithop (GelETree *l, GelETree *r)
6150 {
6151 int lx = 0, ly = 0;
6152 int rx = 0, ry = 0;
6153 GelMatrixW *matr, *matl;
6154 GelETree *tmp;
6155
6156 if (l->type == GEL_IDENTIFIER_NODE ||
6157 l->op.oper == GEL_E_DEREFERENCE) {
6158 GelEFunc *lf = get_functoset (l);
6159 if G_UNLIKELY (lf == NULL)
6160 return;
6161 if G_UNLIKELY (lf->type != GEL_VARIABLE_FUNC) {
6162 gel_errorout (_("Can only swap user variables"));
6163 return;
6164 }
6165 if G_UNLIKELY (lf->type != GEL_VARIABLE_FUNC) {
6166 gel_errorout (_("Can only swap user variables"));
6167 return;
6168 }
6169 if (r->type == GEL_IDENTIFIER_NODE ||
6170 r->op.oper == GEL_E_DEREFERENCE) {
6171 GelEFunc *rf = get_functoset (r);
6172 if G_UNLIKELY (rf == NULL)
6173 return;
6174
6175 if G_UNLIKELY (rf->type != GEL_VARIABLE_FUNC) {
6176 gel_errorout (_("Can only swap user variables"));
6177 return;
6178 }
6179
6180 tmp = lf->data.user;
6181 lf->data.user = rf->data.user;
6182 rf->data.user = tmp;
6183 } else if(r->op.oper == GEL_E_GET_ELEMENT) {
6184 GelMatrixW *mat;
6185 GelETree *index1, *index2;
6186 GEL_GET_XRR (r, index1, index2);
6187
6188 if (index1->type == GEL_VALUE_NODE &&
6189 index2->type == GEL_VALUE_NODE) {
6190 int x, y;
6191 GelETree *t;
6192
6193 x = iter_get_matrix_index_num (index2, INT_MAX);
6194 if G_UNLIKELY (x < 0)
6195 return;
6196 y = iter_get_matrix_index_num (index1, INT_MAX);
6197 if G_UNLIKELY (y < 0)
6198 return;
6199
6200 mat = iter_get_matrix_p (r->op.args);
6201 if G_UNLIKELY (mat == NULL)
6202 return;
6203
6204 gel_matrixw_set_at_least_size (mat, x+1, y+1);
6205 gel_matrixw_make_private (mat, TRUE /* kill_type_caches */);
6206 t = gel_matrixw_get_index (mat, x, y);
6207 if (t != NULL) {
6208 tmp = lf->data.user;
6209 lf->data.user = t;
6210 gel_matrixw_set_index (mat, x, y) = tmp;
6211 } else {
6212 gel_matrixw_set_index (mat, x, y) = lf->data.user;
6213 lf->data.user = gel_makenum_ui (0);
6214 }
6215 } else {
6216 gel_errorout (_("Cannot swap matrix regions"));
6217 }
6218 } else if(r->op.oper == GEL_E_GET_VELEMENT) {
6219 GelMatrixW *mat;
6220 GelETree *index;
6221 GEL_GET_XR (r, index);
6222
6223 if (index->type == GEL_VALUE_NODE) {
6224 int i, x, y;
6225 GelETree *t;
6226
6227 i = iter_get_matrix_index_num (index, INT_MAX);
6228 if G_UNLIKELY (i < 0)
6229 return;
6230
6231 mat = iter_get_matrix_p (r->op.args);
6232 if G_UNLIKELY (mat == NULL)
6233 return;
6234
6235
6236 GEL_MATRIXW_VINDEX_TO_INDEX (mat, i, x, y);
6237
6238 gel_matrixw_set_at_least_size (mat, x+1, y+1);
6239 gel_matrixw_make_private (mat, TRUE /* kill_type_caches */);
6240
6241 t = gel_matrixw_get_vindex (mat, i);
6242 if (t != NULL) {
6243 tmp = lf->data.user;
6244 lf->data.user = t;
6245 gel_matrixw_set_index (mat, x, y) = tmp;
6246 } else {
6247 gel_matrixw_set_index (mat, x, y) = lf->data.user;
6248 lf->data.user = gel_makenum_ui (0);
6249 }
6250 } else {
6251 gel_errorout (_("Cannot swap matrix regions"));
6252 }
6253 }
6254 return;
6255 } else if (r->type == GEL_IDENTIFIER_NODE ||
6256 r->op.oper == GEL_E_DEREFERENCE) {
6257 do_swapwithop (r, l);
6258 return;
6259 }
6260
6261 matl = iter_get_matrix_p (l->op.args);
6262 if G_UNLIKELY (matl == NULL)
6263 return;
6264
6265 matr = iter_get_matrix_p (r->op.args);
6266 if G_UNLIKELY (matr == NULL)
6267 return;
6268
6269 if (l->op.oper == GEL_E_GET_ELEMENT) {
6270 GelETree *index1, *index2;
6271 GEL_GET_XRR (l, index1, index2);
6272
6273 if (index1->type == GEL_VALUE_NODE &&
6274 index2->type == GEL_VALUE_NODE) {
6275 lx = iter_get_matrix_index_num (index2, INT_MAX);
6276 if G_UNLIKELY (lx < 0)
6277 return;
6278 ly = iter_get_matrix_index_num (index1, INT_MAX);
6279 if G_UNLIKELY (ly < 0)
6280 return;
6281 } else {
6282 gel_errorout (_("Cannot swap matrix regions"));
6283 return;
6284 }
6285 } else if (l->op.oper == GEL_E_GET_VELEMENT) {
6286 GelETree *index;
6287 GEL_GET_XR (l, index);
6288
6289 if (index->type == GEL_VALUE_NODE) {
6290 int i;
6291
6292 i = iter_get_matrix_index_num (index, INT_MAX);
6293 if G_UNLIKELY (i < 0)
6294 return;
6295
6296 GEL_MATRIXW_VINDEX_TO_INDEX (matl, i, lx, ly);
6297 } else {
6298 gel_errorout (_("Cannot swap matrix regions"));
6299 return;
6300 }
6301 }
6302
6303 if (r->op.oper == GEL_E_GET_ELEMENT) {
6304 GelETree *index1, *index2;
6305 GEL_GET_XRR (r, index1, index2);
6306
6307 if (index1->type == GEL_VALUE_NODE &&
6308 index2->type == GEL_VALUE_NODE) {
6309 rx = iter_get_matrix_index_num (index2, INT_MAX);
6310 if G_UNLIKELY (rx < 0)
6311 return;
6312 ry = iter_get_matrix_index_num (index1, INT_MAX);
6313 if G_UNLIKELY (ry < 0)
6314 return;
6315 } else {
6316 gel_errorout (_("Cannot swap matrix regions"));
6317 return;
6318 }
6319 } else if(r->op.oper == GEL_E_GET_VELEMENT) {
6320 GelETree *index;
6321 GEL_GET_XR (r, index);
6322
6323 if (index->type == GEL_VALUE_NODE) {
6324 int i;
6325
6326 i = iter_get_matrix_index_num (index, INT_MAX);
6327 if G_UNLIKELY (i < 0)
6328 return;
6329
6330 GEL_MATRIXW_VINDEX_TO_INDEX (matl, i, rx, ry);
6331 } else {
6332 gel_errorout (_("Cannot swap matrix regions"));
6333 return;
6334 }
6335 }
6336
6337 gel_matrixw_set_at_least_size (matl, lx+1, ly+1);
6338 gel_matrixw_set_at_least_size (matr, rx+1, ry+1);
6339
6340 if (matl == matr && lx == rx && ly == ry)
6341 return;
6342
6343 gel_matrixw_make_private (matl, TRUE /* kill_type_caches */);
6344 gel_matrixw_make_private (matr, TRUE /* kill_type_caches */);
6345
6346 tmp = gel_matrixw_set_index (matr, rx, ry);
6347 gel_matrixw_set_index (matr, rx, ry) = gel_matrixw_set_index (matl, lx, ly);
6348 gel_matrixw_set_index (matl, lx, ly) = tmp;
6349 }
6350
6351 static void
iter_swapwithop(GelETree * n)6352 iter_swapwithop(GelETree *n)
6353 {
6354 GelETree *l, *r;
6355
6356 GEL_GET_LR(n,l,r);
6357
6358 if G_UNLIKELY (l->type != GEL_IDENTIFIER_NODE &&
6359 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_VELEMENT) &&
6360 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_GET_ELEMENT) &&
6361 !(l->type == GEL_OPERATOR_NODE && l->op.oper == GEL_E_DEREFERENCE)) {
6362 gel_errorout (_("Lvalue not an identifier/dereference/matrix location!"));
6363 return;
6364 }
6365 if G_UNLIKELY (r->type != GEL_IDENTIFIER_NODE &&
6366 !(r->type == GEL_OPERATOR_NODE && r->op.oper == GEL_E_GET_VELEMENT) &&
6367 !(r->type == GEL_OPERATOR_NODE && r->op.oper == GEL_E_GET_ELEMENT) &&
6368 !(r->type == GEL_OPERATOR_NODE && r->op.oper == GEL_E_DEREFERENCE)) {
6369 gel_errorout (_("Lvalue not an identifier/dereference/matrix location!"));
6370 return;
6371 }
6372
6373 do_swapwithop (l, r);
6374
6375 replacenode (n, gel_makenum_null ());
6376 }
6377
6378 static void
iter_parameterop(GelETree * n)6379 iter_parameterop (GelETree *n)
6380 {
6381 GelETree *r,*rr;
6382
6383 GEL_GET_XRR (n, r, rr);
6384
6385 /* FIXME: l should be the set func */
6386
6387 g_assert (r->type == GEL_IDENTIFIER_NODE);
6388
6389 if G_UNLIKELY (d_curcontext() != 0) {
6390 gel_errorout (_("Parameters can only be created in the global context"));
6391 return;
6392 }
6393
6394 if G_UNLIKELY (r->id.id->protected_) {
6395 gel_errorout (_("Trying to set a protected id '%s'"),
6396 r->id.id->token);
6397 return;
6398 }
6399
6400 d_addfunc (d_makevfunc (r->id.id, gel_copynode (rr)));
6401 r->id.id->parameter = 1;
6402
6403 /*remove from arglist so that it doesn't get freed on replacenode*/
6404 n->op.args->any.next->any.next = NULL;
6405 replacenode (n, rr);
6406 }
6407
6408 static void
iter_push_indexes_and_arg(GelCtx * ctx,GelETree * n)6409 iter_push_indexes_and_arg(GelCtx *ctx, GelETree *n)
6410 {
6411 GelETree *l;
6412
6413 GEL_GET_L(n,l);
6414
6415 if (l->op.oper == GEL_E_GET_ELEMENT) {
6416 GelETree *ll,*rr;
6417
6418 GEL_GET_XRR(l,ll,rr);
6419
6420 GE_PUSH_STACK(ctx,n->op.args->any.next,GE_PRE);
6421 GE_PUSH_STACK(ctx,rr,GE_PRE);
6422 ctx->post = FALSE;
6423 ctx->current = ll;
6424 ctx->whackarg = FALSE;
6425 } else if(l->op.oper == GEL_E_GET_VELEMENT ||
6426 l->op.oper == GEL_E_GET_COL_REGION ||
6427 l->op.oper == GEL_E_GET_ROW_REGION) {
6428 GelETree *ll;
6429
6430 GEL_GET_XR(l,ll);
6431
6432 GE_PUSH_STACK(ctx,n->op.args->any.next,GE_PRE);
6433 ctx->post = FALSE;
6434 ctx->current = ll;
6435 ctx->whackarg = FALSE;
6436 } else {
6437 ctx->post = FALSE;
6438 ctx->current = n->op.args->any.next;
6439 ctx->whackarg = FALSE;
6440 }
6441 }
6442
6443 static void
iter_do_push_index(GelCtx * ctx,GelETree * l)6444 iter_do_push_index (GelCtx *ctx, GelETree *l)
6445 {
6446 if (l->op.oper == GEL_E_GET_ELEMENT) {
6447 GelETree *ll,*rr;
6448
6449 GEL_GET_XRR(l,ll,rr);
6450
6451 GE_PUSH_STACK(ctx,rr,GE_PRE);
6452 GE_PUSH_STACK(ctx,ll,GE_PRE);
6453 } else if(l->op.oper == GEL_E_GET_VELEMENT ||
6454 l->op.oper == GEL_E_GET_COL_REGION ||
6455 l->op.oper == GEL_E_GET_ROW_REGION) {
6456 GelETree *ll;
6457
6458 GEL_GET_XR(l,ll);
6459 GE_PUSH_STACK(ctx,ll,GE_PRE);
6460 }
6461 }
6462
6463 static void
iter_push_left_indexes_only(GelCtx * ctx,GelETree * n)6464 iter_push_left_indexes_only(GelCtx *ctx, GelETree *n)
6465 {
6466 GelETree *l;
6467
6468 GEL_GET_L(n,l);
6469
6470 iter_do_push_index (ctx, l);
6471 iter_pop_stack (ctx);
6472 }
6473
6474 static void
iter_push_indexes_both(GelCtx * ctx,GelETree * n)6475 iter_push_indexes_both (GelCtx *ctx, GelETree *n)
6476 {
6477 GelETree *l,*r;
6478
6479 GEL_GET_LR(n,l,r);
6480
6481 iter_do_push_index (ctx, l);
6482 iter_do_push_index (ctx, r);
6483
6484 iter_pop_stack (ctx);
6485 }
6486
6487 static void
iter_get_velement(GelETree * n)6488 iter_get_velement (GelETree *n)
6489 {
6490 GelETree *m;
6491 GelETree *index;
6492
6493 GEL_GET_LR (n, m, index);
6494
6495 if G_UNLIKELY (m->type != GEL_MATRIX_NODE) {
6496 gel_errorout (_("Index works only on matrices"));
6497 return;
6498 }
6499
6500 if (index->type == GEL_VALUE_NODE) {
6501 GelETree *t;
6502 int i = iter_get_matrix_index_num (index, gel_matrixw_elements (m->mat.matrix));
6503 if G_UNLIKELY (i < 0)
6504 return;
6505 t = gel_copynode (gel_matrixw_vindex (m->mat.matrix, i));
6506 replacenode (n, t);
6507 } else if (index->type == GEL_MATRIX_NODE) {
6508 GelMatrixW *vec;
6509 int matsize = gel_matrixw_elements (m->mat.matrix);
6510 gboolean quoted = m->mat.quoted;
6511 int *reg;
6512 int reglen;
6513
6514 reg = iter_get_matrix_index_vector (index, matsize, ®len);
6515 if G_UNLIKELY (reg == NULL)
6516 return;
6517
6518 vec = gel_matrixw_get_vregion (m->mat.matrix, reg, reglen);
6519 g_free (reg);
6520
6521 freetree_full (n, TRUE /* freeargs */, FALSE /* kill */);
6522 n->type = GEL_MATRIX_NODE;
6523 n->mat.matrix = vec;
6524 n->mat.quoted = quoted;
6525 } else if (index->type == GEL_NULL_NODE) {
6526 freetree_full (n, TRUE, FALSE);
6527 gel_makenum_null_from (n);
6528 } else {
6529 gel_errorout (_("Vector index not an integer or a vector"));
6530 }
6531 }
6532
6533 static void
iter_get_element(GelETree * n)6534 iter_get_element (GelETree *n)
6535 {
6536 GelETree *m, *index1, *index2;
6537
6538 GEL_GET_LRR (n, m, index1, index2);
6539
6540 if G_UNLIKELY (m->type != GEL_MATRIX_NODE) {
6541 gel_errorout (_("Index works only on matrices"));
6542 return;
6543 } else if G_UNLIKELY (index1->type != GEL_NULL_NODE &&
6544 index1->type != GEL_MATRIX_NODE &&
6545 index1->type != GEL_VALUE_NODE &&
6546 index2->type != GEL_NULL_NODE &&
6547 index2->type != GEL_MATRIX_NODE &&
6548 index2->type != GEL_VALUE_NODE) {
6549 gel_errorout (_("Matrix index not an integer or a vector"));
6550 return;
6551 } else if G_UNLIKELY (index1->type == GEL_NULL_NODE ||
6552 index2->type == GEL_NULL_NODE) {
6553 /* This is rather unlikely, most of the time we don't
6554 * want NULLs */
6555 freetree_full (n, TRUE, FALSE);
6556 gel_makenum_null_from (n);
6557 return;
6558
6559
6560 /* this is where we get to the real code */
6561 } else if (index1->type == GEL_VALUE_NODE &&
6562 index2->type == GEL_VALUE_NODE) {
6563 int x, y;
6564 GelETree *t;
6565
6566 x = iter_get_matrix_index_num (index2, gel_matrixw_width (m->mat.matrix));
6567 if G_UNLIKELY (x < 0)
6568 return;
6569 y = iter_get_matrix_index_num (index1, gel_matrixw_height (m->mat.matrix));
6570 if G_UNLIKELY (y < 0)
6571 return;
6572
6573 /* make sure we don't free the args just yet */
6574 n->op.args = NULL;
6575
6576 /* we will free this matrix in just a little bit */
6577 t = gel_matrixw_get_index (m->mat.matrix, x, y);
6578 if (m->mat.matrix->m->use == 1 && t != NULL) {
6579 replacenode (n, t);
6580 gel_matrixw_set_index (m->mat.matrix, x, y) = NULL;
6581 } else if (t == NULL) {
6582 freetree_full (n, FALSE /* freeargs */, FALSE /* kill */);
6583 gel_makenum_ui_from (n, 0);
6584 } else {
6585 replacenode (n, gel_copynode (t));
6586 }
6587
6588 /* free the args now */
6589 gel_freetree (m);
6590 gel_freetree (index1);
6591 gel_freetree (index2);
6592 /* Now at least one is a matrix and the other is a value */
6593 /*} else if ((index1->type == GEL_VALUE_NODE ||
6594 index1->type == GEL_MATRIX_NODE) &&
6595 (index2->type == GEL_VALUE_NODE ||
6596 index2->type == GEL_MATRIX_NODE)) {*/
6597 } else {
6598 GelMatrixW *mat;
6599 int *regx, *regy;
6600 int lx, ly;
6601 int maxx, maxy;
6602 gboolean quoted = m->mat.quoted;
6603
6604 maxx = gel_matrixw_width (m->mat.matrix);
6605 maxy = gel_matrixw_height (m->mat.matrix);
6606
6607 if ( ! iter_get_index_regions (index1, index2,
6608 maxy, maxx,
6609 ®y, ®x,
6610 &ly, &lx))
6611 return;
6612
6613 mat = gel_matrixw_get_region (m->mat.matrix, regx, regy, lx, ly);
6614 g_free (regx);
6615 g_free (regy);
6616
6617 freetree_full (n, TRUE /* freeargs */, FALSE /* kill */);
6618 n->type = GEL_MATRIX_NODE;
6619 n->mat.matrix = mat;
6620 n->mat.quoted = quoted;
6621 }
6622 }
6623
6624 static void
iter_get_region(GelETree * n,gboolean col)6625 iter_get_region (GelETree *n, gboolean col)
6626 {
6627 GelETree *m, *index;
6628
6629 GEL_GET_LR (n, m, index);
6630
6631 if G_UNLIKELY (m->type != GEL_MATRIX_NODE) {
6632 gel_errorout (_("Index works only on matrices"));
6633 return;
6634 } else if G_LIKELY (index->type == GEL_VALUE_NODE ||
6635 index->type == GEL_MATRIX_NODE) {
6636 GelMatrixW *mat;
6637 int *regx, *regy;
6638 int lx, ly;
6639 int i;
6640 int maxx, maxy;
6641 gboolean quoted = m->mat.quoted;
6642
6643 maxx = gel_matrixw_width (m->mat.matrix);
6644 maxy = gel_matrixw_height (m->mat.matrix);
6645
6646 if (col) {
6647 if G_UNLIKELY ( ! iter_get_index_region (index, maxx, ®x, &lx))
6648 return;
6649 regy = g_new (int, maxy);
6650 for (i = 0; i < maxy; i++)
6651 regy[i] = i;
6652 ly = maxy;
6653 } else {
6654 if G_UNLIKELY ( ! iter_get_index_region (index, maxy, ®y, &ly))
6655 return;
6656 regx = g_new (int, maxx);
6657 for (i = 0; i < maxx; i++)
6658 regx[i] = i;
6659 lx = maxx;
6660 }
6661
6662 mat = gel_matrixw_get_region (m->mat.matrix, regx, regy, lx, ly);
6663 g_free (regx);
6664 g_free (regy);
6665
6666 freetree_full (n, TRUE /* freeargs */, FALSE /* kill */);
6667 n->type = GEL_MATRIX_NODE;
6668 n->mat.matrix = mat;
6669 n->mat.quoted = quoted;
6670 } else if (index->type == GEL_NULL_NODE) {
6671 freetree_full (n, TRUE, FALSE);
6672 gel_makenum_null_from (n);
6673 } else {
6674 gel_errorout (_("Matrix index not an integer or a vector"));
6675 }
6676 }
6677
6678 static guint32 iter_get_arg(GelETree *n) G_GNUC_PURE;
6679 static guint32
iter_get_arg(GelETree * n)6680 iter_get_arg(GelETree *n)
6681 {
6682 switch(n->type) {
6683 case GEL_VALUE_NODE: return GO_VALUE;
6684 case GEL_MATRIX_NODE: return GO_MATRIX;
6685 case GEL_STRING_NODE: return GO_STRING;
6686 case GEL_FUNCTION_NODE: return GO_FUNCTION;
6687 case GEL_IDENTIFIER_NODE: return GO_IDENTIFIER;
6688 case GEL_POLYNOMIAL_NODE: return GO_POLYNOMIAL;
6689 case GEL_BOOL_NODE: return GO_BOOL;
6690 default: return 0;
6691 }
6692 }
6693
6694 static char *
iter_get_arg_name(guint32 arg)6695 iter_get_arg_name(guint32 arg)
6696 {
6697 switch(arg) {
6698 case GO_VALUE: return _("number");
6699 case GO_MATRIX: return _("matrix");
6700 case GO_STRING: return _("string");
6701 case GO_FUNCTION: return _("function");
6702 case GO_IDENTIFIER: return _("identifier");
6703 case GO_POLYNOMIAL: return _("polynomial");
6704 case GO_BOOL: return _("boolean");
6705 default:
6706 g_assert_not_reached();
6707 return NULL;
6708 }
6709 }
6710
6711 static char *
iter_get_op_name(int oper)6712 iter_get_op_name(int oper)
6713 {
6714 static char *name = NULL;
6715 g_free(name);
6716 name = NULL;
6717
6718 switch(oper) {
6719 case GEL_E_SEPAR:
6720 case GEL_E_EQUALS:
6721 case GEL_E_DEFEQUALS:
6722 case GEL_E_SWAPWITH:
6723 case GEL_E_INCREMENT:
6724 case GEL_E_INCREMENT_BY:
6725 case GEL_E_PARAMETER: break;
6726 case GEL_E_ABS: name = g_strdup(_("Absolute value")); break;
6727 case GEL_E_PLUS: name = g_strdup(_("Addition")); break;
6728 case GEL_E_ELTPLUS: name = g_strdup(_("Element by element addition")); break;
6729 case GEL_E_MINUS: name = g_strdup(_("Subtraction")); break;
6730 case GEL_E_ELTMINUS: name = g_strdup(_("Element by element subtraction")); break;
6731 case GEL_E_MUL: name = g_strdup(_("Multiplication")); break;
6732 case GEL_E_ELTMUL: name = g_strdup(_("Element by element multiplication")); break;
6733 case GEL_E_DIV: name = g_strdup(_("Division")); break;
6734 case GEL_E_ELTDIV: name = g_strdup(_("Element by element division")); break;
6735 case GEL_E_BACK_DIV: name = g_strdup(_("Back division")); break;
6736 case GEL_E_ELT_BACK_DIV: name = g_strdup(_("Element by element back division")); break;
6737 case GEL_E_MOD: name = g_strdup(_("Modulo")); break;
6738 case GEL_E_ELTMOD: name = g_strdup(_("Element by element modulo")); break;
6739 case GEL_E_NEG: name = g_strdup(_("Negation")); break;
6740 case GEL_E_EXP: name = g_strdup(_("Power")); break;
6741 case GEL_E_ELTEXP: name = g_strdup(_("Element by element power")); break;
6742 case GEL_E_FACT: name = g_strdup(_("Factorial")); break;
6743 case GEL_E_DBLFACT: name = g_strdup(_("Double factorial")); break;
6744 case GEL_E_TRANSPOSE: name = g_strdup(_("Transpose")); break;
6745 case GEL_E_CONJUGATE_TRANSPOSE: name = g_strdup(_("ConjugateTranspose")); break;
6746 case GEL_E_CMP_CMP: name = g_strdup(_("Comparison (<=>)")); break;
6747 case GEL_E_LOGICAL_XOR: name = g_strdup(_("XOR")); break;
6748 case GEL_E_LOGICAL_NOT: name = g_strdup(_("NOT")); break;
6749 default: break;
6750 }
6751
6752 return name;
6753 }
6754
6755 static gboolean
iter_call2(GelCtx * ctx,const GelOper * op,GelETree * n)6756 iter_call2(GelCtx *ctx, const GelOper *op, GelETree *n)
6757 {
6758 GelETree *l,*r;
6759 guint32 arg1,arg2;
6760 int i;
6761
6762 GEL_GET_LR(n,l,r);
6763
6764 arg1 = iter_get_arg(l);
6765 arg2 = iter_get_arg(r);
6766
6767 if G_UNLIKELY (arg1 == 0 || arg2 == 0) {
6768 gel_errorout (_("Bad types for '%s'"),
6769 iter_get_op_name(n->op.oper));
6770 return TRUE;
6771 }
6772
6773 for(i=0;i<OP_TABLE_LEN;i++) {
6774 if(op->prim[i].arg[0]&arg1 &&
6775 op->prim[i].arg[1]&arg2) {
6776 return op->prim[i].evalfunc(ctx,n,l,r);
6777 }
6778 }
6779 gel_errorout (_("%s not defined on <%s> and <%s>"),
6780 iter_get_op_name(n->op.oper),
6781 iter_get_arg_name(arg1),
6782 iter_get_arg_name(arg2));
6783 return TRUE;
6784 }
6785
6786 static gboolean
iter_call1(GelCtx * ctx,const GelOper * op,GelETree * n)6787 iter_call1(GelCtx *ctx, const GelOper *op, GelETree *n)
6788 {
6789 GelETree *l;
6790 guint32 arg1;
6791 int i;
6792
6793 GEL_GET_L(n,l);
6794
6795 arg1 = iter_get_arg(l);
6796
6797 if G_UNLIKELY (arg1 == 0) {
6798 gel_errorout (_("Bad type for '%s'"),
6799 iter_get_op_name(n->op.oper));
6800 return TRUE;
6801 }
6802
6803 for(i=0;i<OP_TABLE_LEN;i++) {
6804 if(op->prim[i].arg[0]&arg1) {
6805 return op->prim[i].evalfunc(ctx,n,l);
6806 }
6807 }
6808 gel_errorout (_("%s not defined on <%s>"),
6809 iter_get_op_name(n->op.oper),
6810 iter_get_arg_name(arg1));
6811 return TRUE;
6812 }
6813
6814 static void
iter_region_sep_op(GelCtx * ctx,GelETree * n)6815 iter_region_sep_op (GelCtx *ctx, GelETree *n)
6816 {
6817 GelETree *from, *to, *by = NULL;
6818 GelETree *vect = NULL;
6819 GelMatrix *mat;
6820 int bysgn = 1, cmp, initcmp, count, i;
6821 mpw_t tmp;
6822
6823 if (n->op.oper == GEL_E_REGION_SEP_BY) {
6824 GEL_GET_LRR (n, from, by, to);
6825 if G_UNLIKELY (from->type != GEL_VALUE_NODE ||
6826 to->type != GEL_VALUE_NODE ||
6827 by->type != GEL_VALUE_NODE) {
6828 gel_errorout (_("Vector building only works on numbers"));
6829 return;
6830 }
6831 initcmp = cmp = mpw_cmp (from->val.value, to->val.value);
6832 bysgn = mpw_sgn (by->val.value);
6833
6834 if G_UNLIKELY ((cmp > 0 && bysgn > 0) ||
6835 (cmp != 0 && bysgn == 0) ||
6836 (cmp < 0 && bysgn < 0)) {
6837 /* FIXME: perhaps we should just return null like octave? */
6838 gel_errorout (_("Impossible arguments to vector building operator"));
6839 return;
6840 }
6841 } else {
6842 GEL_GET_LR (n, from, to);
6843 if G_UNLIKELY (from->type != GEL_VALUE_NODE ||
6844 to->type != GEL_VALUE_NODE) {
6845 gel_errorout (_("Vector building only works on numbers"));
6846 return;
6847 }
6848 initcmp = cmp = mpw_cmp (from->val.value, to->val.value);
6849 if (cmp > 0)
6850 bysgn = -1;
6851 }
6852
6853 count = 0;
6854 mpw_init_set (tmp, from->val.value);
6855 for (;;) {
6856 GelETree *t = gel_makenum (tmp);
6857
6858 t->any.next = vect;
6859 vect = t;
6860 count ++;
6861
6862 if (cmp == 0 || cmp != initcmp)
6863 break;
6864
6865 if (by != NULL)
6866 mpw_add (tmp, tmp, by->val.value);
6867 else if (bysgn == 1)
6868 mpw_add_ui (tmp, tmp, 1);
6869 else
6870 mpw_sub_ui (tmp, tmp, 1);
6871
6872 cmp = mpw_cmp (tmp, to->val.value);
6873
6874 if (cmp != 0 && cmp != initcmp) {
6875 if (mpw_is_real_part_float (tmp)) {
6876 mpw_t tmp2;
6877 int newcmp;
6878
6879 /* maybe we just missed it, let's look back within 2^-20 of the by and see */
6880 if (by != NULL) {
6881 mpfr_ptr f;
6882 /* by is definitely mpfr */
6883 mpw_init_set (tmp2, by->val.value);
6884 mpw_make_copy_real (tmp2);
6885 f = mpw_peek_real_mpf (tmp2);
6886 mpfr_mul_2si (f, f, -20, GMP_RNDN);
6887 } else {
6888 mpw_init (tmp2);
6889 mpw_set_d (tmp2, 1.0/1048576.0 /* 2^-20 */);
6890 }
6891
6892 mpw_sub (tmp2, tmp, tmp2);
6893
6894 newcmp = mpw_cmp (tmp2, to->val.value);
6895 mpw_clear (tmp2);
6896
6897 if (newcmp != initcmp) {
6898 break;
6899 } else {
6900 /* don't use x, but use the to, x might be too far */
6901 mpw_set (tmp, to->val.value);
6902 }
6903 } else {
6904 break;
6905 }
6906 }
6907 }
6908 mpw_clear (tmp);
6909
6910 mat = gel_matrix_new ();
6911 gel_matrix_set_size (mat, count, 1, FALSE /* padding */);
6912
6913 for (i = count-1; i >= 0; i--) {
6914 GelETree *t = vect;
6915 gel_matrix_index (mat, i, 0) = t;
6916 vect = vect->any.next;
6917 t->any.next = NULL;
6918 }
6919
6920 freetree_full (n, TRUE /* freeargs */, FALSE /* kill */);
6921 n->type = GEL_MATRIX_NODE;
6922 n->mat.matrix = gel_matrixw_new_with_matrix (mat);
6923 n->mat.quoted = TRUE;
6924 }
6925
6926 /*The first pass over an operator (sometimes it's enough and we don't go
6927 for a second pass*/
6928 static gboolean
iter_operator_pre(GelCtx * ctx)6929 iter_operator_pre(GelCtx *ctx)
6930 {
6931 GelETree *n = ctx->current;
6932
6933 EDEBUG(" OPERATOR PRE");
6934
6935 switch(n->op.oper) {
6936 case GEL_E_EQUALS:
6937 case GEL_E_DEFEQUALS:
6938 EDEBUG(" EQUALS PRE");
6939 GE_PUSH_STACK (ctx, n,
6940 GE_ADDWHACKARG (GE_POST,
6941 ctx->whackarg));
6942 iter_push_indexes_and_arg(ctx,n);
6943 break;
6944
6945 case GEL_E_INCREMENT:
6946 EDEBUG(" INCREMENT PRE");
6947 GE_PUSH_STACK (ctx, n,
6948 GE_ADDWHACKARG (GE_POST,
6949 ctx->whackarg));
6950 iter_push_left_indexes_only(ctx,n);
6951 break;
6952
6953 case GEL_E_INCREMENT_BY:
6954 EDEBUG(" EQUALS PRE");
6955 GE_PUSH_STACK (ctx, n,
6956 GE_ADDWHACKARG (GE_POST,
6957 ctx->whackarg));
6958 iter_push_indexes_and_arg(ctx,n);
6959 break;
6960
6961 case GEL_E_SWAPWITH:
6962 EDEBUG(" SWAPWITH PRE");
6963 GE_PUSH_STACK (ctx, n,
6964 GE_ADDWHACKARG (GE_POST,
6965 ctx->whackarg));
6966 iter_push_indexes_both(ctx,n);
6967 break;
6968
6969 case GEL_E_PARAMETER:
6970 EDEBUG(" PARAMETER PRE");
6971 GE_PUSH_STACK (ctx, n,
6972 GE_ADDWHACKARG (GE_POST,
6973 ctx->whackarg));
6974 /* Push third parameter (the value) */
6975 ctx->post = FALSE;
6976 ctx->current = n->op.args->any.next->any.next;
6977 ctx->whackarg = FALSE;
6978 break;
6979
6980 case GEL_E_EXP:
6981 case GEL_E_ELTEXP:
6982 EDEBUG(" PUSH US AS POST AND ALL ARGUMENTS AS PRE (no modulo on second)");
6983 GE_PUSH_STACK (ctx, n,
6984 GE_ADDWHACKARG (GE_POST,
6985 ctx->whackarg));
6986 iter_push_two_args_no_modulo_on_2 (ctx, n->op.args);
6987 break;
6988
6989 case GEL_E_SEPAR:
6990 EDEBUG(" PUSH US AS POST AND ALL ARGUMENTS AS PRE WITH "
6991 " WHACKARGS");
6992 GE_PUSH_STACK (ctx, n,
6993 GE_ADDWHACKARG (GE_POST,
6994 ctx->whackarg));
6995 n->op.args = iter_push_args_whack (ctx, n->op.args, n->op.nargs);
6996 break;
6997
6998 case GEL_E_ABS:
6999 case GEL_E_PLUS:
7000 case GEL_E_ELTPLUS:
7001 case GEL_E_MINUS:
7002 case GEL_E_ELTMINUS:
7003 case GEL_E_MUL:
7004 case GEL_E_ELTMUL:
7005 case GEL_E_DIV:
7006 case GEL_E_ELTDIV:
7007 case GEL_E_BACK_DIV:
7008 case GEL_E_ELT_BACK_DIV:
7009 case GEL_E_MOD:
7010 case GEL_E_ELTMOD:
7011 case GEL_E_NEG:
7012 case GEL_E_FACT:
7013 case GEL_E_DBLFACT:
7014 case GEL_E_TRANSPOSE:
7015 case GEL_E_CONJUGATE_TRANSPOSE:
7016 case GEL_E_CMP_CMP:
7017 case GEL_E_LOGICAL_XOR:
7018 case GEL_E_LOGICAL_NOT:
7019 case GEL_E_RETURN:
7020 case GEL_E_GET_VELEMENT:
7021 case GEL_E_GET_ELEMENT:
7022 case GEL_E_GET_ROW_REGION:
7023 case GEL_E_GET_COL_REGION:
7024 case GEL_E_REGION_SEP:
7025 case GEL_E_REGION_SEP_BY:
7026 EDEBUG(" PUSH US AS POST AND ALL ARGUMENTS AS PRE");
7027 GE_PUSH_STACK (ctx, n,
7028 GE_ADDWHACKARG (GE_POST,
7029 ctx->whackarg));
7030 iter_push_args (ctx, n->op.args, n->op.nargs);
7031 break;
7032
7033 case GEL_E_CALL:
7034 EDEBUG(" CHANGE CALL TO DIRECTCALL AND EVAL THE FIRST ARGUMENT");
7035 n->op.oper = GEL_E_DIRECTCALL;
7036 GE_PUSH_STACK (ctx, n,
7037 GE_ADDWHACKARG (GE_PRE,
7038 ctx->whackarg));
7039 /* eval first argument */
7040 ctx->current = n->op.args;
7041 ctx->post = FALSE;
7042 ctx->whackarg = FALSE;
7043 break;
7044
7045 /*in case of DIRECTCALL we don't evaluate the first argument*/
7046 case GEL_E_DIRECTCALL:
7047 /*if there are arguments to evaluate*/
7048 if(n->op.args->any.next) {
7049 GelEFunc *f;
7050 EDEBUG(" DIRECT:PUSH US AS POST AND 2nd AND HIGHER ARGS AS PRE");
7051 GE_PUSH_STACK (ctx, n,
7052 GE_ADDWHACKARG (GE_POST,
7053 ctx->whackarg));
7054 f = get_func_from_arg (n, TRUE /* silent */);
7055 if (f != NULL && f->no_mod_all_args)
7056 iter_push_args_no_modulo (ctx,
7057 n->op.args->any.next,
7058 n->op.nargs - 1);
7059 else
7060 iter_push_args (ctx,
7061 n->op.args->any.next,
7062 n->op.nargs - 1);
7063 } else {
7064 EDEBUG(" DIRECT:JUST GO TO POST");
7065 /*just go to post immediately*/
7066 ctx->post = TRUE;
7067 }
7068 break;
7069
7070 /*these should have been translated to GEL_COMPARE_NODEs*/
7071 case GEL_E_EQ_CMP:
7072 case GEL_E_NE_CMP:
7073 case GEL_E_LT_CMP:
7074 case GEL_E_GT_CMP:
7075 case GEL_E_LE_CMP:
7076 case GEL_E_GE_CMP:
7077 g_assert_not_reached();
7078
7079 case GEL_E_LOGICAL_AND:
7080 EDEBUG(" LOGICAL AND");
7081 GE_PUSH_STACK (ctx, n,
7082 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7083 GE_PUSH_STACK(ctx,n->op.args,GE_AND);
7084 ctx->post = FALSE;
7085 ctx->current = n->op.args;
7086 ctx->whackarg = FALSE;
7087 break;
7088 case GEL_E_LOGICAL_OR:
7089 EDEBUG(" LOGICAL OR");
7090 GE_PUSH_STACK (ctx, n,
7091 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7092 GE_PUSH_STACK(ctx,n->op.args,GE_OR);
7093 ctx->post = FALSE;
7094 ctx->current = n->op.args;
7095 ctx->whackarg = FALSE;
7096 break;
7097
7098 case GEL_E_WHILE_CONS:
7099 iter_loop(ctx,n,FALSE,TRUE);
7100 break;
7101 case GEL_E_UNTIL_CONS:
7102 iter_loop(ctx,n,FALSE,FALSE);
7103 break;
7104 case GEL_E_DOWHILE_CONS:
7105 iter_loop(ctx,n,TRUE,TRUE);
7106 break;
7107 case GEL_E_DOUNTIL_CONS:
7108 iter_loop(ctx,n,TRUE,FALSE);
7109 break;
7110
7111 case GEL_E_IF_CONS:
7112 case GEL_E_IFELSE_CONS:
7113 EDEBUG(" IF/IFELSE PRE");
7114 GE_PUSH_STACK (ctx, n,
7115 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7116 ctx->post = FALSE;
7117 ctx->current = n->op.args;
7118 ctx->whackarg = FALSE;
7119 break;
7120
7121 case GEL_E_DEREFERENCE:
7122 if(!iter_derefvarop(ctx,n))
7123 return FALSE;
7124 if (ctx->whackarg) {
7125 ctx->current = NULL;
7126 gel_freetree (n);
7127 } else {
7128 if ((n->type == GEL_VALUE_NODE ||
7129 n->type == GEL_MATRIX_NODE) &&
7130 ctx->modulo != NULL)
7131 mod_node (n, ctx->modulo);
7132 }
7133 iter_pop_stack(ctx);
7134 break;
7135
7136 case GEL_E_FOR_CONS:
7137 case GEL_E_FORBY_CONS:
7138 case GEL_E_SUM_CONS:
7139 case GEL_E_SUMBY_CONS:
7140 case GEL_E_PROD_CONS:
7141 case GEL_E_PRODBY_CONS:
7142 GE_PUSH_STACK (ctx, n,
7143 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7144 iter_push_args (ctx, n->op.args->any.next, n->op.nargs - 2);
7145 break;
7146
7147 case GEL_E_FORIN_CONS:
7148 case GEL_E_SUMIN_CONS:
7149 case GEL_E_PRODIN_CONS:
7150 GE_PUSH_STACK (ctx, n,
7151 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7152 ctx->current = n->op.args->any.next;
7153 ctx->post = FALSE;
7154 ctx->whackarg = FALSE;
7155 break;
7156
7157 case GEL_E_EXCEPTION:
7158 if (ctx->whackarg) {
7159 ctx->current = NULL;
7160 gel_freetree (n);
7161 }
7162 return FALSE;
7163
7164 case GEL_E_BAILOUT:
7165 if (ctx->whackarg) {
7166 ctx->current = NULL;
7167 gel_freetree (n);
7168 }
7169 iter_bailout_op(ctx);
7170 break;
7171
7172 case GEL_E_CONTINUE:
7173 if (ctx->whackarg) {
7174 ctx->current = NULL;
7175 gel_freetree (n);
7176 }
7177 iter_continue_break_op(ctx,TRUE);
7178 break;
7179
7180 case GEL_E_BREAK:
7181 if (ctx->whackarg) {
7182 ctx->current = NULL;
7183 gel_freetree (n);
7184 }
7185 iter_continue_break_op(ctx,FALSE);
7186 break;
7187
7188 case GEL_E_QUOTE:
7189 if (ctx->whackarg) {
7190 ctx->current = NULL;
7191 gel_freetree (n);
7192 } else {
7193 /* Just replace us with the quoted thing */
7194 GelETree *arg = n->op.args;
7195 n->op.args = NULL;
7196 replacenode (n, arg);
7197 }
7198 iter_pop_stack(ctx);
7199 break;
7200
7201 case GEL_E_REFERENCE:
7202 {
7203 GelETree *t;
7204 GelEFunc *rf;
7205
7206 if (ctx->whackarg) {
7207 ctx->current = NULL;
7208 gel_freetree (n);
7209 }
7210
7211 /* If doesn't exist, make it and set it to null */
7212 t = n->op.args;
7213 rf = d_lookup_global (t->id.id);
7214 if (rf == NULL) {
7215 d_addfunc (d_makevfunc (t->id.id,
7216 gel_makenum_null ()));
7217 }
7218
7219 iter_pop_stack(ctx);
7220 break;
7221 }
7222
7223 case GEL_E_MOD_CALC:
7224 /* Push modulo op, so that we may push the
7225 * first argument once we have gotten a modulo */
7226 GE_PUSH_STACK (ctx, n,
7227 GE_ADDWHACKARG (GE_MODULOOP, ctx->whackarg));
7228 ctx->post = FALSE;
7229 ctx->current = n->op.args->any.next;
7230 ctx->whackarg = FALSE;
7231 break;
7232
7233 default:
7234 gel_errorout (_("Unexpected operator!"));
7235 #ifdef EVAL_DEBUG
7236 printf ("!!!!!!!!!!!!!!!UNEXPECTED_OPERATOR PRE (%p) (%d)\n", n, n->op.oper);
7237 #endif
7238 GE_PUSH_STACK (ctx, n,
7239 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7240 break;
7241 }
7242 return TRUE;
7243 }
7244
7245 static gboolean
iter_operator_post(GelCtx * ctx,gboolean * repushed)7246 iter_operator_post (GelCtx *ctx, gboolean *repushed)
7247 {
7248 GelETree *n = ctx->current;
7249 GelETree *r;
7250 EDEBUG(" OPERATOR POST");
7251 switch(n->op.oper) {
7252 case GEL_E_SEPAR:
7253 /* By now there is only one argument and that
7254 is the last one */
7255 r = n->op.args;
7256 n->op.args = NULL;
7257 replacenode (n, r);
7258 iter_pop_stack (ctx);
7259 break;
7260
7261 case GEL_E_EQUALS:
7262 case GEL_E_DEFEQUALS:
7263 EDEBUG(" EQUALS POST");
7264 iter_equalsop(n);
7265 iter_pop_stack(ctx);
7266 break;
7267
7268 case GEL_E_INCREMENT:
7269 case GEL_E_INCREMENT_BY:
7270 EDEBUG(" INCREMENT POST");
7271 iter_incrementop(n);
7272 iter_pop_stack(ctx);
7273 break;
7274
7275 case GEL_E_SWAPWITH:
7276 EDEBUG(" SWAPWITH POST");
7277 iter_swapwithop(n);
7278 iter_pop_stack(ctx);
7279 break;
7280
7281 case GEL_E_PARAMETER:
7282 EDEBUG(" PARAMETER POST");
7283 iter_parameterop (n);
7284 iter_pop_stack (ctx);
7285 break;
7286
7287 case GEL_E_PLUS:
7288 case GEL_E_ELTPLUS:
7289 case GEL_E_MINUS:
7290 case GEL_E_ELTMINUS:
7291 case GEL_E_MUL:
7292 case GEL_E_ELTMUL:
7293 case GEL_E_DIV:
7294 case GEL_E_ELTDIV:
7295 case GEL_E_BACK_DIV:
7296 case GEL_E_ELT_BACK_DIV:
7297 case GEL_E_MOD:
7298 case GEL_E_ELTMOD:
7299 case GEL_E_EXP:
7300 case GEL_E_ELTEXP:
7301 case GEL_E_CMP_CMP:
7302 case GEL_E_LOGICAL_XOR:
7303 if(!iter_call2(ctx,&prim_table[n->op.oper],n))
7304 return FALSE;
7305 if (ctx->modulo != NULL &&
7306 (n->type == GEL_VALUE_NODE ||
7307 /* FIXME: note, most matrix operations already
7308 * mod, so this will just make things slower,
7309 * but currently it is needed for correct
7310 * behaviour */
7311 n->type == GEL_MATRIX_NODE) &&
7312 ! ctx->whackarg)
7313 mod_node (n, ctx->modulo);
7314 iter_pop_stack(ctx);
7315 break;
7316
7317 case GEL_E_ABS:
7318 case GEL_E_NEG:
7319 case GEL_E_FACT:
7320 case GEL_E_DBLFACT:
7321 case GEL_E_TRANSPOSE:
7322 case GEL_E_CONJUGATE_TRANSPOSE:
7323 case GEL_E_LOGICAL_NOT:
7324 if(!iter_call1(ctx,&prim_table[n->op.oper],n))
7325 return FALSE;
7326 if (ctx->modulo != NULL &&
7327 (n->type == GEL_VALUE_NODE ||
7328 /* FIXME: note, most matrix operations already
7329 * mod, so this will just make things slower,
7330 * but currently it is needed for correct
7331 * behaviour */
7332 n->type == GEL_MATRIX_NODE) &&
7333 ! ctx->whackarg)
7334 mod_node (n, ctx->modulo);
7335 iter_pop_stack(ctx);
7336 break;
7337
7338 case GEL_E_MOD_CALC:
7339 /* FIXME: maybe we should always replace things here,
7340 * not just for values and matrices */
7341 if (n->op.args->type == GEL_BOOL_NODE ||
7342 n->op.args->type == GEL_VALUE_NODE ||
7343 n->op.args->type == GEL_MATRIX_NODE ||
7344 /* also replace if we got a GEL_E_MOD_CALC oper since
7345 * that can only mean an error occured, and we
7346 * don't want to duplicate the mod */
7347 (n->op.args->type == GEL_OPERATOR_NODE &&
7348 n->op.args->op.oper == GEL_E_MOD_CALC)) {
7349 GelETree *t = n->op.args;
7350 gel_freetree (n->op.args->any.next);
7351 n->op.args = NULL;
7352 replacenode (n, t);
7353 }
7354 iter_pop_stack(ctx);
7355 break;
7356
7357 case GEL_E_FOR_CONS:
7358 case GEL_E_FORBY_CONS:
7359 case GEL_E_SUM_CONS:
7360 case GEL_E_SUMBY_CONS:
7361 case GEL_E_PROD_CONS:
7362 case GEL_E_PRODBY_CONS:
7363 iter_forloop (ctx, n, repushed);
7364 break;
7365
7366 case GEL_E_FORIN_CONS:
7367 case GEL_E_SUMIN_CONS:
7368 case GEL_E_PRODIN_CONS:
7369 iter_forinloop (ctx, n, repushed);
7370 break;
7371
7372 case GEL_E_GET_VELEMENT:
7373 iter_get_velement (n);
7374 iter_pop_stack (ctx);
7375 break;
7376
7377 case GEL_E_GET_ELEMENT:
7378 iter_get_element (n);
7379 iter_pop_stack (ctx);
7380 break;
7381
7382 case GEL_E_GET_ROW_REGION:
7383 iter_get_region (n, FALSE /* col */);
7384 iter_pop_stack (ctx);
7385 break;
7386
7387 case GEL_E_GET_COL_REGION:
7388 iter_get_region (n, TRUE /* col */);
7389 iter_pop_stack (ctx);
7390 break;
7391
7392 case GEL_E_IF_CONS:
7393 iter_ifop (ctx, n, FALSE, repushed);
7394 break;
7395 case GEL_E_IFELSE_CONS:
7396 iter_ifop (ctx, n, TRUE, repushed);
7397 break;
7398
7399 case GEL_E_DIRECTCALL:
7400 case GEL_E_CALL:
7401 if ( ! iter_funccallop(ctx, n, repushed))
7402 return FALSE;
7403 break;
7404
7405 case GEL_E_RETURN:
7406 iter_returnop(ctx,n);
7407 break;
7408
7409 case GEL_E_REGION_SEP:
7410 case GEL_E_REGION_SEP_BY:
7411 iter_region_sep_op (ctx, n);
7412 iter_pop_stack (ctx);
7413 break;
7414
7415 /*these should have been translated to GEL_COMPARE_NODEs*/
7416 case GEL_E_EQ_CMP:
7417 case GEL_E_NE_CMP:
7418 case GEL_E_LT_CMP:
7419 case GEL_E_GT_CMP:
7420 case GEL_E_LE_CMP:
7421 case GEL_E_GE_CMP:
7422
7423 /*This operators should never reach post, they are evaluated in pre,
7424 or dealt with through the pop_stack_special*/
7425 case GEL_E_QUOTE:
7426 case GEL_E_REFERENCE:
7427 case GEL_E_LOGICAL_AND:
7428 case GEL_E_LOGICAL_OR:
7429 case GEL_E_WHILE_CONS:
7430 case GEL_E_UNTIL_CONS:
7431 case GEL_E_DOWHILE_CONS:
7432 case GEL_E_DOUNTIL_CONS:
7433 case GEL_E_CONTINUE:
7434 case GEL_E_BREAK:
7435 case GEL_E_EXCEPTION:
7436 case GEL_E_BAILOUT:
7437 case GEL_E_DEREFERENCE:
7438 g_assert_not_reached();
7439
7440 default:
7441 gel_errorout (_("Unexpected operator!"));
7442 #ifdef EVAL_DEBUG
7443 printf ("!!!!!!!!!!!!!!!UNEXPECTED_OPERATOR POST (%p) (%d)\n", n, n->op.oper);
7444 #endif
7445 iter_pop_stack(ctx);
7446 break;
7447 }
7448 return TRUE;
7449 }
7450
7451 GSList *
gel_get_ids_for_extradict(GSList * toklist,GSList * args,GSList * locals,GelETree * n)7452 gel_get_ids_for_extradict (GSList *toklist, GSList *args, GSList *locals, GelETree *n)
7453 {
7454 if (n == NULL)
7455 return toklist;
7456
7457 if (n->type == GEL_IDENTIFIER_NODE) {
7458 if (g_slist_find (args, n->id.id) == NULL &&
7459 g_slist_find (locals, n->id.id) == NULL &&
7460 g_slist_find (toklist, n->id.id) == NULL) {
7461 GelEFunc *f = d_lookup_global (n->id.id);
7462 if (f != NULL && f->context > 0)
7463 toklist = g_slist_prepend (toklist, n->id.id);
7464 }
7465 } else if (n->type == GEL_SPACER_NODE) {
7466 toklist = gel_get_ids_for_extradict (toklist, args, locals, n->sp.arg);
7467 } else if (n->type == GEL_OPERATOR_NODE) {
7468 GelETree *al = n->op.args;
7469 while (al != NULL) {
7470 toklist = gel_get_ids_for_extradict (toklist, args, locals, al);
7471 al = al->any.next;
7472 }
7473 } else if (n->type == GEL_COMPARISON_NODE) {
7474 GelETree *al = n->comp.args;
7475 while (al != NULL) {
7476 toklist = gel_get_ids_for_extradict (toklist, args, locals, al);
7477 al = al->any.next;
7478 }
7479 } else if (n->type == GEL_MATRIX_NODE &&
7480 n->mat.matrix != NULL &&
7481 ! gel_is_matrix_value_only (n->mat.matrix)) {
7482 int i,j;
7483 int w,h;
7484 w = gel_matrixw_width (n->mat.matrix);
7485 h = gel_matrixw_height (n->mat.matrix);
7486 for (i = 0; i < w; i++) {
7487 for(j = 0; j < h; j++) {
7488 GelETree *t = gel_matrixw_get_index
7489 (n->mat.matrix, i, j);
7490 if (t != NULL)
7491 toklist = gel_get_ids_for_extradict (toklist, args, locals, t);
7492 }
7493 }
7494 } else if (n->type == GEL_SET_NODE) {
7495 GelETree *ali;
7496 for(ali = n->set.items; ali != NULL; ali = ali->any.next)
7497 toklist = gel_get_ids_for_extradict (toklist, args, locals, ali);
7498 } else if (n->type == GEL_FUNCTION_NODE &&
7499 (n->func.func->type == GEL_USER_FUNC ||
7500 n->func.func->type == GEL_VARIABLE_FUNC)) {
7501 D_ENSURE_USER_BODY (n->func.func);
7502 toklist = gel_get_ids_for_extradict (toklist, args, locals, n->func.func->data.user);
7503 }
7504 return toklist;
7505 }
7506
7507 GSList *
gel_subst_local_vars(GSList * funclist,GSList ** toklist)7508 gel_subst_local_vars (GSList *funclist, GSList **toklist)
7509 {
7510 GSList *li;
7511 GSList *prev;
7512
7513 li = *toklist;
7514 prev = NULL;
7515 while (li != NULL) {
7516 GelToken *id = li->data;
7517 GelEFunc *func = d_lookup_local (id);
7518 if (func != NULL &&
7519 ! func->is_local) {
7520 GSList *tmp;
7521 GelEFunc *f = d_copyfunc (func);
7522 if ( ! f->on_subst_list)
7523 f->context = -1;
7524 funclist = g_slist_prepend (funclist, f);
7525
7526 tmp = li;
7527 li = li->next;
7528 if (prev != NULL) {
7529 prev->next = g_slist_remove_link (prev->next, tmp);
7530 } else {
7531 *toklist = g_slist_remove_link (*toklist, tmp);
7532 }
7533 } else {
7534 prev = li;
7535 li = li->next;
7536 }
7537 }
7538 return funclist;
7539 }
7540
7541 static GSList *
build_extradict(GSList * funclist,GSList * toklist)7542 build_extradict (GSList *funclist, GSList *toklist)
7543 {
7544 GSList *li;
7545
7546 for (li = toklist; li != NULL; li = li->next) {
7547 GelToken *id = li->data;
7548 GelEFunc *func = d_lookup_global (id);
7549 if G_LIKELY (func != NULL) {
7550 GelEFunc *f = d_copyfunc (func);
7551 /* note that local stays local! */
7552 if ( ! f->on_subst_list)
7553 f->context = -1;
7554 funclist = g_slist_prepend (funclist, f);
7555 } else {
7556 char *similar = gel_similar_possible_ids (id->token);
7557 if (similar != NULL) {
7558 gel_errorout (_("Variable '%s' used uninitialized, "
7559 "perhaps you meant %s."),
7560 id->token,
7561 similar);
7562
7563 g_free (similar);
7564 } else {
7565 gel_errorout (_("Variable '%s' used uninitialized"),
7566 id->token);
7567 }
7568 }
7569 }
7570 return funclist;
7571 }
7572
7573 static gboolean
iter_eval_etree(GelCtx * ctx)7574 iter_eval_etree(GelCtx *ctx)
7575 {
7576 GelETree *n;
7577 gboolean whack_saved;
7578
7579 #define WHACK_SAVEDN_POP \
7580 { \
7581 ctx->current = NULL; \
7582 if (whack_saved) { \
7583 /* WHACKWHACK */ \
7584 gel_freetree (n); \
7585 } \
7586 iter_pop_stack (ctx); \
7587 }
7588
7589 while((n = ctx->current)) {
7590 EDEBUG("ITER");
7591 if (gel_evalnode_hook != NULL) {
7592 static int i = 0;
7593 if G_UNLIKELY ((i++ & GEL_RUN_HOOK_EVERY_MASK) == GEL_RUN_HOOK_EVERY_MASK) {
7594 (*gel_evalnode_hook)();
7595 i = 0;
7596 }
7597 }
7598 whack_saved = ctx->whackarg;
7599
7600 if G_UNLIKELY (gel_interrupted) {
7601 if (whack_saved) {
7602 ctx->current = NULL;
7603 gel_freetree (n);
7604 }
7605 return FALSE;
7606 }
7607
7608 switch(n->type) {
7609 case GEL_NULL_NODE:
7610 EDEBUG(" NULL NODE");
7611 WHACK_SAVEDN_POP;
7612 break;
7613
7614 case GEL_VALUE_NODE:
7615 EDEBUG(" VALUE NODE");
7616
7617 if (ctx->modulo != NULL)
7618 mod_node (n, ctx->modulo);
7619
7620 WHACK_SAVEDN_POP;
7621 break;
7622 case GEL_MATRIX_NODE:
7623 EDEBUG(" MATRIX NODE");
7624 if(!ctx->post) {
7625 /*if in pre mode, push elements onto stack*/
7626 iter_push_matrix(ctx,n,n->mat.matrix);
7627 } else {
7628 /*if in post mode expand the matrix */
7629 if(!n->mat.quoted)
7630 gel_expandmatrix (n);
7631 if (ctx->modulo != NULL)
7632 mod_node (n, ctx->modulo);
7633 WHACK_SAVEDN_POP;
7634 }
7635 break;
7636 case GEL_OPERATOR_NODE:
7637 EDEBUG(" OPERATOR NODE");
7638 if(!ctx->post) {
7639 if G_UNLIKELY (!iter_operator_pre(ctx)) {
7640 /* WHACKWHACK */
7641 /* FIXME: is this needed?
7642 * check if it's possible */
7643 if (n == ctx->current &&
7644 whack_saved) {
7645 ctx->current = NULL;
7646 gel_freetree (n);
7647 }
7648 return FALSE;
7649 }
7650 /* pre either pushes n again or whacks it
7651 itself, in either case we can assume we
7652 are rid of it if we were to whack it */
7653 } else {
7654 gboolean repushed = FALSE;
7655 if G_UNLIKELY ( ! iter_operator_post
7656 (ctx, &repushed)) {
7657 /* WHACKWHACK */
7658 if (whack_saved && ! repushed) {
7659 /* FIXME: is this needed? */
7660 if (ctx->current == n)
7661 ctx->current = NULL;
7662 gel_freetree (n);
7663 }
7664 return FALSE;
7665 }
7666 if (whack_saved && ! repushed) {
7667 gel_freetree (n);
7668 }
7669 }
7670 break;
7671 case GEL_IDENTIFIER_NODE:
7672 EDEBUG(" IDENTIFIER NODE");
7673 if G_UNLIKELY (!iter_variableop(ctx, n)) {
7674 /* WHACKWHACK */
7675 if (whack_saved)
7676 gel_freetree (n);
7677 return FALSE;
7678 }
7679 if ((n->type == GEL_VALUE_NODE ||
7680 n->type == GEL_MATRIX_NODE) &&
7681 ctx->modulo != NULL &&
7682 ! whack_saved)
7683 mod_node (n, ctx->modulo);
7684 WHACK_SAVEDN_POP;
7685 break;
7686 case GEL_STRING_NODE:
7687 EDEBUG(" STRING NODE");
7688 WHACK_SAVEDN_POP;
7689 break;
7690
7691 case GEL_FUNCTION_NODE:
7692 EDEBUG(" FUNCTION NODE");
7693 if (n->func.func->never_on_subst_list) {
7694 if (n->func.func->built_subst_dict) {
7695 n->func.func->extra_dict = build_extradict (n->func.func->extra_dict,
7696 n->func.func->subst_dict);
7697 n->func.func->built_subst_dict = 0;
7698 g_slist_free (n->func.func->subst_dict);
7699 n->func.func->subst_dict = NULL;
7700 }
7701 } else if (n->func.func != NULL &&
7702 (n->func.func->type == GEL_USER_FUNC ||
7703 n->func.func->type == GEL_VARIABLE_FUNC) &&
7704 d_curcontext () != 0) {
7705 D_ENSURE_SUBST_DICT (n->func.func);
7706 if (n->func.func->subst_dict != NULL) {
7707 d_put_on_subst_list (n->func.func);
7708 }
7709 }
7710 WHACK_SAVEDN_POP;
7711 break;
7712
7713 case GEL_COMPARISON_NODE:
7714 EDEBUG(" COMPARISON NODE");
7715 if(!ctx->post) {
7716 /*if in pre mode, push arguments onto stack*/
7717 GE_PUSH_STACK (ctx, n,
7718 GE_ADDWHACKARG (GE_POST,
7719 ctx->whackarg));
7720 iter_push_args(ctx,
7721 n->comp.args,
7722 n->comp.nargs);
7723 } else {
7724 /*if in post mode evaluate */
7725 evalcomp(n);
7726 WHACK_SAVEDN_POP;
7727 }
7728 break;
7729 case GEL_USERTYPE_NODE:
7730 EDEBUG(" USERTYPE NODE");
7731 WHACK_SAVEDN_POP;
7732 break;
7733 case GEL_BOOL_NODE:
7734 #ifdef EVAL_DEBUG
7735 printf (" BOOL NODE -- %p %s\n", n, n->bool_.bool_ ? "true" : "false");
7736 #endif
7737 WHACK_SAVEDN_POP;
7738 break;
7739 default:
7740 gel_errorout (_("Unexpected node!"));
7741 #ifdef EVAL_DEBUG
7742 {
7743 char *s = gel_string_print_etree (n);
7744 printf ("!!!!!!!!!!!!!!!UNEXPECTED_NODE (%p) (%d)\t-> %s\n", n, n->type, s);
7745 g_free (s);
7746 }
7747 #endif
7748 WHACK_SAVEDN_POP;
7749 break;
7750 }
7751 }
7752 return TRUE;
7753 }
7754
7755 GelCtx *
gel_eval_get_context(void)7756 gel_eval_get_context(void)
7757 {
7758 GelCtx *ctx = g_new0(GelCtx,1);
7759 ge_add_stack_array(ctx);
7760 #ifdef MEM_DEBUG_FRIENDLY
7761 most_recent_ctx = ctx;
7762 #endif
7763 return ctx;
7764 }
7765
7766 void
gel_eval_free_context(GelCtx * ctx)7767 gel_eval_free_context(GelCtx *ctx)
7768 {
7769 #ifdef MEM_DEBUG_FRIENDLY
7770 if (most_recent_ctx == ctx)
7771 most_recent_ctx = NULL;
7772 #endif
7773 g_free(ctx->stack);
7774 g_free(ctx);
7775 }
7776
7777 GelETree *
gel_eval_etree(GelCtx * ctx,GelETree * etree)7778 gel_eval_etree (GelCtx *ctx, GelETree *etree)
7779 {
7780 /*level measures any recursion into here such as from
7781 external functions etc, so that we can purge free lists,
7782 but not during calculation*/
7783 static int level = 0;
7784 int flag;
7785 gpointer data;
7786
7787 #ifdef MEM_DEBUG_FRIENDLY
7788 # ifdef EVAL_DEBUG
7789 if (level == 0) {
7790 deregister_all_trees ();
7791 }
7792 # endif
7793 #endif
7794
7795 if (ctx->modulo != NULL) {
7796 GE_PUSH_STACK (ctx, ctx->modulo, GE_SETMODULO);
7797 ctx->modulo = NULL;
7798 }
7799
7800 GE_PUSH_STACK(ctx,ctx->res,GE_RESULT);
7801 if(ctx->post) {
7802 GE_PUSH_STACK(ctx,ctx->current,
7803 GE_ADDWHACKARG (GE_POST, ctx->whackarg));
7804 } else {
7805 GE_PUSH_STACK (ctx, ctx->current,
7806 GE_ADDWHACKARG (GE_PRE, ctx->whackarg));
7807 }
7808 GE_PUSH_STACK (ctx, NULL, GE_EMPTY_STACK);
7809 ctx->res = etree;
7810 ctx->current = etree;
7811 ctx->post = FALSE;
7812 ctx->whackarg = FALSE;
7813
7814 level++;
7815
7816 if G_UNLIKELY (!iter_eval_etree(ctx)) {
7817 /*an exception happened*/
7818 ctx->current = NULL;
7819 gel_freetree (ctx->res);
7820 etree = ctx->res = NULL;
7821 do {
7822 GE_POP_STACK(ctx,data,flag);
7823 ev_free_special_data(ctx,data,flag);
7824 } while(flag != GE_EMPTY_STACK);
7825 }
7826 if G_UNLIKELY (--level == 0) {
7827 purge_free_lists();
7828 if (_gel_finished_toplevel_exec_hook != NULL)
7829 (*_gel_finished_toplevel_exec_hook) ();
7830
7831 }
7832
7833 GE_POP_STACK(ctx,ctx->current,flag);
7834 g_assert ((flag & GE_MASK) == GE_POST || (flag & GE_MASK) == GE_PRE);
7835 ctx->post = ((flag & GE_MASK) == GE_POST);
7836 ctx->whackarg = (flag & GE_WHACKARG);
7837 GE_POP_STACK(ctx,ctx->res,flag);
7838 flag = (flag & GE_MASK);
7839 g_assert(flag == GE_RESULT);
7840
7841 GE_PEEK_STACK (ctx, data, flag);
7842 flag = (flag & GE_MASK);
7843 if (flag == GE_SETMODULO) {
7844 if (ctx->modulo != NULL) {
7845 mpw_clear (ctx->modulo);
7846 g_free (ctx->modulo);
7847 }
7848 ctx->modulo = data;
7849 GE_BLIND_POP_STACK (ctx);
7850 }
7851
7852 #ifdef MEM_DEBUG_FRIENDLY
7853 # ifdef EVAL_DEBUG
7854 if (level == 0) {
7855 print_live_trees ();
7856 }
7857 # endif
7858 #endif
7859
7860 return etree;
7861 }
7862
7863 GelETree *
gel_gather_comparisons(GelETree * n)7864 gel_gather_comparisons(GelETree *n)
7865 {
7866 GelETree *next,*ret;
7867 if(!n) return NULL;
7868
7869 ret = n;
7870 next = n->any.next;
7871
7872 if(n->type == GEL_SPACER_NODE) {
7873 GelETree *t = n->sp.arg;
7874 freenode(n);
7875 ret = gel_gather_comparisons(t);
7876 } else if(n->type==GEL_OPERATOR_NODE) {
7877 GelETree *nn;
7878 GelETree *ali = NULL;
7879 switch(n->op.oper) {
7880 case GEL_E_EQ_CMP:
7881 case GEL_E_NE_CMP:
7882 case GEL_E_LT_CMP:
7883 case GEL_E_GT_CMP:
7884 case GEL_E_LE_CMP:
7885 case GEL_E_GE_CMP:
7886 GEL_GET_NEW_NODE(nn);
7887 nn->type = GEL_COMPARISON_NODE;
7888 nn->comp.nargs = 0;
7889 nn->comp.args = NULL;
7890 nn->comp.comp = NULL;
7891
7892 for(;;) {
7893 GelETree *t;
7894 t = n->op.args->any.next;
7895 if(!ali) {
7896 ali = nn->comp.args =
7897 gel_gather_comparisons(n->op.args);
7898 } else {
7899 ali = ali->any.next =
7900 gel_gather_comparisons(n->op.args);
7901 }
7902 ali->any.next = NULL;
7903 nn->comp.nargs++;
7904 nn->comp.comp =
7905 g_slist_append (nn->comp.comp,
7906 GINT_TO_POINTER((int)n->op.oper));
7907
7908 freenode(n);
7909 n = t;
7910 if(n->type != GEL_OPERATOR_NODE ||
7911 (n->op.oper != GEL_E_EQ_CMP &&
7912 n->op.oper != GEL_E_NE_CMP &&
7913 n->op.oper != GEL_E_LT_CMP &&
7914 n->op.oper != GEL_E_GT_CMP &&
7915 n->op.oper != GEL_E_LE_CMP &&
7916 n->op.oper != GEL_E_GE_CMP)) {
7917 ali = ali->any.next =
7918 gel_gather_comparisons(n);
7919 ali->any.next = NULL;
7920 nn->comp.nargs++;
7921 break;
7922 }
7923 }
7924 ret = nn;
7925 break;
7926 default:
7927 if(n->op.args) {
7928 n->op.args = gel_gather_comparisons(n->op.args);
7929 for(ali=n->op.args;ali->any.next;ali=ali->any.next)
7930 ali->any.next =
7931 gel_gather_comparisons(ali->any.next);
7932 }
7933 }
7934 } else if(n->type==GEL_MATRIX_NODE) {
7935 int i,j;
7936 int w,h;
7937 if(!n->mat.matrix ||
7938 gel_is_matrix_value_only (n->mat.matrix)) {
7939 goto gather_comparisons_end;
7940 }
7941 w = gel_matrixw_width(n->mat.matrix);
7942 h = gel_matrixw_height(n->mat.matrix);
7943 gel_matrixw_make_private(n->mat.matrix, TRUE /* kill_type_caches */);
7944 for(j=0;j<h;j++) {
7945 for(i=0;i<w;i++) {
7946 GelETree *t = gel_matrixw_get_index(n->mat.matrix,i,j);
7947 if (t != NULL) {
7948 gel_matrixw_set_index(n->mat.matrix,i,j) =
7949 gel_gather_comparisons(t);
7950 }
7951 }
7952 }
7953 } else if(n->type==GEL_SET_NODE) {
7954 GelETree *ali;
7955 if(n->set.items) {
7956 n->set.items = gel_gather_comparisons(n->set.items);
7957 for(ali=n->set.items;ali->any.next;ali=ali->any.next)
7958 ali->any.next =
7959 gel_gather_comparisons(ali->any.next);
7960 }
7961 } else if(n->type==GEL_FUNCTION_NODE) {
7962 if ((n->func.func->type == GEL_USER_FUNC ||
7963 n->func.func->type == GEL_VARIABLE_FUNC) &&
7964 n->func.func->data.user) {
7965 n->func.func->data.user =
7966 gel_gather_comparisons(n->func.func->data.user);
7967 }
7968 }
7969 gather_comparisons_end:
7970 ret->any.next = next;
7971 return ret;
7972 }
7973
7974 /* 0 not found
7975 1 found OK
7976 2 found not first */
7977 int
gel_get_local_node(GelETree * n,gboolean first_arg,gboolean * local_all,GSList ** local_idents)7978 gel_get_local_node (GelETree *n, gboolean first_arg,
7979 gboolean *local_all, GSList **local_idents)
7980 {
7981 if (n == NULL) return 0;
7982
7983 if (n->type == GEL_LOCAL_NODE) {
7984 if (first_arg) {
7985 GelETree *arg = n->loc.arg;
7986
7987 *local_idents = n->loc.idents;
7988 if (n->loc.idents == NULL)
7989 *local_all = TRUE;
7990
7991 n->loc.idents = NULL;
7992 n->loc.arg = NULL;
7993
7994 replacenode (n, arg);
7995 if (gel_get_local_node (n, FALSE,
7996 local_all, local_idents) == 2) {
7997 return 2;
7998 } else {
7999 return 1;
8000 }
8001 } else {
8002 return 2;
8003 }
8004 } else if (n->type == GEL_SPACER_NODE) {
8005 return gel_get_local_node (n->sp.arg, first_arg, local_all, local_idents);
8006 } else if (n->type == GEL_OPERATOR_NODE) {
8007 GelETree *ali;
8008 if (n->op.oper == GEL_E_SEPAR) {
8009 int ret = gel_get_local_node (n->op.args, first_arg, local_all, local_idents);
8010 if (ret == 2)
8011 return 2;
8012 for (ali = n->op.args->any.next; ali != NULL; ali = ali->any.next)
8013 if (gel_get_local_node (ali, FALSE, local_all, local_idents))
8014 return 2;
8015 return ret;
8016 } else {
8017 for (ali = n->op.args; ali != NULL; ali = ali->any.next)
8018 if (gel_get_local_node (ali, FALSE, local_all, local_idents))
8019 return 2;
8020 }
8021 return FALSE;
8022 } else if(n->type == GEL_MATRIX_NODE) {
8023 int i, j;
8024 int w, h;
8025 if (n->mat.matrix == NULL ||
8026 gel_is_matrix_value_only (n->mat.matrix)) {
8027 return 0;
8028 }
8029 w = gel_matrixw_width (n->mat.matrix);
8030 h = gel_matrixw_height (n->mat.matrix);
8031 gel_matrixw_make_private (n->mat.matrix, TRUE /* kill_type_caches */);
8032 for (j = 0; j < h; j++) {
8033 for (i = 0; i < w; i++) {
8034 GelETree *t = gel_matrixw_get_index
8035 (n->mat.matrix, i, j);
8036 if (t != NULL) {
8037 if (gel_get_local_node (t, FALSE, local_all,
8038 local_idents))
8039 return 2;
8040 }
8041 }
8042 }
8043 return FALSE;
8044 } else if (n->type == GEL_SET_NODE) {
8045 GelETree *ali;
8046 for (ali = n->set.items; ali != NULL; ali = ali->any.next)
8047 if (gel_get_local_node (ali, FALSE, local_all,
8048 local_idents))
8049 return 2;
8050 return 0;
8051 }
8052 /* Note: Need not go into functions! */
8053 /* Note: Need not go into comparison nodes as those do not exist yet! */
8054 return 0;
8055 }
8056
8057 void
gel_replace_equals(GelETree * n,gboolean in_expression)8058 gel_replace_equals (GelETree *n, gboolean in_expression)
8059 {
8060 if (n == NULL)
8061 return;
8062
8063 if (n->type == GEL_SPACER_NODE) {
8064 gel_replace_equals (n->sp.arg, in_expression);
8065 } else if(n->type == GEL_OPERATOR_NODE) {
8066 gboolean run_through_args = TRUE;
8067 if (n->op.oper == GEL_E_EQUALS &&
8068 in_expression) {
8069 n->op.oper = GEL_E_EQ_CMP;
8070 } else if (n->op.oper == GEL_E_WHILE_CONS ||
8071 n->op.oper == GEL_E_UNTIL_CONS ||
8072 n->op.oper == GEL_E_IF_CONS) {
8073 run_through_args = FALSE;
8074 gel_replace_equals (n->op.args, TRUE);
8075 gel_replace_equals (n->op.args->any.next, in_expression);
8076 } else if (n->op.oper == GEL_E_DOWHILE_CONS ||
8077 n->op.oper == GEL_E_DOUNTIL_CONS) {
8078 run_through_args = FALSE;
8079 gel_replace_equals (n->op.args, in_expression);
8080 gel_replace_equals (n->op.args->any.next, TRUE);
8081 } else if (n->op.oper == GEL_E_IFELSE_CONS) {
8082 run_through_args = FALSE;
8083 gel_replace_equals (n->op.args, TRUE);
8084 gel_replace_equals (n->op.args->any.next, in_expression);
8085 gel_replace_equals (n->op.args->any.next->any.next, in_expression);
8086 }
8087
8088 if (run_through_args) {
8089 GelETree *args = n->op.args;
8090 while (args != NULL) {
8091 gel_replace_equals (args, in_expression);
8092 args = args->any.next;
8093 }
8094 }
8095 } else if (n->type == GEL_MATRIX_NODE &&
8096 n->mat.matrix != NULL &&
8097 ! gel_is_matrix_value_only (n->mat.matrix)) {
8098 int i,j;
8099 int w,h;
8100 w = gel_matrixw_width (n->mat.matrix);
8101 h = gel_matrixw_height (n->mat.matrix);
8102 gel_matrixw_make_private (n->mat.matrix, TRUE /* kill_type_caches */);
8103 for(j = 0; j < h; j++) {
8104 for (i = 0; i < w; i++) {
8105 GelETree *t = gel_matrixw_get_index
8106 (n->mat.matrix, i, j);
8107 if (t != NULL)
8108 gel_replace_equals (t, in_expression);
8109 }
8110 }
8111 } else if (n->type == GEL_SET_NODE ) {
8112 GelETree *ali;
8113 for(ali = n->set.items; ali != NULL; ali = ali->any.next)
8114 gel_replace_equals (ali, in_expression);
8115 } else if (n->type == GEL_FUNCTION_NODE &&
8116 (n->func.func->type == GEL_USER_FUNC ||
8117 n->func.func->type == GEL_VARIABLE_FUNC) &&
8118 n->func.func->data.user != NULL) {
8119 /* function bodies are a completely new thing */
8120 gel_replace_equals (n->func.func->data.user, FALSE);
8121 }
8122
8123 /* Note: no need to handle comparison node, not yet created */
8124 }
8125
8126 void
gel_replace_exp(GelETree * n)8127 gel_replace_exp (GelETree *n)
8128 {
8129 if (n == NULL)
8130 return;
8131
8132 if (n->type == GEL_SPACER_NODE) {
8133 gel_replace_exp (n->sp.arg);
8134 } else if(n->type == GEL_OPERATOR_NODE) {
8135 GelETree *args;
8136 if (n->op.oper == GEL_E_EXP &&
8137 n->op.args->type == GEL_IDENTIFIER_NODE &&
8138 n->op.args->id.id->token != NULL &&
8139 strcmp (n->op.args->id.id->token, "e") == 0) {
8140 n->op.oper = GEL_E_DIRECTCALL;
8141 n->op.args->id.id = d_intern ("exp");
8142 }
8143
8144 args = n->op.args;
8145 while (args != NULL) {
8146 gel_replace_exp (args);
8147 args = args->any.next;
8148 }
8149 } else if (n->type == GEL_MATRIX_NODE &&
8150 n->mat.matrix != NULL &&
8151 ! gel_is_matrix_value_only (n->mat.matrix)) {
8152 int i,j;
8153 int w,h;
8154 w = gel_matrixw_width (n->mat.matrix);
8155 h = gel_matrixw_height (n->mat.matrix);
8156 gel_matrixw_make_private (n->mat.matrix, TRUE /* kill_type_caches */);
8157 for(j = 0; j < h; j++) {
8158 for (i = 0; i < w; i++) {
8159 GelETree *t = gel_matrixw_get_index
8160 (n->mat.matrix, i, j);
8161 if (t != NULL)
8162 gel_replace_exp (t);
8163 }
8164 }
8165 } else if (n->type == GEL_SET_NODE ) {
8166 GelETree *ali;
8167 for(ali = n->set.items; ali != NULL; ali = ali->any.next)
8168 gel_replace_exp (ali);
8169 } else if (n->type == GEL_FUNCTION_NODE &&
8170 (n->func.func->type == GEL_USER_FUNC ||
8171 n->func.func->type == GEL_VARIABLE_FUNC) &&
8172 n->func.func->data.user != NULL) {
8173 gel_replace_exp (n->func.func->data.user);
8174 }
8175 }
8176
8177 /* Fixup number negation */
8178 void
gel_fixup_num_neg(GelETree * n)8179 gel_fixup_num_neg (GelETree *n)
8180 {
8181 if (n == NULL)
8182 return;
8183
8184 if (n->type == GEL_SPACER_NODE) {
8185 gel_fixup_num_neg (n->sp.arg);
8186 } else if(n->type == GEL_OPERATOR_NODE) {
8187 /* replace -1^2 with something like (-1)^2, only
8188 * for numbers. If you typed parenthesis as in
8189 * -(1)^2, there would be a spacer node present
8190 * so the below would not happen */
8191 if (n->op.oper == GEL_E_NEG &&
8192 n->op.args->type == GEL_OPERATOR_NODE &&
8193 (n->op.args->op.oper == GEL_E_EXP ||
8194 n->op.args->op.oper == GEL_E_ELTEXP) &&
8195 n->op.args->op.args->type == GEL_VALUE_NODE) {
8196 GelETree *t = n->op.args;
8197 n->op.args = NULL;
8198 replacenode (n, t);
8199 mpw_neg (n->op.args->val.value,
8200 n->op.args->val.value);
8201 gel_fixup_num_neg (n->op.args->any.next);
8202 } else {
8203 GelETree *args = n->op.args;
8204 while (args != NULL) {
8205 gel_fixup_num_neg (args);
8206 args = args->any.next;
8207 }
8208 }
8209 } else if (n->type == GEL_MATRIX_NODE &&
8210 n->mat.matrix != NULL &&
8211 ! gel_is_matrix_value_only (n->mat.matrix)) {
8212 int i,j;
8213 int w,h;
8214 w = gel_matrixw_width (n->mat.matrix);
8215 h = gel_matrixw_height (n->mat.matrix);
8216 gel_matrixw_make_private (n->mat.matrix, TRUE /* kill_type_caches */);
8217 for(j = 0; j < h; j++) {
8218 for (i = 0; i < w; i++) {
8219 GelETree *t = gel_matrixw_get_index
8220 (n->mat.matrix, i, j);
8221 if (t != NULL)
8222 gel_fixup_num_neg (t);
8223 }
8224 }
8225 } else if (n->type == GEL_SET_NODE ) {
8226 GelETree *ali;
8227 for(ali = n->set.items; ali != NULL; ali = ali->any.next)
8228 gel_fixup_num_neg (ali);
8229 } else if (n->type == GEL_FUNCTION_NODE &&
8230 (n->func.func->type == GEL_USER_FUNC ||
8231 n->func.func->type == GEL_VARIABLE_FUNC) &&
8232 n->func.func->data.user != NULL) {
8233 gel_fixup_num_neg (n->func.func->data.user);
8234 }
8235 }
8236
8237 /* IMPORTANT: There's also a tree traversal function in symbolic.c */
8238
8239 /* find an identifier */
8240 gboolean
gel_eval_find_identifier(GelETree * n,GelToken * tok,gboolean funcbody)8241 gel_eval_find_identifier (GelETree *n, GelToken *tok, gboolean funcbody)
8242 {
8243 if (n == NULL)
8244 return FALSE;
8245
8246 if (n->type == GEL_SPACER_NODE) {
8247 return gel_eval_find_identifier (n->sp.arg, tok, funcbody);
8248 } else if (n->type == GEL_IDENTIFIER_NODE ) {
8249 if (n->id.id == tok)
8250 return TRUE;
8251 else
8252 return FALSE;
8253 } else if(n->type == GEL_OPERATOR_NODE) {
8254 GelETree *args = n->op.args;
8255 while (args != NULL) {
8256 if (gel_eval_find_identifier (args, tok, funcbody))
8257 return TRUE;
8258 args = args->any.next;
8259 }
8260 return FALSE;
8261 } else if (n->type == GEL_MATRIX_NODE &&
8262 n->mat.matrix != NULL) {
8263 int i,j;
8264 int w,h;
8265 w = gel_matrixw_width (n->mat.matrix);
8266 h = gel_matrixw_height (n->mat.matrix);
8267 for(j = 0; j < h; j++) {
8268 for (i = 0; i < w; i++) {
8269 GelETree *t = gel_matrixw_get_index
8270 (n->mat.matrix, i, j);
8271 if (t != NULL &&
8272 gel_eval_find_identifier (t, tok, funcbody))
8273 return TRUE;
8274 }
8275 }
8276 return FALSE;
8277 } else if (n->type == GEL_SET_NODE ) {
8278 GelETree *ali;
8279 for (ali = n->set.items; ali != NULL; ali = ali->any.next) {
8280 if (gel_eval_find_identifier (ali, tok, funcbody))
8281 return TRUE;
8282 }
8283 return FALSE;
8284 } else if (funcbody &&
8285 n->type == GEL_FUNCTION_NODE &&
8286 (n->func.func->type == GEL_USER_FUNC ||
8287 n->func.func->type == GEL_VARIABLE_FUNC)) {
8288 D_ENSURE_USER_BODY (n->func.func);
8289 return gel_eval_find_identifier (n->func.func->data.user, tok,
8290 funcbody);
8291 }
8292 return FALSE;
8293 }
8294
8295 /*this means that it will precalc even complex and float
8296 numbers*/
8297 static void
op_precalc_all_1(GelETree * n,void (* func)(mpw_ptr,mpw_ptr))8298 op_precalc_all_1 (GelETree *n, void (*func)(mpw_ptr,mpw_ptr))
8299 {
8300 GelETree *l;
8301 mpw_t res;
8302 GEL_GET_L(n,l);
8303 if(l->type != GEL_VALUE_NODE)
8304 return;
8305 mpw_init(res);
8306 (*func)(res,l->val.value);
8307 if G_UNLIKELY (gel_error_num) {
8308 mpw_clear(res);
8309 gel_error_num = GEL_NO_ERROR;
8310 return;
8311 }
8312 freetree_full(n,TRUE,FALSE);
8313 gel_makenum_use_from(n,res);
8314 }
8315
8316 static void
op_precalc_1(GelETree * n,void (* func)(mpw_ptr,mpw_ptr),gboolean respect_type)8317 op_precalc_1 (GelETree *n,
8318 void (*func)(mpw_ptr,mpw_ptr),
8319 gboolean respect_type)
8320 {
8321 GelETree *l;
8322 mpw_t res;
8323 GEL_GET_L(n,l);
8324 if (l->type != GEL_VALUE_NODE ||
8325 (respect_type &&
8326 (mpw_is_complex (l->val.value) ||
8327 mpw_is_real_part_float (l->val.value))))
8328 return;
8329 mpw_init(res);
8330 (*func)(res,l->val.value);
8331 if G_UNLIKELY (gel_error_num) {
8332 mpw_clear(res);
8333 gel_error_num = GEL_NO_ERROR;
8334 return;
8335 }
8336 freetree_full(n,TRUE,FALSE);
8337 gel_makenum_use_from(n,res);
8338 }
8339
8340 static void
op_precalc_2(GelETree * n,void (* func)(mpw_ptr,mpw_ptr,mpw_ptr),gboolean respect_type)8341 op_precalc_2 (GelETree *n,
8342 void (*func)(mpw_ptr,mpw_ptr,mpw_ptr),
8343 gboolean respect_type)
8344 {
8345 GelETree *l,*r,*next;
8346 mpw_t res;
8347 GEL_GET_LR(n,l,r);
8348 if (l->type != GEL_VALUE_NODE ||
8349 r->type != GEL_VALUE_NODE ||
8350 (respect_type &&
8351 (mpw_is_complex (l->val.value) ||
8352 mpw_is_complex (r->val.value) ||
8353 mpw_is_real_part_float (l->val.value) ||
8354 mpw_is_real_part_float (r->val.value))))
8355 return;
8356 mpw_init(res);
8357 (*func)(res,l->val.value,r->val.value);
8358 if G_UNLIKELY (gel_error_num) {
8359 mpw_clear(res);
8360 gel_error_num = GEL_NO_ERROR;
8361 return;
8362 }
8363 next = n->any.next;
8364 freetree_full(n,TRUE,FALSE);
8365 gel_makenum_use_from(n,res);
8366 n->any.next = next;
8367 }
8368
8369 static void
try_to_precalc_op(GelETree * n,gboolean respect_type)8370 try_to_precalc_op (GelETree *n, gboolean respect_type)
8371 {
8372 switch(n->op.oper) {
8373 case GEL_E_NEG:
8374 op_precalc_all_1 (n, mpw_neg);
8375 return;
8376 case GEL_E_ABS:
8377 op_precalc_1 (n, mpw_abs, respect_type);
8378 return;
8379 case GEL_E_FACT:
8380 op_precalc_1 (n, mpw_fac, respect_type);
8381 return;
8382 case GEL_E_DBLFACT:
8383 op_precalc_1 (n, mpw_dblfac, respect_type);
8384 return;
8385 case GEL_E_PLUS:
8386 op_precalc_2 (n, mpw_add, respect_type);
8387 return;
8388 case GEL_E_ELTPLUS:
8389 op_precalc_2 (n, mpw_add, respect_type);
8390 return;
8391 case GEL_E_MINUS:
8392 op_precalc_2 (n, mpw_sub, respect_type);
8393 return;
8394 case GEL_E_ELTMINUS:
8395 op_precalc_2 (n, mpw_sub, respect_type);
8396 return;
8397 case GEL_E_MUL:
8398 op_precalc_2 (n, mpw_mul, respect_type);
8399 return;
8400 case GEL_E_ELTMUL:
8401 op_precalc_2 (n, mpw_mul, respect_type);
8402 return;
8403 case GEL_E_DIV:
8404 op_precalc_2 (n, mpw_div, respect_type);
8405 return;
8406 case GEL_E_ELTDIV:
8407 op_precalc_2 (n, mpw_div, respect_type);
8408 return;
8409 case GEL_E_MOD:
8410 op_precalc_2 (n, mpw_mod, respect_type);
8411 return;
8412 /* FIXME: this could be time consuming, somehow catch that */
8413 case GEL_E_EXP:
8414 op_precalc_2 (n, mpw_pow, respect_type);
8415 return;
8416 case GEL_E_ELTEXP:
8417 op_precalc_2 (n, mpw_pow, respect_type);
8418 return;
8419 default:
8420 return;
8421 }
8422 }
8423
8424 void
gel_try_to_do_precalc(GelETree * n)8425 gel_try_to_do_precalc(GelETree *n)
8426 {
8427 if(!n) return;
8428
8429 if(n->type==GEL_OPERATOR_NODE) {
8430 GelETree *ali;
8431
8432 /* double negation is always positive no matter what */
8433 if (n->op.oper == GEL_E_NEG &&
8434 n->op.args->type == GEL_OPERATOR_NODE &&
8435 n->op.args->op.oper == GEL_E_NEG) {
8436 GelETree *nn;
8437 nn = n->op.args->op.args;
8438 n->op.args->op.args = NULL;
8439 replacenode (n, nn);
8440 gel_try_to_do_precalc (n);
8441 } else if(n->op.oper == GEL_E_MOD_CALC) {
8442 /* in case of modular calculation, only do
8443 precalc on the second argument (don't descend
8444 at all into the first one) */
8445 /* FIXME: precalc might be broken in case of mod */
8446 /* gel_try_to_do_precalc(n->op.args->any.next); */;
8447 } else {
8448 if(n->op.args) {
8449 for(ali=n->op.args;ali;ali=ali->any.next)
8450 gel_try_to_do_precalc(ali);
8451 }
8452 if(n->type==GEL_OPERATOR_NODE)
8453 try_to_precalc_op (n,
8454 TRUE /* respect_type */);
8455 }
8456 } else if(n->type==GEL_MATRIX_NODE) {
8457 int i,j;
8458 int w,h;
8459 if (n->mat.matrix == NULL ||
8460 gel_is_matrix_value_only (n->mat.matrix))
8461 return;
8462 w = gel_matrixw_width(n->mat.matrix);
8463 h = gel_matrixw_height(n->mat.matrix);
8464 gel_matrixw_make_private (n->mat.matrix, TRUE /* kill_type_caches */);
8465 for(j=0;j<h;j++) {
8466 for(i=0;i<w;i++) {
8467 GelETree *t = gel_matrixw_get_index(n->mat.matrix,i,j);
8468 if(t)
8469 gel_try_to_do_precalc(t);
8470 }
8471 }
8472 } else if(n->type==GEL_SET_NODE) {
8473 GelETree *ali;
8474 if(n->set.items) {
8475 for(ali=n->set.items;ali;ali=ali->any.next)
8476 gel_try_to_do_precalc(ali);
8477 }
8478 } else if(n->type==GEL_FUNCTION_NODE) {
8479 if ((n->func.func->type == GEL_USER_FUNC ||
8480 n->func.func->type == GEL_VARIABLE_FUNC) &&
8481 n->func.func->data.user)
8482 gel_try_to_do_precalc(n->func.func->data.user);
8483 }
8484 }
8485
8486 gboolean
gel_is_tree_same(GelETree * l,GelETree * r)8487 gel_is_tree_same (GelETree *l, GelETree *r)
8488 {
8489 if (l == NULL && r == NULL)
8490 return TRUE;
8491 if (l == NULL || r == NULL)
8492 return FALSE;
8493
8494 if (l->type != r->type)
8495 return FALSE;
8496
8497 if (l->type == GEL_NULL_NODE) {
8498 return TRUE;
8499 } else if (l->type == GEL_VALUE_NODE) {
8500 return mpw_symbolic_eql (l->val.value, r->val.value);
8501 } else if (l->type == GEL_OPERATOR_NODE) {
8502 GelETree *ali, *bli;
8503 if (l->op.oper != r->op.oper || l->op.nargs != r->op.nargs)
8504 return FALSE;
8505 for (ali = l->op.args, bli = r->op.args;
8506 ali != NULL && bli != NULL;
8507 ali = ali->any.next, bli = bli->any.next) {
8508 if ( ! gel_is_tree_same (ali, bli))
8509 return FALSE;
8510 }
8511 return TRUE;
8512 } else if (l->type == GEL_IDENTIFIER_NODE) {
8513 if (l->id.id == r->id.id)
8514 return TRUE;
8515 else
8516 return FALSE;
8517 } else if (l->type == GEL_STRING_NODE) {
8518 if (l->str.str != NULL && /* sanity only! */
8519 r->str.str != NULL &&
8520 strcmp (l->str.str, r->str.str) == 0)
8521 return TRUE;
8522 else
8523 return FALSE;
8524 } else if (l->type == GEL_BOOL_NODE) {
8525 if ((l->bool_.bool_ && r->bool_.bool_) ||
8526 ( ! l->bool_.bool_ && ! r->bool_.bool_))
8527 return TRUE;
8528 else
8529 return FALSE;
8530 } else if (l->type == GEL_MATRIX_NODE) {
8531 int i, j;
8532 int w, h;
8533 if G_UNLIKELY (l->mat.matrix == NULL ||
8534 r->mat.matrix == NULL)
8535 return FALSE /* possible? */;
8536 w = gel_matrixw_width (l->mat.matrix);
8537 if (w != gel_matrixw_width (r->mat.matrix))
8538 return FALSE;
8539 h = gel_matrixw_height (l->mat.matrix);
8540 if (h != gel_matrixw_height (r->mat.matrix))
8541 return FALSE;
8542 for (i = 0; i < w; i++) {
8543 for (j = 0; j < h; j++) {
8544 GelETree *lt = gel_matrixw_index (l->mat.matrix, i, j);
8545 GelETree *rt = gel_matrixw_index (r->mat.matrix, i, j);
8546 if ( ! gel_is_tree_same (lt, rt))
8547 return FALSE;
8548 }
8549 }
8550 return TRUE;
8551 /* FIXME: GEL_SET_NODE */
8552 /* FIXME: GEL_POLYNOMIAL_NODE */
8553 /* FIXME: GEL_FUNCTION_NODE */
8554 /* FIXME: GEL_COMPARISON_NODE */
8555 /* FIXME: GEL_USERTYPE_NODE */
8556 }
8557 return FALSE;
8558 }
8559
8560 /* FIXME: this is incomplete and stupid! */
8561 static gboolean
oper_reshufle(GelETree * n,int oper)8562 oper_reshufle (GelETree *n, int oper)
8563 {
8564 gboolean shuffled = FALSE;
8565
8566 /* First sort out multiplications or addi */
8567 if (n->op.oper == oper) {
8568 GelETree *l, *r;
8569
8570 GEL_GET_LR (n, l, r);
8571
8572 /* always swap values to go first */
8573 if (r->type == GEL_VALUE_NODE &&
8574 l->type != GEL_VALUE_NODE) {
8575 n->op.args = r;
8576 r->any.next = l;
8577 l->any.next = NULL;
8578
8579 shuffled = TRUE;
8580
8581 GEL_GET_LR (n, l, r);
8582 }
8583
8584 /* make into (a*b)*c, "*" is * or + (oper) */
8585 /* unless a is a value and b and c are not */
8586 if (r->type == GEL_OPERATOR_NODE &&
8587 r->op.oper == oper) {
8588 GelETree *a, *b, *c;
8589 a = l;
8590 b = r->op.args;
8591 c = r->op.args->any.next;
8592
8593 if ( ! (a->type == GEL_VALUE_NODE &&
8594 b->type != GEL_VALUE_NODE &&
8595 c->type != GEL_VALUE_NODE)) {
8596 r->op.args = NULL;
8597 gel_freetree (r);
8598
8599 GEL_GET_NEW_NODE (l);
8600 l->type = GEL_OPERATOR_NODE;
8601 l->op.oper = oper;
8602 l->op.nargs = 2;
8603 l->op.args = a;
8604 a->any.next = b;
8605 b->any.next = NULL;
8606
8607 n->op.args = l;
8608 l->any.next = c;
8609 c->any.next = NULL;
8610
8611 shuffled = TRUE;
8612
8613 GEL_GET_LR (n, l, r);
8614 }
8615 }
8616
8617 /* if (a*b)*c and a is a value and b and c are not
8618 make into a*(b*c) */
8619 if (l->type == GEL_OPERATOR_NODE &&
8620 l->op.oper == oper) {
8621 GelETree *a, *b, *c;
8622 a = l->op.args;
8623 b = l->op.args->any.next;
8624 c = r;
8625
8626 if (a->type == GEL_VALUE_NODE &&
8627 b->type != GEL_VALUE_NODE &&
8628 c->type != GEL_VALUE_NODE) {
8629 l->op.args = NULL;
8630 gel_freetree (l);
8631
8632 GEL_GET_NEW_NODE (r);
8633 r->type = GEL_OPERATOR_NODE;
8634 r->op.oper = oper;
8635 r->op.nargs = 2;
8636 r->op.args = b;
8637 b->any.next = c;
8638 c->any.next = NULL;
8639
8640 n->op.args = a;
8641 a->any.next = r;
8642 r->any.next = NULL;
8643
8644 shuffled = TRUE;
8645
8646 /* GEL_GET_LR (n, l, r); */
8647 }
8648 }
8649 }
8650 return shuffled;
8651 }
8652
8653 void
gel_simplify(GelETree * n)8654 gel_simplify (GelETree *n)
8655 {
8656 resimplify:
8657 if (n == NULL)
8658 return;
8659
8660 if (n->type == GEL_OPERATOR_NODE) {
8661 GelETree *ali;
8662
8663 /* double negation is always positive no matter what */
8664 if (n->op.oper == GEL_E_NEG &&
8665 n->op.args->type == GEL_OPERATOR_NODE &&
8666 n->op.args->op.oper == GEL_E_NEG) {
8667 GelETree *nn;
8668 nn = n->op.args->op.args;
8669 n->op.args->op.args = NULL;
8670 replacenode (n, nn);
8671 goto resimplify;
8672 } else if(n->op.oper == GEL_E_MOD_CALC) {
8673 /* in case of modular calculation, only do
8674 precalc on the second argument (don't descend
8675 at all into the first one) */
8676 /* FIXME: precalc might be broken in case of mod */
8677 /* gel_try_to_do_precalc(n->op.args->any.next); */;
8678 /* double negation is always positive no matter what */
8679 return;
8680 }
8681
8682 if(n->op.args) {
8683 for(ali=n->op.args;ali;ali=ali->any.next)
8684 gel_simplify (ali);
8685 }
8686
8687 /* be aggressive! */
8688 try_to_precalc_op (n, FALSE /* respect_type */);
8689 if (n->type != GEL_OPERATOR_NODE)
8690 return;
8691
8692 /* FIXME: we want to assume addition ALWAYS comutes and
8693 multiplication sometimes commutes (must get some type
8694 info!). We can always at least move all numbers through
8695 and sort them by type and then precompute them */
8696 /* We can always assume associativity anyway! */
8697
8698 /* sort out multiplications and additions,
8699 putting all values first */
8700 if (oper_reshufle (n, GEL_E_MUL)) {
8701 goto resimplify;
8702 }
8703 if (oper_reshufle (n, GEL_E_PLUS)) {
8704 goto resimplify;
8705 }
8706
8707 /* Now try to put together multiplications and exponents */
8708 /* FIXME: this is too specific be more general!, though maybe if we sort out all
8709 multiplication and addition as above, things will work nicely */
8710 if (n->op.oper == GEL_E_MUL) {
8711 GelETree *l, *r;
8712 GelETree *ll, *rr;
8713 GelETree *le = NULL, *re = NULL;
8714 GEL_GET_LR (n, l, r);
8715 ll = l;
8716 rr = r;
8717 if (l->type == GEL_OPERATOR_NODE &&
8718 l->op.oper == GEL_E_EXP) {
8719 ll = l->op.args;
8720 le = l->op.args->any.next;
8721 }
8722 if (r->type == GEL_OPERATOR_NODE &&
8723 r->op.oper == GEL_E_EXP) {
8724 rr = r->op.args;
8725 re = r->op.args->any.next;
8726 }
8727 /* we can put this together! */
8728 if (gel_is_tree_same (ll, rr)) {
8729 GelETree *nn, *e;
8730
8731 n->op.args = NULL;
8732 gel_freetree (rr);
8733 if (re != NULL) {
8734 r->op.args = NULL;
8735 gel_freetree (r);
8736 }
8737 if (l != ll) {
8738 l->op.args = NULL;
8739 gel_freetree (l);
8740 }
8741
8742 GEL_GET_NEW_NODE (e);
8743 e->type = GEL_OPERATOR_NODE;
8744 e->op.oper = GEL_E_PLUS;
8745 e->op.nargs = 2;
8746 if (le == NULL) {
8747 e->op.args = gel_makenum_ui (1);
8748 } else {
8749 e->op.args = le;
8750 }
8751 if (re == NULL) {
8752 e->op.args->any.next = gel_makenum_ui (1);
8753 } else {
8754 e->op.args->any.next = re;
8755 }
8756 e->op.args->any.next->any.next = NULL;
8757
8758 GEL_GET_NEW_NODE (nn);
8759 nn->type = GEL_OPERATOR_NODE;
8760 nn->op.oper = GEL_E_EXP;
8761 nn->op.nargs = 2;
8762
8763 nn->op.args = ll;
8764 ll->any.next = e;
8765 e->any.next = NULL;
8766
8767 replacenode (n, nn);
8768
8769 goto resimplify;
8770 }
8771 }
8772
8773 /* FIXME: this is just like for GEL_E_MUL except re and le
8774 are on the other side si there are some changes */
8775 if (n->op.oper == GEL_E_PLUS) {
8776 GelETree *l, *r;
8777 GelETree *ll, *rr;
8778 GelETree *le = NULL, *re = NULL;
8779 GEL_GET_LR (n, l, r);
8780 ll = l;
8781 rr = r;
8782 if (l->type == GEL_OPERATOR_NODE &&
8783 l->op.oper == GEL_E_MUL) {
8784 le = l->op.args;
8785 ll = l->op.args->any.next;
8786 }
8787 if (r->type == GEL_OPERATOR_NODE &&
8788 r->op.oper == GEL_E_MUL) {
8789 re = r->op.args;
8790 rr = r->op.args->any.next;
8791 }
8792 /* we can put this together! */
8793 if (gel_is_tree_same (ll, rr)) {
8794 GelETree *nn, *e;
8795
8796 n->op.args = NULL;
8797 gel_freetree (rr);
8798 if (re != NULL) {
8799 r->op.args = NULL;
8800 gel_freetree (r);
8801 }
8802 if (l != ll) {
8803 l->op.args = NULL;
8804 gel_freetree (l);
8805 }
8806
8807 GEL_GET_NEW_NODE (e);
8808 e->type = GEL_OPERATOR_NODE;
8809 e->op.oper = GEL_E_PLUS;
8810 e->op.nargs = 2;
8811 if (le == NULL) {
8812 e->op.args = gel_makenum_ui (1);
8813 } else {
8814 e->op.args = le;
8815 }
8816 if (re == NULL) {
8817 e->op.args->any.next = gel_makenum_ui (1);
8818 } else {
8819 e->op.args->any.next = re;
8820 }
8821 e->op.args->any.next->any.next = NULL;
8822
8823 GEL_GET_NEW_NODE (nn);
8824 nn->type = GEL_OPERATOR_NODE;
8825 nn->op.oper = GEL_E_MUL;
8826 nn->op.nargs = 2;
8827
8828 nn->op.args = e;
8829 e->any.next = ll;
8830 ll->any.next = NULL;
8831
8832 replacenode (n, nn);
8833
8834 goto resimplify;
8835 }
8836 }
8837
8838 if (n->op.oper == GEL_E_MUL &&
8839 (n->op.args->type == GEL_VALUE_NODE ||
8840 n->op.args->any.next->type == GEL_VALUE_NODE)) {
8841 GelETree *l, *r;
8842 GEL_GET_LR (n, l, r);
8843
8844 /* multiply by 0, so nothing */
8845 if ((l->type == GEL_VALUE_NODE &&
8846 mpw_zero_p (l->val.value)) ||
8847 (r->type == GEL_VALUE_NODE &&
8848 mpw_zero_p (r->val.value))) {
8849 freetree_full (n, TRUE, FALSE);
8850 gel_makenum_ui_from (n, 0);
8851 } else if (l->type == GEL_VALUE_NODE &&
8852 mpw_eql_ui (l->val.value, 1)) {
8853 /* multiply by 1, so identity */
8854 n->op.args = NULL;
8855 gel_freetree (l);
8856 replacenode (n, r);
8857 } else if (r->type == GEL_VALUE_NODE &&
8858 mpw_eql_ui (r->val.value, 1)) {
8859 /* multiply by 1, so identity */
8860 n->op.args = NULL;
8861 gel_freetree (r);
8862 replacenode (n, l);
8863 }
8864 } else if (n->op.oper == GEL_E_DIV &&
8865 (n->op.args->type == GEL_VALUE_NODE ||
8866 n->op.args->any.next->type == GEL_VALUE_NODE)) {
8867 GelETree *l, *r;
8868 GEL_GET_LR (n, l, r);
8869
8870 /* divide 0 by something so nothing
8871 (unless the bottom is 0) */
8872 if ((l->type == GEL_VALUE_NODE &&
8873 mpw_zero_p (l->val.value)) &&
8874 (r->type != GEL_VALUE_NODE ||
8875 ! mpw_zero_p (r->val.value))) {
8876 freetree_full (n, TRUE, FALSE);
8877 gel_makenum_ui_from (n, 0);
8878 } else if (r->type == GEL_VALUE_NODE &&
8879 mpw_eql_ui (r->val.value, 1)) {
8880 /* divide by 1, so identity */
8881 n->op.args = NULL;
8882 gel_freetree (r);
8883 replacenode (n, l);
8884 }
8885 } else if (n->op.oper == GEL_E_PLUS &&
8886 (n->op.args->type == GEL_VALUE_NODE ||
8887 n->op.args->any.next->type == GEL_VALUE_NODE)) {
8888 GelETree *l, *r;
8889 GEL_GET_LR (n, l, r);
8890
8891 if (l->type == GEL_VALUE_NODE &&
8892 mpw_zero_p (l->val.value)) {
8893 /* add 0, so identity */
8894 n->op.args = NULL;
8895 gel_freetree (l);
8896 replacenode (n, r);
8897 } else if (r->type == GEL_VALUE_NODE &&
8898 mpw_zero_p (r->val.value)) {
8899 /* add 0, so identity */
8900 n->op.args = NULL;
8901 gel_freetree (r);
8902 replacenode (n, l);
8903 }
8904 } else if (n->op.oper == GEL_E_EXP) {
8905 GelETree *l, *r;
8906 GEL_GET_LR (n, l, r);
8907
8908 if (r->type == GEL_VALUE_NODE &&
8909 mpw_zero_p (r->val.value)) {
8910 /* something^0 so we get 1 */
8911 freetree_full (n, TRUE, FALSE);
8912 gel_makenum_ui_from (n, 1);
8913 } else if (l->type == GEL_OPERATOR_NODE &&
8914 l->op.oper == GEL_E_EXP) {
8915 /* (x^v)^w => x^(v*w);
8916 and then simplify again */
8917 GelETree *nn;
8918 GelETree *x, *v, *w;
8919
8920 x = l->op.args;
8921 v = l->op.args->any.next;
8922 w = r;
8923 l->op.args = NULL;
8924 gel_freetree (l);
8925
8926 GEL_GET_NEW_NODE (nn);
8927 nn->type = GEL_OPERATOR_NODE;
8928 nn->op.oper = GEL_E_MUL;
8929 nn->op.nargs = 2;
8930
8931 nn->op.args = v;
8932 v->any.next = w;
8933 w->any.next = NULL;
8934
8935 n->op.args = x;
8936 x->any.next = nn;
8937 nn->any.next = NULL;
8938
8939 goto resimplify;
8940 }
8941 }
8942 } else if(n->type==GEL_MATRIX_NODE) {
8943 int i,j;
8944 int w,h;
8945 if (n->mat.matrix == NULL ||
8946 gel_is_matrix_value_only (n->mat.matrix))
8947 return;
8948 w = gel_matrixw_width(n->mat.matrix);
8949 h = gel_matrixw_height(n->mat.matrix);
8950 gel_matrixw_make_private (n->mat.matrix, TRUE /* kill_type_caches */);
8951 for(j=0;j<h;j++) {
8952 for(i=0;i<w;i++) {
8953 GelETree *t = gel_matrixw_get_index(n->mat.matrix,i,j);
8954 if(t)
8955 gel_simplify (t);
8956 }
8957 }
8958 } else if(n->type==GEL_SET_NODE) {
8959 GelETree *ali;
8960 if(n->set.items) {
8961 for(ali=n->set.items;ali;ali=ali->any.next)
8962 gel_simplify (ali);
8963 }
8964 } else if(n->type==GEL_FUNCTION_NODE) {
8965 if ((n->func.func->type == GEL_USER_FUNC ||
8966 n->func.func->type == GEL_VARIABLE_FUNC) &&
8967 n->func.func->data.user)
8968 gel_simplify (n->func.func->data.user);
8969 }
8970 }
8971
8972 /* we define these even if MEM_DEBUG_FRIENDLY is on */
8973 static gboolean _gel_max_nodes_check = TRUE;
8974 /* Will get to the warning another page later, but that's OK
8975 * we don't expect this to be happening often */
8976 void
gel_test_max_nodes_again(void)8977 gel_test_max_nodes_again (void)
8978 {
8979 _gel_max_nodes_check = TRUE;
8980 }
8981
8982
8983 #ifndef MEM_DEBUG_FRIENDLY
8984 /* In tests it seems that this achieves better then 4096 */
8985 #define GEL_CHUNK_SIZE 4048
8986 #define ALIGNED_SIZE(t) (sizeof(t) + sizeof (t) % G_MEM_ALIGN)
8987
8988 static long _gel_tree_num = 0;
8989
8990 void
_gel_make_free_trees(void)8991 _gel_make_free_trees (void)
8992 {
8993 guint i;
8994 char *p;
8995
8996 if G_UNLIKELY (_gel_max_nodes_check &&
8997 gel_calcstate.max_nodes > 0 &&
8998 _gel_tree_num > gel_calcstate.max_nodes) {
8999 if (_gel_tree_limit_hook != NULL) {
9000 (*_gel_tree_limit_hook) ();
9001 }
9002 _gel_max_nodes_check = FALSE;
9003 }
9004
9005 p = g_malloc ((GEL_CHUNK_SIZE / ALIGNED_SIZE (GelETree)) *
9006 ALIGNED_SIZE (GelETree));
9007 for (i = 0; i < (GEL_CHUNK_SIZE / ALIGNED_SIZE (GelETree)); i++) {
9008 GelETree *t = (GelETree *)p;
9009 /*put onto the free list*/
9010 t->any.next = gel_free_trees;
9011 gel_free_trees = t;
9012 p += ALIGNED_SIZE (GelETree);
9013 _gel_tree_num ++;
9014 }
9015 }
9016
9017 static void
_gel_make_free_evl(void)9018 _gel_make_free_evl (void)
9019 {
9020 guint i;
9021 char *p;
9022
9023 p = g_malloc ((GEL_CHUNK_SIZE / ALIGNED_SIZE (GelEvalLoop)) *
9024 ALIGNED_SIZE (GelEvalLoop));
9025 for (i = 0; i < (GEL_CHUNK_SIZE / ALIGNED_SIZE (GelEvalLoop)); i++) {
9026 GelEvalLoop *t = (GelEvalLoop *)p;
9027 /*put onto the free list*/
9028 t->condition = (gpointer)free_evl;
9029 free_evl = t;
9030 p += ALIGNED_SIZE (GelEvalLoop);
9031 }
9032 }
9033
9034 static void
_gel_make_free_evf(void)9035 _gel_make_free_evf (void)
9036 {
9037 guint i;
9038 char *p;
9039
9040 p = g_malloc ((GEL_CHUNK_SIZE / ALIGNED_SIZE (GelEvalFor)) *
9041 ALIGNED_SIZE (GelEvalFor));
9042 for (i = 0; i < (GEL_CHUNK_SIZE / ALIGNED_SIZE (GelEvalFor)); i++) {
9043 GelEvalFor *t = (GelEvalFor *)p;
9044 /*put onto the free list*/
9045 t->body = (gpointer)free_evf;
9046 free_evf = t;
9047 p += ALIGNED_SIZE (GelEvalFor);
9048 }
9049 }
9050
9051 static void
_gel_make_free_evfi(void)9052 _gel_make_free_evfi (void)
9053 {
9054 guint i;
9055 char *p;
9056
9057 p = g_malloc ((GEL_CHUNK_SIZE / ALIGNED_SIZE (GelEvalForIn)) *
9058 ALIGNED_SIZE (GelEvalForIn));
9059 for (i = 0; i < (GEL_CHUNK_SIZE / ALIGNED_SIZE (GelEvalForIn)); i++) {
9060 GelEvalForIn *t = (GelEvalForIn *)p;
9061 /*put onto the free list*/
9062 t->body = (gpointer)free_evfi;
9063 free_evfi = t;
9064 p += ALIGNED_SIZE (GelEvalForIn);
9065 }
9066 }
9067 #endif /* ! MEM_DEBUG_FRIENDLY */
9068
9069 #ifdef MEM_DEBUG_FRIENDLY
9070 # ifdef EVAL_DEBUG
9071 static GSList *trees_list = NULL;
9072 void
register_new_tree(GelETree * n)9073 register_new_tree (GelETree *n)
9074 {
9075 trees_list = g_slist_prepend (trees_list, n);
9076 }
9077 void
deregister_tree(GelETree * n)9078 deregister_tree (GelETree *n)
9079 {
9080 trees_list = g_slist_remove (trees_list, n);
9081 }
9082 void
print_live_trees(void)9083 print_live_trees (void)
9084 {
9085 GSList *li;
9086 int count = 0;
9087 for (li = trees_list; li != NULL; li = li->next) {
9088 char *s;
9089 GelETree *n = li->data;
9090 s = gel_string_print_etree (n);
9091 printf ("TREE %p:\t%s\n", n, s);
9092 g_free (s);
9093 count ++;
9094 }
9095 printf ("count %d:\n", count);
9096 }
9097 void
deregister_all_trees(void)9098 deregister_all_trees (void)
9099 {
9100 g_slist_free (trees_list);
9101 trees_list = NULL;
9102 }
9103 # endif /* EVAL_DEBUG */
9104 #endif /* MEM_DEBUG_FRIENDLY */
9105