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