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