FORM v5.0.1-33-gdf7fc94
comexpr.c
Go to the documentation of this file.
1
8/* #[ License : */
9/*
10 * Copyright (C) 1984-2026 J.A.M. Vermaseren
11 * When using this file you are requested to refer to the publication
12 * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
13 * This is considered a matter of courtesy as the development was paid
14 * for by FOM the Dutch physics granting agency and we would like to
15 * be able to track its scientific use to convince FOM of its value
16 * for the community.
17 *
18 * This file is part of FORM.
19 *
20 * FORM is free software: you can redistribute it and/or modify it under the
21 * terms of the GNU General Public License as published by the Free Software
22 * Foundation, either version 3 of the License, or (at your option) any later
23 * version.
24 *
25 * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
26 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
27 * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
28 * details.
29 *
30 * You should have received a copy of the GNU General Public License along
31 * with FORM. If not, see <http://www.gnu.org/licenses/>.
32 */
33/* #] License : */
34
35/*
36 #[ Includes : compi2.c
37
38 File contains most of what has to do with compiling expressions.
39 Main supporting file: token.c
40*/
41
42#include "form3.h"
43
44static struct id_options {
45 UBYTE *name;
46 int code;
47 int dummy;
48} IdOptions[] = {
49 {(UBYTE *)"multi", SUBMULTI ,0}
50 ,{(UBYTE *)"many", SUBMANY ,0}
51 ,{(UBYTE *)"only", SUBONLY ,0}
52 ,{(UBYTE *)"once", SUBONCE ,0}
53 ,{(UBYTE *)"ifmatch", SUBAFTER ,0}
54 ,{(UBYTE *)"ifnomatch", SUBAFTERNOT ,0}
55 ,{(UBYTE *)"ifnotmatch", SUBAFTERNOT ,0}
56 ,{(UBYTE *)"disorder", SUBDISORDER ,0}
57 ,{(UBYTE *)"select", SUBSELECT ,0}
58 ,{(UBYTE *)"all", SUBALL ,0}
59};
60
61/*
62 #] Includes :
63 #[ CoLocal :
64*/
65
66int CoLocal(UBYTE *inp) { return(DoExpr(inp,LOCALEXPRESSION,0)); }
67
68/*
69 #] CoLocal :
70 #[ CoGlobal :
71*/
72
73int CoGlobal(UBYTE *inp) { return(DoExpr(inp,GLOBALEXPRESSION,0)); }
74
75/*
76 #] CoGlobal :
77 #[ CoLocalFactorized :
78*/
79
80int CoLocalFactorized(UBYTE *inp) { return(DoExpr(inp,LOCALEXPRESSION,1)); }
81
82/*
83 #] CoLocalFactorized :
84 #[ CoGlobalFactorized :
85*/
86
87int CoGlobalFactorized(UBYTE *inp) { return(DoExpr(inp,GLOBALEXPRESSION,1)); }
88
89/*
90 #] CoGlobalFactorized :
91 #[ DoExpr:
92
93
94*/
95
96int DoExpr(UBYTE *inp, int type, int par)
97{
98 GETIDENTITY
99 int error = 0;
100 UBYTE *p, *q, c;
101 WORD *w, i, j = 0, c1, c2, *OldWork = AT.WorkPointer, osize;
102 WORD jold = 0;
103 POSITION pos;
104 while ( *inp == ',' ) inp++;
105 if ( par ) AC.ToBeInFactors = 1;
106 else AC.ToBeInFactors = 0;
107 p = inp;
108 while ( *p && *p != '=' ) {
109 if ( *p == '(' ) SKIPBRA4(p)
110 else if ( *p == '{' ) SKIPBRA5(p)
111 else if ( *p == '[' ) SKIPBRA1(p)
112 else p++;
113 }
114 if ( *p ) { /* Variety with the = sign */
115 q = SkipAName(inp);
116 if ( *inp == '$' || q == 0 || q[-1] == '_' ) {
117 MesPrint("&Illegal name for expression");
118 error = 1;
119 return(error);
120 }
121 else {
122 c = *q; *q = 0;
123 if ( GetVar(inp,&c1,&c2,ALLVARIABLES,NOAUTO) != NAMENOTFOUND ) {
124 if ( c1 == CEXPRESSION ) {
125 if ( Expressions[c2].status == STOREDEXPRESSION ) {
126 MesPrint("&Illegal attempt to overwrite a stored expression");
127 error = 1;
128 }
129 else {
130 HighWarning("Expression is replaced by new definition");
131 if ( AO.OptimizeResult.nameofexpr != NULL &&
132 StrCmp(inp,AO.OptimizeResult.nameofexpr) == 0 ) {
133 ClearOptimize();
134 }
135 if ( Expressions[c2].status != DROPPEDEXPRESSION ) {
136 w = &(Expressions[c2].status);
137 if ( *w == LOCALEXPRESSION || *w == SKIPLEXPRESSION )
138 *w = DROPLEXPRESSION;
139 else if ( *w == GLOBALEXPRESSION || *w == SKIPGEXPRESSION )
140 *w = DROPGEXPRESSION;
141 else if ( *w == HIDDENLEXPRESSION )
142 *w = DROPHLEXPRESSION;
143 else if ( *w == HIDDENGEXPRESSION )
144 *w = DROPHGEXPRESSION;
145 }
146 AC.TransEname = Expressions[c2].name;
147 j = EntVar(CEXPRESSION,0,type,0,0,0);
148 Expressions[j].node = Expressions[c2].node;
149 Expressions[c2].replace = j;
150 }
151 }
152 else {
153 MesPrint("&name of expression is also name of a variable");
154 error = 1;
155 j = EntVar(CEXPRESSION,inp,type,0,0,0);
156 }
157 jold = c2;
158 }
159 else {
160/*
161 Here we have to worry about reuse of the expression in the
162 same module. That will need AS.Oldvflags but that may not
163 be defined or have the proper value.
164*/
165 j = EntVar(CEXPRESSION,inp,type,0,0,0);
166 jold = j;
167 }
168 *q = c;
169 OldWork = w = AT.WorkPointer;
170 *w++ = TYPEEXPRESSION;
171 *w++ = 3+SUBEXPSIZE;
172 *w++ = j;
173 AC.ProtoType = w;
174 AR.CurExpr = j; /* Block expression j */
175 *w++ = SUBEXPRESSION;
176 *w++ = SUBEXPSIZE;
177 *w++ = j;
178 *w++ = 1;
179 *w++ = AC.cbufnum;
180 FILLSUB(w)
181
182 if ( c == '(' ) {
183 while ( *q == ',' || *q == '(' ) {
184 inp = q+1;
185 if ( ( q = SkipAName(inp) ) == 0 ) {
186 MesPrint("&Illegal name for expression argument");
187 error = 1;
188 q = p - 1;
189 break;
190 }
191 c = *q; *q = 0;
192 if ( GetVar(inp,&c1,&c2,ALLVARIABLES,WITHAUTO) < 0 ) c1 = -1;
193 switch ( c1 ) {
194 case CSYMBOL :
195 *w++ = SYMTOSYM; *w++ = 4; *w++ = c2; *w++ = 0;
196 break;
197 case CINDEX :
198 *w++ = INDTOIND; *w++ = 4;
199 *w++ = c2 + AM.OffsetIndex; *w++ = 0;
200 break;
201 case CVECTOR :
202 *w++ = VECTOVEC; *w++ = 4;
203 *w++ = c2 + AM.OffsetVector; *w++ = 0;
204 break;
205 case CFUNCTION :
206 *w++ = FUNTOFUN; *w++ = 4; *w++ = c2 + FUNCTION; *w++ = 0;
207 break;
208 default :
209 MesPrint("&Illegal expression parameter: %s",inp);
210 error = 1;
211 break;
212 }
213 *q = c;
214 }
215 if ( *q != ')' || q+1 != p ) {
216 MesPrint("&Illegal use of arguments for expression");
217 error = 1;
218 }
219 AC.ProtoType[1] = w - AC.ProtoType;
220 }
221 else if ( c != '=' ) {
222/*
223 The dummy accepted L F := RHS;
224*/
225 MesPrint("&Illegal LHS for expression definition");
226 error = 1;
227 }
228 *w++ = 1;
229 *w++ = 1;
230 *w++ = 3;
231 *w++ = 0;
232 SeekScratch(AR.outfile,&pos);
233 Expressions[j].counter = 1;
234 Expressions[j].onfile = pos;
235 Expressions[j].whichbuffer = 0;
236#ifdef PARALLELCODE
237 Expressions[j].partodo = AC.inparallelflag;
238#endif
239 OldWork[2] = w - OldWork - 3;
240 AT.WorkPointer = w;
241/*
242 Writing the expression prototype to disk and to the compiler
243 buffer is done only after the RHS has been compiled because
244 we don't know the number of the main level RHS yet.
245*/
246 }
247 inp = p+1;
248 ClearWildcardNames();
249 osize = AC.ProtoType[1]; AC.ProtoType[1] = SUBEXPSIZE;
250 PutInVflags(jold);
251 if ( ( i = CompileAlgebra(inp,RHSIDE,AC.ProtoType) ) < 0 ) {
252 AC.ProtoType[1] = osize;
253 error = 1;
254 }
255 else if ( error == 0 ) {
256 AC.ProtoType[1] = osize;
257 AC.ProtoType[2] = i;
258 if ( PutOut(BHEAD OldWork+2,&pos,AR.outfile,0) < 0 ) {
259/* INTERNAL_ERROR_EXCL_START */
260 MesPrint("!>Cannot create expression");
261 error = -1;
262/* INTERNAL_ERROR_EXCL_STOP */
263 }
264 else {
265 Expressions[j].sizeprototype = OldWork[2];
266 OldWork[2] = 4+SUBEXPSIZE;
267 OldWork[4] = SUBEXPSIZE;
268 OldWork[5] = i;
269 OldWork[SUBEXPSIZE+3] = 1;
270 OldWork[SUBEXPSIZE+4] = 1;
271 OldWork[SUBEXPSIZE+5] = 3;
272 OldWork[SUBEXPSIZE+6] = 0;
273 if ( PutOut(BHEAD OldWork+2,&pos,AR.outfile,0) < 0
274 || FlushOut(&pos,AR.outfile,0) ) {
275/* INTERNAL_ERROR_EXCL_START */
276 MesPrint("!>Cannot create expression");
277 error = -1;
278/* INTERNAL_ERROR_EXCL_STOP */
279 }
280 AR.outfile->POfull = AR.outfile->POfill;
281 }
282 OldWork[2] = j;
283/*
284 Seems unnecessary (13-feb-2018)
285
286 AddNtoL(OldWork[1],OldWork);
287*/
288 AT.WorkPointer = OldWork;
289 if ( AC.dumnumflag ) Add2Com(TYPEDETCURDUM)
290 }
291 AC.ToBeInFactors = 0;
292 }
293 else { /* Variety in which expressions change property */
294/*
295 This code got a major revision because it didn't
296 take hidden expressions into account. (1-jun-2010 JV)
297*/
298 do {
299 if ( ( q = SkipAName(inp) ) == 0 ) {
300 MesPrint("&Illegal name(s) for expression(s)");
301 return(1);
302 }
303 c = *q; *q = 0;
304 if ( GetName(AC.exprnames,inp,&c2,NOAUTO) == NAMENOTFOUND ) {
305 MesPrint("&%s is not a valid expression",inp);
306 error = 1;
307 }
308 else {
309 w = &(Expressions[c2].status);
310 if ( type == LOCALEXPRESSION ) {
311 switch ( *w ) {
312 case GLOBALEXPRESSION:
313 *w = LOCALEXPRESSION;
314 break;
315 case SKIPGEXPRESSION:
316 *w = SKIPLEXPRESSION;
317 break;
318 case DROPGEXPRESSION:
319 *w = DROPLEXPRESSION;
320 break;
321 case HIDDENGEXPRESSION:
322 *w = HIDDENLEXPRESSION;
323 break;
324 case HIDEGEXPRESSION:
325 *w = HIDELEXPRESSION;
326 break;
327 case UNHIDEGEXPRESSION:
328 *w = UNHIDELEXPRESSION;
329 break;
330 case INTOHIDEGEXPRESSION:
331 *w = INTOHIDELEXPRESSION;
332 break;
333 case DROPHGEXPRESSION:
334 *w = DROPHLEXPRESSION;
335 break;
336 }
337 }
338 else if ( type == GLOBALEXPRESSION ) {
339 switch ( *w ) {
340 case LOCALEXPRESSION:
341 *w = GLOBALEXPRESSION;
342 break;
343 case SKIPLEXPRESSION:
344 *w = SKIPGEXPRESSION;
345 break;
346 case DROPLEXPRESSION:
347 *w = DROPGEXPRESSION;
348 break;
349 case HIDDENLEXPRESSION:
350 *w = HIDDENGEXPRESSION;
351 break;
352 case HIDELEXPRESSION:
353 *w = HIDEGEXPRESSION;
354 break;
355 case UNHIDELEXPRESSION:
356 *w = UNHIDEGEXPRESSION;
357 break;
358 case INTOHIDELEXPRESSION:
359 *w = INTOHIDEGEXPRESSION;
360 break;
361 case DROPHLEXPRESSION:
362 *w = DROPHGEXPRESSION;
363 break;
364 }
365 }
366/*
367 old code
368 if ( type != LOCALEXPRESSION || *w != STOREDEXPRESSION )
369 *w = type;
370*/
371 }
372 *q = c; inp = q+1;
373 } while ( c == ',' );
374 if ( c ) {
375 MesPrint("&Illegal object in local or global redefinition");
376 error = 1;
377 }
378 }
379 return(error);
380}
381
382/*
383 #] DoExpr:
384 #[ CoIdOld :
385*/
386
387int CoIdOld(UBYTE *inp)
388{
389 AC.idoption = 0;
390 return(CoIdExpression(inp,TYPEIDOLD));
391}
392
393/*
394 #] CoIdOld :
395 #[ CoId :
396*/
397
398int CoId(UBYTE *inp)
399{
400 AC.idoption = 0;
401 return(CoIdExpression(inp,TYPEIDNEW));
402}
403
404/*
405 #] CoId :
406 #[ CoIdNew :
407*/
408
409int CoIdNew(UBYTE *inp)
410{
411 AC.idoption = 0;
412 return(CoIdExpression(inp,TYPEIDNEW));
413}
414
415/*
416 #] CoIdNew :
417 #[ CoDisorder :
418*/
419
420int CoDisorder(UBYTE *inp)
421{
422 AC.idoption = SUBDISORDER;
423 return(CoIdExpression(inp,TYPEIDNEW));
424}
425
426/*
427 #] CoDisorder :
428 #[ CoMany :
429*/
430
431int CoMany(UBYTE *inp)
432{
433 AC.idoption = SUBMANY;
434 return(CoIdExpression(inp,TYPEIDNEW));
435}
436
437/*
438 #] CoMany :
439 #[ CoMulti :
440*/
441
442int CoMulti(UBYTE *inp)
443{
444 AC.idoption = SUBMULTI;
445 return(CoIdExpression(inp,TYPEIDNEW));
446}
447
448/*
449 #] CoMulti :
450 #[ CoIfMatch :
451*/
452
453int CoIfMatch(UBYTE *inp)
454{
455 AC.idoption = SUBAFTER;
456 return(CoIdExpression(inp,TYPEIDNEW));
457}
458
459/*
460 #] CoIfMatch :
461 #[ CoIfNoMatch :
462*/
463
464int CoIfNoMatch(UBYTE *inp)
465{
466 AC.idoption = SUBAFTERNOT;
467 return(CoIdExpression(inp,TYPEIDNEW));
468}
469
470/*
471 #] CoIfNoMatch :
472 #[ CoOnce :
473*/
474
475int CoOnce(UBYTE *inp)
476{
477 AC.idoption = SUBONCE;
478 return(CoIdExpression(inp,TYPEIDNEW));
479}
480
481/*
482 #] CoOnce :
483 #[ CoOnly :
484*/
485
486int CoOnly(UBYTE *inp)
487{
488 AC.idoption = SUBONLY;
489 return(CoIdExpression(inp,TYPEIDNEW));
490}
491
492/*
493 #] CoOnly :
494 #[ CoSelect :
495*/
496
497int CoSelect(UBYTE *inp)
498{
499 AC.idoption = SUBSELECT;
500 return(CoIdExpression(inp,TYPEIDNEW));
501}
502
503/*
504 #] CoSelect :
505 #[ CoIdExpression :
506
507 First finish dealing with secondary keywords
508*/
509
510int CoIdExpression(UBYTE *inp, int type)
511{
512 GETIDENTITY
513 int i, j, idhead, error = 0, MinusSign = 0, opt, retcode;
514 WORD *w, *s, *m, *mm, *ww, *FirstWork, *OldWork, c1, numsets = 0,
515 oldnumrhs, *ow, oldEside;
516 UBYTE *p, *pp, c;
517 CBUF *C = cbuf+AC.cbufnum;
518 LONG oldcpointer, x;
519 FirstWork = OldWork = AT.WorkPointer;
520/*
521 Don't forget to change in StudyPattern if we change/add_to the
522 following setup.
523 if ( type == TYPEIF ) idhead = IDHEAD-1;
524 else
525*/
526 idhead = IDHEAD;
527 AR.CurExpr = -1;
528 w = AT.WorkPointer;
529 *w++ = type;
530 *w++ = idhead + SUBEXPSIZE;
531 w++;
532 if ( idhead >= IDHEAD ) *w++ = -1;
533#if IDHEAD > 4
534 for ( i = 4; i < idhead; i++ ) *w++ = 0;
535#endif
536 while ( *inp == ',' ) inp++;
537 p = inp;
538 if ( AC.idoption == SUBSELECT ) {
539 p--;
540 goto findsets;
541 }
542 else if ( ( AC.idoption == SUBAFTER ) || ( AC.idoption == SUBAFTERNOT ) ) {
543 while ( *p && *p != '=' && *p != ',' ) {
544 if ( *p == '(' ) SKIPBRA4(p)
545 else if ( *p == '{' ) SKIPBRA5(p)
546 else if ( *p == '[' ) SKIPBRA1(p)
547 else p++;
548 }
549 if ( *p == '=' || *inp != '-' || inp[1] != '>' ) {
550 MesPrint("&Illegal use if if[no]match in id statement");
551 error = 1; goto AllDone;
552 }
553 if ( *p == 0 ) {
554 MesPrint("&id-statement without = sign");
555 error = 1; goto AllDone;
556 }
557 inp += 2; pp = inp;
558 goto readlabel;
559 }
560 for(;;) {
561 while ( *p && *p != '=' && *p != ',' ) {
562 if ( *p == '(' ) SKIPBRA4(p)
563 else if ( *p == '{' ) SKIPBRA5(p)
564 else if ( *p == '[' ) SKIPBRA1(p)
565 else p++;
566 }
567 if ( *p == '=' ) break;
568 if ( *p == 0 ) {
569 MesPrint("&id-statement without = sign");
570 error = 1; goto AllDone;
571 }
572/*
573 We have either a secondary option or a syntax error
574*/
575 pp = inp;
576 while ( FG.cTable[*pp] == 0 ) pp++;
577 c = *pp; *pp = 0;
578 i = sizeof(IdOptions)/sizeof(struct id_options);
579 while ( --i >= 0 ) {
580 if ( StrICmp(inp,IdOptions[i].name) == 0 ) break;
581 }
582 if ( i < 0 ) {
583 MesPrint("&Illegal option %s in id-statement",inp);
584 *pp = c; error = 1; p++; inp = p; continue;
585 }
586 opt = IdOptions[i].code;
587 *pp = c;
588 inp = pp+1;
589 switch ( opt ) {
590 case SUBDISORDER:
591 if ( pp != p ) goto IllField;
592 AC.idoption |= SUBDISORDER;
593 p++; inp = p;
594 break;
595 case SUBSELECT:
596 if ( p != pp ) goto IllField;
597 if ( ( AC.idoption & SUBMASK ) != 0 ) {
598 if ( AC.idoption == SUBMULTI && type == TYPEIF ) {}
599 else {
600 MesPrint("&Conflicting options in id-statement");
601 error = 1;
602 }
603 }
604findsets:;
605/*
606 Now we read the sets
607*/
608 numsets = 0;
609 for(;;) {
610 inp = ++p;
611 while ( *p && *p != '=' && *p != ',' ) {
612 if ( *p == '(' ) SKIPBRA4(p)
613 else if ( *p == '{' ) SKIPBRA5(p)
614 else if ( *p == '[' ) SKIPBRA1(p)
615 else p++;
616 }
617 if ( *p == '=' ) break;
618 if ( *p == 0 ) {
619 MesPrint("&id-statement without = sign");
620 error = 1; goto AllDone;
621 }
622/*
623 We have a set at inp.
624*/
625 if ( *inp == '{' ) {
626 if ( p[-1] != '}' ) {
627 c = *p; *p = 0;
628 MesPrint("&Illegal temporary set: %s",inp);
629 error = 1; *p = c;
630 }
631 else {
632 inp++;
633 c = p[-1]; p[-1] = 0;
634 c1 = DoTempSet(inp,p-1);
635 *w++ = c1;
636 p[-1] = c;
637 numsets++;
638 if ( w[-1] < 0 ) error = 1;
639 }
640 }
641 else {
642 c = *p; *p = 0;
643 if ( GetName(AC.varnames,inp,&c1,NOAUTO) != CSET ) {
644 MesPrint("&%s is not a set",inp);
645 error = 1;
646 }
647 else {
648 if ( c1 < AM.NumFixedSets ) {
649 MesPrint("&Built in sets are not allowed in the select option");
650 error = 1;
651 }
652 else if ( Sets[c1].type == CRANGE ) {
653 MesPrint("&Ranged sets are not allowed in the select option");
654 error = 1;
655 }
656 numsets++;
657 *w++ = c1;
658 }
659 *p = c;
660 }
661 }
662/*
663 Now exchange the positions a bit.
664 Regular stuff at OldWork, numsets sets at FirstWork[idhead]
665*/
666 OldWork = w;
667 for ( i = 0; i < idhead; i++ ) *w++ = FirstWork[i];
668 AC.idoption = SUBSELECT;
669 break;
670 case SUBAFTER:
671 case SUBAFTERNOT:
672 if ( type == TYPEIF ) {
673 MesPrint("&The if[no]match->label option is not allowed in an if statement");
674 error = 1; goto AllDone;
675 }
676 if ( pp[0] != '-' || pp[1] != '>' ) goto IllField;
677 pp += 2; /* points now at the label */
678 inp = pp;
679 AC.idoption |= opt;
680readlabel:
681 while ( FG.cTable[*pp] <= 1 ) pp++;
682 if ( pp != p ) {
683 c = *p; *p = 0;
684 MesPrint("&Illegal label %s in if[no]match option of id-statement",inp);
685 *p = c; error = 1; inp = p+1; continue;
686 }
687 c = *p; *p = 0;
688 OldWork[3] = GetLabel(inp);
689 *p++ = c; inp = p;
690 break;
691 case SUBALL:
692 x = 0;
693 if ( *pp == '(' ) {
694 if ( FG.cTable[*inp] == 1 ) {
695 while ( *inp >= '0' && *inp <= '9' ) x = 10*x+*inp++ - '0';
696 }
697 else {
698 pp++;
699 while ( FG.cTable[*inp] == 0 ) inp++;
700 c = *inp; *inp = 0;
701 if ( StrICont(pp,(UBYTE *)"normalize") != 0 ) goto IllOpt;
702 *inp = c;
703 OldWork[4] |= NORMALIZEFLAG;
704 }
705 if ( *inp != ')' || inp+1 != p ) {
706 c = *inp; *inp = 0;
707IllOpt:
708 MesPrint("&Illegal ALL option in id-statement: ",pp);
709 *inp++ = c;
710 error = 1;
711 continue;
712 }
713 pp = inp;
714 inp = pp+1;
715 }
716/*
717 Note that the following statement limits x to
718*/
719 if ( x > MAXPOSITIVE ) {
720 MesPrint("&Requested maximum number of matches %l in ALL option in id-statement is greater than %l ",x,MAXPOSITIVE);
721 error = 1;
722 }
723 OldWork[5] = x;
724 if ( type != TYPEIDNEW ) {
725 if ( type == TYPEIDOLD ) {
726 MesPrint("&Requested ALL option not allowed in idold/also statement.");
727 error = 1;
728 }
729 else if ( type == TYPEIF ) {
730 MesPrint("&Requested ALL option not allowed in if(match())");
731 error = 1;
732 }
733 else {
734 MesPrint("&ALL option only allowed in regular id-statement.");
735 error = 1;
736 }
737 }
738 p++; inp = p;
739 AC.idoption = opt;
740 break;
741 default:
742 if ( pp != p ) {
743IllField: c = *p; *p = 0;
744 MesPrint("&Illegal optionfield %s in id-statement",inp);
745 *p = c; error = 1; inp = p+1; continue;
746 }
747 i = AC.idoption & SUBMASK;
748 if ( i && i != opt ) {
749 MesPrint("&Conflicting options in id-statement");
750 error = 1; continue;
751 }
752 else AC.idoption |= opt;
753 while ( *p == ',' ) p++;
754 inp = p;
755 break;
756 }
757 }
758 if ( ( AC.idoption & SUBMASK ) == 0 ) AC.idoption |= SUBMULTI;
759 OldWork[2] = AC.idoption;
760/*
761 Now we have a field till the = sign
762 Now the subexpression prototype
763*/
764 AC.ProtoType = w;
765 *w++ = SUBEXPRESSION;
766 *w++ = SUBEXPSIZE;
767 *w++ = C->numrhs+1;
768 *w++ = 1;
769 *w++ = AC.cbufnum;
770 FILLSUB(w)
771 AC.WildC = w;
772 AC.NwildC = 0;
773 AT.WorkPointer = s = w + 4*AM.MaxWildcards + 8;
774/*
775 Now read the LHS
776*/
777 ClearWildcardNames();
778 oldcpointer = AddLHS(AC.cbufnum) - C->Buffer;
779
780 *p = 0;
781 oldnumrhs = C->numrhs;
782 if ( ( retcode = CompileAlgebra(inp,LHSIDE,AC.ProtoType) ) < 0 ) { error = 1; }
783 else AC.ProtoType[2] = retcode;
784 *p = '='; inp = p+1;
785 AT.WorkPointer = s;
786 if ( AC.NwildC && SortWild(w,AC.NwildC) ) error = 1;
787
788 /* Make the LHS pointers ready */
789
790 OldWork[1] = AC.WildC-OldWork;
791 OldWork[idhead+1] = OldWork[1] - idhead;
792 w = AC.WildC;
793 AT.WorkPointer = w;
794 s = C->rhs[C->numrhs];
795/*
796 Now check whether wildcards get converted to dollars (for PARALLEL)
797*/
798 {
799 WORD *tw, *twstop;
800 tw = AC.ProtoType; twstop = tw + tw[1]; tw += SUBEXPSIZE;
801 while ( tw < twstop ) {
802 if ( *tw == LOADDOLLAR ) {
803 AddPotModdollar(tw[2]);
804 }
805 tw += tw[1];
806 }
807 }
808/*
809 We have the expression in the compiler buffers.
810 The main level is at lhs[numlhs]
811 The partial lhs (including ProtoType) is in OldWork (in WorkSpace)
812 We need to load the result at w after the prototype
813 Because these sort routines don't use the WorkSpace
814 there should not be a conflict
815*/
816 if ( !error && *s == 0 ) {
817IllLeft:MesPrint("&Illegal LHS");
818 AC.lhdollarflag = 0;
819 return(1);
820 }
821 if ( !error && *(s+*s) != 0 ) {
822 MesPrint("&LHS should be one term only");
823 return(1);
824 }
825 if ( error == 0 ) {
826 WORD oldpolyfun = AR.PolyFun;
827 if ( NewSort(BHEAD0) || NewSort(BHEAD0) ) {
828 if ( !error ) error = 1;
829 return(error);
830 }
831 AN.RepPoint = AT.RepCount + 1;
832 ow = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
833 mm = s; ww = ow; i = *mm;
834 while ( --i >= 0 ) {*ww++ = *mm++;} AT.WorkPointer = ww;
835 AC.lhdollarflag = 0; oldEside = AR.Eside; AR.Eside = LHSIDE;
836 AR.Cnumlhs = C->numlhs;
837 AR.PolyFun = 0;
838 if ( Generator(BHEAD ow,C->numlhs) ) {
839 AR.Eside = oldEside;
840 LowerSortLevel(); LowerSortLevel(); AR.PolyFun = oldpolyfun; goto IllLeft;
841 }
842 AR.Eside = oldEside;
843 AT.WorkPointer = w;
844 if ( EndSort(BHEAD w,0) < 0 ) { LowerSortLevel(); AR.PolyFun = oldpolyfun; goto IllLeft; }
845 AR.PolyFun = oldpolyfun;
846 if ( *w == 0 || *(w+*w) != 0 ) {
847 MesPrint("&LHS must be one term");
848 AC.lhdollarflag = 0;
849 return(1);
850 }
851 LowerSortLevel();
852 if ( AC.lhdollarflag ) MarkDirty(w,DIRTYFLAG);
853 }
854 AT.WorkPointer = w + *w;
855 AC.DumNum = 0;
856/*
857 Everything is now after OldWork. We can pop the compilerbuffer.
858 Next test for illegal things like a coefficient
859 At this point we have:
860 w = the term of the LHS
861*/
862 C->Pointer = C->Buffer + oldcpointer;
863 C->numrhs = oldnumrhs;
864 C->numlhs--;
865
866 m = w + *w - 3;
867 AC.vectorlikeLHS = 0;
868 if ( !error ) {
869 if ( m[2] != 3 || m[1] != 1 || *m != 1 ) {
870 if ( *m == 1 && m[1] == 1 && m[2] == -3 ) {
871 MinusSign = 1;
872 }
873 else {
874 MesPrint("&Coefficient in LHS");
875 error = 1;
876 AC.DumNum = 0;
877 *w -= ABS(m[2])-3;
878 }
879 }
880 if ( *w == 7 && w[1] == INDEX && w[3] < 0 ) {
881 if ( ( AC.idoption & SUBMASK ) != 0 && ( AC.idoption & SUBMASK ) !=
882 SUBMULTI ) {
883 MesPrint("&Illegal option for substitution of a vector");
884 error = 1;
885 }
886 AC.DumNum = AM.IndDum;
887 OldWork[2] = ( OldWork[2] - ( OldWork[2] & SUBMASK ) ) | SUBVECTOR;
888 c1 = w[3];
889 /* We overwrite the LHS */
890 *w++ = INDTOIND;
891 *w++ = 4;
892 *w++ = AC.DumNum + WILDOFFSET;
893 *w++ = 0;
894 w[0] = 5;
895 w[1] = VECTOR;
896 w[2] = 4;
897 w[3] = c1;
898 w[4] = AC.DumNum + WILDOFFSET;
899 OldWork[idhead+1] = w - OldWork - idhead;
900 AC.vectorlikeLHS = 1;
901 }
902 else {
903 AC.DumNum = 0;
904 *w -= 3;
905 i = OldWork[2] & SUBMASK;
906 m = w + *w;
907 if ( i == 0 || i == SUBMULTI ) {
908 s = w+1;
909 while ( s < m ) {
910 if ( *s == SYMBOL ) {
911 j = s[1]/2; s += 2;
912 while ( --j >= 0 ) {
913 if ( ABS(s[1]) > 2*MAXPOWER ) {
914 OldWork[2] = ( OldWork[2] - i ) | SUBONCE;
915 break;
916 }
917 s += 2;
918 }
919 if ( j >= 0 ) break;
920 }
921 else if ( *s == DOTPRODUCT ) {
922 j = s[1]/3; s += 2;
923 while ( --j >= 0 ) {
924 if ( ABS(s[2]) > 2*MAXPOWER ) {
925 OldWork[2] = ( OldWork[2] - i ) | SUBONCE;
926 break;
927 }
928 else if ( s[1] >= -(2*WILDOFFSET) || s[0] >= -(2*WILDOFFSET) ) {
929 OldWork[2] = ( OldWork[2] - i ) | SUBMANY;
930 i = SUBMANY;
931 }
932 s += 3;
933 }
934 if ( j >= 0 ) break;
935 }
936 else {
937 OldWork[2] = ( OldWork[2] - i ) | SUBMANY;
938 break;
939 }
940 }
941 }
942 if ( ( OldWork[2] & SUBMASK ) == 0 ) OldWork[2] |= SUBMULTI;
943 }
944 if ( ( OldWork[2] & SUBMASK ) == SUBSELECT ) {
945/*
946 Paste the SETSET information after the pattern.
947 Important note: We will still get function information for the
948 smart patternmatching after it. To distinguish them we need to have
949 that SETSET != m*n+1 in which m is the number of words per function
950 and n the number of functions. Currently (29-may-1997) m = 4.
951*/
952 *m++ = SETSET;
953 *m++ = numsets+2;
954 s = FirstWork + idhead;
955 while ( --numsets >= 0 ) *m++ = *s++;
956 }
957 else {
958 m = w + *w;
959 }
960 }
961/*
962 We keep the whole thing in OldWork for the moment.
963 We still have to add the number of the RHS expression.
964 There is also some opportunity now to be smart about the pattern.
965 This is needed for complicated wildcarding with symmetric functions.
966 We do this in a special routine during compile time to make sure
967 that we loose as little time as possible (during running) if there
968 is no need to be smart.
969*/
970 *m++ = 0;
971 OldWork[1] = m - OldWork;
972 AC.ProtoType = OldWork+idhead;
973 if ( !error ) {
974 if ( StudyPattern(OldWork) ) error = 1;
975 }
976 AT.WorkPointer = OldWork + OldWork[1];
977 if ( AC.lhdollarflag ) OldWork[4] |= DOLLARFLAG;
978 AC.lhdollarflag = 0;
979/*
980 Test whether the id/idold configuration is fine.
981*/
982 if ( type == TYPEIDOLD ) {
983 WORD ci = C->numlhs;
984 while ( ci >= 1 ) {
985 if ( C->lhs[ci][0] == TYPEIDNEW ) {
986 if ( (C->lhs[ci][2] & SUBMASK) == SUBALL ) {
987 MesPrint("&Idold/also cannot follow an id,all statement.");
988 error = 1;
989 }
990 break;
991 }
992 else if ( C->lhs[ci][0] == TYPEDETCURDUM ) { ci--; continue; }
993 else if ( C->lhs[ci][0] == TYPEIDOLD ) { ci--; continue; }
994 else ci = 0;
995 }
996 if ( ci < 1 ) {
997 MesPrint("&Idold/also should follow an id/idnew statement.");
998 error = 1;
999 }
1000 }
1001/*
1002 Now the right hand side.
1003*/
1004 if ( type != TYPEIF ) {
1005 if ( ( retcode = CompileAlgebra(inp,RHSIDE,AC.ProtoType) ) < 0 ) error = 1;
1006 else {
1007 AC.ProtoType[2] = retcode;
1008 AC.DumNum = 0;
1009 if ( MinusSign ) { /* Flip the sign of the RHS */
1010 w = C->rhs[retcode];
1011 while ( *w ) { w += *w; w[-1] = -w[-1]; }
1012 }
1013 if ( AC.dumnumflag ) Add2Com(TYPEDETCURDUM)
1014 }
1015 }
1016/*
1017 Actual adding happens only now after numrhs insertion
1018*/
1019 if ( !error ) { AddNtoL(OldWork[1],OldWork); }
1020AllDone:
1021 AC.lhdollarflag = 0;
1022 AT.WorkPointer = FirstWork;
1023 return(error);
1024}
1025
1026/*
1027 #] CoIdExpression :
1028 #[ CoMultiply :
1029*/
1030
1031static WORD mularray[13] = { TYPEMULT, SUBEXPSIZE+3, 0, SUBEXPRESSION,
1032 SUBEXPSIZE, 0, 1, 0, 0, 0, 0, 0, 0 };
1033
1034int CoMultiply(UBYTE *inp)
1035{
1036 UBYTE *p;
1037 int error = 0, RetCode;
1038 mularray[2] = 0; /* right multiply is default */
1039 while ( *inp == ',' ) inp++;
1040/* if ( inp[-1] == '-' || inp[-1] == '+' ) inp--; */
1041 p = SkipField(inp,0);
1042 if ( *p ) {
1043 *p = 0;
1044 if ( StrICont(inp,(UBYTE *)"left") == 0 ) mularray[2] = 1;
1045 else if ( StrICont(inp,(UBYTE *)"right") == 0 ) mularray[2] = 0;
1046 else {
1047 MesPrint("&Illegal option in multiply statement or ; forgotten.");
1048 return(1);
1049 }
1050 *p = ',';
1051 inp = p + 1;
1052 }
1053 ClearWildcardNames();
1054 while ( *inp == ',' ) inp++;
1055 AC.ProtoType = mularray+3;
1056 mularray[7] = AC.cbufnum;
1057 if ( ( RetCode = CompileAlgebra(inp,RHSIDE,AC.ProtoType) ) < 0 ) error = 1;
1058 else {
1059 mularray[5] = RetCode;
1060 AddNtoL(SUBEXPSIZE+3,mularray);
1061 if ( AC.dumnumflag ) Add2Com(TYPEDETCURDUM)
1062 }
1063 return(error);
1064}
1065
1066/*
1067 #] CoMultiply :
1068 #[ CoFill :
1069
1070 Special additions for tablebase-like tables added 12-aug-2002
1071*/
1072
1073int CoFill(UBYTE *inp)
1074{
1075 GETIDENTITY
1076 WORD error = 0, x, xx, funnum, type, *oldwp = AT.WorkPointer;
1077 int i, oldcbufnum = AC.cbufnum, nofill = 0, numover, redef = 0;
1078 WORD *w, *wold, *Tprototype;
1079 UBYTE *p = inp, c, *inp1;
1080 TABLES T = 0, oldT;
1081 LONG newreservation, sum = 0;
1082 UBYTE *p1, *p2, *p3, *p4, *fake = 0;
1083 int tablestub = 0;
1084 if ( AC.exprfillwarning == 1 ) AC.exprfillwarning = 0;
1085/*
1086 Read the name of the function and test that it is in the table.
1087*/
1088 p1 = inp;
1089 if ( ( p = SkipAName(inp) ) == 0 ) return(1);
1090 p2 = p;
1091 c = *p; *p = 0;
1092 if ( ( GetVar(inp,&type,&funnum,CFUNCTION,WITHAUTO) == NAMENOTFOUND )
1093 || ( T = functions[funnum].tabl ) == 0 || ( T->numind > 0 && c != '(' ) ) {
1094 MesPrint("&%s should be a table with argument(s)",inp);
1095 *p = c; return(1);
1096 }
1097 oldT = T;
1098 *p++ = c;
1099 if ( T->numind == 0 ) {
1100 if ( c == '(' ) {
1101 if ( *p != ')' ) {
1102 c = *p; *p = 0;
1103 MesPrint("&%s should be a table without arguments",inp);
1104 *p = c; return(1);
1105 }
1106 else { p++; }
1107 }
1108 else { p--; }
1109 sum = 0;
1110 p3 = p;
1111 goto andagain;
1112 }
1113 w = oldwp;
1114 if ( T->numind < 0 ) { /* Pick up the first index */
1115 ParseSignedNumber(xx,p);
1116 if ( FG.cTable[p[-1]] != 1 || *p != ',' || xx < 1 || ( xx > ( -T->numind - 1 ) ) ) {
1117 MesPrint("&No valid number of table indices in *-table fill statement.");
1118 return(1);
1119 }
1120 *w++ = xx;
1121 p++;
1122 }
1123 else { xx = T->numind; }
1124 for ( sum = 0, i = 0; i < xx; i++ ) {
1125 ParseSignedNumber(x,p);
1126 if ( FG.cTable[p[-1]] != 1 || ( *p != ',' && *p != ')' ) ) {
1127 MesPrint("&Table arguments in fill statement should be numbers");
1128 return(1);
1129 }
1130 if ( T->sparse ) *w++ = x;
1131 else if ( x < T->mm[i].mini || x > T->mm[i].maxi ) {
1132 MesPrint("&Value %d for argument %d of table out of bounds",x,i+1);
1133 error = 1; nofill = 1;
1134 }
1135 else sum += ( x - T->mm[i].mini ) * T->mm[i].size;
1136 if ( *p == ')' ) break;
1137 p++;
1138 }
1139 p3 = p;
1140 if ( T->numind < 0 ) {
1141 for ( ; i < ABS(T->numind)-1; i++ ) *w++ = 0;
1142 xx = -T->numind;
1143 }
1144 if ( *p != ')' || i < ( xx - 1 ) ) {
1145 MesPrint("&Incorrect number of table arguments in fill statement. Should be %d"
1146 ,T->numind);
1147 error = 1; nofill = 1;
1148 }
1149 AT.WorkPointer = w;
1150 if ( T->sparse == 0 ) sum *= TABLEEXTENSION;
1151andagain:;
1152 AC.cbufnum = T->bufnum;
1153 if ( T->sparse ) {
1154 i = FindTableTree(T,oldwp,1);
1155 if ( i >= 0 ) {
1156 sum = i + ABS(T->numind);
1157 if ( tablestub == 0 && ( ( T->sparse & 2 ) == 2 ) && ( T->mode != 0 )
1158 && ( AC.vetotablebasefill == 0 ) ) {
1159/*
1160 This redefinition does not need a new stub
1161*/
1162 functions[funnum].tabl = T = T->spare;
1163 tablestub = 1;
1164 goto andagain;
1165 }
1166 redef = 1;
1167 goto redef;
1168 }
1169 if ( T->totind >= T->reserved ) {
1170 if ( T->reserved == 0 ) newreservation = 20;
1171 else newreservation = T->reserved;
1172 while ( T->totind >= newreservation && newreservation < MAXTABLECOMBUF )
1173 newreservation = 2*newreservation;
1174 if ( newreservation > MAXTABLECOMBUF ) newreservation = MAXTABLECOMBUF;
1175 if ( T->totind >= newreservation ) {
1176 MesPrint("@More than %ld elements in sparse table",MAXTABLECOMBUF);
1177 AC.cbufnum = oldcbufnum;
1178 Terminate(-1);
1179 }
1180 wold = (WORD *)Malloc1(newreservation*sizeof(WORD)*
1181 (ABS(T->numind)+TABLEEXTENSION),"tablepointers");
1182 for ( i = T->reserved*(ABS(T->numind)+TABLEEXTENSION)-1; i >= 0; i-- )
1183 wold[i] = T->tablepointers[i];
1184 if ( T->tablepointers ) M_free(T->tablepointers,"tablepointers");
1185 T->tablepointers = wold;
1186 T->reserved = newreservation;
1187 }
1188 w = oldwp;
1189 for ( sum = T->totind*(ABS(T->numind)+TABLEEXTENSION), i = 0; i < ABS(T->numind); i++ ) {
1190 T->tablepointers[sum++] = *w++;
1191 }
1192 InsTableTree(T,T->tablepointers+sum-ABS(T->numind));
1193#if TABLEEXTENSION == 2
1194 T->tablepointers[sum+TABLEEXTENSION-1] = -1; /* New element! */
1195#else
1196 T->tablepointers[sum+1] = T->bufnum;
1197 T->tablepointers[sum+2] = -1;
1198 T->tablepointers[sum+3] = -1;
1199 T->tablepointers[sum+4] = 0;
1200 T->tablepointers[sum+5] = 0;
1201#endif
1202 }
1203 else {
1204 if ( !nofill && T->tablepointers[sum] >= 0 ) {
1205redef:;
1206 if ( AC.vetofilling ) nofill = 1;
1207 else {
1208 Warning("Table element was already defined. New definition will be used");
1209 }
1210 }
1211#if TABLEEXTENSION == 2
1212 T->tablepointers[sum+TABLEEXTENSION-1] = -1; /* New element! */
1213#else
1214 T->tablepointers[sum+1] = T->bufnum;
1215 T->tablepointers[sum+2] = -1;
1216 T->tablepointers[sum+3] = -1;
1217 T->tablepointers[sum+4] = 0;
1218 T->tablepointers[sum+5] = 0;
1219#endif
1220 }
1221 if ( T->numind ) { p++; }
1222 if ( *p != '=' ) {
1223 MesPrint("&Fill statement misses = sign after the table element");
1224 AC.cbufnum = oldcbufnum;
1225 AT.WorkPointer = oldwp;
1226 functions[funnum].tabl = oldT;
1227 return(1);
1228 }
1229 if ( tablestub == 0 && T->mode == 1 && AC.vetotablebasefill == 0 ) {
1230/*
1231 Here we construct a righthandside from the indices and the wildcards
1232*/
1233 int numfake;
1234 tablestub = 1;
1235 p4 = T->argtail;
1236 while ( *p4 ) p4++;
1237 numfake = (p4-T->argtail)+(p3-p1)+10;
1238
1239 fake = (UBYTE *)Malloc1(numfake*sizeof(UBYTE),"Fill fake rhs");
1240 p = fake;
1241 *p++ = 't'; *p++ = 'b'; *p++ = 'l'; *p++ = '_'; *p++ = '(';
1242 p4 = p1; while ( p4 < p2 ) *p++ = *p4++; *p++ = ',';
1243 p4 = p2+1; while ( p4 < p3 ) *p++ = *p4++;
1244 if ( T->argtail ) {
1245 p4 = T->argtail + 1;
1246 while ( FG.cTable[*p4] == 1 ) p4++;
1247 while ( *p4 ) {
1248 if ( *p4 == '?' && p[-1] != ',' ) {
1249 p4++;
1250 if ( FG.cTable[*p4] == 0 || *p4 == '$' || *p4 == '[' ) {
1251 p4 = SkipAName(p4);
1252 if ( *p4 == '[' ) {
1253 SKIPBRA1(p4);
1254 }
1255 }
1256 else if ( *p4 == '{' ) {
1257 SKIPBRA2(p4);
1258 }
1259 else if ( *p4 ) { *p++ = *p4++; continue; }
1260 }
1261 else *p++ = *p4++;
1262 }
1263 }
1264 *p++ = ')';
1265 *p = 0;
1266 inp1 = fake;
1267 }
1268 else {
1269 inp1 = ++p;
1270 }
1271 c = 0;
1272/*
1273 Now we have the indices and p points to the rhs.
1274*/
1275 numover = 0;
1276 AC.tablefilling = funnum;
1277 while ( *inp1 ) {
1278 p = SkipField(inp1,0);
1279 c = *p; *p = 0;
1280#ifdef WITHPTHREADS
1281 Tprototype = T->prototype[0];
1282#else
1283 Tprototype = T->prototype;
1284#endif
1285 if ( ( i = CompileAlgebra(inp1,RHSIDE,Tprototype) ) < 0 ) { error = 1; i = 0; }
1286 if ( !nofill ) {
1287 T->tablepointers[sum] = i;
1288 T->tablepointers[sum+1] = T->bufnum;
1289 }
1290 AC.DumNum = 0;
1291 *p = c;
1292 if ( T->sparse || c == 0 ) break;
1293 inp1 = ++p;
1294#if ( TABLEEXTENSION == 2 )
1295 sum++;
1296#else
1297 sum += 2;
1298#endif
1299 if ( !nofill && T->tablepointers[sum] >= 0 ) numover++;
1300#if ( TABLEEXTENSION == 2 )
1301 sum++;
1302#else
1303 sum += TABLEEXTENSION-2;
1304#endif
1305 }
1306 if ( AC.exprfillwarning == 1 ) {
1307 AC.exprfillwarning = 2;
1308 Warning("Use of expressions and/or $variables in Fill statements is potentially very dangerous.");
1309 }
1310 AC.tablefilling = 0;
1311 if ( T->sparse && c != 0 ) {
1312 MesPrint("&In sparse tables one can fill only one element at a time");
1313 error = 1;
1314 }
1315 else if ( numover ) {
1316 if ( numover == 1 )
1317 Warning("one element was overwritten. New definition will be used");
1318 else if ( AC.WarnFlag )
1319 MesPrint("&Warning: %d elements were overwritten. New definitions will be used",numover);
1320 }
1321 if ( T->sparse ) {
1322 if ( redef == 0 ) T->totind++;
1323 }
1324 else T->defined++;
1325/*
1326 NumSets = AC.SetList.numtemp;
1327 NumSetElements = AC.SetElementList.numtemp;
1328*/
1329 if ( fake ) {
1330 M_free(fake,"Fill fake rhs");
1331 fake = 0;
1332 functions[funnum].tabl = T = T->spare;
1333 p = p3;
1334 goto andagain;
1335 }
1336 AC.cbufnum = oldcbufnum;
1337 AC.SymChangeFlag = 1;
1338 AT.WorkPointer = oldwp;
1339 functions[funnum].tabl = oldT;
1340 return(error);
1341}
1342
1343/*
1344 #] CoFill :
1345 #[ CoFillExpression :
1346
1347 Syntax: FillExpression table = expression(x1,...,xn);
1348 The arguments should have been bracketed. Each corresponds to one
1349 of the dimensions of the table. Then the bracket with x1^2*x3^4
1350 will fill the (2,0,4) element of the table (if n=3 of course).
1351 Brackets that don't fit will be skipped. It just gives a warning.
1352
1353 New option (13-jul-2005)
1354 Syntax: FillExpression table = expression(f);
1355 The table indices are arguments of the function f which should
1356 have been bracketed before.
1357*/
1358
1359int CoFillExpression(UBYTE *inp)
1360{
1361 GETIDENTITY
1362 UBYTE *p, c;
1363 WORD type, funnum, expnum, symnum, numsym = 0, *oldwork = AT.WorkPointer;
1364 WORD *brackets, *term, brasize, *b, *m, *w, *pw, *tstop, zero = 0;
1365 WORD oldcbuf = AC.cbufnum, curelement = 0;
1366 int weneedit, i, j, numzero, pow, numfirst;
1367 TABLES T = 0;
1368 LONG newreservation, numcommu, sum;
1369 POSITION oldposition;
1370 FILEHANDLE *fi;
1371 CBUF *C;
1372 WORD numdummies;
1373
1374 AN.IndDum = AM.IndDum;
1375 if ( ( p = SkipAName(inp) ) == 0 ) return(1);
1376 c = *p; *p = 0;
1377 if ( ( GetVar(inp,&type,&funnum,CFUNCTION,NOAUTO) == NAMENOTFOUND )
1378 || ( T = functions[funnum].tabl ) == 0 ) {
1379 MesPrint("&%s should be a previously declared table",inp);
1380 *p = c; return(1);
1381 }
1382 *p++ = c;
1383 if ( T->spare ) T = T->spare;
1384 C = cbuf + T->bufnum;
1385 if ( c != '=' ) {
1386 MesPrint("&No = sign in FillExpression statement");
1387 return(1);
1388 }
1389 inp = p;
1390 if ( ( p = SkipAName(inp) ) == 0 ) return(1);
1391 c = *p; *p = 0;
1392 if ( ( type = GetName(AC.exprnames,inp,&expnum,NOAUTO) ) == NAMENOTFOUND
1393 || c != '(' || (
1394 Expressions[expnum].status != LOCALEXPRESSION &&
1395 Expressions[expnum].status != SKIPLEXPRESSION &&
1396 Expressions[expnum].status != DROPLEXPRESSION &&
1397 Expressions[expnum].status != GLOBALEXPRESSION &&
1398 Expressions[expnum].status != SKIPGEXPRESSION &&
1399 Expressions[expnum].status != DROPGEXPRESSION ) ) {
1400 MesPrint("&%s should be an active expression with arguments",inp);
1401 *p = c; return(1);
1402 }
1403 if ( Expressions[expnum].inmem ) {
1404 MesPrint("&%s cannot be used in a FillExpression statement in the same %n\
1405 module that it has been redefined",inp);
1406 *p = c; return(1);
1407 }
1408 *p++ = c;
1409 while ( *p ) {
1410 inp = p;
1411 if ( ( p = SkipAName(inp) ) == 0 ) return(1);
1412 c = *p; *p = 0;
1413
1414 if ( GetVar(inp,&type,&symnum,-1,NOAUTO) == NAMENOTFOUND ) {
1415 MesPrint("&%s should be a previously declared symbol or function",inp);
1416 *p = c; return(1);
1417 }
1418 else if ( type == CSYMBOL ) {
1419 *p++ = c;
1420 *AT.WorkPointer++ = symnum;
1421 numsym++;
1422 }
1423 else if ( type == CFUNCTION ) {
1424 numsym = -1;
1425 *p++ = c;
1426 if ( c != ')' ) {
1427 MesPrint("&Argument should be a single function or a list of symbols");
1428 return(1);
1429 }
1430 symnum += FUNCTION;
1431 *AT.WorkPointer++ = symnum;
1432 }
1433 else {
1434 MesPrint("&%s should be a previously declared symbol or function",inp);
1435 *p = c; return(1);
1436 }
1437 if ( c == ')' ) break;
1438 if ( c != ',' ) {
1439 MesPrint("&Illegal separator in FillExpression statement");
1440 goto noway;
1441 }
1442 }
1443 if ( *p ) {
1444 MesPrint("&Illegal end of FillExpression statement");
1445 goto noway;
1446 }
1447/*
1448 We have the number of the table in funnum.
1449 The number of the expression in expnum, the table struct in T
1450 and either the numbers of the symbols in oldwork (there are numsym of them)
1451 or the number of the function in oldwork (just one and numsym = -1).
1452 We don't sort them!!!!
1453*/
1454 if ( ( numsym > 0 ) && ( ABS(T->numind) != numsym ) ) {
1455 MesPrint("&This table needs %d symbols for its array indices");
1456 goto noway;
1457 }
1458 EXCHINOUT
1459#ifdef WITHMPI
1460 /*
1461 * The workers can't access to the data of the input expression. We need to
1462 * broadcast it to all the workers.
1463 */
1464 PF_BroadcastExpr(&Expressions[expnum], AR.infile);
1465 if ( PF.me == MASTER ) {
1466 /*
1467 * Restore the file position on the master.
1468 */
1469 POSITION pos;
1470 SetEndScratch(AR.infile, &pos);
1471 }
1472#endif
1473 fi = AR.infile;
1474 if ( fi->handle >= 0 ) {
1475 PUTZERO(oldposition);
1476 SeekFile(fi->handle,&oldposition,SEEK_CUR);
1477 SetScratch(fi,&(Expressions[expnum].onfile));
1478 if ( ISNEGPOS(Expressions[expnum].onfile) ) {
1479/* INTERNAL_ERROR_EXCL_START */
1480 MesPrint("!>File error in FillExpression");
1481 BACKINOUT
1482 goto noway;
1483/* INTERNAL_ERROR_EXCL_STOP */
1484 }
1485 }
1486 else {
1487/*
1488 Note: Because everything fits inside memory we never get problems
1489 with excessive file sizes.
1490*/
1491 SETBASEPOSITION(oldposition,(UBYTE *)(fi->POfill)-(UBYTE *)(fi->PObuffer));
1492 fi->POfill = (WORD *)((UBYTE *)(fi->PObuffer) + BASEPOSITION(Expressions[expnum].onfile));
1493 }
1494 pw = AT.WorkPointer;
1495 if ( numsym < 0 ) { brackets = pw + 1; }
1496 else { brackets = pw + numsym; }
1497 brasize = -1; weneedit = 0; /* stands for we need it */
1498 term = (WORD *)(((UBYTE *)(brackets)) + AM.MaxTer);
1499 AT.WorkPointer = (WORD *)(((UBYTE *)(term)) + AM.MaxTer);
1500 AC.cbufnum = T->bufnum;
1501 AC.tablefilling = funnum;
1502 if ( GetTerm(BHEAD term) > 0 ) { /* Skip prototype */
1503 while ( GetTerm(BHEAD term) > 0 ) {
1504 GETSTOP(term,tstop);
1505 w = m = term + 1;
1506 while ( m < tstop && *m != HAAKJE ) m += m[1];
1507 if ( *m != HAAKJE ) {
1508 MesPrint("&Illegal attempt to put an expression without brackets in a table");
1509 BACKINOUT
1510 goto noway;
1511 }
1512 if ( brasize == m - w ) {
1513 b = brackets;
1514 while ( *b == *w && w < m ) { b++; w++; }
1515 if ( w == m ) { /* Same as current bracket. Copy. */
1516 if ( weneedit ) {
1517 m += m[1] - 1;
1518 *m = *term - (m-term);
1519 AddNtoC(AC.cbufnum,*m,m,3);
1520 numdummies = DetCurDum(BHEAD term) - AM.IndDum;
1521 if ( numdummies > T->numdummies ) T->numdummies = numdummies;
1522 }
1523 continue; /* Next term */
1524 }
1525 }
1526 if ( weneedit ) {
1527 AddNtoC(AC.cbufnum,1,&zero,4); /* Terminate old bracket */
1528 numcommu = numcommute(C->rhs[curelement],&(C->NumTerms[curelement]));
1529 C->CanCommu[curelement] = numcommu;
1530 }
1531 b = brackets; w = term + 1;
1532 if ( numsym < 0 ) pw = oldwork + 1;
1533 else pw = oldwork + numsym;
1534 while ( w < m ) *b++ = *w++;
1535 brasize = b - brackets;
1536/*
1537 Now compute the element. See whether we need it
1538*/
1539 if ( numsym < 0 ) {
1540 WORD *bb, bnum;
1541 if ( *brackets != symnum || brasize != brackets[1] ) {
1542 weneedit = 0; continue; /* Cannot work! */
1543 }
1544/*
1545 Now count the number of arguments and whether they are numbers
1546*/
1547 b = brackets + FUNHEAD;
1548 bb = brackets+brackets[1];
1549 i = 0;
1550 if ( T->numind < 0 ) {
1551 bnum = b[1]+1;
1552 if ( bnum > -T->numind ) {
1553 weneedit = 0; continue; /* Cannot work! */
1554 }
1555 }
1556 else bnum = T->numind;
1557 while ( b < bb ) {
1558 if ( *b != -SNUMBER ) break;
1559 i++;
1560 b += 2;
1561 }
1562 if ( b < bb || i != bnum ) {
1563 weneedit = 0; continue; /* Cannot work! */
1564 }
1565 }
1566 else if ( brasize > 0 && ( *brackets != SYMBOL
1567 || brackets[1] < brasize || (brackets[1]-2) > numsym*2 ) ) {
1568 weneedit = 0; continue; /* Cannot work! */
1569 }
1570 numzero = 0; sum = 0;
1571 numfirst = 0;
1572 if ( numsym > 0 ) {
1573 for ( i = 0; i < numsym; i++ ) {
1574 if ( brasize > 0 ) {
1575 b = brackets + 2; j = brackets[1]-2;
1576 while ( j > 0 ) {
1577 if ( *b == oldwork[i] ) break;
1578 j -= 2; b += 2;
1579 }
1580 if ( j <= 0 ) { /* it was not there */
1581 numzero++; pow = 0;
1582 if ( 2*numzero+brackets[1]-2 > numsym*2 ) {
1583 weneedit = 0; goto nextterm;
1584 }
1585 }
1586 else pow = b[1];
1587 }
1588 else pow = 0;
1589 if ( T->sparse ) {
1590 if ( T->numind < 0 ) {
1591 if ( i == 0 ) {
1592 numfirst = pow;
1593 if ( pow > -T->numind ) {
1594 weneedit = 0; goto nextterm;
1595 }
1596 }
1597 else if ( i > pow ) {
1598 weneedit = 0; goto nextterm;
1599 }
1600 }
1601 *pw++ = pow;
1602 }
1603 else if ( pow < T->mm[i].mini || pow > T->mm[i].maxi ) {
1604 weneedit = 0; goto nextterm;
1605 }
1606 else sum += ( pow - T->mm[i].mini ) * T->mm[i].size;
1607 }
1608 }
1609 else {
1610 WORD xx;
1611 b = brackets + FUNHEAD;
1612 sum = 0;
1613/*
1614 Now scan the arguments of the function.
1615 We did check already the number and type of the arguments.
1616*/
1617 xx = (brackets[1]-FUNHEAD)/2;
1618 for ( i = 0; i < xx; i++ ) {
1619 pow = b[1];
1620 b += 2;
1621 if ( T->sparse ) {
1622 if ( T->numind < 0 ) {
1623 if ( i == 0 ) {
1624 numfirst = pow;
1625 if ( pow >= -T->numind ) {
1626 weneedit = 0; goto nextterm;
1627 }
1628 }
1629 }
1630 *pw++ = pow;
1631 }
1632 else if ( pow < T->mm[i].mini || pow > T->mm[i].maxi ) {
1633 weneedit = 0; goto nextterm;
1634 }
1635 else sum += ( pow - T->mm[i].mini ) * T->mm[i].size;
1636 }
1637 }
1638 if ( T->numind < 0 ) {
1639 for ( i = numfirst+1; i < -T->numind; i++ ) *pw++ = 0;
1640 }
1641 weneedit = 1;
1642 if ( T->sparse ) {
1643 if ( numsym < 0 ) pw = oldwork + 1;
1644 else pw = oldwork + ABS(T->numind);
1645 i = FindTableTree(T,pw,1);
1646 if ( i >= 0 ) {
1647 sum = i+ABS(T->numind);
1648/*
1649Wrong!!!! C->rhs[T->tablepointers[sum]] = C->Pointer;
1650*/
1651 C->Pointer--; /* Back up over the zero */
1652 goto newentry;
1653 }
1654 if ( T->totind >= T->reserved ) {
1655 if ( T->reserved == 0 ) newreservation = 20;
1656 else newreservation = T->reserved;
1657/*---Copied from Fill---------------------------*/
1658 while ( T->totind >= newreservation && newreservation < MAXTABLECOMBUF )
1659 newreservation = 2*newreservation;
1660 if ( newreservation > MAXTABLECOMBUF ) newreservation = MAXTABLECOMBUF;
1661 if ( T->totind >= newreservation ) {
1662 MesPrint("@More than %ld elements in sparse table",MAXTABLECOMBUF);
1663 AC.cbufnum = oldcbuf;
1664 AT.WorkPointer = oldwork;
1665 Terminate(-1);
1666 }
1667/*---Copied from Fill---------------------------*/
1668 if ( T->totind >= newreservation ) {
1669 MesPrint("@More than %ld elements in sparse table",MAXTABLECOMBUF);
1670 AC.cbufnum = oldcbuf;
1671 AT.WorkPointer = oldwork;
1672 Terminate(-1);
1673 }
1674 w = (WORD *)Malloc1(newreservation*sizeof(WORD)*
1675 (ABS(T->numind)+TABLEEXTENSION),"tablepointers");
1676 for ( i = T->reserved*(ABS(T->numind)+TABLEEXTENSION)-1; i >= 0; i-- )
1677 w[i] = T->tablepointers[i];
1678 if ( T->tablepointers ) M_free(T->tablepointers,"tablepointers");
1679 T->tablepointers = w;
1680 T->reserved = newreservation;
1681 }
1682 if ( numsym < 0 ) pw = oldwork + 1;
1683 else pw = oldwork + numsym;
1684 for ( sum = T->totind*(ABS(T->numind)+TABLEEXTENSION), i = 0; i < ABS(T->numind); i++ ) {
1685 T->tablepointers[sum++] = *pw++;
1686 }
1687 InsTableTree(T,T->tablepointers+sum-ABS(T->numind));
1688 (T->totind)++;
1689 }
1690#if ( TABLEEXTENSION != 2 )
1691 else {
1692 sum *= TABLEEXTENSION;
1693 }
1694#endif
1695/*
1696 Start a new entry. Copy the element.
1697*/
1698 AddRHS(T->bufnum,0);
1699 T->tablepointers[sum] = C->numrhs;
1700#if ( TABLEEXTENSION == 2 )
1701 T->tablepointers[sum+TABLEEXTENSION-1] = -1;
1702#else
1703 T->tablepointers[sum+1] = T->bufnum;
1704 T->tablepointers[sum+2] = -1;
1705 T->tablepointers[sum+3] = -1;
1706 T->tablepointers[sum+4] = 0;
1707 T->tablepointers[sum+5] = 0;
1708#endif
1709newentry: if ( *m == HAAKJE ) { m += m[1] - 1; }
1710 else m--;
1711 *m = *term - (m-term);
1712 AddNtoC(AC.cbufnum,*m,m,5);
1713 curelement = T->tablepointers[sum];
1714nextterm:;
1715 }
1716 if ( weneedit ) {
1717 AddNtoC(AC.cbufnum,1,&zero,6); /* Terminate old bracket */
1718 numcommu = numcommute(C->rhs[curelement],&(C->NumTerms[curelement]));
1719 C->CanCommu[curelement] = numcommu;
1720 }
1721 }
1722 if ( fi->handle >= 0 ) {
1723 SetScratch(fi,&(oldposition));
1724 }
1725 else {
1726 fi->POfill = (WORD *)((UBYTE *)(fi->PObuffer) + BASEPOSITION(oldposition));
1727 }
1728 BACKINOUT
1729 AC.cbufnum = oldcbuf;
1730 AC.tablefilling = 0;
1731 AT.WorkPointer = oldwork;
1732 return(0);
1733noway:
1734 BACKINOUT
1735 AC.cbufnum = oldcbuf;
1736 AC.tablefilling = 0;
1737 AT.WorkPointer = oldwork;
1738 return(1);
1739}
1740
1741/*
1742 #] CoFillExpression :
1743 #[ CoPrintTable :
1744
1745 Syntax
1746 PrintTable [+f] [+s] tablename [>[>] file];
1747 All defined elements are written with individual Fill statements.
1748 If a file is specified, the result is written to file only.
1749 The flags of the print statement apply as much as possible.
1750 We make use of the regular write routines.
1751*/
1752
1753int CoPrintTable(UBYTE *inp)
1754{
1755 GETIDENTITY
1756 int fflag = 0, sflag = 0, addflag = 0, error = 0, sum, i, j;
1757 UBYTE *filename, *p, c, buffer[100], *s, *oldoutputline = AO.OutputLine;
1758 WORD type, funnum, *expr, *m, num;
1759 TABLES T = 0;
1760 WORD oldSkip = AO.OutSkip, oldMode = AC.OutputMode, oldHandle = AC.LogHandle;
1761 WORD oldType = AO.PrintType, *oldwork = AT.WorkPointer;
1762 UBYTE *oldFill = AO.OutFill, *oldLine = AO.OutputLine;
1763#ifdef WITHMPI
1764 if ( PF.me != MASTER ) return 0;
1765#endif
1766/*
1767 First the flags
1768*/
1769 while ( *inp == '+' ) {
1770 inp++;
1771 if ( *inp == 'f' || *inp == 'F' ) { fflag = 1; inp++; }
1772 else if ( *inp == 's' || *inp == 'S' ) { sflag = PRINTONETERM; inp++; }
1773 else {
1774 MesPrint("&Illegal + option in PrintTable statement");
1775 error = 1; inp++;
1776 }
1777 while ( *inp != ',' && *inp && *inp != '+' ) {
1778 if ( !error ) {
1779 if ( *inp ) {
1780 MesPrint("&Illegal + option in PrintTable statement");
1781 inp++;
1782 }
1783 else {
1784 MesPrint("&Unfinished PrintTable statement");
1785 return(1);
1786 }
1787 error = 1;
1788 }
1789 inp++;
1790 }
1791 if ( *inp == ',' ) inp++;
1792 }
1793/*
1794 Now the name of the table
1795*/
1796 if ( ( p = SkipAName(inp) ) == 0 ) return(1);
1797 c = *p; *p = 0;
1798 if ( ( GetVar(inp,&type,&funnum,CFUNCTION,NOAUTO) == NAMENOTFOUND )
1799 || ( T = functions[funnum].tabl ) == 0 ) {
1800 MesPrint("&%s should be a previously declared table",inp);
1801 *p = c; return(1);
1802 }
1803 if ( T->spare && T->mode == 1 ) T = T->spare;
1804 *p++ = c;
1805/*
1806 Check for a filename. Runs to the end of the statement.
1807*/
1808 filename = 0;
1809 if ( c == '>' ) {
1810 if ( *p == '>' ) { addflag = 1; p++; }
1811 filename = p;
1812 }
1813 else filename = 0;
1814
1815 if ( filename ) {
1816 if ( addflag ) AC.LogHandle = OpenAddFile((char *)filename);
1817 else AC.LogHandle = CreateFile((char *)filename);
1818 if ( AC.LogHandle < 0 ) {
1819 MesPrint("&Cannot open file '%s' properly",filename);
1820 error = 1; goto finally;
1821 }
1822 AO.PrintType = PRINTLFILE;
1823 }
1824 else if ( fflag && AC.LogHandle >= 0 ) {
1825 AO.PrintType = PRINTLFILE;
1826 }
1827 AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer;
1828 AT.WorkPointer += 2*AC.LineLength;
1829
1830 AO.PrintType |= sflag;
1831 AC.OutputMode = 0;
1832 AO.IsBracket = 0;
1833 AO.OutSkip = 0;
1834 AR.DeferFlag = 0;
1835 AC.outsidefun = 1;
1836 if ( AC.LogHandle == oldHandle ) FiniLine();
1837 AO.OutputLine = AO.OutFill = (UBYTE *)Malloc1(AC.LineLength+20,"PrintTable");
1838 AO.OutStop = AO.OutFill + AC.LineLength;
1839 for ( i = 0; i < T->totind; i++ ) {
1840 if ( !T->sparse && T->tablepointers[i*TABLEEXTENSION] < 0 ) continue;
1841 TokenToLine((UBYTE *)"Fill ");
1842 TokenToLine((UBYTE *)(VARNAME(functions,funnum)));
1843 TokenToLine((UBYTE *)"(");
1844 AO.OutSkip = 3;
1845 if ( T->sparse ) {
1846 sum = i * ( T->numind + TABLEEXTENSION );
1847 for ( j = 0; j < T->numind; j++, sum++ ) {
1848 if ( j > 0 ) TokenToLine((UBYTE *)",");
1849 num = T->tablepointers[sum];
1850 s = buffer; s = NumCopy(num,s);
1851 TokenToLine(buffer);
1852 }
1853 expr = cbuf[T->bufnum].rhs[T->tablepointers[sum]];
1854 }
1855 else {
1856 for ( j = 0; j < T->numind; j++ ) {
1857 if ( j > 0 ) {
1858 TokenToLine((UBYTE *)",");
1859 num = T->mm[j].mini + ( i % T->mm[j-1].size ) / T->mm[j].size;
1860 }
1861 else {
1862 num = T->mm[j].mini + i / T->mm[j].size;
1863 }
1864 s = buffer; s = NumCopy(num,s);
1865 TokenToLine(buffer);
1866 }
1867 expr = cbuf[T->bufnum].rhs[T->tablepointers[TABLEEXTENSION*i]];
1868 }
1869 TOKENTOLINE(") =",")=");
1870 if ( sflag ) {
1871 FiniLine();
1872 if ( AC.OutputSpaces != NOSPACEFORMAT ) TokenToLine((UBYTE *)" ");
1873 }
1874 m = expr;
1875/*
1876 WORD lbrac, first;
1877 lbrac = 0; first = 1;
1878 while ( *m ) {
1879 if ( WriteTerm(m,&lbrac,first,1,0) ) {
1880 MesPrint("Error while writing table");
1881 error = 1;
1882 goto finally;
1883 }
1884 first = 0;
1885 m += *m;
1886 }
1887 if ( first ) { TOKENTOLINE(" 0","0") }
1888 else if ( lbrac ) { TOKENTOLINE(" )",")") }
1889*/
1890 while ( *m ) m += *m;
1891 if ( m > expr ) {
1892 if ( WriteExpression(expr,(LONG)(m-expr)) ) { error = 1; goto finally; }
1893 AO.OutSkip = 0;
1894 }
1895 else {
1896 TokenToLine((UBYTE *)"0");
1897 }
1898 TokenToLine((UBYTE *)";");
1899 FiniLine();
1900 }
1901 M_free(AO.OutputLine,"PrintTable");
1902 AO.OutputLine = AO.OutFill = oldoutputline;
1903/*
1904 Reset the file pointers and parameters if any. Close file if needed.
1905*/
1906finally:
1907 AO.OutSkip = oldSkip;
1908 AC.OutputMode = oldMode;
1909 AC.LogHandle = oldHandle;
1910 AO.PrintType = oldType;
1911 AO.OutFill = oldFill;
1912 AO.OutputLine = oldLine;
1913 AT.WorkPointer = oldwork;
1914 AC.outsidefun = 0;
1915 return(error);
1916}
1917
1918/*
1919 #] CoPrintTable :
1920 #[ CoAssign :
1921
1922 This statement has an easy syntax:
1923 $name = expression
1924*/
1925
1926static WORD AssignLHS[14] = { TYPEASSIGN, 3+SUBEXPSIZE, 0,
1927 SUBEXPRESSION, SUBEXPSIZE, 0, 1, 0, 0,0,0,0,0 };
1928
1929int CoAssign(UBYTE *inp)
1930{
1931 int error = 0, retcode;
1932 UBYTE *name, c;
1933 WORD number;
1934 if ( *inp != '$' ) {
1935nolhs: MesPrint("&assign statement should have a dollar variable in the LHS");
1936 return(1);
1937 }
1938 inp++; name = inp;
1939 if ( FG.cTable[*inp] != 0 ) goto nolhs;
1940 while ( FG.cTable[*inp] < 2 ) inp++;
1941 if ( AP.PreAssignFlag == 2 ) {
1942 if ( *inp == '_' ) inp++;
1943 }
1944 if ( ( *inp == ',' && inp[1] != '=' ) && ( *inp != '=' ) ) {
1945 MesPrint("&assign statement should have only a dollar variable in the LHS");
1946 return(1);
1947 }
1948 c = *inp;
1949 *inp = 0;
1950 if ( GetName(AC.dollarnames,name,&number,NOAUTO) == NAMENOTFOUND ) {
1951 number = AddDollar(name,DOLUNDEFINED,0,0);
1952 }
1953 *inp = c;
1954 if ( c == ',' ) inp++;
1955 *inp++ = '=';
1956 if ( *inp == ',' ) inp++;
1957/*
1958 Fake a Prototype and read the RHS
1959*/
1960 AssignLHS[7] = AC.cbufnum;
1961 retcode = CompileAlgebra(inp,RHSIDE,(AssignLHS+3));
1962 if ( retcode < 0 ) error = 1;
1963 AC.DumNum = 0;
1964/*
1965 Now add the LHS
1966*/
1967 AssignLHS[2] = number;
1968 AssignLHS[5] = retcode;
1969 AddNtoL(AssignLHS[1],AssignLHS);
1970/*
1971 Add to the list of potentially modified dollars (for PARALLEL)
1972*/
1973 AddPotModdollar(number);
1974 return(error);
1975}
1976
1977/*
1978 #] CoAssign :
1979 #[ CoDeallocateTable :
1980
1981 Syntax: DeallocateTable tablename(s);
1982 Should work only for sparse tables.
1983 Action: Cleans all definitions of elements of a table as if there have
1984 never been any fill statements.
1985*/
1986
1987int CoDeallocateTable(UBYTE *inp)
1988{
1989 UBYTE *p, c;
1990 TABLES T = 0;
1991 WORD type, funnum, i;
1992 c = *inp;
1993 while ( c ) {
1994 while ( *inp == ',' ) inp++;
1995 if ( *inp == 0 ) break;
1996 if ( ( p = SkipAName(inp) ) == 0 ) return(1);
1997 c = *p; *p = 0;
1998 if ( ( GetVar(inp,&type,&funnum,CFUNCTION,NOAUTO) == NAMENOTFOUND )
1999 || ( T = functions[funnum].tabl ) == 0 ) {
2000 MesPrint("&%s should be a previously declared table",inp);
2001 *p = c; return(1);
2002 }
2003 if ( T->sparse == 0 ) {
2004 MesPrint("&%s should be a sparse table",inp);
2005 *p = c; return(1);
2006 }
2007 if ( T->tablepointers ) M_free(T->tablepointers,"tablepointers");
2008 ClearTableTree(T);
2009 for (i = 0; i < T->buffersfill; i++ ) { /* was <= */
2010 finishcbuf(T->buffers[i]);
2011 }
2012 T->bufnum = inicbufs();
2013 T->buffersfill = 0;
2014 T->buffers[T->buffersfill++] = T->bufnum;
2015 T->tablepointers = 0;
2016 T->boomlijst = 0;
2017 T->totind = 0;
2018 T->reserved = 0;
2019
2020 if ( T->spare ) {
2021 TABLES TT = T->spare;
2022 if ( TT->tablepointers ) M_free(TT->tablepointers,"tablepointers");
2023 ClearTableTree(TT);
2024 for (i = 0; i < TT->buffersfill; i++ ) { /* was <= */
2025 finishcbuf(TT->buffers[i]);
2026 }
2027 TT->bufnum = inicbufs();
2028 TT->buffersfill = 0;
2029 TT->buffers[T->buffersfill++] = T->bufnum;
2030 TT->tablepointers = 0;
2031 TT->boomlijst = 0;
2032 TT->totind = 0;
2033 TT->reserved = 0;
2034 }
2035 *p++ = c;
2036 inp = p;
2037 }
2038 return(0);
2039}
2040
2041/*
2042 #] CoDeallocateTable :
2043 #[ CoFactorCache :
2044*/
2054/*
2055int CoFactorCache(UBYTE *inp)
2056{
2057 Code to be added in due time
2058 We need to read 'expression', get its terms through Generator and sort them.
2059 We store the result in the WorkSpace in argument notation.
2060 This will be argin.
2061 Then we do the same with the sequence of factors. They form argout.
2062 The whole is put in the buffer with the call
2063 InsertArg(BHEAD argin,argout,1)
2064 return(0);
2065}
2066*/
2067
2068/*
2069 #] CoFactorCache :
2070*/
SkipAName
UBYTE * SkipAName(UBYTE *s)
Definition compiler.c:443
AddNtoL
int AddNtoL(int n, WORD *array)
Definition comtool.c:284
AddRHS
WORD * AddRHS(int num, int type)
Definition comtool.c:210
inicbufs
int inicbufs(void)
Definition comtool.c:47
finishcbuf
void finishcbuf(WORD num)
Definition comtool.c:89
AddNtoC
int AddNtoC(int bufnum, int n, WORD *array, int par)
Definition comtool.c:313
AddLHS
WORD * AddLHS(int num)
Definition comtool.c:184
SortWild
int SortWild(WORD *, WORD)
Definition sort.c:4536
AddPotModdollar
void AddPotModdollar(WORD)
Definition dollar.c:3944
PutOut
WORD PutOut(PHEAD WORD *, POSITION *, FILEHANDLE *, WORD)
Definition sort.c:1217
EndSort
LONG EndSort(PHEAD WORD *, int)
Definition sort.c:488
Generator
int Generator(PHEAD WORD *, WORD)
Definition proces.c:3275
SkipField
UBYTE * SkipField(UBYTE *, int)
Definition tools.c:1978
LowerSortLevel
void LowerSortLevel(void)
Definition sort.c:4731
ClearOptimize
int ClearOptimize(void)
Definition optimize.cc:4978
NewSort
int NewSort(PHEAD0)
Definition sort.c:397
FlushOut
int FlushOut(POSITION *, FILEHANDLE *, int)
Definition sort.c:1581
PF_BroadcastExpr
int PF_BroadcastExpr(EXPRESSIONS e, FILEHANDLE *file)
Definition parallel.c:3552
CbUf::NumTerms
LONG * NumTerms
Definition structs.h:977
CbUf::rhs
WORD ** rhs
Definition structs.h:975
CbUf::lhs
WORD ** lhs
Definition structs.h:974
CbUf::Buffer
WORD * Buffer
Definition structs.h:971
CbUf::Pointer
WORD * Pointer
Definition structs.h:973
CbUf::CanCommu
LONG * CanCommu
Definition structs.h:976
FiLe::handle
int handle
Definition structs.h:709
MiNmAx::mini
WORD mini
Definition structs.h:302
MiNmAx::size
WORD size
Definition structs.h:304
MiNmAx::maxi
WORD maxi
Definition structs.h:303
TaBlEs::buffers
WORD * buffers
Definition structs.h:357
TaBlEs::spare
struct TaBlEs * spare
Definition structs.h:356
TaBlEs::tablepointers
WORD * tablepointers
Definition structs.h:343
TaBlEs::argtail
UBYTE * argtail
Definition structs.h:354
TaBlEs::boomlijst
COMPTREE * boomlijst
Definition structs.h:353
TaBlEs::reserved
LONG reserved
Definition structs.h:359
TaBlEs::buffersfill
WORD buffersfill
Definition structs.h:372
TaBlEs::prototype
WORD * prototype
Definition structs.h:348
TaBlEs::mode
WORD mode
Definition structs.h:374
TaBlEs::mm
MINMAX * mm
Definition structs.h:351
TaBlEs::bufnum
WORD bufnum
Definition structs.h:370
TaBlEs::numind
int numind
Definition structs.h:363
TaBlEs::totind
LONG totind
Definition structs.h:358
TaBlEs::sparse
int sparse
Definition structs.h:366
TaBlEs::defined
LONG defined
Definition structs.h:360
Generated by doxygen 1.9.8