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