FORM  4.2
compcomm.c
Go to the documentation of this file.
1 
10 /* #[ License : */
11 /*
12  * Copyright (C) 1984-2017 J.A.M. Vermaseren
13  * When using this file you are requested to refer to the publication
14  * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
15  * This is considered a matter of courtesy as the development was paid
16  * for by FOM the Dutch physics granting agency and we would like to
17  * be able to track its scientific use to convince FOM of its value
18  * for the community.
19  *
20  * This file is part of FORM.
21  *
22  * FORM is free software: you can redistribute it and/or modify it under the
23  * terms of the GNU General Public License as published by the Free Software
24  * Foundation, either version 3 of the License, or (at your option) any later
25  * version.
26  *
27  * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
28  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
29  * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
30  * details.
31  *
32  * You should have received a copy of the GNU General Public License along
33  * with FORM. If not, see <http://www.gnu.org/licenses/>.
34  */
35 /* #] License : */
36 /*
37  #[ includes :
38 */
39 
40 #include "form3.h"
41 #include "comtool.h"
42 
43 static KEYWORD formatoptions[] = {
44  {"c", (TFUN)0, CMODE, 0}
45  ,{"doublefortran", (TFUN)0, DOUBLEFORTRANMODE, 0}
46  ,{"float", (TFUN)0, 0, 2}
47  ,{"fortran", (TFUN)0, FORTRANMODE, 0}
48  ,{"fortran90", (TFUN)0, FORTRANMODE, 4}
49  ,{"maple", (TFUN)0, MAPLEMODE, 0}
50  ,{"mathematica", (TFUN)0, MATHEMATICAMODE, 0}
51  ,{"normal", (TFUN)0, NORMALFORMAT, 1}
52  ,{"nospaces", (TFUN)0, NOSPACEFORMAT, 3}
53  ,{"pfortran", (TFUN)0, PFORTRANMODE, 0}
54  ,{"quadfortran", (TFUN)0, QUADRUPLEFORTRANMODE, 0}
55  ,{"quadruplefortran", (TFUN)0, QUADRUPLEFORTRANMODE, 0}
56  ,{"rational", (TFUN)0, RATIONALMODE, 1}
57  ,{"reduce", (TFUN)0, REDUCEMODE, 0}
58  ,{"spaces", (TFUN)0, NORMALFORMAT, 3}
59  ,{"vortran", (TFUN)0, VORTRANMODE, 0}
60 };
61 
62 static KEYWORD trace4options[] = {
63  {"contract", (TFUN)0, CHISHOLM, 0 }
64  ,{"nocontract", (TFUN)0, 0, CHISHOLM }
65  ,{"nosymmetrize",(TFUN)0, 0, ALSOREVERSE}
66  ,{"notrick", (TFUN)0, NOTRICK, 0 }
67  ,{"symmetrize", (TFUN)0, ALSOREVERSE, 0 }
68  ,{"trick", (TFUN)0, 0, NOTRICK }
69 };
70 
71 static KEYWORD chisoptions[] = {
72  {"nosymmetrize",(TFUN)0, 0, ALSOREVERSE}
73  ,{"symmetrize", (TFUN)0, ALSOREVERSE, 0 }
74 };
75 
76 static KEYWORD writeoptions[] = {
77  {"stats", (TFUN)&(AC.StatsFlag), 1, 0}
78  ,{"statistics", (TFUN)&(AC.StatsFlag), 1, 0}
79  ,{"shortstats", (TFUN)&(AC.ShortStats), 1, 0}
80  ,{"shortstatistics",(TFUN)&(AC.ShortStats), 1, 0}
81  ,{"warnings", (TFUN)&(AC.WarnFlag), 1, 0}
82  ,{"allwarnings", (TFUN)&(AC.WarnFlag), 2, 0}
83  ,{"setup", (TFUN)&(AC.SetupFlag), 1, 0}
84  ,{"names", (TFUN)&(AC.NamesFlag), 1, 0}
85  ,{"allnames", (TFUN)&(AC.NamesFlag), 2, 0}
86  ,{"codes", (TFUN)&(AC.CodesFlag), 1, 0}
87  ,{"highfirst", (TFUN)&(AC.SortType), SORTHIGHFIRST, SORTLOWFIRST}
88  ,{"lowfirst", (TFUN)&(AC.SortType), SORTLOWFIRST, SORTHIGHFIRST}
89  ,{"powerfirst", (TFUN)&(AC.SortType), SORTPOWERFIRST, SORTHIGHFIRST}
90  ,{"tokens", (TFUN)&(AC.TokensWriteFlag),1, 0}
91 };
92 
93 static KEYWORD onoffoptions[] = {
94  {"compress", (TFUN)&(AC.NoCompress), 0, 1}
95  ,{"checkpoint", (TFUN)&(AC.CheckpointFlag), 1, 0}
96  ,{"insidefirst", (TFUN)&(AC.insidefirst), 1, 0}
97  ,{"propercount", (TFUN)&(AC.BottomLevel), 1, 0}
98  ,{"stats", (TFUN)&(AC.StatsFlag), 1, 0}
99  ,{"statistics", (TFUN)&(AC.StatsFlag), 1, 0}
100  ,{"shortstats", (TFUN)&(AC.ShortStats), 1, 0}
101  ,{"shortstatistics",(TFUN)&(AC.ShortStats), 1, 0}
102  ,{"names", (TFUN)&(AC.NamesFlag), 1, 0}
103  ,{"allnames", (TFUN)&(AC.NamesFlag), 2, 0}
104  ,{"warnings", (TFUN)&(AC.WarnFlag), 1, 0}
105  ,{"allwarnings", (TFUN)&(AC.WarnFlag), 2, 0}
106  ,{"highfirst", (TFUN)&(AC.SortType), SORTHIGHFIRST, SORTLOWFIRST}
107  ,{"lowfirst", (TFUN)&(AC.SortType), SORTLOWFIRST, SORTHIGHFIRST}
108  ,{"powerfirst", (TFUN)&(AC.SortType), SORTPOWERFIRST, SORTHIGHFIRST}
109  ,{"setup", (TFUN)&(AC.SetupFlag), 1, 0}
110  ,{"codes", (TFUN)&(AC.CodesFlag), 1, 0}
111  ,{"tokens", (TFUN)&(AC.TokensWriteFlag),1,0}
112  ,{"properorder", (TFUN)&(AC.properorderflag),1,0}
113  ,{"threadloadbalancing",(TFUN)&(AC.ThreadBalancing),1, 0}
114  ,{"threads", (TFUN)&(AC.ThreadsFlag),1, 0}
115  ,{"threadsortfilesynch",(TFUN)&(AC.ThreadSortFileSynch),1, 0}
116  ,{"threadstats", (TFUN)&(AC.ThreadStats),1, 0}
117  ,{"finalstats", (TFUN)&(AC.FinalStats),1, 0}
118  ,{"fewerstats", (TFUN)&(AC.ShortStatsMax), 10, 0}
119  ,{"fewerstatistics",(TFUN)&(AC.ShortStatsMax), 10, 0}
120  ,{"processstats", (TFUN)&(AC.ProcessStats),1, 0}
121  ,{"oldparallelstats",(TFUN)&(AC.OldParallelStats),1,0}
122  ,{"parallel", (TFUN)&(AC.parallelflag),PARALLELFLAG,NOPARALLEL_USER}
123  ,{"nospacesinnumbers",(TFUN)&(AO.NoSpacesInNumbers),1,0}
124  ,{"indentspace", (TFUN)&(AO.IndentSpace),INDENTSPACE,0}
125  ,{"totalsize", (TFUN)&(AM.PrintTotalSize), 1, 0}
126  ,{"flag", (TFUN)&(AC.debugFlags), 1, 0}
127  ,{"oldfactarg", (TFUN)&(AC.OldFactArgFlag), 1, 0}
128  ,{"memdebugflag", (TFUN)&(AC.MemDebugFlag), 1, 0}
129  ,{"oldgcd", (TFUN)&(AC.OldGCDflag), 1, 0}
130  ,{"innertest", (TFUN)&(AC.InnerTest), 1, 0}
131  ,{"wtimestats", (TFUN)&(AC.WTimeStatsFlag), 1, 0}
132 };
133 
134 static WORD one = 1;
135 
136 /*
137  #] includes :
138  #[ CoCollect :
139 
140  Collect,functionname
141 */
142 
143 int CoCollect(UBYTE *s)
144 {
145 /* --------------change 17-feb-2003 Added percentage */
146  WORD numfun;
147  int type,x = 0;
148  UBYTE *t = SkipAName(s), *t1, *t2;
149  AC.AltCollectFun = 0;
150  if ( t == 0 ) goto syntaxerror;
151  t1 = t; while ( *t1 == ',' || *t1 == ' ' || *t1 == '\t' ) t1++;
152  *t = 0; t = t1;
153  if ( *t1 && ( FG.cTable[*t1] == 0 || *t1 == '[' ) ) {
154  t2 = SkipAName(t1);
155  if ( t2 == 0 ) goto syntaxerror;
156  t = t2;
157  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
158  *t2 = 0;
159  }
160  else t1 = 0;
161  if ( *t && FG.cTable[*t] == 1 ) {
162  while ( *t >= '0' && *t <= '9' ) x = 10*x + *t++ - '0';
163  if ( x > 100 ) x = 100;
164  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
165  if ( *t ) goto syntaxerror;
166  }
167  else {
168  if ( *t ) goto syntaxerror;
169  x = 100;
170  }
171  if ( ( ( type = GetName(AC.varnames,s,&numfun,WITHAUTO) ) != CFUNCTION )
172  || ( functions[numfun].spec != 0 ) ) {
173  MesPrint("&%s should be a regular function",s);
174  if ( type < 0 ) {
175  if ( GetName(AC.exprnames,s,&numfun,NOAUTO) == NAMENOTFOUND )
176  AddFunction(s,0,0,0,0,0,-1,-1);
177  }
178  return(1);
179  }
180  AC.CollectFun = numfun+FUNCTION;
181  AC.CollectPercentage = (WORD)x;
182  if ( t1 ) {
183  if ( ( ( type = GetName(AC.varnames,t1,&numfun,WITHAUTO) ) != CFUNCTION )
184  || ( functions[numfun].spec != 0 ) ) {
185  MesPrint("&%s should be a regular function",t1);
186  if ( type < 0 ) {
187  if ( GetName(AC.exprnames,t1,&numfun,NOAUTO) == NAMENOTFOUND )
188  AddFunction(t1,0,0,0,0,0,-1,-1);
189  }
190  return(1);
191  }
192  AC.AltCollectFun = numfun+FUNCTION;
193  }
194  return(0);
195 syntaxerror:
196  MesPrint("&Collect statement needs one or two functions (and a percentage) for its argument(s)");
197  return(1);
198 }
199 
200 /*
201  #] CoCollect :
202  #[ setonoff :
203 */
204 
205 int setonoff(UBYTE *s, int *flag, int onvalue, int offvalue)
206 {
207  if ( StrICmp(s,(UBYTE *)"on") == 0 ) *flag = onvalue;
208  else if ( StrICmp(s,(UBYTE *)"off") == 0 ) *flag = offvalue;
209  else {
210  MesPrint("&Unknown option: %s, on or off expected",s);
211  return(1);
212  }
213  return(0);
214 }
215 
216 /*
217  #] setonoff :
218  #[ CoCompress :
219 */
220 
221 int CoCompress(UBYTE *s)
222 {
223  GETIDENTITY
224  UBYTE *t, c;
225  if ( StrICmp(s,(UBYTE *)"on") == 0 ) {
226  AC.NoCompress = 0;
227  AR.gzipCompress = 0;
228  }
229  else if ( StrICmp(s,(UBYTE *)"off") == 0 ) {
230  AC.NoCompress = 1;
231  AR.gzipCompress = 0;
232  }
233  else {
234  t = s; while ( FG.cTable[*t] <= 1 ) t++;
235  c = *t; *t = 0;
236  if ( StrICmp(s,(UBYTE *)"gzip") == 0 ) {
237 #ifndef WITHZLIB
238  Warning("gzip compression not supported on this platform");
239 #endif
240  s = t; *s = c;
241  if ( *s == 0 ) {
242  AR.gzipCompress = GZIPDEFAULT; /* Normally should be 6 */
243  return(0);
244  }
245  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
246  t = s;
247  if ( FG.cTable[*s] == 1 ) {
248  AR.gzipCompress = *s - '0';
249  s++;
250  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
251  if ( *s == 0 ) return(0);
252  }
253  MesPrint("&Unknown gzip option: %s, a digit was expected",t);
254  return(1);
255 
256  }
257  else {
258  MesPrint("&Unknown option: %s, on, off or gzip expected",s);
259  return(1);
260  }
261  }
262  return(0);
263 }
264 
265 /*
266  #] CoCompress :
267  #[ CoFlags :
268 */
269 
270 int CoFlags(UBYTE *s,int value)
271 {
272  int i, error = 0;
273  if ( *s != ',' ) {
274  MesPrint("&Proper syntax is: On/Off Flag,number[s];");
275  error = 1;
276  }
277  while ( *s == ',' ) {
278  do { s++; } while ( *s == ',' );
279  i = 0;
280  if ( FG.cTable[*s] != 1 ) {
281  MesPrint("&Proper syntax is: On/Off Flag,number[s];");
282  error = 1;
283  break;
284  }
285  while ( FG.cTable[*s] == 1 ) { i = 10*i + *s++ - '0'; }
286  if ( i <= 0 || i > MAXFLAGS ) {
287  MesPrint("&The number of a flag in On/Off Flag should be in the range 0-%d",(int)MAXFLAGS);
288  error = 1;
289  break;
290  }
291  AC.debugFlags[i] = value;
292  }
293  if ( *s ) {
294  MesPrint("&Proper syntax is: On/Off Flag,number[s];");
295  error = 1;
296  }
297  return(error);
298 }
299 
300 /*
301  #] CoFlags :
302  #[ CoOff :
303 */
304 
305 int CoOff(UBYTE *s)
306 {
307  GETIDENTITY
308  UBYTE *t, c;
309  int i, num = sizeof(onoffoptions)/sizeof(KEYWORD);
310  for (;;) {
311  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
312  if ( *s == 0 ) return(0);
313  if ( chartype[*s] != 0 ) {
314  MesPrint("&Illegal character or option encountered in OFF statement");
315  return(-1);
316  }
317  t = s; while ( chartype[*s] == 0 ) s++;
318  c = *s; *s = 0;
319  for ( i = 0; i < num; i++ ) {
320  if ( StrICont(t,(UBYTE *)(onoffoptions[i].name)) == 0 ) break;
321  }
322  if ( i >= num ) {
323  MesPrint("&Unrecognized option in OFF statement: %s",t);
324  *s = c; return(-1);
325  }
326  else if ( StrICont(t,(UBYTE *)"compress") == 0 ) {
327  AR.gzipCompress = 0;
328  }
329  else if ( StrICont(t,(UBYTE *)"checkpoint") == 0 ) {
330  AC.CheckpointInterval = 0;
331  if ( AC.CheckpointRunBefore ) { free(AC.CheckpointRunBefore); AC.CheckpointRunBefore = NULL; }
332  if ( AC.CheckpointRunAfter ) { free(AC.CheckpointRunAfter); AC.CheckpointRunAfter = NULL; }
333  if ( AC.NoShowInput == 0 ) MesPrint("Checkpoints deactivated.");
334  }
335  else if ( StrICont(t,(UBYTE *)"threads") == 0 ) {
336  AS.MultiThreaded = 0;
337  }
338  else if ( StrICont(t,(UBYTE *)"flag") == 0 ) {
339  *s = c;
340  return(CoFlags(s,0));
341  }
342  else if ( StrICont(t,(UBYTE *)"innertest") == 0 ) {
343  *s = c;
344  AC.InnerTest = 0;
345  if ( AC.TestValue ) {
346  M_free(AC.TestValue,"InnerTest");
347  AC.TestValue = 0;
348  }
349  }
350  *s = c;
351  *((int *)(onoffoptions[i].func)) = onoffoptions[i].flags;
352  AR.SortType = AC.SortType;
353  AC.mparallelflag = AC.parallelflag | AM.hparallelflag;
354  }
355 }
356 
357 /*
358  #] CoOff :
359  #[ CoOn :
360 */
361 
362 int CoOn(UBYTE *s)
363 {
364  GETIDENTITY
365  UBYTE *t, c;
366  int i, num = sizeof(onoffoptions)/sizeof(KEYWORD);
367  LONG interval;
368  for (;;) {
369  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
370  if ( *s == 0 ) return(0);
371  if ( chartype[*s] != 0 ) {
372  MesPrint("&Illegal character or option encountered in ON statement");
373  return(-1);
374  }
375  t = s; while ( chartype[*s] == 0 ) s++;
376  c = *s; *s = 0;
377  for ( i = 0; i < num; i++ ) {
378  if ( StrICont(t,(UBYTE *)(onoffoptions[i].name)) == 0 ) break;
379  }
380  if ( i >= num ) {
381  MesPrint("&Unrecognized option in ON statement: %s",t);
382  *s = c; return(-1);
383  }
384  if ( StrICont(t,(UBYTE *)"compress") == 0 ) {
385  AR.gzipCompress = 0;
386  *s = c;
387  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
388  if ( *s ) {
389  t = s;
390  while ( FG.cTable[*s] <= 1 ) s++;
391  c = *s; *s = 0;
392  if ( StrICmp(t,(UBYTE *)"gzip") == 0 ) {}
393  else {
394  MesPrint("&Unrecognized option in ON compress statement: %s",t);
395  return(-1);
396  }
397  *s = c;
398  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
399 #ifndef WITHZLIB
400  Warning("gzip compression not supported on this platform");
401 #endif
402  if ( FG.cTable[*s] == 1 ) {
403  AR.gzipCompress = *s++ - '0';
404  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
405  if ( *s ) {
406  MesPrint("&Unrecognized option in ON compress gzip statement: %s",t);
407  return(-1);
408  }
409  }
410  else if ( *s == 0 ) {
411  AR.gzipCompress = GZIPDEFAULT;
412  }
413  else {
414  MesPrint("&Unrecognized option in ON compress gzip statement: %s, single digit expected",t);
415  return(-1);
416  }
417  }
418  }
419  else if ( StrICont(t,(UBYTE *)"checkpoint") == 0 ) {
420  AC.CheckpointInterval = 0;
421  if ( AC.CheckpointRunBefore ) { free(AC.CheckpointRunBefore); AC.CheckpointRunBefore = NULL; }
422  if ( AC.CheckpointRunAfter ) { free(AC.CheckpointRunAfter); AC.CheckpointRunAfter = NULL; }
423  *s = c;
424  while ( *s ) {
425  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
426  if ( FG.cTable[*s] == 1 ) {
427  interval = 0;
428  t = s;
429  do { interval = 10*interval + *s++ - '0'; } while ( FG.cTable[*s] == 1 );
430  if ( *s == 's' || *s == 'S' ) {
431  s++;
432  }
433  else if ( *s == 'm' || *s == 'M' ) {
434  interval *= 60; s++;
435  }
436  else if ( *s == 'h' || *s == 'H' ) {
437  interval *= 3600; s++;
438  }
439  else if ( *s == 'd' || *s == 'D' ) {
440  interval *= 86400; s++;
441  }
442  if ( *s != ',' && FG.cTable[*s] != 6 && FG.cTable[*s] != 10 ) {
443  MesPrint("&Unrecognized time interval in ON Checkpoint statement: %s", t);
444  return(-1);
445  }
446  AC.CheckpointInterval = interval * 100; /* in 1/100 of seconds */
447  }
448  else if ( FG.cTable[*s] == 0 ) {
449  int type;
450  t = s;
451  while ( FG.cTable[*s] == 0 ) s++;
452  c = *s; *s = 0;
453  if ( StrICmp(t,(UBYTE *)"run") == 0 ) {
454  type = 3;
455  }
456  else if ( StrICmp(t,(UBYTE *)"runafter") == 0 ) {
457  type = 2;
458  }
459  else if ( StrICmp(t,(UBYTE *)"runbefore") == 0 ) {
460  type = 1;
461  }
462  else {
463  MesPrint("&Unrecognized option in ON Checkpoint statement: %s", t);
464  *s = c; return(-1);
465  }
466  *s = c;
467  if ( *s != '=' && FG.cTable[*(s+1)] != 9 ) {
468  MesPrint("&Unrecognized option in ON Checkpoint statement: %s", t);
469  return(-1);
470  }
471  ++s;
472  t = ++s;
473  while ( *s ) {
474  if ( FG.cTable[*s] == 9 ) {
475  c = *s; *s = 0;
476  if ( type & 1 ) {
477  if ( AC.CheckpointRunBefore ) {
478  free(AC.CheckpointRunBefore); AC.CheckpointRunBefore = NULL;
479  }
480  if ( s-t > 0 ) {
481  AC.CheckpointRunBefore = Malloc1(s-t+1, "AC.CheckpointRunBefore");
482  StrCopy(t, (UBYTE*)AC.CheckpointRunBefore);
483  }
484  }
485  if ( type & 2 ) {
486  if ( AC.CheckpointRunAfter ) {
487  free(AC.CheckpointRunAfter); AC.CheckpointRunAfter = NULL;
488  }
489  if ( s-t > 0 ) {
490  AC.CheckpointRunAfter = Malloc1(s-t+1, "AC.CheckpointRunAfter");
491  StrCopy(t, (UBYTE*)AC.CheckpointRunAfter);
492  }
493  }
494  *s = c;
495  break;
496  }
497  ++s;
498  }
499  if ( FG.cTable[*s] != 9 ) {
500  MesPrint("&Unrecognized option in ON Checkpoint statement: %s", t);
501  return(-1);
502  }
503  ++s;
504  }
505  }
506 /*
507  if ( AC.NoShowInput == 0 ) {
508  MesPrint("Checkpoints activated.");
509  if ( AC.CheckpointInterval ) {
510  MesPrint("-> Minimum saving interval: %l seconds.", AC.CheckpointInterval/100);
511  }
512  else {
513  MesPrint("-> No minimum saving interval given. Saving after EVERY module.");
514  }
515  if ( AC.CheckpointRunBefore ) {
516  MesPrint("-> Calling script \"%s\" before saving.", AC.CheckpointRunBefore);
517  }
518  if ( AC.CheckpointRunAfter ) {
519  MesPrint("-> Calling script \"%s\" after saving.", AC.CheckpointRunAfter);
520  }
521  }
522 */
523  }
524  else if ( StrICont(t,(UBYTE *)"indentspace") == 0 ) {
525  *s = c;
526  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
527  if ( *s ) {
528  i = 0;
529  while ( FG.cTable[*s] == 1 ) { i = 10*i + *s++ - '0'; }
530  if ( *s ) {
531  MesPrint("&Unrecognized option in ON IndentSpace statement: %s",t);
532  return(-1);
533  }
534  if ( i > 40 ) {
535  Warning("IndentSpace parameter adjusted to 40");
536  i = 40;
537  }
538  AO.IndentSpace = i;
539  }
540  else {
541  AO.IndentSpace = AM.ggIndentSpace;
542  }
543  return(0);
544  }
545  else if ( ( StrICont(t,(UBYTE *)"fewerstats") == 0 ) ||
546  ( StrICont(t,(UBYTE *)"fewerstatistics") == 0 ) ) {
547  *s = c;
548  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
549  if ( *s ) {
550  i = 0;
551  while ( FG.cTable[*s] == 1 ) { i = 10*i + *s++ - '0'; }
552  if ( *s ) {
553  MesPrint("&Unrecognized option in ON FewerStatistics statement: %s",t);
554  return(-1);
555  }
556  if ( i > AM.S0->MaxPatches ) {
557  if ( AC.WarnFlag )
558  MesPrint("&Warning: FewerStatistics parameter greater than MaxPatches(=%d). Adjusted to %d"
559  ,AM.S0->MaxPatches,(AM.S0->MaxPatches+1)/2);
560  i = (AM.S0->MaxPatches+1)/2;
561  }
562  AC.ShortStatsMax = i;
563  }
564  else {
565  AC.ShortStatsMax = 10; /* default value */
566  }
567  return(0);
568  }
569  else if ( StrICont(t,(UBYTE *)"threads") == 0 ) {
570  if ( AM.totalnumberofthreads > 1 ) AS.MultiThreaded = 1;
571  }
572  else if ( StrICont(t,(UBYTE *)"flag") == 0 ) {
573  *s = c;
574  return(CoFlags(s,1));
575  }
576  else if ( StrICont(t,(UBYTE *)"innertest") == 0 ) {
577  UBYTE *t;
578  *s = c;
579  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
580  if ( *s ) {
581  t = s; while ( *t ) t++;
582  while ( t[-1] == ' ' || t[-1] == '\t' ) t--;
583  c = *t; *t = 0;
584  if ( AC.TestValue ) M_free(AC.TestValue,"InnerTest");
585  AC.TestValue = strDup1(s,"InnerTest");
586  *t = c;
587  s = t;
588  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
589  }
590  else {
591  if ( AC.TestValue ) {
592  M_free(AC.TestValue,"InnerTest");
593  AC.TestValue = 0;
594  }
595  }
596  }
597  else { *s = c; }
598  *((int *)(onoffoptions[i].func)) = onoffoptions[i].type;
599  AR.SortType = AC.SortType;
600  AC.mparallelflag = AC.parallelflag | AM.hparallelflag;
601  }
602 }
603 
604 /*
605  #] CoOn :
606  #[ CoInsideFirst :
607 */
608 
609 int CoInsideFirst(UBYTE *s) { return(setonoff(s,&AC.insidefirst,1,0)); }
610 
611 /*
612  #] CoInsideFirst :
613  #[ CoProperCount :
614 */
615 
616 int CoProperCount(UBYTE *s) { return(setonoff(s,&AC.BottomLevel,1,0)); }
617 
618 /*
619  #] CoProperCount :
620  #[ CoDelete :
621 */
622 
623 int CoDelete(UBYTE *s)
624 {
625  int error = 0;
626  if ( StrICmp(s,(UBYTE *)"storage") == 0 ) {
627  if ( DeleteStore(1) < 0 ) {
628  MesPrint("&Cannot restart storage file");
629  error = 1;
630  }
631  }
632  else {
633  UBYTE *t = s, c;
634  while ( *t && *t != ',' && *t != '>' ) t++;
635  c = *t; *t = 0;
636  if ( ( StrICmp(s,(UBYTE *)"extrasymbols") == 0 )
637  || ( StrICmp(s,(UBYTE *)"extrasymbol") == 0 ) ) {
638  WORD x = 0;
639 /*
640  Either deletes all extra symbols or deletes above a given number
641 */
642  *t = c; s = t;
643  if ( *s == '>' ) {
644  s++;
645  if ( FG.cTable[*s] != 1 ) goto unknown;
646  while ( *s <= '9' && *s >= '0' ) x = 10*x + *s++ - '0';
647  if ( *s ) goto unknown;
648  }
649  else if ( *s ) goto unknown;
650  if ( x < AM.gnumextrasym ) x = AM.gnumextrasym;
651  PruneExtraSymbols(x);
652  }
653  else {
654  *t = c;
655 unknown:
656  MesPrint("&Unknown option: %s",s);
657  error = 1;
658  }
659  }
660  return(error);
661 }
662 
663 /*
664  #] CoDelete :
665  #[ CoFormat :
666 */
667 
668 int CoFormat(UBYTE *s)
669 {
670  int error = 0, x;
671  KEYWORD *key;
672  UBYTE *ss;
673  while ( *s == ' ' || *s == ',' ) s++;
674  if ( *s == 0 ) {
675  AC.OutputMode = 72;
676  AC.OutputSpaces = NORMALFORMAT;
677  return(error);
678  }
679 /*
680  First the optimization level
681 */
682  if ( *s == 'O' || *s == 'o' ) {
683  if ( ( FG.cTable[s[1]] == 1 ) ||
684  ( s[1] == '=' && FG.cTable[s[2]] == 1 ) ) {
685  s++; if ( *s == '=' ) s++;
686  x = 0;
687  while ( *s >= '0' && *s <= '9' ) x = 10*x + *s++ - '0';
688  while ( *s == ',' ) s++;
689  AO.OptimizationLevel = x;
690  AO.Optimize.greedytimelimit = 0;
691  AO.Optimize.mctstimelimit = 0;
692  AO.Optimize.printstats = 0;
693  AO.Optimize.debugflags = 0;
694  AO.Optimize.schemeflags = 0;
695  AO.Optimize.mctsdecaymode = 1; // default is decreasing C_p with iteration number
696  if ( AO.inscheme ) {
697  M_free(AO.inscheme,"Horner input scheme");
698  AO.inscheme = 0; AO.schemenum = 0;
699  }
700  switch ( x ) {
701  case 0:
702  break;
703  case 1:
704  AO.Optimize.mctsconstant.fval = -1.0;
705  AO.Optimize.horner = O_OCCURRENCE;
706  AO.Optimize.hornerdirection = O_FORWARDORBACKWARD;
707  AO.Optimize.method = O_CSE;
708  break;
709  case 2:
710  AO.Optimize.horner = O_OCCURRENCE;
711  AO.Optimize.hornerdirection = O_FORWARDORBACKWARD;
712  AO.Optimize.method = O_GREEDY;
713  AO.Optimize.greedyminnum = 10;
714  AO.Optimize.greedymaxperc = 5;
715  break;
716  case 3:
717  AO.Optimize.mctsconstant.fval = 1.0;
718  AO.Optimize.horner = O_MCTS;
719  AO.Optimize.hornerdirection = O_FORWARDORBACKWARD;
720  AO.Optimize.method = O_GREEDY;
721  AO.Optimize.mctsnumexpand = 1000;
722  AO.Optimize.mctsnumkeep = 10;
723  AO.Optimize.mctsnumrepeat = 1;
724  AO.Optimize.greedyminnum = 10;
725  AO.Optimize.greedymaxperc = 5;
726  break;
727  case 4:
728  AO.Optimize.horner = O_SIMULATED_ANNEALING;
729  AO.Optimize.saIter = 1000;
730  AO.Optimize.saMaxT.fval = 2000;
731  AO.Optimize.saMinT.fval = 1;
732  break;
733  default:
734  error = 1;
735  MesPrint("&Illegal optimization specification in format statement");
736  break;
737  }
738  if ( error == 0 && *s != 0 && x > 0 ) return(CoOptimizeOption(s));
739  return(error);
740  }
741 #ifdef EXPOPT
742  { UBYTE c;
743  ss = s;
744  while ( FG.cTable[*s] == 0 ) s++;
745  c = *s; *s = 0;
746  if ( StrICont(ss,(UBYTE *)"optimize") == 0 ) {
747  *s = c;
748  while ( *s == ',' ) s++;
749  if ( *s == '=' ) s++;
750  AO.OptimizationLevel = 3;
751  AO.Optimize.mctsconstant.fval = 1.0;
752  AO.Optimize.horner = O_MCTS;
753  AO.Optimize.hornerdirection = O_FORWARDORBACKWARD;
754  AO.Optimize.method = O_GREEDY;
755  AO.Optimize.mctstimelimit = 0;
756  AO.Optimize.mctsnumexpand = 1000;
757  AO.Optimize.mctsnumkeep = 10;
758  AO.Optimize.mctsnumrepeat = 1;
759  AO.Optimize.greedytimelimit = 0;
760  AO.Optimize.greedyminnum = 10;
761  AO.Optimize.greedymaxperc = 5;
762  AO.Optimize.printstats = 0;
763  AO.Optimize.debugflags = 0;
764  AO.Optimize.schemeflags = 0;
765  AO.Optimize.mctsdecaymode = 1;
766  if ( AO.inscheme ) {
767  M_free(AO.inscheme,"Horner input scheme");
768  AO.inscheme = 0; AO.schemenum = 0;
769  }
770  return(CoOptimizeOption(s));
771  }
772  else {
773  error = 1;
774  MesPrint("&Illegal optimization specification in format statement");
775  return(error);
776  }
777  }
778 #endif
779  }
780  else if ( FG.cTable[*s] == 1 ) {
781  x = 0;
782  while ( FG.cTable[*s] == 1 ) x = 10*x + *s++ - '0';
783  if ( x <= 0 || x >= MAXLINELENGTH ) {
784  x = 72;
785  error = 1;
786  MesPrint("&Illegal value for linesize: %d",x);
787  }
788  if ( x < 39 ) {
789  MesPrint(" ... Too small value for linesize corrected to 39");
790  x = 39;
791  }
792  AO.DoubleFlag = 0;
793 /*
794  The next line resets the mode to normal. Because the special modes
795  reset the line length we have a little problem with the special modes
796  and customized line length. We try to improve by removing the next line
797 */
798 /* AC.OutputMode = 0; */
799  AC.LineLength = x;
800  if ( *s != 0 ) {
801  error = 1;
802  MesPrint("&Illegal linesize field in format statement");
803  }
804  }
805  else {
806  key = FindKeyWord(s,formatoptions,
807  sizeof(formatoptions)/sizeof(KEYWORD));
808  if ( key ) {
809  if ( key->flags == 0 ) {
810  if ( key->type == FORTRANMODE || key->type == PFORTRANMODE
811  || key->type == DOUBLEFORTRANMODE
812  || key->type == QUADRUPLEFORTRANMODE || key->type == VORTRANMODE ) {
813  AC.IsFortran90 = ISNOTFORTRAN90;
814  if ( AC.Fortran90Kind ) {
815  M_free(AC.Fortran90Kind,"Fortran90 Kind");
816  AC.Fortran90Kind = 0;
817  }
818  }
819  AO.DoubleFlag = 0;
820  AC.OutputMode = key->type & NODOUBLEMASK;
821  if ( ( key->type & DOUBLEPRECISIONFLAG ) != 0 ) {
822  AO.DoubleFlag = 1;
823  }
824  else if ( ( key->type & QUADRUPLEPRECISIONFLAG ) != 0 ) {
825  AO.DoubleFlag = 2;
826  }
827  }
828  else if ( key->flags == 1 ) {
829  AC.OutputMode = AC.OutNumberType = key->type;
830  }
831  else if ( key->flags == 2 ) {
832  while ( FG.cTable[*s] == 0 ) s++;
833  if ( *s == 0 ) AC.OutNumberType = 10;
834  else if ( *s == ',' ) {
835  s++;
836  x = 0;
837  while ( FG.cTable[*s] == 1 ) x = 10*x + *s++ - '0';
838  if ( *s != 0 ) {
839  error = 1;
840  MesPrint("&Illegal float format specifier");
841  }
842  else {
843  if ( x < 3 ) {
844  x = 3;
845  MesPrint("& ... float format value corrected to 3");
846  }
847  if ( x > 100 ) {
848  x = 100;
849  MesPrint("& ... float format value corrected to 100");
850  }
851  AC.OutNumberType = x;
852  }
853  }
854  }
855  else if ( key->flags == 3 ) {
856  AC.OutputSpaces = key->type;
857  }
858  else if ( key->flags == 4 ) {
859  AC.IsFortran90 = ISFORTRAN90;
860  if ( AC.Fortran90Kind ) {
861  M_free(AC.Fortran90Kind,"Fortran90 Kind");
862  AC.Fortran90Kind = 0;
863  }
864  while ( FG.cTable[*s] <= 1 ) s++;
865  if ( *s == ',' ) {
866  s++; ss = s;
867  while ( *ss && *ss != ',' ) ss++;
868  if ( *ss == ',' ) {
869  MesPrint("&No white space or comma's allowed in Fortran90 option: %s",s); error = 1;
870  }
871  else {
872  AC.Fortran90Kind = strDup1(s,"Fortran90 Kind");
873  }
874  }
875  AO.DoubleFlag = 0;
876  AC.OutputMode = key->type & NODOUBLEMASK;
877  }
878  }
879  else if ( ( *s == 'c' || *s == 'C' ) && ( FG.cTable[s[1]] == 1 ) ) {
880  UBYTE *ss = s+1;
881  WORD x = 0;
882  while ( *ss >= '0' && *ss <= '9' ) x = 10*x + *ss++ - '0';
883  if ( *ss != 0 ) goto Unknown;
884  AC.OutputMode = CMODE;
885  AC.Cnumpows = x;
886  }
887  else {
888 Unknown: MesPrint("&Unknown option: %s",s); error = 1;
889  }
890  AC.LineLength = 72;
891  }
892  return(error);
893 }
894 
895 /*
896  #] CoFormat :
897  #[ CoKeep :
898 */
899 
900 int CoKeep(UBYTE *s)
901 {
902  if ( StrICmp(s,(UBYTE *)"brackets") == 0 ) AC.ComDefer = 1;
903  else { MesPrint("&Unknown option: '%s'",s); return(1); }
904  return(0);
905 }
906 
907 /*
908  #] CoKeep :
909  #[ CoFixIndex :
910 */
911 
912 int CoFixIndex(UBYTE *s)
913 {
914  int x, y, error = 0;
915  while ( *s ) {
916  if ( FG.cTable[*s] != 1 ) {
917 proper: MesPrint("&Proper syntax is: FixIndex,number:value[,number,value];");
918  return(1);
919  }
920  ParseNumber(x,s)
921  if ( *s != ':' ) goto proper;
922  s++;
923  if ( *s != '-' && *s != '+' && FG.cTable[*s] != 1 ) goto proper;
924  ParseSignedNumber(y,s)
925  if ( *s && *s != ',' ) goto proper;
926  while ( *s == ',' ) s++;
927  if ( x >= AM.OffsetIndex ) {
928  MesPrint("&Fixed index out of allowed range. Change ConstIndex in setup file?");
929  MesPrint("&Current value of ConstIndex = %d",AM.OffsetIndex-1);
930  error = 1;
931  }
932  if ( y != (int)((WORD)y) ) {
933  MesPrint("&Value of d_(%d,%d) outside range for this computer",x,x);
934  error = 1;
935  }
936  if ( error == 0 ) AC.FixIndices[x] = y;
937  }
938  return(error);
939 }
940 
941 /*
942  #] CoFixIndex :
943  #[ CoMetric :
944 */
945 
946 int CoMetric(UBYTE *s)
947 { DUMMYUSE(s); MesPrint("&The metric statement does not do anything yet"); return(1); }
948 
949 /*
950  #] CoMetric :
951  #[ DoPrint :
952 */
953 
954 int DoPrint(UBYTE *s, int par)
955 {
956  int i, error = 0, numdol = 0, type;
957  UBYTE *name, c, *t;
958  EXPRESSIONS e;
959  WORD numexpr, tofile = 0, *w;
960  CBUF *C = cbuf + AC.cbufnum;
961  while ( *s == ',' ) s++;
962 /* if ( s[-1] == '+' || s[-1] == '-' ) s--; */
963  if ( ( *s == '+' || *s == '-' ) && ( s[1] == 'f' || s[1] == 'F' ) ) {
964  t = s + 2; while ( *t == ' ' || *t == ',' ) t++;
965  if ( *t == '"' ) {
966  if ( *s == '+' ) tofile = 1;
967  s = t;
968  }
969  }
970  if ( par == PRINTON && *s == '"' ) {
971  WORD code;
972  if ( tofile == 1 ) code = TYPEFPRINT;
973  else code = TYPEPRINT;
974  s++; name = s;
975  while ( *s && *s != '"' ) {
976  if ( *s == '\\' ) s++;
977  if ( *s == '%' && s[1] == '$' ) numdol++;
978  s++;
979  }
980  if ( *s != '"' ) {
981  MesPrint("&String in print statement should be enclosed in \"");
982  return(1);
983  }
984  *s = 0;
985  AddComString(1,&code,name,1);
986  *s++ = '"';
987  while ( *s == ',' ) {
988  s++;
989  if ( *s == '$' ) {
990  s++; name = s; while ( FG.cTable[*s] <= 1 ) s++;
991  c = *s; *s = 0;
992  type = GetName(AC.dollarnames,name,&numexpr,NOAUTO);
993  if ( type == NAMENOTFOUND ) {
994  MesPrint("&$ variable %s not (yet) defined",name);
995  error = 1;
996  }
997  else {
998  C->lhs[C->numlhs][1] += 2;
999  *(C->Pointer)++ = DOLLAREXPRESSION;
1000  *(C->Pointer)++ = numexpr;
1001  numdol--;
1002  }
1003  }
1004  else {
1005  MesPrint("&Illegal object in print statement");
1006  error = 1;
1007  return(error);
1008  }
1009  *s = c;
1010  if ( c == '[' ) {
1011  w = C->Pointer;
1012  s++;
1013  s = GetDoParam(s,&(C->Pointer),-1);
1014  if ( s == 0 ) return(1);
1015  if ( *s != ']' ) {
1016  MesPrint("&unmatched [] in $ factor");
1017  return(1);
1018  }
1019  C->lhs[C->numlhs][1] += C->Pointer - w;
1020  s++;
1021  }
1022  }
1023  if ( *s != 0 ) {
1024  MesPrint("&Illegal object in print statement");
1025  error = 1;
1026  }
1027  if ( numdol > 0 ) {
1028  MesPrint("&More $ variables asked for than provided");
1029  error = 1;
1030  }
1031  *(C->Pointer)++ = 0;
1032  return(error);
1033  }
1034  if ( *s == 0 ) { /* All active expressions */
1035 AllExpr:
1036  for ( e = Expressions, i = NumExpressions; i > 0; i--, e++ ) {
1037  if ( e->status == LOCALEXPRESSION || e->status ==
1038  GLOBALEXPRESSION || e->status == UNHIDELEXPRESSION
1039  || e->status == UNHIDEGEXPRESSION ) e->printflag = par;
1040  }
1041  return(error);
1042  }
1043  while ( *s ) {
1044  if ( *s == '+' ) {
1045  s++;
1046  if ( tolower(*s) == 'f' ) par |= PRINTLFILE;
1047  else if ( tolower(*s) == 's' ) {
1048  if ( tolower(s[1]) == 's' ) {
1049  if ( tolower(s[2]) == 's' ) {
1050  par |= PRINTONEFUNCTION | PRINTONETERM | PRINTALL;
1051  s++;
1052  }
1053  else if ( ( par & 3 ) < 2 ) par |= PRINTONEFUNCTION | PRINTONETERM;
1054  s++;
1055  }
1056  else {
1057  if ( ( par & 3 ) < 2 ) par |= PRINTONETERM;
1058  }
1059  }
1060  else {
1061 illeg: MesPrint("&Illegal option in (n)print statement");
1062  error = 1;
1063  }
1064  s++;
1065  if ( *s == 0 ) goto AllExpr;
1066  }
1067  else if ( *s == '-' ) {
1068  s++;
1069  if ( tolower(*s) == 'f' ) par &= ~PRINTLFILE;
1070  else if ( tolower(*s) == 's' ) {
1071  if ( tolower(s[1]) == 's' ) {
1072  if ( tolower(s[2]) == 's' ) {
1073  par &= ~PRINTALL;
1074  s++;
1075  }
1076  else if ( ( par & 3 ) < 2 ) {
1077  par &= ~PRINTONEFUNCTION;
1078  par &= ~PRINTALL;
1079  }
1080  s++;
1081  }
1082  else {
1083  if ( ( par & 3 ) < 2 ) {
1084  par &= ~PRINTONETERM;
1085  par &= ~PRINTONEFUNCTION;
1086  par &= ~PRINTALL;
1087  }
1088  }
1089  }
1090  else goto illeg;
1091  s++;
1092  if ( *s == 0 ) goto AllExpr;
1093  }
1094  else if ( FG.cTable[*s] == 0 || *s == '[' ) {
1095  name = s;
1096  if ( ( s = SkipAName(s) ) == 0 ) {
1097  MesPrint("&Improper name in (n)print statement");
1098  return(1);
1099  }
1100  c = *s; *s = 0;
1101  if ( ( GetName(AC.exprnames,name,&numexpr,NOAUTO) == CEXPRESSION )
1102  && ( Expressions[numexpr].status == LOCALEXPRESSION
1103  || Expressions[numexpr].status == GLOBALEXPRESSION ) ) {
1104 FoundExpr:;
1105  if ( c == '[' && s[1] == ']' ) {
1106  Expressions[numexpr].printflag = par | PRINTCONTENTS;
1107  *s++ = c; c = *++s;
1108  }
1109  else
1110  Expressions[numexpr].printflag = par;
1111  }
1112  else if ( GetLastExprName(name,&numexpr)
1113  && ( Expressions[numexpr].status == LOCALEXPRESSION
1114  || Expressions[numexpr].status == GLOBALEXPRESSION
1115  || Expressions[numexpr].status == UNHIDELEXPRESSION
1116  || Expressions[numexpr].status == UNHIDEGEXPRESSION
1117  ) ) {
1118  goto FoundExpr;
1119  }
1120  else {
1121  MesPrint("&%s is not the name of an active expression",name);
1122  error = 1;
1123  }
1124  *s++ = c;
1125  if ( c == 0 ) return(0);
1126  if ( c == '-' || c == '+' ) s--;
1127  }
1128  else if ( *s == ',' ) s++;
1129  else {
1130  MesPrint("&Illegal object in (n)print statement");
1131  return(1);
1132  }
1133  }
1134  return(0);
1135 }
1136 
1137 /*
1138  #] DoPrint :
1139  #[ CoPrint :
1140 */
1141 
1142 int CoPrint(UBYTE *s) { return(DoPrint(s,PRINTON)); }
1143 
1144 /*
1145  #] CoPrint :
1146  #[ CoPrintB :
1147 */
1148 
1149 int CoPrintB(UBYTE *s) { return(DoPrint(s,PRINTCONTENT)); }
1150 
1151 /*
1152  #] CoPrintB :
1153  #[ CoNPrint :
1154 */
1155 
1156 int CoNPrint(UBYTE *s) { return(DoPrint(s,PRINTOFF)); }
1157 
1158 /*
1159  #] CoNPrint :
1160  #[ CoPushHide :
1161 */
1162 
1163 int CoPushHide(UBYTE *s)
1164 {
1165  GETIDENTITY
1166  WORD *ScratchBuf;
1167  int i;
1168  if ( AR.Fscr[2].PObuffer == 0 ) {
1169  ScratchBuf = (WORD *)Malloc1(AM.HideSize*sizeof(WORD),"hidesize");
1170  AR.Fscr[2].POsize = AM.HideSize * sizeof(WORD);
1171  AR.Fscr[2].POfull = AR.Fscr[2].POfill = AR.Fscr[2].PObuffer = ScratchBuf;
1172  AR.Fscr[2].POstop = AR.Fscr[2].PObuffer + AM.HideSize;
1173  PUTZERO(AR.Fscr[2].POposition);
1174  }
1175  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
1176  AC.HideLevel += 2;
1177  if ( *s ) {
1178  MesPrint("&PushHide statement should have no arguments");
1179  return(-1);
1180  }
1181  for ( i = 0; i < NumExpressions; i++ ) {
1182  switch ( Expressions[i].status ) {
1183  case DROPLEXPRESSION:
1184  case SKIPLEXPRESSION:
1185  case LOCALEXPRESSION:
1186  Expressions[i].status = HIDELEXPRESSION;
1187  Expressions[i].hidelevel = AC.HideLevel-1;
1188  break;
1189  case DROPGEXPRESSION:
1190  case SKIPGEXPRESSION:
1191  case GLOBALEXPRESSION:
1192  Expressions[i].status = HIDEGEXPRESSION;
1193  Expressions[i].hidelevel = AC.HideLevel-1;
1194  break;
1195  default:
1196  break;
1197  }
1198  }
1199  return(0);
1200 }
1201 
1202 /*
1203  #] CoPushHide :
1204  #[ CoPopHide :
1205 */
1206 
1207 int CoPopHide(UBYTE *s)
1208 {
1209  int i;
1210  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
1211  if ( AC.HideLevel <= 0 ) {
1212  MesPrint("&PopHide statement without corresponding PushHide statement");
1213  return(-1);
1214  }
1215  AC.HideLevel -= 2;
1216  if ( *s ) {
1217  MesPrint("&PopHide statement should have no arguments");
1218  return(-1);
1219  }
1220  for ( i = 0; i < NumExpressions; i++ ) {
1221  switch ( Expressions[i].status ) {
1222  case HIDDENLEXPRESSION:
1223  if ( Expressions[i].hidelevel > AC.HideLevel )
1224  Expressions[i].status = UNHIDELEXPRESSION;
1225  break;
1226  case HIDDENGEXPRESSION:
1227  if ( Expressions[i].hidelevel > AC.HideLevel )
1228  Expressions[i].status = UNHIDEGEXPRESSION;
1229  break;
1230  default:
1231  break;
1232  }
1233  }
1234  return(0);
1235 }
1236 
1237 /*
1238  #] CoPopHide :
1239  #[ SetExprCases :
1240 */
1241 
1242 int SetExprCases(int par, int setunset, int val)
1243 {
1244  switch ( par ) {
1245  case SKIP:
1246  switch ( val ) {
1247  case SKIPLEXPRESSION:
1248  if ( !setunset ) val = LOCALEXPRESSION;
1249  break;
1250  case SKIPGEXPRESSION:
1251  if ( !setunset ) val = GLOBALEXPRESSION;
1252  break;
1253  case LOCALEXPRESSION:
1254  if ( setunset ) val = SKIPLEXPRESSION;
1255  break;
1256  case GLOBALEXPRESSION:
1257  if ( setunset ) val = SKIPGEXPRESSION;
1258  break;
1259  case INTOHIDEGEXPRESSION:
1260  case INTOHIDELEXPRESSION:
1261  default:
1262  break;
1263  }
1264  break;
1265  case DROP:
1266  switch ( val ) {
1267  case SKIPLEXPRESSION:
1268  case LOCALEXPRESSION:
1269  case HIDELEXPRESSION:
1270  if ( setunset ) val = DROPLEXPRESSION;
1271  break;
1272  case DROPLEXPRESSION:
1273  if ( !setunset ) val = LOCALEXPRESSION;
1274  break;
1275  case SKIPGEXPRESSION:
1276  case GLOBALEXPRESSION:
1277  case HIDEGEXPRESSION:
1278  if ( setunset ) val = DROPGEXPRESSION;
1279  break;
1280  case DROPGEXPRESSION:
1281  if ( !setunset ) val = GLOBALEXPRESSION;
1282  break;
1283  case HIDDENLEXPRESSION:
1284  case UNHIDELEXPRESSION:
1285  if ( setunset ) val = DROPHLEXPRESSION;
1286  break;
1287  case HIDDENGEXPRESSION:
1288  case UNHIDEGEXPRESSION:
1289  if ( setunset ) val = DROPHGEXPRESSION;
1290  break;
1291  case DROPHLEXPRESSION:
1292  if ( !setunset ) val = HIDDENLEXPRESSION;
1293  break;
1294  case DROPHGEXPRESSION:
1295  if ( !setunset ) val = HIDDENGEXPRESSION;
1296  break;
1297  case INTOHIDEGEXPRESSION:
1298  case INTOHIDELEXPRESSION:
1299  default:
1300  break;
1301  }
1302  break;
1303  case HIDE:
1304  switch ( val ) {
1305  case DROPLEXPRESSION:
1306  case SKIPLEXPRESSION:
1307  case LOCALEXPRESSION:
1308  if ( setunset ) val = HIDELEXPRESSION;
1309  break;
1310  case HIDELEXPRESSION:
1311  if ( !setunset ) val = LOCALEXPRESSION;
1312  break;
1313  case DROPGEXPRESSION:
1314  case SKIPGEXPRESSION:
1315  case GLOBALEXPRESSION:
1316  if ( setunset ) val = HIDEGEXPRESSION;
1317  break;
1318  case HIDEGEXPRESSION:
1319  if ( !setunset ) val = GLOBALEXPRESSION;
1320  break;
1321  case INTOHIDEGEXPRESSION:
1322  case INTOHIDELEXPRESSION:
1323  default:
1324  break;
1325  }
1326  break;
1327  case UNHIDE:
1328  switch ( val ) {
1329  case HIDDENLEXPRESSION:
1330  case DROPHLEXPRESSION:
1331  if ( setunset ) val = UNHIDELEXPRESSION;
1332  break;
1333  case UNHIDELEXPRESSION:
1334  if ( !setunset ) val = HIDDENLEXPRESSION;
1335  break;
1336  case HIDDENGEXPRESSION:
1337  case DROPHGEXPRESSION:
1338  if ( setunset ) val = UNHIDEGEXPRESSION;
1339  break;
1340  case UNHIDEGEXPRESSION:
1341  if ( !setunset ) val = HIDDENGEXPRESSION;
1342  break;
1343  case INTOHIDEGEXPRESSION:
1344  case INTOHIDELEXPRESSION:
1345  default:
1346  break;
1347  }
1348  break;
1349  case INTOHIDE:
1350  switch ( val ) {
1351  case HIDDENLEXPRESSION:
1352  case HIDDENGEXPRESSION:
1353  MesPrint("&Expression is already hidden");
1354  return(-1);
1355  case DROPHLEXPRESSION:
1356  case DROPHGEXPRESSION:
1357  case UNHIDELEXPRESSION:
1358  case UNHIDEGEXPRESSION:
1359  MesPrint("&Cannot unhide and put intohide expression in the same module");
1360  return(-1);
1361  case LOCALEXPRESSION:
1362  case DROPLEXPRESSION:
1363  case SKIPLEXPRESSION:
1364  case HIDELEXPRESSION:
1365  if ( setunset ) val = INTOHIDELEXPRESSION;
1366  break;
1367  case GLOBALEXPRESSION:
1368  case DROPGEXPRESSION:
1369  case SKIPGEXPRESSION:
1370  case HIDEGEXPRESSION:
1371  if ( setunset ) val = INTOHIDEGEXPRESSION;
1372  break;
1373  default:
1374  break;
1375  }
1376  break;
1377  default:
1378  break;
1379  }
1380  return(val);
1381 }
1382 
1383 /*
1384  #] SetExprCases :
1385  #[ SetExpr :
1386 */
1387 
1388 int SetExpr(UBYTE *s, int setunset, int par)
1389 {
1390  WORD *w, numexpr;
1391  int error = 0, i;
1392  UBYTE *name, c;
1393  if ( *s == 0 && ( par != INTOHIDE ) ) {
1394  for ( i = 0; i < NumExpressions; i++ ) {
1395  w = &(Expressions[i].status);
1396  *w = SetExprCases(par,setunset,*w);
1397  if ( *w < 0 ) error = 1;
1398  if ( par == HIDE && setunset == 1 )
1399  Expressions[i].hidelevel = AC.HideLevel;
1400  }
1401  return(0);
1402  }
1403  while ( *s ) {
1404  if ( *s == ',' ) { s++; continue; }
1405  if ( *s == '0' ) { s++; continue; }
1406  name = s;
1407  if ( ( s = SkipAName(s) ) == 0 ) {
1408  MesPrint("&Improper name for an expression: '%s'",name);
1409  return(1);
1410  }
1411  c = *s; *s = 0;
1412  if ( GetName(AC.exprnames,name,&numexpr,NOAUTO) == CEXPRESSION ) {
1413  w = &(Expressions[numexpr].status);
1414  *w = SetExprCases(par,setunset,*w);
1415  if ( *w < 0 ) error = 1;
1416  if ( ( par == HIDE || par == INTOHIDE ) && setunset == 1 )
1417  Expressions[numexpr].hidelevel = AC.HideLevel;
1418  }
1419  else if ( GetName(AC.varnames,name,&numexpr,NOAUTO) != NAMENOTFOUND ) {
1420  MesPrint("&%s is not an expression",name);
1421  error = 1;
1422  }
1423  *s = c;
1424  }
1425  return(error);
1426 }
1427 
1428 /*
1429  #] SetExpr :
1430  #[ CoDrop :
1431 */
1432 
1433 int CoDrop(UBYTE *s) { return(SetExpr(s,1,DROP)); }
1434 
1435 /*
1436  #] CoDrop :
1437  #[ CoNoDrop :
1438 */
1439 
1440 int CoNoDrop(UBYTE *s) { return(SetExpr(s,0,DROP)); }
1441 
1442 /*
1443  #] CoNoDrop :
1444  #[ CoSkip :
1445 */
1446 
1447 int CoSkip(UBYTE *s) { return(SetExpr(s,1,SKIP)); }
1448 
1449 /*
1450  #] CoSkip :
1451  #[ CoNoSkip :
1452 */
1453 
1454 int CoNoSkip(UBYTE *s) { return(SetExpr(s,0,SKIP)); }
1455 
1456 /*
1457  #] CoNoSkip :
1458  #[ CoHide :
1459 */
1460 
1461 int CoHide(UBYTE *inp) {
1462  GETIDENTITY
1463  WORD *ScratchBuf;
1464  if ( AR.Fscr[2].PObuffer == 0 ) {
1465  ScratchBuf = (WORD *)Malloc1(AM.HideSize*sizeof(WORD),"hidesize");
1466  AR.Fscr[2].POsize = AM.HideSize * sizeof(WORD);
1467  AR.Fscr[2].POfull = AR.Fscr[2].POfill = AR.Fscr[2].PObuffer = ScratchBuf;
1468  AR.Fscr[2].POstop = AR.Fscr[2].PObuffer + AM.HideSize;
1469  PUTZERO(AR.Fscr[2].POposition);
1470  }
1471  return(SetExpr(inp,1,HIDE));
1472 }
1473 
1474 /*
1475  #] CoHide :
1476  #[ CoIntoHide :
1477 */
1478 
1479 int CoIntoHide(UBYTE *inp) {
1480  GETIDENTITY
1481  WORD *ScratchBuf;
1482  if ( AR.Fscr[2].PObuffer == 0 ) {
1483  ScratchBuf = (WORD *)Malloc1(AM.HideSize*sizeof(WORD),"hidesize");
1484  AR.Fscr[2].POsize = AM.HideSize * sizeof(WORD);
1485  AR.Fscr[2].POfull = AR.Fscr[2].POfill = AR.Fscr[2].PObuffer = ScratchBuf;
1486  AR.Fscr[2].POstop = AR.Fscr[2].PObuffer + AM.HideSize;
1487  PUTZERO(AR.Fscr[2].POposition);
1488  }
1489  return(SetExpr(inp,1,INTOHIDE));
1490 }
1491 
1492 /*
1493  #] CoIntoHide :
1494  #[ CoNoHide :
1495 */
1496 
1497 int CoNoHide(UBYTE *inp) { return(SetExpr(inp,0,HIDE)); }
1498 
1499 /*
1500  #] CoNoHide :
1501  #[ CoUnHide :
1502 */
1503 
1504 int CoUnHide(UBYTE *inp) { return(SetExpr(inp,1,UNHIDE)); }
1505 
1506 /*
1507  #] CoUnHide :
1508  #[ CoNoUnHide :
1509 */
1510 
1511 int CoNoUnHide(UBYTE *inp) { return(SetExpr(inp,0,UNHIDE)); }
1512 
1513 /*
1514  #] CoNoUnHide :
1515  #[ AddToCom :
1516 */
1517 
1518 void AddToCom(int n, WORD *array)
1519 {
1520  CBUF *C = cbuf+AC.cbufnum;
1521 #ifdef COMPBUFDEBUG
1522  MesPrint(" %a",n,array);
1523 #endif
1524  while ( C->Pointer+n >= C->Top ) DoubleCbuffer(AC.cbufnum,C->Pointer,18);
1525  while ( --n >= 0 ) *(C->Pointer)++ = *array++;
1526 }
1527 
1528 /*
1529  #] AddToCom :
1530  #[ AddComString :
1531 */
1532 
1533 int AddComString(int n, WORD *array, UBYTE *thestring, int par)
1534 {
1535  CBUF *C = cbuf+AC.cbufnum;
1536  UBYTE *s = thestring, *w;
1537 #ifdef COMPBUFDEBUG
1538  WORD *cc;
1539  UBYTE *ww;
1540 #endif
1541  int i, numchars = 0, size, zeroes;
1542  while ( *s ) {
1543  if ( *s == '\\' ) s++;
1544  else if ( par == 1 &&
1545  ( ( *s == '%' && s[1] != 't' && s[1] != 'T' && s[1] != '$' &&
1546  s[1] != 'w' && s[1] != 'W' && s[1] != 'r' && s[1] != 0 ) || *s == '#'
1547  || *s == '@' || *s == '&' ) ) {
1548  numchars++;
1549  }
1550  s++; numchars++;
1551  }
1552  AddLHS(AC.cbufnum);
1553  size = numchars/sizeof(WORD)+1;
1554  while ( C->Pointer+size+n+2 >= C->Top ) DoubleCbuffer(AC.cbufnum,C->Pointer,19);
1555 #ifdef COMPBUFDEBUG
1556  cc = C->Pointer;
1557 #endif
1558  *(C->Pointer)++ = array[0];
1559  *(C->Pointer)++ = size+n+2;
1560  for ( i = 1; i < n; i++ ) *(C->Pointer)++ = array[i];
1561  *(C->Pointer)++ = size;
1562 #ifdef COMPBUFDEBUG
1563  ww =
1564 #endif
1565  w = (UBYTE *)(C->Pointer);
1566  zeroes = size*sizeof(WORD)-numchars;
1567  s = thestring;
1568  while ( *s ) {
1569  if ( *s == '\\' ) s++;
1570  else if ( par == 1 && ( ( *s == '%' &&
1571  s[1] != 't' && s[1] != 'T' && s[1] != '$' &&
1572  s[1] != 'w' && s[1] != 'W' && s[1] != 'r' && s[1] != 0 ) || *s == '#'
1573  || *s == '@' || *s == '&' ) ) {
1574  *w++ = '%';
1575  }
1576  *w++ = *s++;
1577  }
1578  while ( --zeroes >= 0 ) *w++ = 0;
1579  C->Pointer += size;
1580 #ifdef COMPBUFDEBUG
1581  MesPrint("LH: %a",size+1+n,cc);
1582  MesPrint(" %s",thestring);
1583 #endif
1584  return(0);
1585 }
1586 
1587 /*
1588  #] AddComString :
1589  #[ Add2ComStrings :
1590 */
1591 
1592 int Add2ComStrings(int n, WORD *array, UBYTE *string1, UBYTE *string2)
1593 {
1594  CBUF *C = cbuf+AC.cbufnum;
1595  UBYTE *s1 = string1, *s2 = string2, *w;
1596  int i, num1chars = 0, num2chars = 0, size1, size2, zeroes1, zeroes2;
1597  AddLHS(AC.cbufnum);
1598  while ( *s1 ) { s1++; num1chars++; }
1599  size1 = num1chars/sizeof(WORD)+1;
1600  if ( s2 ) {
1601  while ( *s2 ) { s2++; num2chars++; }
1602  size2 = num2chars/sizeof(WORD)+1;
1603  }
1604  else size2 = 0;
1605  while ( C->Pointer+size1+size2+n+3 >= C->Top ) DoubleCbuffer(AC.cbufnum,C->Pointer,20);
1606  *(C->Pointer)++ = array[0];
1607  *(C->Pointer)++ = size1+size2+n+3;
1608  for ( i = 1; i < n; i++ ) *(C->Pointer)++ = array[i];
1609  *(C->Pointer)++ = size1;
1610  w = (UBYTE *)(C->Pointer);
1611  zeroes1 = size1*sizeof(WORD)-num1chars;
1612  s1 = string1;
1613  while ( *s1 ) { *w++ = *s1++; }
1614  while ( --zeroes1 >= 0 ) *w++ = 0;
1615  C->Pointer += size1;
1616  *(C->Pointer)++ = size2;
1617  if ( size2 ) {
1618  w = (UBYTE *)(C->Pointer);
1619  zeroes2 = size2*sizeof(WORD)-num2chars;
1620  s2 = string2;
1621  while ( *s2 ) { *w++ = *s2++; }
1622  while ( --zeroes2 >= 0 ) *w++ = 0;
1623  C->Pointer += size2;
1624  }
1625  return(0);
1626 }
1627 
1628 /*
1629  #] Add2ComStrings :
1630  #[ CoDiscard :
1631 */
1632 
1633 int CoDiscard(UBYTE *s)
1634 {
1635  if ( *s == 0 ) {
1636  Add2Com(TYPEDISCARD)
1637  return(0);
1638  }
1639  MesPrint("&Illegal argument in discard statement: '%s'",s);
1640  return(1);
1641 }
1642 
1643 /*
1644  #] CoDiscard :
1645  #[ CoContract :
1646 
1647  Syntax:
1648  Contract
1649  Contract:#
1650  Contract #
1651  Contract:#,#
1652 */
1653 
1654 static WORD ccarray[5] = { TYPEOPERATION,5,CONTRACT,0,0 };
1655 
1656 int CoContract(UBYTE *s)
1657 {
1658  int x;
1659  if ( *s == ':' ) {
1660  s++;
1661  ParseNumber(x,s)
1662  if ( *s != ',' && *s ) {
1663 proper: MesPrint("&Illegal number in contract statement");
1664  return(1);
1665  }
1666  if ( *s ) s++;
1667  ccarray[4] = x;
1668  }
1669  else ccarray[4] = 0;
1670  if ( FG.cTable[*s] == 1 ) {
1671  ParseNumber(x,s)
1672  if ( *s ) goto proper;
1673  ccarray[3] = x;
1674  }
1675  else if ( *s ) goto proper;
1676  else ccarray[3] = -1;
1677  return(AddNtoL(5,ccarray));
1678 }
1679 
1680 /*
1681  #] CoContract :
1682  #[ CoGoTo :
1683 */
1684 
1685 int CoGoTo(UBYTE *inp)
1686 {
1687  UBYTE *s = inp;
1688  int x;
1689  while ( FG.cTable[*s] <= 1 ) s++;
1690  if ( *s ) {
1691  MesPrint("&Label should be an alpha-numeric string");
1692  return(1);
1693  }
1694  x = GetLabel(inp);
1695  Add3Com(TYPEGOTO,x);
1696  return(0);
1697 }
1698 
1699 /*
1700  #] CoGoTo :
1701  #[ CoLabel :
1702 */
1703 
1704 int CoLabel(UBYTE *inp)
1705 {
1706  UBYTE *s = inp;
1707  int x;
1708  while ( FG.cTable[*s] <= 1 ) s++;
1709  if ( *s ) {
1710  MesPrint("&Label should be an alpha-numeric string");
1711  return(1);
1712  }
1713  x = GetLabel(inp);
1714  if ( AC.Labels[x] >= 0 ) {
1715  MesPrint("&Label %s defined more than once",AC.LabelNames[x]);
1716  return(1);
1717  }
1718  AC.Labels[x] = cbuf[AC.cbufnum].numlhs;
1719  return(0);
1720 }
1721 
1722 /*
1723  #] CoLabel :
1724  #[ DoArgument :
1725 
1726  Layout:
1727  par,full size,numlhs(+1),par,scale
1728  scale is for normalize
1729 */
1730 
1731 int DoArgument(UBYTE *s, int par)
1732 {
1733  GETIDENTITY
1734  UBYTE *name, *t, *v, c;
1735  WORD *oldworkpointer = AT.WorkPointer, *w, *ww, number, *scale;
1736  int error = 0, zeroflag, type, x;
1737  AC.lhdollarflag = 0;
1738  while ( *s == ',' ) s++;
1739  w = AT.WorkPointer;
1740  *w++ = par;
1741  w++;
1742  switch ( par ) {
1743  case TYPEARG:
1744  if ( AC.arglevel >= MAXNEST ) {
1745  MesPrint("@Nesting of argument statements more than %d levels"
1746  ,(WORD)MAXNEST);
1747  return(-1);
1748  }
1749  AC.argsumcheck[AC.arglevel] = NestingChecksum();
1750  AC.argstack[AC.arglevel] = cbuf[AC.cbufnum].Pointer
1751  - cbuf[AC.cbufnum].Buffer + 2;
1752  AC.arglevel++;
1753  *w++ = cbuf[AC.cbufnum].numlhs;
1754  break;
1755  case TYPENORM:
1756  case TYPENORM4:
1757  case TYPESPLITARG:
1758  case TYPESPLITFIRSTARG:
1759  case TYPESPLITLASTARG:
1760  case TYPEFACTARG:
1761  case TYPEARGTOEXTRASYMBOL:
1762  *w++ = cbuf[AC.cbufnum].numlhs+1;
1763  break;
1764  }
1765  *w++ = par;
1766  scale = w;
1767  *w++ = 1;
1768  *w++ = 0;
1769  if ( *s == '^' ) {
1770  s++; ParseSignedNumber(x,s)
1771  while ( *s == ',' ) s++;
1772  *scale = x;
1773  }
1774  if ( *s == '(' ) {
1775  t = s+1; SKIPBRA3(s) /* We did check the brackets already */
1776  if ( par == TYPEARG ) {
1777  MesPrint("&Illegal () entry in argument statement");
1778  error = 1; s++; goto skipbracks;
1779  }
1780  else if ( par == TYPESPLITFIRSTARG ) {
1781  MesPrint("&Illegal () entry in splitfirstarg statement");
1782  error = 1; s++; goto skipbracks;
1783  }
1784  else if ( par == TYPESPLITLASTARG ) {
1785  MesPrint("&Illegal () entry in splitlastarg statement");
1786  error = 1; s++; goto skipbracks;
1787  }
1788  v = t;
1789  while ( v < s ) {
1790  if ( *v == '?' ) {
1791  MesPrint("&Wildcarding not allowed in this type of statement");
1792  error = 1; break;
1793  }
1794  v++;
1795  }
1796  v = s++;
1797  if ( *t == '(' && v[-1] == ')' ) {
1798  t++; v--;
1799  if ( par == TYPESPLITARG ) oldworkpointer[0] = TYPESPLITARG2;
1800  else if ( par == TYPEFACTARG ) oldworkpointer[0] = TYPEFACTARG2;
1801  else if ( par == TYPENORM4 ) oldworkpointer[0] = TYPENORM4;
1802  else if ( par == TYPENORM ) {
1803  if ( *t == '-' ) { oldworkpointer[0] = TYPENORM3; t++; }
1804  else { oldworkpointer[0] = TYPENORM2; *scale = 0; }
1805  }
1806  }
1807  if ( error == 0 ) {
1808  CBUF *C = cbuf+AC.cbufnum;
1809  WORD oldnumrhs = C->numrhs, oldnumlhs = C->numlhs;
1810  WORD prototype[SUBEXPSIZE+40]; /* Up to 10 nested sums! */
1811  WORD *m, *mm;
1812  int i, retcode;
1813  LONG oldpointer = C->Pointer - C->Buffer;
1814  *v = 0;
1815  prototype[0] = SUBEXPRESSION;
1816  prototype[1] = SUBEXPSIZE;
1817  prototype[2] = C->numrhs+1;
1818  prototype[3] = 1;
1819  prototype[4] = AC.cbufnum;
1820  AT.WorkPointer += TYPEARGHEADSIZE+1;
1821  AddLHS(AC.cbufnum);
1822  if ( ( retcode = CompileAlgebra(t,LHSIDE,prototype) ) < 0 )
1823  error = 1;
1824  else {
1825  prototype[2] = retcode;
1826  ww = C->lhs[retcode];
1827  AC.lhdollarflag = 0;
1828  if ( *ww == 0 ) {
1829  *w++ = -2; *w++ = 0;
1830  }
1831  else if ( ww[ww[0]] != 0 ) {
1832  MesPrint("&There should be only one term between ()");
1833  error = 1;
1834  }
1835  else if ( NewSort(BHEAD0) ) { if ( !error ) error = 1; }
1836  else if ( NewSort(BHEAD0) ) {
1837  LowerSortLevel();
1838  if ( !error ) error = 1;
1839  }
1840  else {
1841  AN.RepPoint = AT.RepCount + 1;
1842  m = AT.WorkPointer;
1843  mm = ww; i = *mm;
1844  while ( --i >= 0 ) *m++ = *mm++;
1845  mm = AT.WorkPointer; AT.WorkPointer = m;
1846  AR.Cnumlhs = C->numlhs;
1847  if ( Generator(BHEAD mm,C->numlhs) ) {
1848  LowerSortLevel(); error = 1;
1849  }
1850  else if ( EndSort(BHEAD mm,0) < 0 ) {
1851  error = 1;
1852  AT.WorkPointer = mm;
1853  }
1854  else if ( *mm == 0 ) {
1855  *w++ = -2; *w++ = 0;
1856  AT.WorkPointer = mm;
1857  }
1858  else if ( mm[mm[0]] != 0 ) {
1859  error = 1;
1860  AT.WorkPointer = mm;
1861  }
1862  else {
1863  AT.WorkPointer = mm;
1864  m = mm+*mm;
1865  if ( par == TYPEFACTARG ) {
1866  if ( *mm != ABS(m[-1])+1 ) {
1867  *mm -= ABS(m[-1]); /* Strip coefficient */
1868  }
1869  mm[-1] = -*mm-1; w += *mm+1;
1870  }
1871  else {
1872  *mm -= ABS(m[-1]); /* Strip coefficient */
1873 /*
1874  if ( *mm == 1 ) { *w++ = -2; *w++ = 0; }
1875  else
1876 */
1877  { mm[-1] = -*mm-1; w += *mm+1; }
1878  }
1879  oldworkpointer[1] = w - oldworkpointer;
1880  }
1881  LowerSortLevel();
1882  }
1883  oldworkpointer[5] = AC.lhdollarflag;
1884  }
1885  *v = ')';
1886  C->numrhs = oldnumrhs;
1887  C->numlhs = oldnumlhs;
1888  C->Pointer = C->Buffer + oldpointer;
1889  }
1890  }
1891 skipbracks:
1892  if ( *s == 0 ) { *w++ = 0; *w++ = 2; *w++ = 1; }
1893  else {
1894  do {
1895  if ( *s == ',' ) { s++; continue; }
1896  ww = w; *w++ = 0; w++;
1897  if ( FG.cTable[*s] > 1 && *s != '[' && *s != '{' ) {
1898  MesPrint("&Illegal parameters in statement");
1899  error = 1;
1900  break;
1901  }
1902  while ( FG.cTable[*s] == 0 || *s == '[' || *s == '{' ) {
1903  if ( *s == '{' ) {
1904  name = s+1;
1905  SKIPBRA2(s)
1906  c = *s; *s = 0;
1907  number = DoTempSet(name,s);
1908  name--; *s++ = c; c = *s; *s = 0;
1909  goto doset;
1910  }
1911  else {
1912  name = s;
1913  if ( ( s = SkipAName(s) ) == 0 ) {
1914  MesPrint("&Illegal name '%s'",name);
1915  return(1);
1916  }
1917  c = *s; *s = 0;
1918  if ( ( type = GetName(AC.varnames,name,&number,WITHAUTO) ) == CSET ) {
1919 doset: if ( Sets[number].type != CFUNCTION ) goto nofun;
1920  *w++ = CSET; *w++ = number;
1921  }
1922  else if ( type == CFUNCTION ) {
1923  *w++ = CFUNCTION; *w++ = number + FUNCTION;
1924  }
1925  else {
1926 nofun: MesPrint("&%s is not a function or a set of functions"
1927  ,name);
1928  error = 1;
1929  }
1930  }
1931  *s = c;
1932  while ( *s == ',' ) s++;
1933  }
1934  ww[1] = w - ww;
1935  ww = w; w++; zeroflag = 0;
1936  while ( FG.cTable[*s] == 1 ) {
1937  ParseNumber(x,s)
1938  if ( *s && *s != ',' ) {
1939  MesPrint("&Illegal separator after number");
1940  error = 1;
1941  while ( *s && *s != ',' ) s++;
1942  }
1943  while ( *s == ',' ) s++;
1944  if ( x == 0 ) zeroflag = 1;
1945  if ( !zeroflag ) *w++ = (WORD)x;
1946  }
1947  *ww = w - ww;
1948  } while ( *s );
1949  }
1950  oldworkpointer[1] = w - oldworkpointer;
1951  if ( par == TYPEARG ) { /* To make sure. The Pointer might move in the future */
1952  AC.argstack[AC.arglevel-1] = cbuf[AC.cbufnum].Pointer
1953  - cbuf[AC.cbufnum].Buffer + 2;
1954  }
1955  AddNtoL(oldworkpointer[1],oldworkpointer);
1956  AT.WorkPointer = oldworkpointer;
1957  return(error);
1958 }
1959 
1960 /*
1961  #] DoArgument :
1962  #[ CoArgument :
1963 */
1964 
1965 int CoArgument(UBYTE *s) { return(DoArgument(s,TYPEARG)); }
1966 
1967 /*
1968  #] CoArgument :
1969  #[ CoEndArgument :
1970 */
1971 
1972 int CoEndArgument(UBYTE *s)
1973 {
1974  CBUF *C = cbuf+AC.cbufnum;
1975  while ( *s == ',' ) s++;
1976  if ( *s ) {
1977  MesPrint("&Illegal syntax for EndArgument statement");
1978  return(1);
1979  }
1980  if ( AC.arglevel <= 0 ) {
1981  MesPrint("&EndArgument without corresponding Argument statement");
1982  return(1);
1983  }
1984  AC.arglevel--;
1985  cbuf[AC.cbufnum].Buffer[AC.argstack[AC.arglevel]] = C->numlhs;
1986  if ( AC.argsumcheck[AC.arglevel] != NestingChecksum() ) {
1987  MesNesting();
1988  return(1);
1989  }
1990  return(0);
1991 }
1992 
1993 /*
1994  #] CoEndArgument :
1995  #[ CoInside :
1996 */
1997 
1998 int CoInside(UBYTE *s) { return(ExecInside(s)); }
1999 
2000 /*
2001  #] CoInside :
2002  #[ CoEndInside :
2003 */
2004 
2005 int CoEndInside(UBYTE *s)
2006 {
2007  CBUF *C = cbuf+AC.cbufnum;
2008  while ( *s == ',' ) s++;
2009  if ( *s ) {
2010  MesPrint("&Illegal syntax for EndInside statement");
2011  return(1);
2012  }
2013  if ( AC.insidelevel <= 0 ) {
2014  MesPrint("&EndInside without corresponding Inside statement");
2015  return(1);
2016  }
2017  AC.insidelevel--;
2018  cbuf[AC.cbufnum].Buffer[AC.insidestack[AC.insidelevel]] = C->numlhs;
2019  if ( AC.insidesumcheck[AC.insidelevel] != NestingChecksum() ) {
2020  MesNesting();
2021  return(1);
2022  }
2023  return(0);
2024 }
2025 
2026 /*
2027  #] CoEndInside :
2028  #[ CoNormalize :
2029 */
2030 
2031 int CoNormalize(UBYTE *s) { return(DoArgument(s,TYPENORM)); }
2032 
2033 /*
2034  #] CoNormalize :
2035  #[ CoMakeInteger :
2036 */
2037 
2038 int CoMakeInteger(UBYTE *s) { return(DoArgument(s,TYPENORM4)); }
2039 
2040 /*
2041  #] CoMakeInteger :
2042  #[ CoSplitArg :
2043 */
2044 
2045 int CoSplitArg(UBYTE *s) { return(DoArgument(s,TYPESPLITARG)); }
2046 
2047 /*
2048  #] CoSplitArg :
2049  #[ CoSplitFirstArg :
2050 */
2051 
2052 int CoSplitFirstArg(UBYTE *s) { return(DoArgument(s,TYPESPLITFIRSTARG)); }
2053 
2054 /*
2055  #] CoSplitFirstArg :
2056  #[ CoSplitLastArg :
2057 */
2058 
2059 int CoSplitLastArg(UBYTE *s) { return(DoArgument(s,TYPESPLITLASTARG)); }
2060 
2061 /*
2062  #] CoSplitLastArg :
2063  #[ CoFactArg :
2064 */
2065 
2066 int CoFactArg(UBYTE *s) {
2067  if ( ( AC.topolynomialflag & TOPOLYNOMIALFLAG ) != 0 ) {
2068  MesPrint("&ToPolynomial statement and FactArg statement are not allowed in the same module");
2069  return(1);
2070  }
2071  AC.topolynomialflag |= FACTARGFLAG;
2072  return(DoArgument(s,TYPEFACTARG));
2073 }
2074 
2075 /*
2076  #] CoFactArg :
2077  #[ DoSymmetrize :
2078 
2079  Syntax:
2080  Symmetrize Fun[:[number]] [Fields] -> par = 0;
2081  AntiSymmetrize Fun[:[number]] [Fields] -> par = 1;
2082  CycleSymmetrize Fun[:[number]] [Fields] -> par = 2;
2083  RCycleSymmetrize Fun[:[number]] [Fields]-> par = 3;
2084 */
2085 
2086 int DoSymmetrize(UBYTE *s, int par)
2087 {
2088  GETIDENTITY
2089  int extra = 0, error = 0, err, fix, x, groupsize, num, i;
2090  UBYTE *name, c;
2091  WORD funnum, *w, *ww, type;
2092  for(;;) {
2093  name = s;
2094  if ( ( s = SkipAName(s) ) == 0 ) {
2095  MesPrint("&Improper function name");
2096  return(1);
2097  }
2098  c = *s; *s = 0;
2099  if ( c != ',' || ( FG.cTable[s[1]] != 0 && s[1] != '[' ) ) break;
2100  if ( par <= 0 && StrICmp(name,(UBYTE *)"cyclic") == 0 ) extra = 2;
2101  else if ( par <= 0 && StrICmp(name,(UBYTE *)"rcyclic") == 0 ) extra = 6;
2102  else {
2103  MesPrint("&Illegal option: '%s'",name);
2104  error = 1;
2105  }
2106  *s++ = c;
2107  }
2108  if ( ( err = GetVar(name,&type,&funnum,CFUNCTION,WITHAUTO) ) == NAMENOTFOUND ) {
2109  MesPrint("&Undefined function: %s",name);
2110  AddFunction(name,0,0,0,0,0,-1,-1);
2111  *s++ = c;
2112  return(1);
2113  }
2114  funnum += FUNCTION;
2115  if ( err == -1 ) error = 1;
2116  *s = c;
2117  if ( *s == ':' ) {
2118  s++;
2119  if ( *s == ',' || *s == '(' || *s == 0 ) fix = -1;
2120  else if ( FG.cTable[*s] == 1 ) {
2121  ParseNumber(fix,s)
2122  if ( fix == 0 )
2123  Warning("Restriction to zero arguments removed");
2124  }
2125  else {
2126  MesPrint("&Illegal character after :");
2127  return(1);
2128  }
2129  }
2130  else fix = 0;
2131  w = AT.WorkPointer;
2132  *w++ = TYPEOPERATION;
2133  w++;
2134  *w++ = SYMMETRIZE;
2135  *w++ = par | extra;
2136  *w++ = funnum;
2137  *w++ = fix;
2138 /*
2139  And now the argument lists. We have either ,#,#,... or (#,#,..,#),(#,...
2140 */
2141  w += 2; ww = w; groupsize = -1;
2142  while ( *s == ',' ) s++;
2143  while ( *s ) {
2144  if ( *s == '(' ) {
2145  s++; num = 0;
2146  while ( *s && *s != ')' ) {
2147  if ( *s == ',' ) { s++; continue; }
2148  if ( FG.cTable[*s] != 1 ) goto illarg;
2149  ParseNumber(x,s)
2150  if ( x <= 0 || ( fix > 0 && x > fix ) ) goto illnum;
2151  num++;
2152  *w++ = x-1;
2153  }
2154  if ( *s == 0 ) {
2155  MesPrint("&Improper termination of statement");
2156  return(1);
2157  }
2158  if ( groupsize < 0 ) groupsize = num;
2159  else if ( groupsize != num ) goto group;
2160  s++;
2161  }
2162  else if ( FG.cTable[*s] == 1 ) {
2163  if ( groupsize < 0 ) groupsize = 1;
2164  else if ( groupsize != 1 ) {
2165 group: MesPrint("&All groups should have the same number of arguments");
2166  return(1);
2167  }
2168  ParseNumber(x,s)
2169  if ( x <= 0 || ( fix > 0 && x > fix ) ) {
2170 illnum: MesPrint("&Illegal argument number: %d",x);
2171  return(1);
2172  }
2173  *w++ = x-1;
2174  }
2175  else {
2176 illarg: MesPrint("&Illegal argument");
2177  return(1);
2178  }
2179  while ( *s == ',' ) s++;
2180  }
2181 /*
2182  Now the completion
2183 */
2184  if ( w == ww ) {
2185  ww[-1] = 1;
2186  ww[-2] = 0;
2187  if ( fix > 0 ) {
2188  for ( i = 0; i < fix; i++ ) *w++ = i;
2189  ww[-2] = fix; /* Bugfix 31-oct-2001. Reported by York Schroeder */
2190  }
2191  }
2192  else {
2193  ww[-1] = groupsize;
2194  ww[-2] = (w-ww)/groupsize;
2195  }
2196  AT.WorkPointer[1] = w - AT.WorkPointer;
2197  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
2198  return(error);
2199 }
2200 
2201 /*
2202  #] DoSymmetrize :
2203  #[ CoSymmetrize :
2204 */
2205 
2206 int CoSymmetrize(UBYTE *s) { return(DoSymmetrize(s,SYMMETRIC)); }
2207 
2208 /*
2209  #] CoSymmetrize :
2210  #[ CoAntiSymmetrize :
2211 */
2212 
2213 int CoAntiSymmetrize(UBYTE *s) { return(DoSymmetrize(s,ANTISYMMETRIC)); }
2214 
2215 /*
2216  #] CoAntiSymmetrize :
2217  #[ CoCycleSymmetrize :
2218 */
2219 
2220 int CoCycleSymmetrize(UBYTE *s) { return(DoSymmetrize(s,CYCLESYMMETRIC)); }
2221 
2222 /*
2223  #] CoCycleSymmetrize :
2224  #[ CoRCycleSymmetrize :
2225 */
2226 
2227 int CoRCycleSymmetrize(UBYTE *s) { return(DoSymmetrize(s,RCYCLESYMMETRIC)); }
2228 
2229 /*
2230  #] CoRCycleSymmetrize :
2231  #[ CoWrite :
2232 */
2233 
2234 int CoWrite(UBYTE *s)
2235 {
2236  GETIDENTITY
2237  UBYTE *option;
2238  KEYWORD *key;
2239  option = s;
2240  if ( ( ( s = SkipAName(s) ) == 0 ) || *s != 0 ) {
2241  MesPrint("&Proper use of write statement is: write option");
2242  return(1);
2243  }
2244  key = FindInKeyWord(option,writeoptions,sizeof(writeoptions)/sizeof(KEYWORD));
2245  if ( key == 0 ) {
2246  MesPrint("&Unrecognized option in write statement");
2247  return(1);
2248  }
2249  *((int *)(key->func)) = key->type;
2250  AR.SortType = AC.SortType;
2251  return(0);
2252 }
2253 
2254 /*
2255  #] CoWrite :
2256  #[ CoNWrite :
2257 */
2258 
2259 int CoNWrite(UBYTE *s)
2260 {
2261  GETIDENTITY
2262  UBYTE *option;
2263  KEYWORD *key;
2264  option = s;
2265  if ( ( ( s = SkipAName(s) ) == 0 ) || *s != 0 ) {
2266  MesPrint("&Proper use of nwrite statement is: nwrite option");
2267  return(1);
2268  }
2269  key = FindInKeyWord(option,writeoptions,sizeof(writeoptions)/sizeof(KEYWORD));
2270  if ( key == 0 ) {
2271  MesPrint("&Unrecognized option in nwrite statement");
2272  return(1);
2273  }
2274  *((int *)(key->func)) = key->flags;
2275  AR.SortType = AC.SortType;
2276  return(0);
2277 }
2278 
2279 /*
2280  #] CoNWrite :
2281  #[ CoRatio :
2282 */
2283 
2284 static WORD ratstring[6] = { TYPEOPERATION, 6, RATIO, 0, 0, 0 };
2285 
2286 int CoRatio(UBYTE *s)
2287 {
2288  UBYTE c, *t;
2289  int i, type, error = 0;
2290  WORD numsym, *rs;
2291  rs = ratstring+3;
2292  for ( i = 0; i < 3; i++ ) {
2293  if ( *s ) {
2294  t = s;
2295  s = SkipAName(s);
2296  c = *s; *s = 0;
2297  if ( ( ( type = GetName(AC.varnames,t,&numsym,WITHAUTO) ) != CSYMBOL )
2298  && type != CDUBIOUS ) {
2299  MesPrint("&%s is not a symbol",t);
2300  error = 4;
2301  if ( type < 0 ) numsym = AddSymbol(t,-MAXPOWER,MAXPOWER,0,0);
2302  }
2303  *s = c;
2304  if ( *s == ',' ) s++;
2305  }
2306  else {
2307  if ( error == 0 )
2308  MesPrint("&The ratio statement needs three symbols for its arguments");
2309  error++;
2310  numsym = 0;
2311  }
2312  *rs++ = numsym;
2313  }
2314  AddNtoL(6,ratstring);
2315  return(error);
2316 }
2317 
2318 /*
2319  #] CoRatio :
2320  #[ CoRedefine :
2321 
2322  We have a preprocessor variable and a (new) value for it.
2323  This value is inside a string that must be stored.
2324 */
2325 
2326 int CoRedefine(UBYTE *s)
2327 {
2328  UBYTE *name, c, *args = 0;
2329  int numprevar;
2330  WORD code[2];
2331  name = s;
2332  if ( FG.cTable[*s] || ( s = SkipAName(s) ) == 0 || s[-1] == '_' ) {
2333  MesPrint("&Illegal name for preprocessor variable in redefine statement");
2334  return(1);
2335  }
2336  c = *s; *s = 0;
2337  for ( numprevar = NumPre-1; numprevar >= 0; numprevar-- ) {
2338  if ( StrCmp(name,PreVar[numprevar].name) == 0 ) break;
2339  }
2340  if ( numprevar < 0 ) {
2341  MesPrint("&There is no preprocessor variable with the name `%s'",name);
2342  *s = c;
2343  return(1);
2344  }
2345  *s = c;
2346 /*
2347  The next code worries about arguments.
2348  It is a direct copy of the code in TheDefine in the preprocessor.
2349 */
2350  if ( *s == '(' ) { /* arguments. scan for correctness */
2351  s++; args = s;
2352  for (;;) {
2353  if ( chartype[*s] != 0 ) goto illarg;
2354  s++;
2355  while ( chartype[*s] <= 1 ) s++;
2356  while ( *s == ' ' || *s == '\t' ) s++;
2357  if ( *s == ')' ) break;
2358  if ( *s != ',' ) goto illargs;
2359  s++;
2360  while ( *s == ' ' || *s == '\t' ) s++;
2361  }
2362  *s++ = 0;
2363  while ( *s == ' ' || *s == '\t' ) s++;
2364  }
2365  while ( *s == ',' ) s++;
2366  if ( *s != '"' ) {
2367 encl: MesPrint("&Value for %s should be enclosed in double quotes"
2368  ,PreVar[numprevar].name);
2369  return(1);
2370  }
2371  s++; name = s; /* actually name points to the new string */
2372  while ( *s && *s != '"' ) { if ( *s == '\\' ) s++; s++; }
2373  if ( *s != '"' ) goto encl;
2374  *s = 0;
2375  code[0] = TYPEREDEFPRE; code[1] = numprevar;
2376 /*
2377  AddComString(2,code,name,0);
2378 */
2379  Add2ComStrings(2,code,name,args);
2380  *s = '"';
2381 #ifdef PARALLELCODE
2382 /*
2383  Now we prepare the input numbering system for pthreads.
2384  We need a list of preprocessor variables that are redefined in this
2385  module.
2386 */
2387  {
2388  int j;
2389  WORD *newpf;
2390  LONG *newin;
2391  for ( j = 0; j < AC.numpfirstnum; j++ ) {
2392  if ( numprevar == AC.pfirstnum[j] ) break;
2393  }
2394  if ( j >= AC.numpfirstnum ) { /* add to list */
2395  if ( j >= AC.sizepfirstnum ) {
2396  if ( AC.sizepfirstnum <= 0 ) { AC.sizepfirstnum = 10; }
2397  else { AC.sizepfirstnum = 2 * AC.sizepfirstnum; }
2398  newin = (LONG *)Malloc1(AC.sizepfirstnum*(sizeof(WORD)+sizeof(LONG)),"AC.pfirstnum");
2399  newpf = (WORD *)(newin+AC.sizepfirstnum);
2400  for ( j = 0; j < AC.numpfirstnum; j++ ) {
2401  newpf[j] = AC.pfirstnum[j];
2402  newin[j] = AC.inputnumbers[j];
2403  }
2404  if ( AC.inputnumbers ) M_free(AC.inputnumbers,"AC.pfirstnum");
2405  AC.inputnumbers = newin;
2406  AC.pfirstnum = newpf;
2407  }
2408  AC.pfirstnum[AC.numpfirstnum] = numprevar;
2409  AC.inputnumbers[AC.numpfirstnum] = -1;
2410  AC.numpfirstnum++;
2411  }
2412  }
2413 #endif
2414  return(0);
2415 illarg:;
2416  MesPrint("&Illegally formed name in argument of redefine statement");
2417  return(1);
2418 illargs:;
2419  MesPrint("&Illegally formed arguments in redefine statement");
2420  return(1);
2421 }
2422 
2423 /*
2424  #] CoRedefine :
2425  #[ CoRenumber :
2426 
2427  renumber or renumber,0 Only exchanges (n^2 until no improvement)
2428  renumber,1 All permutations (could be slow)
2429 */
2430 
2431 int CoRenumber(UBYTE *s)
2432 {
2433  int x;
2434  UBYTE *inp;
2435  while ( *s == ',' ) s++;
2436  inp = s;
2437  if ( *s == 0 ) { x = 0; }
2438  else ParseNumber(x,s)
2439  if ( *s == 0 && x >= 0 && x <= 1 ) {
2440  Add3Com(TYPERENUMBER,x);
2441  return(0);
2442  }
2443  MesPrint("&Illegal argument in Renumber statement: '%s'",inp);
2444  return(1);
2445 }
2446 
2447 /*
2448  #] CoRenumber :
2449  #[ CoSum :
2450 */
2451 
2452 int CoSum(UBYTE *s)
2453 {
2454  CBUF *C = cbuf+AC.cbufnum;
2455  UBYTE *ss = 0, c, *t;
2456  int error = 0, i = 0, type, x;
2457  WORD numindex,number;
2458  while ( *s ) {
2459  t = s;
2460  if ( *s == '$' ) {
2461  t++; s++; while ( FG.cTable[*s] < 2 ) s++;
2462  c = *s; *s = 0;
2463  if ( ( number = GetDollar(t) ) < 0 ) {
2464  MesPrint("&Undefined variable $%s",t);
2465  if ( !error ) error = 1;
2466  number = AddDollar(t,0,0,0);
2467  }
2468  numindex = -number;
2469  }
2470  else {
2471  if ( ( s = SkipAName(s) ) == 0 ) return(1);
2472  c = *s; *s = 0;
2473  if ( ( ( type = GetOName(AC.exprnames,t,&numindex,NOAUTO) ) != NAMENOTFOUND )
2474  || ( ( type = GetOName(AC.varnames,t,&numindex,WITHAUTO) ) != CINDEX ) ) {
2475  if ( type != NAMENOTFOUND ) error = NameConflict(type,t);
2476  else {
2477  MesPrint("&%s should have been declared as an index",t);
2478  error = 1;
2479  numindex = AddIndex(s,AC.lDefDim,AC.lDefDim4) + AM.OffsetIndex;
2480  }
2481  }
2482  }
2483  Add3Com(TYPESUM,numindex);
2484  i = 3; *s = c;
2485  if ( *s == 0 ) break;
2486  if ( *s != ',' ) {
2487  MesPrint("&Illegal separator between objects in sum statement.");
2488  return(1);
2489  }
2490  s++;
2491  if ( FG.cTable[*s] == 0 || *s == '[' || *s == '$' ) {
2492  while ( FG.cTable[*s] == 0 || *s == '[' || *s == '$' ) {
2493  if ( *s == '$' ) {
2494  s++;
2495  ss = t = s;
2496  while ( FG.cTable[*s] < 2 ) s++;
2497  c = *s; *s = 0;
2498  if ( ( number = GetDollar(t) ) < 0 ) {
2499  MesPrint("&Undefined variable $%s",t);
2500  if ( !error ) error = 1;
2501  number = AddDollar(t,0,0,0);
2502  }
2503  numindex = -number;
2504  }
2505  else {
2506  ss = t = s;
2507  if ( ( s = SkipAName(s) ) == 0 ) return(1);
2508  c = *s; *s = 0;
2509  if ( ( ( type = GetOName(AC.exprnames,t,&numindex,NOAUTO) ) != NAMENOTFOUND )
2510  || ( ( type = GetOName(AC.varnames,t,&numindex,WITHAUTO) ) != CINDEX ) ) {
2511  if ( type != NAMENOTFOUND ) error = NameConflict(type,t);
2512  else {
2513  MesPrint("&%s should have been declared as an index",t);
2514  error = 1;
2515  numindex = AddIndex(s,AC.lDefDim,AC.lDefDim4) + AM.OffsetIndex;
2516  }
2517  }
2518  }
2519  AddToCB(C,numindex)
2520  i++;
2521  C->Pointer[-i+1] = i;
2522  *s = c;
2523  if ( *s == 0 ) return(error);
2524  if ( *s != ',' ) {
2525  MesPrint("&Illegal separator between objects in sum statement.");
2526  return(1);
2527  }
2528  s++;
2529  }
2530  if ( FG.cTable[*s] == 1 ) {
2531  C->Pointer[-i+1]--; C->Pointer--; s = ss;
2532  }
2533  }
2534  else if ( FG.cTable[*s] == 1 ) {
2535  while ( FG.cTable[*s] == 1 ) {
2536  t = s;
2537  x = *s++ - '0';
2538  while( FG.cTable[*s] == 1 ) x = 10*x + *s++ - '0';
2539  if ( *s && *s != ',' ) {
2540  MesPrint("&%s is not a legal fixed index",t);
2541  return(1);
2542  }
2543  else if ( x >= AM.OffsetIndex ) {
2544  MesPrint("&%d is too large to be a fixed index",x);
2545  error = 1;
2546  }
2547  else {
2548  AddToCB(C,x)
2549  i++;
2550  C->Pointer[-i] = TYPESUMFIX;
2551  C->Pointer[-i+1] = i;
2552  }
2553  if ( *s == 0 ) break;
2554  s++;
2555  }
2556  }
2557  else {
2558  MesPrint("&Illegal object in sum statement");
2559  error = 1;
2560  }
2561  }
2562  return(error);
2563 }
2564 
2565 /*
2566  #] CoSum :
2567  #[ CoToTensor :
2568 */
2569 
2570 static WORD cttarray[7] = { TYPEOPERATION,7,TENVEC,0,0,1,0 };
2571 
2572 int CoToTensor(UBYTE *s)
2573 {
2574  UBYTE c, *t;
2575  int type, j, nargs, error = 0;
2576  WORD number, dol[2] = { 0, 0 };
2577  cttarray[1] = 6; /* length */
2578  cttarray[3] = 0; /* tensor */
2579  cttarray[4] = 0; /* vector */
2580  cttarray[5] = 1; /* option flags */
2581 /* cttarray[6] = 0; set veto */
2582 /*
2583  Count the number of the arguments. The validity of them is not checked here.
2584 */
2585  nargs = 0;
2586  t = s;
2587  for (;;) {
2588  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
2589  if ( *s == 0 ) break;
2590  if ( *s == '!' ) {
2591  s++;
2592  if ( *s == '{' ) {
2593  SKIPBRA2(s)
2594  s++;
2595  } else {
2596  if ( ( s = SkipAName(s) ) == 0 ) goto syntax_error;
2597  }
2598  } else {
2599  if ( ( s = SkipAName(s) ) == 0 ) goto syntax_error;
2600  }
2601  nargs++;
2602  }
2603  if ( nargs < 2 ) goto not_enough_arguments;
2604  s = t;
2605 /*
2606  Parse options, which are given as the arguments except the last two.
2607 */
2608  for ( j = 2; j < nargs; j++ ) {
2609  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
2610  if ( *s == '!' ) {
2611 /*
2612  Handle !set or !{vector,...}. Note: If two or more sets are
2613  specified, then only the last one is used.
2614 */
2615  s++;
2616  cttarray[1] = 7;
2617  cttarray[5] |= 8;
2618  if ( FG.cTable[*s] == 0 || *s == '[' || *s == '_' ) {
2619  t = s;
2620  if ( ( s = SkipAName(s) ) == 0 ) goto syntax_error;
2621  c = *s; *s = 0;
2622  type = GetName(AC.varnames,t,&number,WITHAUTO);
2623  if ( type == CVECTOR ) {
2624 /*
2625  As written in the manual, "!p" (without "{}") should work.
2626 */
2627  cttarray[6] = DoTempSet(t,s);
2628  *s = c;
2629  goto check_tempset;
2630  }
2631  else if ( type != CSET ) {
2632  MesPrint("&%s is not the name of a set or a vector",t);
2633  error = 1;
2634  }
2635  *s = c;
2636  cttarray[6] = number;
2637  }
2638  else if ( *s == '{' ) {
2639  t = ++s; SKIPBRA2(s) *s = 0;
2640  cttarray[6] = DoTempSet(t,s);
2641  *s++ = '}';
2642 check_tempset:
2643  if ( cttarray[6] < 0 ) {
2644  error = 1;
2645  }
2646  if ( AC.wildflag ) {
2647  MesPrint("&Improper use of wildcard(s) in set specification");
2648  error = 1;
2649  }
2650  }
2651  } else {
2652 /*
2653  Other options.
2654 */
2655  t = s;
2656  if ( ( s = SkipAName(s) ) == 0 ) goto syntax_error;
2657  c = *s; *s = 0;
2658  if ( StrICmp(t,(UBYTE *)"nosquare") == 0 ) cttarray[5] |= 2;
2659  else if ( StrICmp(t,(UBYTE *)"functions") == 0 ) cttarray[5] |= 4;
2660  else {
2661  MesPrint("&Unrecognized option in ToTensor statement: '%s'",t);
2662  *s = c;
2663  return(1);
2664  }
2665  *s = c;
2666  }
2667  }
2668 /*
2669  Now parse a vector and a tensor. The ordering doesn't matter.
2670 */
2671  for ( j = 0; j < 2; j++ ) {
2672  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
2673  t = s;
2674  if ( ( s = SkipAName(s) ) == 0 ) goto syntax_error;
2675  c = *s; *s = 0;
2676  if ( t[0] == '$' ) {
2677  dol[j] = GetDollar(t+1);
2678  if ( dol[j] < 0 ) dol[j] = AddDollar(t+1,DOLUNDEFINED,0,0);
2679  } else {
2680  type = GetName(AC.varnames,t,&number,WITHAUTO);
2681  if ( type == CVECTOR ) {
2682  cttarray[4] = number + AM.OffsetVector;
2683  }
2684  else if ( type == CFUNCTION && ( functions[number].spec > 0 ) ) {
2685  cttarray[3] = number + FUNCTION;
2686  }
2687  else {
2688  MesPrint("&%s is not a vector or a tensor",t);
2689  error = 1;
2690  }
2691  }
2692  *s = c;
2693  }
2694  if ( cttarray[3] == 0 || cttarray[4] == 0 ) {
2695  if ( dol[0] == 0 && dol[1] == 0 ) {
2696  goto not_enough_arguments;
2697  }
2698  else if ( cttarray[3] ) {
2699  if ( dol[1] ) cttarray[4] = dol[1];
2700  else if ( dol[0] ) { cttarray[4] = dol[0]; }
2701  else {
2702  goto not_enough_arguments;
2703  }
2704  }
2705  else if ( cttarray[4] ) {
2706  if ( dol[1] ) { cttarray[3] = -dol[1]; }
2707  else if ( dol[0] ) cttarray[3] = -dol[0];
2708  else {
2709  goto not_enough_arguments;
2710  }
2711  }
2712  else {
2713  if ( dol[0] == 0 || dol[1] == 0 ) {
2714  goto not_enough_arguments;
2715  }
2716  else {
2717  cttarray[3] = -dol[0]; cttarray[4] = dol[1];
2718  }
2719  }
2720  }
2721  AddNtoL(cttarray[1],cttarray);
2722  return(error);
2723 
2724 syntax_error:
2725  MesPrint("&Syntax error in ToTensor statement");
2726  return(1);
2727 
2728 not_enough_arguments:
2729  MesPrint("&ToTensor statement needs a vector and a tensor");
2730  return(1);
2731 }
2732 
2733 /*
2734  #] CoToTensor :
2735  #[ CoToVector :
2736 */
2737 
2738 static WORD ctvarray[6] = { TYPEOPERATION,6,TENVEC,0,0,0 };
2739 
2740 int CoToVector(UBYTE *s)
2741 {
2742  UBYTE *t, c;
2743  int j, type, error = 0;
2744  WORD number, dol[2];
2745  dol[0] = dol[1] = 0;
2746  ctvarray[3] = ctvarray[4] = ctvarray[5] = 0;
2747  for ( j = 0; j < 2; j++ ) {
2748  t = s;
2749  if ( ( s = SkipAName(s) ) == 0 ) {
2750 proper: MesPrint("&Arguments of ToVector statement should be a vector and a tensor");
2751  return(1);
2752  }
2753  c = *s; *s = 0;
2754  if ( *t == '$' ) {
2755  dol[j] = GetDollar(t+1);
2756  if ( dol[j] < 0 ) dol[j] = AddDollar(t+1,DOLUNDEFINED,0,0);
2757  }
2758  else if ( ( type = GetName(AC.varnames,t,&number,WITHAUTO) ) == CVECTOR )
2759  ctvarray[4] = number + AM.OffsetVector;
2760  else if ( type == CFUNCTION && ( functions[number].spec > 0 ) )
2761  ctvarray[3] = number+FUNCTION;
2762  else {
2763  MesPrint("&%s is not a vector or a tensor",t);
2764  error = 1;
2765  }
2766  *s = c; if ( *s && *s != ',' ) goto proper;
2767  if ( *s ) s++;
2768  }
2769  if ( *s != 0 ) goto proper;
2770  if ( ctvarray[3] == 0 || ctvarray[4] == 0 ) {
2771  if ( dol[0] == 0 && dol[1] == 0 ) {
2772  MesPrint("&ToVector statement needs a vector and a tensor");
2773  error = 1;
2774  }
2775  else if ( ctvarray[3] ) {
2776  if ( dol[1] ) ctvarray[4] = dol[1];
2777  else if ( dol[0] ) ctvarray[4] = dol[0];
2778  else {
2779  MesPrint("&ToVector statement needs a vector and a tensor");
2780  error = 1;
2781  }
2782  }
2783  else if ( ctvarray[4] ) {
2784  if ( dol[1] ) ctvarray[3] = -dol[1];
2785  else if ( dol[0] ) ctvarray[3] = -dol[0];
2786  else {
2787  MesPrint("&ToVector statement needs a vector and a tensor");
2788  error = 1;
2789  }
2790  }
2791  else {
2792  if ( dol[0] == 0 || dol[1] == 0 ) {
2793  MesPrint("&ToVector statement needs a vector and a tensor");
2794  error = 1;
2795  }
2796  else {
2797  ctvarray[3] = -dol[0]; ctvarray[4] = dol[1];
2798  }
2799  }
2800  }
2801  AddNtoL(6,ctvarray);
2802  return(error);
2803 }
2804 
2805 /*
2806  #] CoToVector :
2807  #[ CoTrace4 :
2808 */
2809 
2810 int CoTrace4(UBYTE *s)
2811 {
2812  int error = 0, type, option = CHISHOLM;
2813  UBYTE *t, c;
2814  WORD numindex, one = 1;
2815  KEYWORD *key;
2816  for (;;) {
2817  t = s;
2818  if ( FG.cTable[*s] == 1 ) break;
2819  if ( ( s = SkipAName(s) ) == 0 ) {
2820 proper: MesPrint("&Proper syntax for Trace4 is 'Trace4[,options],index;'");
2821  return(1);
2822  }
2823  if ( *s == 0 ) break;
2824  c = *s; *s = 0;
2825  if ( ( key = FindKeyWord(t,trace4options,
2826  sizeof(trace4options)/sizeof(KEYWORD)) ) == 0 ) break;
2827  else {
2828  option |= key->type;
2829  option &= ~key->flags;
2830  }
2831  if ( ( *s++ = c ) != ',' ) {
2832  MesPrint("&Illegal separator in Trace4 statement");
2833  return(1);
2834  }
2835  if ( *s == 0 ) goto proper;
2836  }
2837  s = t;
2838  if ( FG.cTable[*s] == 1 ) {
2839 retry:
2840  ParseNumber(numindex,s)
2841  if ( *s != 0 ) {
2842  MesPrint("&Last argument of Trace4 should be an index");
2843  return(1);
2844  }
2845  if ( numindex >= AM.OffsetIndex ) {
2846  MesPrint("&fixed index >= %d. Change value of OffsetIndex in setup file"
2847  ,AM.OffsetIndex);
2848  return(1);
2849  }
2850  }
2851  else if ( *s == '$' ) {
2852  if ( ( type = GetName(AC.dollarnames,s+1,&numindex,NOAUTO) ) == CDOLLAR )
2853  numindex = -numindex;
2854  else {
2855  MesPrint("&%s is undefined",s);
2856  numindex = AddDollar(s+1,DOLINDEX,&one,1);
2857  return(1);
2858  }
2859 tests: s = SkipAName(s);
2860  if ( *s != 0 ) {
2861  MesPrint("&Trace4 should have a single index or $variable for its argument");
2862  return(1);
2863  }
2864  }
2865  else if ( ( type = GetName(AC.varnames,s,&numindex,WITHAUTO) ) == CINDEX ) {
2866  numindex += AM.OffsetIndex;
2867  goto tests;
2868  }
2869  else if ( type != -1 ) {
2870  if ( type != CDUBIOUS ) {
2871  if ( ( FG.cTable[*s] != 0 ) && ( *s != '[' ) ) {
2872  if ( *s == '+' && FG.cTable[s[1]] == 1 ) { s++; goto retry; }
2873  goto proper;
2874  }
2875  NameConflict(type,s);
2876  type = MakeDubious(AC.varnames,s,&numindex);
2877  }
2878  return(1);
2879  }
2880  else {
2881  MesPrint("&%s is not an index",s);
2882  numindex = AddIndex(s,AC.lDefDim,AC.lDefDim4) + AM.OffsetIndex;
2883  return(1);
2884  }
2885  if ( error ) return(error);
2886  if ( ( option & CHISHOLM ) != 0 )
2887  Add4Com(TYPECHISHOLM,numindex,(option & ALSOREVERSE));
2888  Add5Com(TYPEOPERATION,TAKETRACE,4 + (option & NOTRICK),numindex);
2889  return(0);
2890 }
2891 
2892 /*
2893  #] CoTrace4 :
2894  #[ CoTraceN :
2895 */
2896 
2897 int CoTraceN(UBYTE *s)
2898 {
2899  WORD numindex, one = 1;
2900  int type;
2901  if ( FG.cTable[*s] == 1 ) {
2902 retry:
2903  ParseNumber(numindex,s)
2904  if ( *s != 0 ) {
2905 proper: MesPrint("&TraceN should have a single index for its argument");
2906  return(1);
2907  }
2908  if ( numindex >= AM.OffsetIndex ) {
2909  MesPrint("&fixed index >= %d. Change value of OffsetIndex in setup file"
2910  ,AM.OffsetIndex);
2911  return(1);
2912  }
2913  }
2914  else if ( *s == '$' ) {
2915  if ( ( type = GetName(AC.dollarnames,s+1,&numindex,NOAUTO) ) == CDOLLAR )
2916  numindex = -numindex;
2917  else {
2918  MesPrint("&%s is undefined",s);
2919  numindex = AddDollar(s+1,DOLINDEX,&one,1);
2920  return(1);
2921  }
2922 tests: s = SkipAName(s);
2923  if ( *s != 0 ) {
2924  MesPrint("&TraceN should have a single index or $variable for its argument");
2925  return(1);
2926  }
2927  }
2928  else if ( ( type = GetName(AC.varnames,s,&numindex,WITHAUTO) ) == CINDEX ) {
2929  numindex += AM.OffsetIndex;
2930  goto tests;
2931  }
2932  else if ( type != -1 ) {
2933  if ( type != CDUBIOUS ) {
2934  if ( ( FG.cTable[*s] != 0 ) && ( *s != '[' ) ) {
2935  if ( *s == '+' && FG.cTable[s[1]] == 1 ) { s++; goto retry; }
2936  goto proper;
2937  }
2938  NameConflict(type,s);
2939  type = MakeDubious(AC.varnames,s,&numindex);
2940  }
2941  return(1);
2942  }
2943  else {
2944  MesPrint("&%s is not an index",s);
2945  numindex = AddIndex(s,AC.lDefDim,AC.lDefDim4) + AM.OffsetIndex;
2946  return(1);
2947  }
2948  Add5Com(TYPEOPERATION,TAKETRACE,0,numindex);
2949  return(0);
2950 }
2951 
2952 /*
2953  #] CoTraceN :
2954  #[ CoChisholm :
2955 */
2956 
2957 int CoChisholm(UBYTE *s)
2958 {
2959  int error = 0, type, option = CHISHOLM;
2960  UBYTE *t, c;
2961  WORD numindex, one = 1;
2962  KEYWORD *key;
2963  for (;;) {
2964  t = s;
2965  if ( FG.cTable[*s] == 1 ) break;
2966  if ( ( s = SkipAName(s) ) == 0 ) {
2967 proper: MesPrint("&Proper syntax for Chisholm is 'Chisholm[,options],index;'");
2968  return(1);
2969  }
2970  if ( *s == 0 ) break;
2971  c = *s; *s = 0;
2972  if ( ( key = FindKeyWord(t,chisoptions,
2973  sizeof(chisoptions)/sizeof(KEYWORD)) ) == 0 ) break;
2974  else {
2975  option |= key->type;
2976  option &= ~key->flags;
2977  }
2978  if ( ( *s++ = c ) != ',' ) {
2979  MesPrint("&Illegal separator in Chisholm statement");
2980  return(1);
2981  }
2982  if ( *s == 0 ) goto proper;
2983  }
2984  s = t;
2985  if ( FG.cTable[*s] == 1 ) {
2986  ParseNumber(numindex,s)
2987  if ( *s != 0 ) {
2988  MesPrint("&Last argument of Chisholm should be an index");
2989  return(1);
2990  }
2991  if ( numindex >= AM.OffsetIndex ) {
2992  MesPrint("&fixed index >= %d. Change value of OffsetIndex in setup file"
2993  ,AM.OffsetIndex);
2994  return(1);
2995  }
2996  }
2997  else if ( *s == '$' ) {
2998  if ( ( type = GetName(AC.dollarnames,s+1,&numindex,NOAUTO) ) == CDOLLAR )
2999  numindex = -numindex;
3000  else {
3001  MesPrint("&%s is undefined",s);
3002  numindex = AddDollar(s+1,DOLINDEX,&one,1);
3003  return(1);
3004  }
3005 tests: s = SkipAName(s);
3006  if ( *s != 0 ) {
3007  MesPrint("&Chisholm should have a single index or $variable for its argument");
3008  return(1);
3009  }
3010  }
3011  else if ( ( type = GetName(AC.varnames,s,&numindex,WITHAUTO) ) == CINDEX ) {
3012  numindex += AM.OffsetIndex;
3013  goto tests;
3014  }
3015  else if ( type != -1 ) {
3016  if ( type != CDUBIOUS ) {
3017  NameConflict(type,s);
3018  type = MakeDubious(AC.varnames,s,&numindex);
3019  }
3020  return(1);
3021  }
3022  else {
3023  MesPrint("&%s is not an index",s);
3024  numindex = AddIndex(s,AC.lDefDim,AC.lDefDim4) + AM.OffsetIndex;
3025  return(1);
3026  }
3027  if ( error ) return(error);
3028  Add4Com(TYPECHISHOLM,numindex,(option & ALSOREVERSE));
3029  return(0);
3030 }
3031 
3032 /*
3033  #] CoChisholm :
3034  #[ DoChain :
3035 
3036  Syntax: Chainxx functionname;
3037 */
3038 
3039 int DoChain(UBYTE *s, int option)
3040 {
3041  WORD numfunc,type;
3042  if ( *s == '$' ) {
3043  if ( ( type = GetName(AC.dollarnames,s+1,&numfunc,NOAUTO) ) == CDOLLAR )
3044  numfunc = -numfunc;
3045  else {
3046  MesPrint("&%s is undefined",s);
3047  numfunc = AddDollar(s+1,DOLINDEX,&one,1);
3048  return(1);
3049  }
3050 tests: s = SkipAName(s);
3051  if ( *s != 0 ) {
3052  MesPrint("&ChainIn/ChainOut should have a single function or $variable for its argument");
3053  return(1);
3054  }
3055  }
3056  else if ( ( type = GetName(AC.varnames,s,&numfunc,WITHAUTO) ) == CFUNCTION ) {
3057  numfunc += FUNCTION;
3058  goto tests;
3059  }
3060  else if ( type != -1 ) {
3061  if ( type != CDUBIOUS ) {
3062  NameConflict(type,s);
3063  type = MakeDubious(AC.varnames,s,&numfunc);
3064  }
3065  return(1);
3066  }
3067  else {
3068  MesPrint("&%s is not a function",s);
3069  numfunc = AddFunction(s,0,0,0,0,0,-1,-1) + FUNCTION;
3070  return(1);
3071  }
3072  Add3Com(option,numfunc);
3073  return(0);
3074 }
3075 
3076 /*
3077  #] DoChain :
3078  #[ CoChainin :
3079 
3080  Syntax: Chainin functionname;
3081 */
3082 
3083 int CoChainin(UBYTE *s)
3084 {
3085  return(DoChain(s,TYPECHAININ));
3086 }
3087 
3088 /*
3089  #] CoChainin :
3090  #[ CoChainout :
3091 
3092  Syntax: Chainout functionname;
3093 */
3094 
3095 int CoChainout(UBYTE *s)
3096 {
3097  return(DoChain(s,TYPECHAINOUT));
3098 }
3099 
3100 /*
3101  #] CoChainout :
3102  #[ CoExit :
3103 */
3104 
3105 int CoExit(UBYTE *s)
3106 {
3107  UBYTE *name;
3108  WORD code = TYPEEXIT;
3109  while ( *s == ',' ) s++;
3110  if ( *s == 0 ) {
3111  Add3Com(TYPEEXIT,0);
3112  return(0);
3113  }
3114  name = s+1;
3115  s++;
3116  while ( *s ) { if ( *s == '\\' ) s++; s++; }
3117  if ( name[-1] != '"' || s[-1] != '"' ) {
3118  MesPrint("&Illegal syntax for exit statement");
3119  return(1);
3120  }
3121  s[-1] = 0;
3122  AddComString(1,&code,name,0);
3123  s[-1] = '"';
3124  return(0);
3125 }
3126 
3127 /*
3128  #] CoExit :
3129  #[ CoInParallel :
3130 */
3131 
3132 int CoInParallel(UBYTE *s)
3133 {
3134  return(DoInParallel(s,1));
3135 }
3136 
3137 /*
3138  #] CoInParallel :
3139  #[ CoNotInParallel :
3140 */
3141 
3142 int CoNotInParallel(UBYTE *s)
3143 {
3144  return(DoInParallel(s,0));
3145 }
3146 
3147 /*
3148  #] CoNotInParallel :
3149  #[ DoInParallel :
3150 
3151  InParallel;
3152  InParallel,names;
3153  NotInParallel;
3154  NotInParallel,names;
3155 */
3156 
3157 int DoInParallel(UBYTE *s, int par)
3158 {
3159 #ifdef PARALLELCODE
3160  EXPRESSIONS e;
3161  WORD i;
3162 #endif
3163  WORD number;
3164  UBYTE *t, c;
3165  int error = 0;
3166 #ifndef WITHPTHREADS
3167  DUMMYUSE(par);
3168 #endif
3169  if ( *s == 0 ) {
3170  AC.inparallelflag = par;
3171 #ifdef PARALLELCODE
3172  for ( i = NumExpressions-1; i >= 0; i-- ) {
3173  e = Expressions+i;
3174  if ( e->status == LOCALEXPRESSION || e->status == GLOBALEXPRESSION
3175  || e->status == UNHIDELEXPRESSION || e->status == UNHIDEGEXPRESSION
3176  ) {
3177  e->partodo = par;
3178  }
3179  }
3180 #endif
3181  }
3182  else {
3183  for(;;) { /* Look for a (comma separated) list of variables */
3184  while ( *s == ',' ) s++;
3185  if ( *s == 0 ) break;
3186  if ( *s == '[' || FG.cTable[*s] == 0 ) {
3187  t = s;
3188  if ( ( s = SkipAName(s) ) == 0 ) {
3189  MesPrint("&Improper name for an expression: '%s'",t);
3190  return(1);
3191  }
3192  c = *s; *s = 0;
3193  if ( GetName(AC.exprnames,t,&number,NOAUTO) == CEXPRESSION ) {
3194 #ifdef PARALLELCODE
3195  e = Expressions+number;
3196  if ( e->status == LOCALEXPRESSION || e->status == GLOBALEXPRESSION
3197  || e->status == UNHIDELEXPRESSION || e->status == UNHIDEGEXPRESSION
3198  ) {
3199  e->partodo = par;
3200  }
3201 #endif
3202  }
3203  else if ( GetName(AC.varnames,t,&number,NOAUTO) != NAMENOTFOUND ) {
3204  MesPrint("&%s is not an expression",t);
3205  error = 1;
3206  }
3207  *s = c;
3208  }
3209  else {
3210  MesPrint("&Illegal object in InExpression statement");
3211  error = 1;
3212  while ( *s && *s != ',' ) s++;
3213  if ( *s == 0 ) break;
3214  }
3215  }
3216 
3217  }
3218  return(error);
3219 }
3220 
3221 /*
3222  #] DoInParallel :
3223  #[ CoInExpression :
3224 */
3225 
3226 int CoInExpression(UBYTE *s)
3227 {
3228  GETIDENTITY
3229  UBYTE *t, c;
3230  WORD *w, number;
3231  int error = 0;
3232  w = AT.WorkPointer;
3233  if ( AC.inexprlevel >= MAXNEST ) {
3234  MesPrint("@Nesting of inexpression statements more than %d levels",(WORD)MAXNEST);
3235  return(-1);
3236  }
3237  AC.inexprsumcheck[AC.inexprlevel] = NestingChecksum();
3238  AC.inexprstack[AC.inexprlevel] = cbuf[AC.cbufnum].Pointer
3239  - cbuf[AC.cbufnum].Buffer + 2;
3240  AC.inexprlevel++;
3241  *w++ = TYPEINEXPRESSION;
3242  w++; w++;
3243  for(;;) { /* Look for a (comma separated) list of variables */
3244  while ( *s == ',' ) s++;
3245  if ( *s == 0 ) break;
3246  if ( *s == '[' || FG.cTable[*s] == 0 ) {
3247  t = s;
3248  if ( ( s = SkipAName(s) ) == 0 ) {
3249  MesPrint("&Improper name for an expression: '%s'",t);
3250  return(1);
3251  }
3252  c = *s; *s = 0;
3253  if ( GetName(AC.exprnames,t,&number,NOAUTO) == CEXPRESSION ) {
3254  *w++ = number;
3255  }
3256  else if ( GetName(AC.varnames,t,&number,NOAUTO) != NAMENOTFOUND ) {
3257  MesPrint("&%s is not an expression",t);
3258  error = 1;
3259  }
3260  *s = c;
3261  }
3262  else {
3263  MesPrint("&Illegal object in InExpression statement");
3264  error = 1;
3265  while ( *s && *s != ',' ) s++;
3266  if ( *s == 0 ) break;
3267  }
3268  }
3269  AT.WorkPointer[1] = w - AT.WorkPointer;
3270  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
3271  return(error);
3272 }
3273 
3274 /*
3275  #] CoInExpression :
3276  #[ CoEndInExpression :
3277 */
3278 
3279 int CoEndInExpression(UBYTE *s)
3280 {
3281  CBUF *C = cbuf+AC.cbufnum;
3282  while ( *s == ',' ) s++;
3283  if ( *s ) {
3284  MesPrint("&Illegal syntax for EndInExpression statement");
3285  return(1);
3286  }
3287  if ( AC.inexprlevel <= 0 ) {
3288  MesPrint("&EndInExpression without corresponding InExpression statement");
3289  return(1);
3290  }
3291  AC.inexprlevel--;
3292  cbuf[AC.cbufnum].Buffer[AC.inexprstack[AC.inexprlevel]] = C->numlhs;
3293  if ( AC.inexprsumcheck[AC.inexprlevel] != NestingChecksum() ) {
3294  MesNesting();
3295  return(1);
3296  }
3297  return(0);
3298 }
3299 
3300 /*
3301  #] CoEndInExpression :
3302  #[ CoSetExitFlag :
3303 */
3304 
3305 int CoSetExitFlag(UBYTE *s)
3306 {
3307  if ( *s ) {
3308  MesPrint("&Illegal syntax for the SetExitFlag statement");
3309  return(1);
3310  }
3311  Add2Com(TYPESETEXIT);
3312  return(0);
3313 }
3314 
3315 /*
3316  #] CoSetExitFlag :
3317  #[ CoTryReplace :
3318 */
3319 int CoTryReplace(UBYTE *p)
3320 {
3321  GETIDENTITY
3322  UBYTE *name, c;
3323  WORD *w, error = 0, i, which = -1, c1, minvec = 0;
3324  w = AT.WorkPointer;
3325  *w++ = TYPETRY;
3326  *w++ = 3;
3327  *w++ = 0;
3328  *w++ = REPLACEMENT;
3329  *w++ = FUNHEAD;
3330  FILLFUN(w)
3331 /*
3332  Now we have to read a function argument for the replace_ function.
3333  Current arguments that we allow involve only single arguments
3334  that do not expand further. No brackets!
3335 */
3336  while ( *p ) {
3337 /*
3338  No numbers yet
3339 */
3340  if ( *p == '-' && minvec == 0 && which == (CVECTOR+1) ) {
3341  minvec = 1; p++;
3342  }
3343  if ( *p == '[' || FG.cTable[*p] == 0 ) {
3344  name = p;
3345  if ( ( p = SkipAName(p) ) == 0 ) return(1);
3346  c = *p; *p = 0;
3347  i = GetName(AC.varnames,name,&c1,WITHAUTO);
3348  if ( which >= 0 && i >= 0 && i != CDUBIOUS && which != (i+1) ) {
3349  MesPrint("&Illegal combination of objects in TryReplace");
3350  error = 1;
3351  }
3352  else if ( minvec && i != CVECTOR && i != CDUBIOUS ) {
3353  MesPrint("&Currently a - sign can be used only with a vector in TryReplace");
3354  error = 1;
3355  }
3356  else switch ( i ) {
3357  case CSYMBOL: *w++ = -SYMBOL; *w++ = c1; break;
3358  case CVECTOR:
3359  if ( minvec ) *w++ = -MINVECTOR;
3360  else *w++ = -VECTOR;
3361  *w++ = c1 + AM.OffsetVector;
3362  minvec = 0;
3363  break;
3364  case CINDEX: *w++ = -INDEX; *w++ = c1 + AM.OffsetIndex;
3365  if ( c1 >= AM.WilInd && c == '?' ) { *p++ = c; c = *p; }
3366  break;
3367  case CFUNCTION: *w++ = -c1-FUNCTION; break;
3368  case CDUBIOUS: minvec = 0; error = 1; break;
3369  default:
3370  MesPrint("&Illegal object type in TryReplace: %s",name);
3371  error = 1;
3372  i = 0;
3373  break;
3374  }
3375  if ( which < 0 ) which = i+1;
3376  else which = -1;
3377  *p = c;
3378  if ( *p == ',' ) p++;
3379  continue;
3380  }
3381  else {
3382  MesPrint("&Illegal object in TryReplace");
3383  error = 1;
3384  while ( *p && *p != ',' ) {
3385  if ( *p == '(' ) SKIPBRA3(p)
3386  else if ( *p == '{' ) SKIPBRA2(p)
3387  else if ( *p == '[' ) SKIPBRA1(p)
3388  else p++;
3389  }
3390  }
3391  if ( *p == ',' ) p++;
3392  if ( which < 0 ) which = 0;
3393  else which = -1;
3394  }
3395  if ( which >= 0 ) {
3396  MesPrint("&Odd number of arguments in TryReplace");
3397  error = 1;
3398  }
3399  i = w - AT.WorkPointer;
3400  AT.WorkPointer[1] = i;
3401  AT.WorkPointer[2] = i - 3;
3402  AT.WorkPointer[4] = i - 3;
3403  AddNtoL((int)i,AT.WorkPointer);
3404  return(error);
3405 }
3406 
3407 /*
3408  #] CoTryReplace :
3409  #[ CoModulus :
3410 
3411  Old syntax: Modulus [-] number [:number]
3412  New syntax: Modulus [option(s)] number
3413  Options are: NoFunctions/CoefficientsOnly/AlsoFunctions
3414  PlusMin/Positive
3415  InverseTable
3416  PrintPowersOf(number)
3417  AlsoPowers/NoPowers
3418  AlsoDollars/NoDollars
3419  Notice: We change the defaults. This may cause problems to some.
3420 */
3421 
3422 int CoModulus(UBYTE *inp)
3423 {
3424 #ifdef OLDMODULUS
3425 /* #[ Old Syntax : */
3426  UBYTE *p, c;
3427  WORD sign = 1, Retval;
3428  while ( *inp == '-' || *inp == '+' ) {
3429  if ( *inp == '-' ) sign = -sign;
3430  inp++;
3431  }
3432  p = inp;
3433  if ( FG.cTable[*inp] != 1 ) {
3434  MesPrint("&Invalid value for modulus:%s",inp);
3435  if ( AC.modpowers ) M_free(AC.modpowers,"AC.modpowers");
3436  AC.modpowers = 0;
3437  return(1);
3438  }
3439  do { inp++; } while ( FG.cTable[*inp] == 1 );
3440  c = *inp; *inp = 0;
3441  Retval = GetLong(p,(UWORD *)AC.cmod,&AC.ncmod);
3442  if ( sign < 0 ) AC.ncmod = -AC.ncmod;
3443  *p = c;
3444  if ( c == 0 ) goto regular;
3445  else if ( c != ':' ) {
3446  MesPrint("&Illegal option for modulus %s",inp);
3447  if ( AC.modpowers ) M_free(AC.modpowers,"AC.modpowers");
3448  AC.modpowers = 0;
3449  return(1);
3450  }
3451  inp++;
3452  p = inp;
3453  while ( FG.cTable[*inp] == 1 ) inp++;
3454  if ( *inp ) {
3455  MesPrint("&Illegal character in option for modulus %s",inp);
3456  if ( AC.modpowers ) M_free(AC.modpowers,"AC.modpowers");
3457  AC.modpowers = 0;
3458  return(1);
3459  }
3460  if ( GetLong(p,(UWORD *)AC.powmod,&AC.npowmod) ) Retval = -1;
3461  if ( TakeModulus((UWORD *)AC.powmod,&AC.npowmod,AC.cmod,AC.ncmod,NOUNPACK) ) Retval = -1;
3462  if ( AC.npowmod == 0 ) {
3463  MesPrint("&Improper value for generator");
3464  Retval = -1;
3465  }
3466  if ( MakeModTable() ) Retval = -1;
3467  AC.DirtPow = 1;
3468 regular:
3469  AN.ncmod = AC.ncmod;
3470  if ( AC.halfmod ) {
3471  M_free(AC.halfmod,"halfmod");
3472  AC.halfmod = 0; AC.nhalfmod = 0;
3473  }
3474  if ( AC.modinverses ) {
3475  M_free(AC.halfmod,"modinverses");
3476  AC.modinverses = 0;
3477  }
3478  return(Retval);
3479 /* #] Old Syntax : */
3480 #else
3481  GETIDENTITY
3482  int Retval = 0, sign = 1;
3483  UBYTE *p, c;
3484  while ( *inp == ',' || *inp == ' ' || *inp == '\t' ) inp++;
3485  if ( *inp == 0 ) {
3486 SwitchOff:
3487  if ( AC.modpowers ) M_free(AC.modpowers,"AC.modpowers");
3488  AC.modpowers = 0;
3489  AN.ncmod = AC.ncmod = 0;
3490  if ( AC.halfmod ) M_free(AC.halfmod,"halfmod");
3491  AC.halfmod = 0; AC.nhalfmod = 0;
3492  if ( AC.modinverses ) M_free(AC.modinverses,"modinverses");
3493  AC.modinverses = 0;
3494  AC.modmode = 0;
3495  return(0);
3496  }
3497  AC.modmode = 0;
3498  if ( *inp == '-' ) {
3499  sign = -1;
3500  inp++;
3501  }
3502  else {
3503  while ( FG.cTable[*inp] == 0 ) {
3504  p = inp;
3505  while ( FG.cTable[*inp] == 0 ) inp++;
3506  c = *inp; *inp = 0;
3507  if ( StrICmp(p,(UBYTE *)"nofunctions") == 0 ) {
3508  AC.modmode &= ~ALSOFUNARGS;
3509  }
3510  else if ( StrICmp(p,(UBYTE *)"alsofunctions") == 0 ) {
3511  AC.modmode |= ALSOFUNARGS;
3512  }
3513  else if ( StrICmp(p,(UBYTE *)"coefficientsonly") == 0 ) {
3514  AC.modmode &= ~ALSOFUNARGS;
3515  AC.modmode &= ~ALSOPOWERS;
3516  sign = -1;
3517  }
3518  else if ( StrICmp(p,(UBYTE *)"plusmin") == 0 ) {
3519  AC.modmode |= POSNEG;
3520  }
3521  else if ( StrICmp(p,(UBYTE *)"positive") == 0 ) {
3522  AC.modmode &= ~POSNEG;
3523  }
3524  else if ( StrICmp(p,(UBYTE *)"inversetable") == 0 ) {
3525  AC.modmode |= INVERSETABLE;
3526  }
3527  else if ( StrICmp(p,(UBYTE *)"noinversetable") == 0 ) {
3528  AC.modmode &= ~INVERSETABLE;
3529  }
3530  else if ( StrICmp(p,(UBYTE *)"nodollars") == 0 ) {
3531  AC.modmode &= ~ALSODOLLARS;
3532  }
3533  else if ( StrICmp(p,(UBYTE *)"alsodollars") == 0 ) {
3534  AC.modmode |= ALSODOLLARS;
3535  }
3536  else if ( StrICmp(p,(UBYTE *)"printpowersof") == 0 ) {
3537  *inp = c;
3538  if ( *inp != '(' ) {
3539 badsyntax:
3540  MesPrint("&Bad syntax in argument of PrintPowersOf(number) in Modulus statement");
3541  return(1);
3542  }
3543  while ( *inp == ',' || *inp == ' ' || *inp == '\t' ) inp++;
3544  inp++; p = inp;
3545  if ( FG.cTable[*inp] != 1 ) goto badsyntax;
3546  do { inp++; } while ( FG.cTable[*inp] == 1 );
3547  c = *inp; *inp = 0;
3548  if ( GetLong(p,(UWORD *)AC.powmod,&AC.npowmod) ) Retval = -1;
3549  if ( TakeModulus((UWORD *)AC.powmod,&AC.npowmod,AC.cmod,AC.ncmod,NOUNPACK) ) Retval = -1;
3550  if ( AC.npowmod == 0 ) {
3551  MesPrint("&Improper value for generator");
3552  Retval = -1;
3553  }
3554  if ( MakeModTable() ) Retval = -1;
3555  AC.DirtPow = 1;
3556  *inp = c;
3557  while ( *inp == ',' || *inp == ' ' || *inp == '\t' ) inp++;
3558  if ( *inp != ')' ) goto badsyntax;
3559  inp++;
3560  c = *inp;
3561  }
3562  else if ( StrICmp(p,(UBYTE *)"alsopowers") == 0 ) {
3563  AC.modmode |= ALSOPOWERS;
3564  sign = 1;
3565  }
3566  else if ( StrICmp(p,(UBYTE *)"nopowers") == 0 ) {
3567  AC.modmode &= ~ALSOPOWERS;
3568  sign = -1;
3569  }
3570  else {
3571  MesPrint("&Unrecognized option %s in Modulus statement",inp);
3572  return(1);
3573  }
3574  *inp = c;
3575  while ( *inp == ',' || *inp == ' ' || *inp == '\t' ) inp++;
3576  if ( *inp == 0 ) {
3577  MesPrint("&Modulus statement with no value!!!");
3578  return(1);
3579  }
3580  }
3581  }
3582  p = inp;
3583  if ( FG.cTable[*inp] != 1 ) {
3584  MesPrint("&Invalid value for modulus:%s",inp);
3585  if ( AC.modpowers ) M_free(AC.modpowers,"AC.modpowers");
3586  AC.modpowers = 0;
3587  AN.ncmod = AC.ncmod = 0;
3588  if ( AC.halfmod ) M_free(AC.halfmod,"halfmod");
3589  AC.halfmod = 0; AC.nhalfmod = 0;
3590  if ( AC.modinverses ) M_free(AC.modinverses,"modinverses");
3591  AC.modinverses = 0;
3592  return(1);
3593  }
3594  do { inp++; } while ( FG.cTable[*inp] == 1 );
3595  c = *inp; *inp = 0;
3596  Retval = GetLong(p,(UWORD *)AC.cmod,&AC.ncmod);
3597  if ( Retval == 0 && AC.ncmod == 0 ) goto SwitchOff;
3598  if ( sign < 0 ) AC.ncmod = -AC.ncmod;
3599  AN.ncmod = AC.ncmod;
3600  if ( ( AC.modmode & INVERSETABLE ) != 0 ) MakeInverses();
3601  if ( AC.halfmod ) M_free(AC.halfmod,"halfmod");
3602  AC.halfmod = 0; AC.nhalfmod = 0;
3603  return(Retval);
3604 #endif
3605 }
3606 
3607 /*
3608  #] CoModulus :
3609  #[ CoRepeat :
3610 */
3611 
3612 int CoRepeat(UBYTE *inp)
3613 {
3614  int error = 0;
3615  AC.RepSumCheck[AC.RepLevel] = NestingChecksum();
3616  AC.RepLevel++;
3617  if ( AC.RepLevel > AM.RepMax ) {
3618  MesPrint("&Too many repeat levels. Maximum is %d",AM.RepMax);
3619  return(1);
3620  }
3621  Add3Com(TYPEREPEAT,-1) /* Means indefinite */
3622  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
3623  if ( *inp ) {
3624  error = CompileStatement(inp);
3625  if ( CoEndRepeat(inp) ) error = 1;
3626  }
3627  return(error);
3628 }
3629 
3630 /*
3631  #] CoRepeat :
3632  #[ CoEndRepeat :
3633 */
3634 
3635 int CoEndRepeat(UBYTE *inp)
3636 {
3637  CBUF *C = cbuf+AC.cbufnum;
3638  int level, error = 0, repeatlevel = 0;
3639  DUMMYUSE(inp);
3640  AC.RepLevel--;
3641  if ( AC.RepLevel < 0 ) {
3642  MesPrint("&EndRepeat without Repeat");
3643  AC.RepLevel = 0;
3644  return(1);
3645  }
3646  else if ( AC.RepSumCheck[AC.RepLevel] != NestingChecksum() ) {
3647  MesNesting();
3648  error = 1;
3649  }
3650  level = C->numlhs+1;
3651  while ( level > 0 ) {
3652  if ( C->lhs[--level][0] == TYPEREPEAT ) {
3653  if ( repeatlevel == 0 ) {
3654  Add3Com(TYPEENDREPEAT,level)
3655  return(error);
3656  }
3657  repeatlevel--;
3658  }
3659  else if ( C->lhs[level][0] == TYPEENDREPEAT ) repeatlevel++;
3660  }
3661  return(1);
3662 }
3663 
3664 /*
3665  #] CoEndRepeat :
3666  #[ DoBrackets :
3667 
3668  Reads in the bracket information.
3669  Storage is in the form of a regular term.
3670  No subterms and arguments are allowed.
3671 */
3672 
3673 int DoBrackets(UBYTE *inp, int par)
3674 {
3675  GETIDENTITY
3676  UBYTE *p, *pp, c;
3677  WORD *to, i, type, *w, error = 0;
3678  WORD c1,c2, *WorkSave;
3679  int biflag;
3680  p = inp;
3681  WorkSave = to = AT.WorkPointer;
3682  to++;
3683  if ( AT.BrackBuf == 0 ) {
3684  AR.MaxBracket = 100;
3685  AT.BrackBuf = (WORD *)Malloc1(sizeof(WORD)*(AR.MaxBracket+1),"bracket buffer");
3686  }
3687  *AT.BrackBuf = 0;
3688  AR.BracketOn = 0;
3689  AC.bracketindexflag = 0;
3690  AT.bracketindexflag = 0;
3691  if ( *p == '+' || *p == '-' ) p++;
3692  if ( p[-1] == ',' && *p ) p--;
3693  if ( p[-1] == '+' && *p ) { biflag = 1; if ( *p != ',' ) { *--p = ','; } }
3694  else if ( p[-1] == '-' && *p ) { biflag = -1; if ( *p != ',' ) { *--p = ','; } }
3695  else biflag = 0;
3696  while ( *p == ',' ) {
3697 redo: AR.BracketOn++;
3698  while ( *p == ',' ) p++;
3699  if ( *p == 0 ) break;
3700  if ( *p == '0' ) {
3701  p++; while ( *p == '0' ) p++;
3702  continue;
3703  }
3704  inp = pp = p;
3705  p = SkipAName(p);
3706  if ( p == 0 ) return(1);
3707  c = *p;
3708  *p = 0;
3709  type = GetName(AC.varnames,inp,&c1,WITHAUTO);
3710  if ( c == '.' ) {
3711  if ( type == CVECTOR || type == CDUBIOUS ) {
3712  *p++ = c;
3713  inp = p;
3714  p = SkipAName(p);
3715  if ( p == 0 ) return(1);
3716  c = *p;
3717  *p = 0;
3718  type = GetName(AC.varnames,inp,&c2,WITHAUTO);
3719  if ( type != CVECTOR && type != CDUBIOUS ) {
3720  MesPrint("&Not a vector in dotproduct in bracket statement: %s",inp);
3721  error = 1;
3722  }
3723  else type = CDOTPRODUCT;
3724  }
3725  else {
3726  MesPrint("&Illegal use of . after %s in bracket statement",inp);
3727  error = 1;
3728  *p++ = c;
3729  goto redo;
3730  }
3731  }
3732  switch ( type ) {
3733  case CSYMBOL :
3734  *to++ = SYMBOL; *to++ = 4; *to++ = c1; *to++ = 1; break;
3735  case CVECTOR :
3736  *to++ = INDEX; *to++ = 3; *to++ = AM.OffsetVector + c1; break;
3737  case CFUNCTION :
3738  *to++ = c1+FUNCTION; *to++ = FUNHEAD; *to++ = 0;
3739  FILLFUN3(to)
3740  break;
3741  case CDOTPRODUCT :
3742  *to++ = DOTPRODUCT; *to++ = 5; *to++ = c1 + AM.OffsetVector;
3743  *to++ = c2 + AM.OffsetVector; *to++ = 1; break;
3744  case CDELTA :
3745  *to++ = DELTA; *to++ = 4; *to++ = EMPTYINDEX; *to++ = EMPTYINDEX; break;
3746  case CSET :
3747  *to++ = SETSET; *to++ = 4; *to++ = c1; *to++ = Sets[c1].type; break;
3748  default :
3749  MesPrint("&Illegal bracket request for %s",pp);
3750  error = 1; break;
3751  }
3752  *p = c;
3753  }
3754  if ( *p ) {
3755  MesCerr("separator",p);
3756  AC.BracketNormalize = 0;
3757  AT.WorkPointer = WorkSave;
3758  error = 1;
3759  return(error);
3760  }
3761  *to++ = 1; *to++ = 1; *to++ = 3;
3762  *AT.WorkPointer = to - AT.WorkPointer;
3763  AT.WorkPointer = to;
3764  AC.BracketNormalize = 1;
3765  if ( BracketNormalize(BHEAD WorkSave) ) { error = 1; AR.BracketOn = 0; }
3766  else {
3767  w = WorkSave;
3768  if ( *w == 4 || !*w ) { AR.BracketOn = 0; }
3769  else {
3770  i = *(w+*w-1);
3771  if ( i < 0 ) i = -i;
3772  *w -= i;
3773  i = *w;
3774  if ( i > AR.MaxBracket ) {
3775  WORD *newbuf;
3776  newbuf = (WORD *)Malloc1(sizeof(WORD)*(i+1),"bracket buffer");
3777  AR.MaxBracket = i;
3778  if ( AT.BrackBuf != 0 ) M_free(AT.BrackBuf,"bracket buffer");
3779  AT.BrackBuf = newbuf;
3780  }
3781  to = AT.BrackBuf;
3782  NCOPY(to,w,i);
3783  }
3784  }
3785  AC.BracketNormalize = 0;
3786  if ( par == 1 ) AR.BracketOn = -AR.BracketOn;
3787  if ( error == 0 ) {
3788  AC.bracketindexflag = biflag;
3789  AT.bracketindexflag = biflag;
3790  }
3791  AT.WorkPointer = WorkSave;
3792  return(error);
3793 }
3794 
3795 /*
3796  #] DoBrackets :
3797  #[ CoBracket :
3798 */
3799 
3800 int CoBracket(UBYTE *inp)
3801 { return(DoBrackets(inp,0)); }
3802 
3803 /*
3804  #] CoBracket :
3805  #[ CoAntiBracket :
3806 */
3807 
3808 int CoAntiBracket(UBYTE *inp)
3809 { return(DoBrackets(inp,1)); }
3810 
3811 /*
3812  #] CoAntiBracket :
3813  #[ CoMultiBracket :
3814 
3815  Syntax:
3816  MultiBracket:{A|B} bracketinfo:...:{A|B} bracketinfo;
3817 */
3818 
3819 int CoMultiBracket(UBYTE *inp)
3820 {
3821  GETIDENTITY
3822  int i, error = 0, error1, type, num;
3823  UBYTE *s, c;
3824  WORD *to, *from;
3825 
3826  if ( *inp != ':' ) {
3827  MesPrint("&Illegal Multiple Bracket separator: %s",inp);
3828  return(1);
3829  }
3830  inp++;
3831  if ( AC.MultiBracketBuf == 0 ) {
3832  AC.MultiBracketBuf = (WORD **)Malloc1(sizeof(WORD *)*MAXMULTIBRACKETLEVELS,"multi bracket buffer");
3833  for ( i = 0; i < MAXMULTIBRACKETLEVELS; i++ ) {
3834  AC.MultiBracketBuf[i] = 0;
3835  }
3836  }
3837  else {
3838  for ( i = 0; i < MAXMULTIBRACKETLEVELS; i++ ) {
3839  if ( AC.MultiBracketBuf[i] ) {
3840  M_free(AC.MultiBracketBuf[i],"bracket buffer i");
3841  AC.MultiBracketBuf[i] = 0;
3842  }
3843  }
3844  AC.MultiBracketLevels = 0;
3845  }
3846  AC.MultiBracketLevels = 0;
3847 /*
3848  Start with disabling the regular brackets.
3849 */
3850  if ( AT.BrackBuf == 0 ) {
3851  AR.MaxBracket = 100;
3852  AT.BrackBuf = (WORD *)Malloc1(sizeof(WORD)*(AR.MaxBracket+1),"bracket buffer");
3853  }
3854  *AT.BrackBuf = 0;
3855  AR.BracketOn = 0;
3856  AC.bracketindexflag = 0;
3857  AT.bracketindexflag = 0;
3858 /*
3859  Now loop through the various levels, separated by the colons.
3860 */
3861  for ( i = 0; i < MAXMULTIBRACKETLEVELS; i++ ) {
3862  if ( *inp == 0 ) goto RegEnd;
3863 /*
3864  1: skip to ':', determine bracket or antibracket
3865 */
3866  s = inp;
3867  while ( *s && *s != ':' ) {
3868  if ( *s == '[' ) { SKIPBRA1(s) s++; }
3869  else if ( *s == '{' ) { SKIPBRA2(s) s++; }
3870  else s++;
3871  }
3872  c = *s; *s = 0;
3873  if ( StrICont(inp,(UBYTE *)"antibrackets") == 0 ) { type = 1; }
3874  else if ( StrICont(inp,(UBYTE *)"brackets") == 0 ) { type = 0; }
3875  else {
3876  MesPrint("&Illegal (anti)bracket specification in MultiBracket statement");
3877  if ( error == 0 ) error = 1;
3878  goto NextLevel;
3879  }
3880  while ( FG.cTable[*inp] == 0 ) inp++;
3881  if ( *inp != ',' ) {
3882  MesPrint("&Illegal separator after (anti)bracket specification in MultiBracket statement");
3883  if ( error == 0 ) error = 1;
3884  goto NextLevel;
3885  }
3886  inp++;
3887 /*
3888  2: call DoBrackets.
3889 */
3890  error1 = DoBrackets(inp, type);
3891  if ( error < 0 ) return(error1);
3892  if ( error1 > error ) error = error1;
3893 /*
3894  3: copy bracket information to the multi bracket arrays
3895 */
3896  if ( AR.BracketOn ) {
3897  num = AT.BrackBuf[0];
3898  to = AC.MultiBracketBuf[i] = (WORD *)Malloc1((num+2)*sizeof(WORD),"bracket buffer i");
3899  from = AT.BrackBuf;
3900  *to++ = AR.BracketOn;
3901  NCOPY(to,from,num);
3902  *to = 0;
3903  }
3904 /*
3905  4: set ready for the next level
3906 */
3907 NextLevel:
3908  *s = c; if ( c == ':' ) s++;
3909  inp = s;
3910  *AT.BrackBuf = 0;
3911  AR.BracketOn = 0;
3912  }
3913  if ( *inp != 0 ) {
3914  MesPrint("&More than %d levels in MultiBracket statement",(WORD)MAXMULTIBRACKETLEVELS);
3915  if ( error == 0 ) error = 1;
3916  }
3917 RegEnd:
3918  AC.MultiBracketLevels = i;
3919  *AT.BrackBuf = 0;
3920  AR.BracketOn = 0;
3921  AC.bracketindexflag = 0;
3922  AT.bracketindexflag = 0;
3923  return(error);
3924 }
3925 
3926 /*
3927  #] CoMultiBracket :
3928  #[ CountComp :
3929 
3930  This routine reads the count statement. The syntax is:
3931  count minimum,object,size[,object,size]
3932  Objects can be:
3933  symbol
3934  dotproduct
3935  vector
3936  function
3937  Vectors can have the auxiliary flags:
3938  +v +f +d +?setname
3939 
3940  Output for the compiler:
3941  TYPECOUNT,size,minimum,objects
3942  with the objects:
3943  SYMBOL,4,number,size
3944  DOTPRODUCT,5,v1,v2,size
3945  FUNCTION,4,number,size
3946  VECTOR,5,number,bits,size or VECTOR,6,number,bits,setnumber,size
3947 
3948  Currently only used in the if statement
3949 */
3950 
3951 WORD *CountComp(UBYTE *inp, WORD *to)
3952 {
3953  GETIDENTITY
3954  UBYTE *p, c;
3955  WORD *w, mini = 0, type, c1, c2;
3956  int error = 0;
3957  p = inp;
3958  w = to;
3959  AR.Eside = 2;
3960  *w++ = TYPECOUNT;
3961  *w++ = 0;
3962  *w++ = 0;
3963  while ( *p == ',' ) {
3964  p++; inp = p;
3965  if ( *p == '[' || FG.cTable[*p] == 0 ) {
3966  if ( ( p = SkipAName(inp) ) == 0 ) return(0);
3967  c = *p; *p = 0;
3968  type = GetName(AC.varnames,inp,&c1,WITHAUTO);
3969  if ( c == '.' ) {
3970  if ( type == CVECTOR || type == CDUBIOUS ) {
3971  *p++ = c;
3972  inp = p;
3973  p = SkipAName(p);
3974  if ( p == 0 ) return(0);
3975  c = *p;
3976  *p = 0;
3977  type = GetName(AC.varnames,inp,&c2,WITHAUTO);
3978  if ( type != CVECTOR && type != CDUBIOUS ) {
3979  MesPrint("&Not a vector in dotproduct in if statement: %s",inp);
3980  error = 1;
3981  }
3982  else type = CDOTPRODUCT;
3983  }
3984  else {
3985  MesPrint("&Illegal use of . after %s in if statement",inp);
3986  if ( type == NAMENOTFOUND )
3987  MesPrint("&%s is not a properly declared variable",inp);
3988  error = 1;
3989  *p++ = c;
3990  while ( *p && *p != ')' && *p != ',' ) p++;
3991  if ( *p == ',' && FG.cTable[p[1]] == 1 ) {
3992  p++;
3993  while ( *p && *p != ')' && *p != ',' ) p++;
3994  }
3995  continue;
3996  }
3997  }
3998  *p = c;
3999  switch ( type ) {
4000  case CSYMBOL:
4001  *w++ = SYMBOL; *w++ = 4; *w++ = c1;
4002 Sgetnum: if ( *p != ',' ) {
4003  MesCerr("sequence",p);
4004  while ( *p && *p != ')' && *p != ',' ) p++;
4005  error = 1;
4006  }
4007  p++; inp = p;
4008  ParseSignedNumber(mini,p)
4009  if ( FG.cTable[p[-1]] != 1 || ( *p && *p != ')' && *p != ',' ) ) {
4010  while ( *p && *p != ')' && *p != ',' ) p++;
4011  error = 1;
4012  c = *p; *p = 0;
4013  MesPrint("&Improper value in count: %s",inp);
4014  *p = c;
4015  while ( *p && *p != ')' && *p != ',' ) p++;
4016  }
4017  *w++ = mini;
4018  break;
4019  case CFUNCTION:
4020  *w++ = FUNCTION; *w++ = 4; *w++ = c1+FUNCTION; goto Sgetnum;
4021  case CDOTPRODUCT:
4022  *w++ = DOTPRODUCT; *w++ = 5;
4023  *w++ = c2 + AM.OffsetVector;
4024  *w++ = c1 + AM.OffsetVector;
4025  goto Sgetnum;
4026  case CVECTOR:
4027  *w++ = VECTOR; *w++ = 5;
4028  *w++ = c1 + AM.OffsetVector;
4029  if ( *p == ',' ) {
4030  *w++ = VECTBIT | DOTPBIT | FUNBIT;
4031  goto Sgetnum;
4032  }
4033  else if ( *p == '+' ) {
4034  p++;
4035  *w = 0;
4036  while ( *p && *p != ',' ) {
4037  if ( *p == 'v' || *p == 'V' ) {
4038  *w |= VECTBIT; p++;
4039  }
4040  else if ( *p == 'd' || *p == 'D' ) {
4041  *w |= DOTPBIT; p++;
4042  }
4043  else if ( *p == 'f' || *p == 'F'
4044  || *p == 't' || *p == 'T' ) {
4045  *w |= FUNBIT; p++;
4046  }
4047  else if ( *p == '?' ) {
4048  p++; inp = p;
4049  if ( *p == '{' ) { /* } */
4050  SKIPBRA2(p)
4051  if ( p == 0 ) return(0);
4052  if ( ( c1 = DoTempSet(inp+1,p) ) < 0 ) return(0);
4053  if ( Sets[c1].type != CFUNCTION ) {
4054  MesPrint("&set type conflict: Function expected");
4055  return(0);
4056  }
4057  type = CSET;
4058  c = *++p;
4059  }
4060  else {
4061  p = SkipAName(p);
4062  if ( p == 0 ) return(0);
4063  c = *p; *p = 0;
4064  type = GetName(AC.varnames,inp,&c1,WITHAUTO);
4065  }
4066  if ( type != CSET && type != CDUBIOUS ) {
4067  MesPrint("&%s is not a set",inp);
4068  error = 1;
4069  }
4070  w[-2] = 6;
4071  *w++ |= SETBIT;
4072  *w++ = c1;
4073  *p = c;
4074  goto Sgetnum;
4075  }
4076  else {
4077  MesCerr("specifier for vector",p);
4078  error = 1;
4079  }
4080  }
4081  w++;
4082  goto Sgetnum;
4083  }
4084  else {
4085  MesCerr("specifier for vector",p);
4086  while ( *p && *p != ')' && *p != ',' ) p++;
4087  error = 1;
4088  *w++ = VECTBIT | DOTPBIT | FUNBIT;
4089  goto Sgetnum;
4090  }
4091  case CDUBIOUS:
4092  goto skipfield;
4093  default:
4094  *p = 0;
4095  MesPrint("&%s is not a symbol, function, vector or dotproduct",inp);
4096  error = 1;
4097 skipfield: while ( *p && *p != ')' && *p != ',' ) p++;
4098  if ( *p && FG.cTable[p[1]] == 1 ) {
4099  p++;
4100  while ( *p && *p != ')' && *p != ',' ) p++;
4101  }
4102  break;
4103  }
4104  }
4105  else {
4106  MesCerr("name",p);
4107  while ( *p && *p != ',' ) p++;
4108  error = 1;
4109  }
4110  }
4111  to[1] = w-to;
4112  if ( *p == ')' ) p++;
4113  if ( *p ) { MesCerr("end of statement",p); return(0); }
4114  if ( error ) return(0);
4115  return(w);
4116 }
4117 
4118 /*
4119  #] CountComp :
4120  #[ CoIf :
4121 
4122  Reads the if statement: There must be a pair of parentheses.
4123  Much work is delegated to the routines in compi2 and CountComp.
4124  The goto is kept hanging as it is forward.
4125  The address in which the label must be written is pushed on
4126  the AC.IfStack.
4127 
4128  Here we allow statements of the type
4129  if ( condition ) single statement;
4130  compile the if statement.
4131  test character at end
4132  if not ; or )
4133  copy the statement after the proper parenthesis to the
4134  beginning of the AC.iBuffer.
4135  Have it compiled.
4136  generate an endif statement.
4137 */
4138 
4139 static UWORD *CIscratC = 0;
4140 
4141 int CoIf(UBYTE *inp)
4142 {
4143  GETIDENTITY
4144  int error = 0, level;
4145  WORD *w, *ww, *u, *s, *OldWork, *OldSpace = AT.WorkSpace;
4146  WORD gotexp = 0; /* Indicates whether there can be a condition */
4147  WORD lenpp, lenlev, ncoef, i, number;
4148  UBYTE *p, *pp, *ppp, c;
4149  CBUF *C = cbuf+AC.cbufnum;
4150  LONG x;
4151  if ( *inp == '(' && inp[1] == ',' ) inp += 2;
4152  else if ( *inp == '(' ) inp++; /* Usually we enter at the bracket */
4153 
4154  if ( CIscratC == 0 )
4155  CIscratC = (UWORD *)Malloc1((AM.MaxTal+2)*sizeof(UWORD),"CoIf");
4156  lenpp = 0;
4157  lenlev = 1;
4158  if ( AC.IfLevel >= AC.MaxIf ) DoubleIfBuffers();
4159  AC.IfCount[lenpp++] = 0;
4160 /*
4161  IfStack is used for organizing the 'go to' for the various if levels
4162 */
4163  *AC.IfStack++ = C->Pointer-C->Buffer+2;
4164 /*
4165  IfSumCheck is used to test for illegal nesting of if, argument or repeat.
4166 */
4167  AC.IfSumCheck[AC.IfLevel] = NestingChecksum();
4168  AC.IfLevel++;
4169  w = OldWork = AT.WorkPointer;
4170  *w++ = TYPEIF;
4171  w += 2;
4172  p = inp;
4173  for(;;) {
4174  inp = p;
4175  level = 0;
4176 ReDo:
4177  if ( FG.cTable[*p] == 1 ) { /* Number */
4178  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4179  u = w;
4180  *w++ = LONGNUMBER;
4181  w += 2;
4182  if ( GetLong(p,(UWORD *)w,&ncoef) ) { ncoef = 1; error = 1; }
4183  w[-1] = ncoef;
4184  while ( FG.cTable[*++p] == 1 );
4185  if ( *p == '/' ) {
4186  p++;
4187  if ( FG.cTable[*p] != 1 ) {
4188  MesCerr("sequence",p); error = 1; goto OnlyNum;
4189  }
4190  if ( GetLong(p,CIscratC,&ncoef) ) {
4191  ncoef = 1; error = 1;
4192  }
4193  while ( FG.cTable[*++p] == 1 );
4194  if ( ncoef == 0 ) {
4195  MesPrint("&Division by zero!");
4196  error = 1;
4197  }
4198  else {
4199  if ( w[-1] != 0 ) {
4200  if ( Simplify(BHEAD (UWORD *)w,(WORD *)(w-1),
4201  CIscratC,&ncoef) ) error = 1;
4202  else {
4203  i = w[-1];
4204  if ( i >= ncoef ) {
4205  i = w[-1];
4206  w += i;
4207  i -= ncoef;
4208  s = (WORD *)CIscratC;
4209  NCOPY(w,s,ncoef);
4210  while ( --i >= 0 ) *w++ = 0;
4211  }
4212  else {
4213  w += i;
4214  i = ncoef - i;
4215  while ( --i >= 0 ) *w++ = 0;
4216  s = (WORD *)CIscratC;
4217  NCOPY(w,s,ncoef);
4218  }
4219  }
4220  }
4221  }
4222  }
4223  else {
4224 OnlyNum:
4225  w += ncoef;
4226  if ( ncoef > 0 ) {
4227  ncoef--; *w++ = 1;
4228  while ( --ncoef >= 0 ) *w++ = 0;
4229  }
4230  }
4231  u[1] = WORDDIF(w,u);
4232  u[2] = (u[1] - 3)>>1;
4233  if ( level ) u[2] = -u[2];
4234  gotexp = 1;
4235  }
4236  else if ( *p == '+' ) { p++; goto ReDo; }
4237  else if ( *p == '-' ) { level ^= 1; p++; goto ReDo; }
4238  else if ( *p == 'c' || *p == 'C' ) { /* Count or Coefficient */
4239  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4240  while ( FG.cTable[*++p] == 0 );
4241  c = *p; *p = 0;
4242  if ( !StrICmp(inp,(UBYTE *)"count") ) {
4243  *p = c;
4244  if ( c != '(' ) {
4245  MesPrint("&no ( after count");
4246  error = 1;
4247  goto endofif;
4248  }
4249  inp = p;
4250  SKIPBRA4(p);
4251  c = *++p; *p = 0; *inp = ',';
4252  w = CountComp(inp,w);
4253  *p = c; *inp = '(';
4254  if ( w == 0 ) { error = 1; goto endofif; }
4255  gotexp = 1;
4256  }
4257  else if ( ConWord(inp,(UBYTE *)"coefficient") && ( p - inp ) > 3 ) {
4258  *w++ = COEFFI;
4259  *w++ = 2;
4260  *p = c;
4261  gotexp = 1;
4262  }
4263  else goto NoGood;
4264  inp = p;
4265  }
4266  else if ( *p == 'm' || *p == 'M' ) { /* match */
4267  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4268  while ( !FG.cTable[*++p] );
4269  c = *p; *p = 0;
4270  if ( !StrICmp(inp,(UBYTE *)"match") ) {
4271  *p = c;
4272  if ( c != '(' ) {
4273  MesPrint("&no ( after match");
4274  error = 1;
4275  goto endofif;
4276  }
4277  p++; inp = p;
4278  SKIPBRA4(p);
4279  *p = '=';
4280 /*
4281  Now we can call the reading of the lhs of an id statement.
4282  This has to be modified in the future.
4283 */
4284  AT.WorkSpace = AT.WorkPointer = w;
4285  ppp = inp;
4286  while ( FG.cTable[*ppp] == 0 && ppp < p ) ppp++;
4287  if ( *ppp == ',' ) AC.idoption = 0;
4288  else AC.idoption = SUBMULTI;
4289  level = CoIdExpression(inp,TYPEIF);
4290  AT.WorkSpace = OldSpace;
4291  AT.WorkPointer = OldWork;
4292  if ( level != 0 ) {
4293  if ( level < 0 ) { error = -1; goto endofif; }
4294  error = 1;
4295  }
4296 /*
4297  If we pop numlhs we are in good shape
4298 */
4299  s = u = C->lhs[C->numlhs];
4300  while ( u < C->Pointer ) *w++ = *u++;
4301  C->numlhs--; C->Pointer = s;
4302  *p++ = ')';
4303  inp = p;
4304  gotexp = 1;
4305  }
4306  else if ( !StrICmp(inp,(UBYTE *)"multipleof") ) {
4307  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4308  *p = c;
4309  if ( c != '(' ) {
4310  MesPrint("&no ( after multipleof");
4311  error = 1; goto endofif;
4312  }
4313  p++;
4314  if ( FG.cTable[*p] != 1 ) {
4315 Nomulof: MesPrint("&multipleof needs a short positive integer argument");
4316  error = 1; goto endofif;
4317  }
4318  ParseNumber(x,p)
4319  if ( *p != ')' || x <= 0 || x > MAXPOSITIVE ) goto Nomulof;
4320  p++;
4321  *w++ = MULTIPLEOF; *w++ = 3; *w++ = (WORD)x;
4322  inp = p;
4323  gotexp = 1;
4324  }
4325  else {
4326 NoGood: MesPrint("&Unrecognized word: %s",inp);
4327  *p = c;
4328  error = 1;
4329  level = 0;
4330  if ( c == '(' ) SKIPBRA4(p)
4331  inp = ++p;
4332  gotexp = 1;
4333  }
4334  }
4335  else if ( *p == 'f' || *p == 'F' ) { /* FindLoop */
4336  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4337  while ( FG.cTable[*++p] == 0 );
4338  c = *p; *p = 0;
4339  if ( !StrICmp(inp,(UBYTE *)"findloop") ) {
4340  *p = c;
4341  if ( c != '(' ) {
4342  MesPrint("&no ( after findloop");
4343  error = 1;
4344  goto endofif;
4345  }
4346  inp = p;
4347  SKIPBRA4(p);
4348  c = *++p; *p = 0; *inp = ',';
4349  if ( CoFindLoop(inp) ) goto endofif;
4350  s = u = C->lhs[C->numlhs];
4351  while ( u < C->Pointer ) *w++ = *u++;
4352  C->numlhs--; C->Pointer = s;
4353  *p = c; *inp = '(';
4354  if ( w == 0 ) { error = 1; goto endofif; }
4355  gotexp = 1;
4356  }
4357  else goto NoGood;
4358  inp = p;
4359  }
4360  else if ( *p == 'e' || *p == 'E' ) { /* Expression */
4361  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4362  while ( FG.cTable[*++p] == 0 );
4363  c = *p; *p = 0;
4364  if ( !StrICmp(inp,(UBYTE *)"expression") ) {
4365  *p = c;
4366  if ( c != '(' ) {
4367  MesPrint("&no ( after expression");
4368  error = 1;
4369  goto endofif;
4370  }
4371  p++; ww = w; *w++ = IFEXPRESSION; w++;
4372  while ( *p != ')' ) {
4373  if ( *p == ',' ) { p++; continue; }
4374  if ( *p == '[' || FG.cTable[*p] == 0 ) {
4375  pp = p;
4376  if ( ( p = SkipAName(p) ) == 0 ) {
4377  MesPrint("&Improper name for an expression: '%s'",pp);
4378  error = 1;
4379  goto endofif;
4380  }
4381  c = *p; *p = 0;
4382  if ( GetName(AC.exprnames,pp,&number,NOAUTO) == CEXPRESSION ) {
4383  *w++ = number;
4384  }
4385  else if ( GetName(AC.varnames,pp,&number,NOAUTO) != NAMENOTFOUND ) {
4386  MesPrint("&%s is not an expression",pp);
4387  error = 1;
4388  *w++ = number;
4389  }
4390  *p = c;
4391  }
4392  else {
4393  MesPrint("&Illegal object in Expression in if-statement");
4394  error = 1;
4395  while ( *p && *p != ',' && *p != ')' ) p++;
4396  if ( *p == 0 || *p == ')' ) break;
4397  }
4398  }
4399  ww[1] = w - ww;
4400  p++;
4401  gotexp = 1;
4402  }
4403  else goto NoGood;
4404  inp = p;
4405  }
4406  else if ( *p == 'i' || *p == 'I' ) { /* IsFactorized */
4407  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4408  while ( FG.cTable[*++p] == 0 );
4409  c = *p; *p = 0;
4410  if ( !StrICmp(inp,(UBYTE *)"isfactorized") ) {
4411  *p = c;
4412  if ( c != '(' ) { /* No expression means current expression */
4413  ww = w; *w++ = IFISFACTORIZED; w++;
4414  }
4415  else {
4416  p++; ww = w; *w++ = IFISFACTORIZED; w++;
4417  while ( *p != ')' ) {
4418  if ( *p == ',' ) { p++; continue; }
4419  if ( *p == '[' || FG.cTable[*p] == 0 ) {
4420  pp = p;
4421  if ( ( p = SkipAName(p) ) == 0 ) {
4422  MesPrint("&Improper name for an expression: '%s'",pp);
4423  error = 1;
4424  goto endofif;
4425  }
4426  c = *p; *p = 0;
4427  if ( GetName(AC.exprnames,pp,&number,NOAUTO) == CEXPRESSION ) {
4428  *w++ = number;
4429  }
4430  else if ( GetName(AC.varnames,pp,&number,NOAUTO) != NAMENOTFOUND ) {
4431  MesPrint("&%s is not an expression",pp);
4432  error = 1;
4433  *w++ = number;
4434  }
4435  *p = c;
4436  }
4437  else {
4438  MesPrint("&Illegal object in IsFactorized in if-statement");
4439  error = 1;
4440  while ( *p && *p != ',' && *p != ')' ) p++;
4441  if ( *p == 0 || *p == ')' ) break;
4442  }
4443  }
4444  p++;
4445  }
4446  ww[1] = w - ww;
4447  gotexp = 1;
4448  }
4449  else goto NoGood;
4450  inp = p;
4451  }
4452  else if ( *p == 'o' || *p == 'O' ) { /* Occurs */
4453 /*
4454  Tests whether variables occur inside a term.
4455  At the moment this is done one by one.
4456  If we want to do them in groups we should do the reading
4457  a bit different: each as a variable in a term, and then
4458  use Normalize to get the variables grouped and in order.
4459  That way FindVar (in if.c) can work more efficiently.
4460  Still to be done!!!
4461  TASK: Nice little task for someone to learn.
4462 */
4463  UBYTE cc;
4464  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4465  while ( FG.cTable[*++p] == 0 );
4466  c = cc = *p; *p = 0;
4467  if ( !StrICmp(inp,(UBYTE *)"occurs") ) {
4468  WORD c1, c2, type;
4469  *p = cc;
4470  if ( cc != '(' ) {
4471  MesPrint("&no ( after occurs");
4472  error = 1;
4473  goto endofif;
4474  }
4475  inp = p;
4476  SKIPBRA4(p);
4477  cc = *++p; *p = 0; *inp = ','; pp = p;
4478  ww = w;
4479  *w++ = IFOCCURS; *w++ = 0;
4480  while ( *inp ) {
4481  while ( *inp == ',' ) inp++;
4482  if ( *inp == 0 || *inp == ')' ) break;
4483 /*
4484  Now read a list of names
4485  We can have symbols, vectors, dotproducts, indices, functions.
4486  There could also be dummy indices and/or extra symbols.
4487 */
4488  if ( *inp == '[' || FG.cTable[*inp] == 0 ) {
4489  if ( ( p = SkipAName(inp) ) == 0 ) return(0);
4490  c = *p; *p = 0;
4491  type = GetName(AC.varnames,inp,&c1,WITHAUTO);
4492  if ( c == '.' ) {
4493  if ( type == CVECTOR || type == CDUBIOUS ) {
4494  *p++ = c;
4495  inp = p;
4496  p = SkipAName(p);
4497  if ( p == 0 ) return(0);
4498  c = *p;
4499  *p = 0;
4500  type = GetName(AC.varnames,inp,&c2,WITHAUTO);
4501  if ( type != CVECTOR && type != CDUBIOUS ) {
4502  MesPrint("&Not a vector in dotproduct in if statement: %s",inp);
4503  error = 1;
4504  }
4505  else type = CDOTPRODUCT;
4506  }
4507  else {
4508  MesPrint("&Illegal use of . after %s in if statement",inp);
4509  if ( type == NAMENOTFOUND )
4510  MesPrint("&%s is not a properly declared variable",inp);
4511  error = 1;
4512  *p++ = c;
4513  while ( *p && *p != ')' && *p != ',' ) p++;
4514  if ( *p == ',' && FG.cTable[p[1]] == 1 ) {
4515  p++;
4516  while ( *p && *p != ')' && *p != ',' ) p++;
4517  }
4518  continue;
4519  }
4520  }
4521  *p = c;
4522  switch ( type ) {
4523  case CSYMBOL: /* To worry about extra symbols */
4524  *w++ = SYMBOL;
4525  *w++ = c1;
4526  break;
4527  case CINDEX:
4528  *w++ = INDEX;
4529  *w++ = c1 + AM.OffsetIndex;
4530  break;
4531  case CVECTOR:
4532  *w++ = VECTOR;
4533  *w++ = c1 + AM.OffsetVector;
4534  break;
4535  case CDOTPRODUCT:
4536  *w++ = DOTPRODUCT;
4537  *w++ = c1 + AM.OffsetVector;
4538  *w++ = c2 + AM.OffsetVector;
4539  break;
4540  case CFUNCTION:
4541  *w++ = FUNCTION;
4542  *w++ = c1+FUNCTION;
4543  break;
4544  default:
4545  MesPrint("&Illegal variable %s in occurs condition in if statement",inp);
4546  error = 1;
4547  break;
4548  }
4549  inp = p;
4550  }
4551  else {
4552  MesPrint("&Illegal object %s in occurs condition in if statement",inp);
4553  error = 1;
4554  break;
4555  }
4556  }
4557  ww[1] = w-ww;
4558  p = pp; *p = cc; *inp = '(';
4559  gotexp = 1;
4560  if ( ww[1] <= 2 ) {
4561  MesPrint("&The occurs condition in the if statement needs arguments.");
4562  error = 1;
4563  }
4564  }
4565  else goto NoGood;
4566  inp = p;
4567  }
4568  else if ( *p == '$' ) {
4569  if ( gotexp == 1 ) { MesCerr("position for )",p); error = 1; }
4570  p++; inp = p;
4571  while ( FG.cTable[*p] == 0 || FG.cTable[*p] == 1 ) p++;
4572  c = *p; *p = 0;
4573  if ( ( i = GetDollar(inp) ) < 0 ) {
4574  MesPrint("&undefined dollar expression %s",inp);
4575  error = 1;
4576  i = AddDollar(inp,DOLUNDEFINED,0,0);
4577  }
4578  *p = c;
4579  *w++ = IFDOLLAR; *w++ = 3; *w++ = i;
4580 /*
4581  And then the IFDOLLAREXTRA pieces for [1] [$y] etc
4582 */
4583  if ( *p == '[' ) {
4584  p++;
4585  if ( ( w = GetIfDollarFactor(&p,w) ) == 0 ) {
4586  error = 1;
4587  goto endofif;
4588  }
4589  else if ( *p != ']' ) {
4590  error = 1;
4591  goto endofif;
4592  }
4593  p++;
4594  }
4595  inp = p;
4596  gotexp = 1;
4597  }
4598  else if ( *p == '(' ) {
4599  if ( gotexp ) {
4600  MesCerr("parenthesis",p);
4601  error = 1;
4602  goto endofif;
4603  }
4604  gotexp = 0;
4605  if ( ++lenlev >= AC.MaxIf ) DoubleIfBuffers();
4606  AC.IfCount[lenpp++] = w-OldWork;
4607  *w++ = SUBEXPR;
4608  w += 2;
4609  p++;
4610  }
4611  else if ( *p == ')' ) {
4612  if ( gotexp == 0 ) { MesCerr("position for )",p); error = 1; }
4613  gotexp = 1;
4614  u = AC.IfCount[--lenpp]+OldWork;
4615  lenlev--;
4616  u[1] = w - u;
4617  if ( lenlev <= 0 ) { /* End if condition */
4618  AT.WorkSpace = OldSpace;
4619  AT.WorkPointer = OldWork;
4620  AddNtoL(OldWork[1],OldWork);
4621  p++;
4622  if ( *p == ')' ) {
4623  MesPrint("&unmatched parenthesis in if/while ()");
4624  error = 1;
4625  while ( *++p == ')' );
4626  }
4627  if ( *p ) {
4628  level = CompileStatement(p);
4629  if ( level ) error = level;
4630  while ( *p ) p++;
4631  if ( CoEndIf(p) && error == 0 ) error = 1;
4632  }
4633  return(error);
4634  }
4635  p++;
4636  }
4637  else if ( *p == '>' ) {
4638  if ( gotexp == 0 ) goto NoExp;
4639  if ( p[1] == '=' ) { *w++ = GREATEREQUAL; *w++ = 2; p += 2; }
4640  else { *w++ = GREATER; *w++ = 2; p++; }
4641  gotexp = 0;
4642  }
4643  else if ( *p == '<' ) {
4644  if ( gotexp == 0 ) goto NoExp;
4645  if ( p[1] == '=' ) { *w++ = LESSEQUAL; *w++ = 2; p += 2; }
4646  else { *w++ = LESS; *w++ = 2; p++; }
4647  gotexp = 0;
4648  }
4649  else if ( *p == '=' ) {
4650  if ( gotexp == 0 ) goto NoExp;
4651  if ( p[1] == '=' ) p++;
4652  *w++ = EQUAL; *w++ = 2; p++;
4653  gotexp = 0;
4654  }
4655  else if ( *p == '!' && p[1] == '=' ) {
4656  if ( gotexp == 0 ) { p++; goto NoExp; }
4657  *w++ = NOTEQUAL; *w++ = 2; p += 2;
4658  gotexp = 0;
4659  }
4660  else if ( *p == '|' && p[1] == '|' ) {
4661  if ( gotexp == 0 ) { p++; goto NoExp; }
4662  *w++ = ORCOND; *w++ = 2; p += 2;
4663  gotexp = 0;
4664  }
4665  else if ( *p == '&' && p[1] == '&' ) {
4666  if ( gotexp == 0 ) {
4667  p++;
4668 NoExp: p++;
4669  MesCerr("sequence",p);
4670  error = 1;
4671  }
4672  else {
4673  *w++ = ANDCOND; *w++ = 2; p += 2;
4674  gotexp = 0;
4675  }
4676  }
4677  else if ( *p == 0 ) {
4678  MesPrint("&Unmatched parentheses");
4679  error = 1;
4680  goto endofif;
4681  }
4682  else {
4683  if ( FG.cTable[*p] == 0 ) {
4684  WORD ij;
4685  inp = p;
4686  while ( ( ij = FG.cTable[*++p] ) == 0 || ij == 1 );
4687  c = *p; *p = 0;
4688  goto NoGood;
4689  }
4690  MesCerr("sequence",p);
4691  error = 1;
4692  p++;
4693  }
4694  }
4695 endofif:;
4696  return(error);
4697 }
4698 
4699 /*
4700  #] CoIf :
4701  #[ CoElse :
4702 */
4703 
4704 int CoElse(UBYTE *p)
4705 {
4706  int error = 0;
4707  CBUF *C = cbuf+AC.cbufnum;
4708  if ( *p != 0 ) {
4709  while ( *p == ',' ) p++;
4710  if ( tolower(*p) == 'i' && tolower(p[1]) == 'f' && p[2] == '(' )
4711  return(CoElseIf(p+2));
4712  MesPrint("&No extra text allowed as part of an else statement");
4713  error = 1;
4714  }
4715  if ( AC.IfLevel <= 0 ) { MesPrint("&else statement without if"); return(1); }
4716  if ( AC.IfSumCheck[AC.IfLevel-1] != NestingChecksum() - 1 ) {
4717  MesNesting();
4718  error = 1;
4719  }
4720  Add3Com(TYPEELSE,AC.IfLevel)
4721  C->Buffer[AC.IfStack[-1]] = C->numlhs;
4722  AC.IfStack[-1] = C->Pointer - C->Buffer - 1;
4723  return(error);
4724 }
4725 
4726 /*
4727  #] CoElse :
4728  #[ CoElseIf :
4729 */
4730 
4731 int CoElseIf(UBYTE *inp)
4732 {
4733  CBUF *C = cbuf+AC.cbufnum;
4734  if ( AC.IfLevel <= 0 ) { MesPrint("&elseif statement without if"); return(1); }
4735  Add3Com(TYPEELSE,-AC.IfLevel)
4736  AC.IfLevel--;
4737  C->Buffer[*--AC.IfStack] = C->numlhs;
4738  return(CoIf(inp));
4739 }
4740 
4741 /*
4742  #] CoElseIf :
4743  #[ CoEndIf :
4744 
4745  It puts a RHS-level at the position indicated in the AC.IfStack.
4746  This corresponds to the label belonging to a forward goto.
4747  It is the goto that belongs either to the failing condition
4748  of the if (no else statement), or the completion of the
4749  success path (with else statement)
4750  The code is a jump to the next statement. It is there to prevent
4751  problems with
4752  if ( .. )
4753  if ( .. )
4754  endif;
4755  elseif ( .. )
4756 */
4757 
4758 int CoEndIf(UBYTE *inp)
4759 {
4760  CBUF *C = cbuf+AC.cbufnum;
4761  WORD i = C->numlhs, to, k = -AC.IfLevel;
4762  int error = 0;
4763  while ( *inp == ',' ) inp++;
4764  if ( *inp != 0 ) {
4765  error = 1;
4766  MesPrint("&No extra text allowed as part of an endif/elseif statement");
4767  }
4768  if ( AC.IfLevel <= 0 ) {
4769  MesPrint("&Endif statement without corresponding if"); return(1);
4770  }
4771  AC.IfLevel--;
4772  C->Buffer[*--AC.IfStack] = i+1;
4773  if ( AC.IfSumCheck[AC.IfLevel] != NestingChecksum() ) {
4774  MesNesting();
4775  error = 1;
4776  }
4777  Add3Com(TYPEENDIF,i+1)
4778 /*
4779  Now the search for the TYPEELSE in front of the elseif statements
4780 */
4781  to = C->numlhs;
4782  while ( i > 0 ) {
4783  if ( C->lhs[i][0] == TYPEELSE && C->lhs[i][2] == to ) to = i;
4784  if ( C->lhs[i][0] == TYPEIF ) {
4785  if ( C->lhs[i][2] == to ) {
4786  i--;
4787  if ( i <= 0 || C->lhs[i][0] != TYPEELSE
4788  || C->lhs[i][2] != k ) break;
4789  C->lhs[i][2] = C->numlhs;
4790  to = i;
4791  }
4792  }
4793  i--;
4794  }
4795  return(error);
4796 }
4797 
4798 /*
4799  #] CoEndIf :
4800  #[ CoWhile :
4801 */
4802 
4803 int CoWhile(UBYTE *inp)
4804 {
4805  CBUF *C = cbuf+AC.cbufnum;
4806  WORD startnum = C->numlhs + 1;
4807  int error;
4808  AC.WhileLevel++;
4809  error = CoIf(inp);
4810  if ( C->numlhs > startnum && C->lhs[startnum][2] == C->numlhs
4811  && C->lhs[C->numlhs][0] == TYPEENDIF ) {
4812  C->lhs[C->numlhs][2] = startnum-1;
4813  AC.WhileLevel--;
4814  }
4815  else C->lhs[startnum][2] = startnum;
4816  return(error);
4817 }
4818 
4819 /*
4820  #] CoWhile :
4821  #[ CoEndWhile :
4822 */
4823 
4824 int CoEndWhile(UBYTE *inp)
4825 {
4826  int error = 0;
4827  WORD i;
4828  CBUF *C = cbuf+AC.cbufnum;
4829  if ( AC.WhileLevel <= 0 ) {
4830  MesPrint("&EndWhile statement without corresponding While"); return(1);
4831  }
4832  AC.WhileLevel--;
4833  i = C->Buffer[AC.IfStack[-1]];
4834  error = CoEndIf(inp);
4835  C->lhs[C->numlhs][2] = i - 1;
4836  return(error);
4837 }
4838 
4839 /*
4840  #] CoEndWhile :
4841  #[ DoFindLoop :
4842 
4843  Function,arguments=number,loopsize=number,outfun=function,include=index;
4844 */
4845 
4846 static char *messfind[] = {
4847  "Findloop(function,arguments=#,loopsize(=#|<#)[,include=index])"
4848  ,"Replaceloop,function,arguments=#,loopsize(=#|<#),outfun=function[,include=index]"
4849  };
4850 static WORD comfindloop[7] = { TYPEFINDLOOP,7,0,0,0,0,0 };
4851 
4852 int DoFindLoop(UBYTE *inp, int mode)
4853 {
4854  UBYTE *s, c;
4855  WORD funnum, nargs = 0, nloop = 0, indexnum = 0, outfun = 0;
4856  int type, aflag, lflag, indflag, outflag, error = 0, sym;
4857  while ( *inp == ',' ) inp++;
4858  if ( ( s = SkipAName(inp) ) == 0 ) {
4859 syntax: MesPrint("&Proper syntax is:");
4860  MesPrint("%s",messfind[mode]);
4861  return(1);
4862  }
4863  c = *s; *s = 0;
4864  if ( ( ( type = GetName(AC.varnames,inp,&funnum,WITHAUTO) ) == NAMENOTFOUND )
4865  || type != CFUNCTION || ( ( sym = (functions[funnum].symmetric) & ~REVERSEORDER )
4866  != SYMMETRIC && sym != ANTISYMMETRIC ) ) {
4867  MesPrint("&%s should be a (anti)symmetric function or tensor",inp);
4868  }
4869  funnum += FUNCTION;
4870  *s = c; inp = s;
4871  aflag = lflag = indflag = outflag = 0;
4872  while ( *inp == ',' ) {
4873  while ( *inp == ',' ) inp++;
4874  s = inp;
4875  if ( ( s = SkipAName(inp) ) == 0 ) goto syntax;
4876  c = *s; *s = 0;
4877  if ( StrICont(inp,(UBYTE *)"arguments") == 0 ) {
4878  if ( c != '=' ) goto syntax;
4879  *s++ = c;
4880  NeedNumber(nargs,s,syntax)
4881  aflag++;
4882  inp = s;
4883  }
4884  else if ( StrICont(inp,(UBYTE *)"loopsize") == 0 ) {
4885  if ( c != '=' && c != '<' ) goto syntax;
4886  *s++ = c;
4887  if ( FG.cTable[*s] == 1 ) {
4888  NeedNumber(nloop,s,syntax)
4889  if ( nloop < 2 ) {
4890  MesPrint("&loopsize should be at least 2");
4891  error = 1;
4892  }
4893  if ( c == '<' ) nloop = -nloop;
4894  }
4895  else if ( tolower(*s) == 'a' && tolower(s[1]) == 'l'
4896  && tolower(s[2]) == 'l' && FG.cTable[s[3]] > 1 ) {
4897  nloop = -1; s += 3;
4898  if ( c != '=' ) goto syntax;
4899  }
4900  inp = s;
4901  lflag++;
4902  }
4903  else if ( StrICont(inp,(UBYTE *)"include") == 0 ) {
4904  if ( c != '=' ) goto syntax;
4905  *s++ = c;
4906  if ( ( inp = SkipAName(s) ) == 0 ) goto syntax;
4907  c = *inp; *inp = 0;
4908  if ( ( type = GetName(AC.varnames,s,&indexnum,WITHAUTO) ) != CINDEX ) {
4909  MesPrint("&%s is not a proper index",s);
4910  error = 1;
4911  }
4912  else if ( indexnum < WILDOFFSET
4913  && indices[indexnum].dimension == 0 ) {
4914  MesPrint("&%s should be a summable index",s);
4915  error = 1;
4916  }
4917  indexnum += AM.OffsetIndex;
4918  *inp = c;
4919  indflag++;
4920  }
4921  else if ( StrICont(inp,(UBYTE *)"outfun") == 0 ) {
4922  if ( c != '=' ) goto syntax;
4923  *s++ = c;
4924  if ( ( inp = SkipAName(s) ) == 0 ) goto syntax;
4925  c = *inp; *inp = 0;
4926  if ( ( type = GetName(AC.varnames,s,&outfun,WITHAUTO) ) != CFUNCTION ) {
4927  MesPrint("&%s is not a proper function or tensor",s);
4928  error = 1;
4929  }
4930  outfun += FUNCTION;
4931  outflag++;
4932  *inp = c;
4933  }
4934  else {
4935  MesPrint("&Unrecognized option in FindLoop or ReplaceLoop: %s",inp);
4936  *s = c; inp = s;
4937  while ( *inp && *inp != ',' ) inp++;
4938  }
4939  }
4940  if ( *inp != 0 && mode == REPLACELOOP ) goto syntax;
4941  if ( mode == FINDLOOP && outflag > 0 ) {
4942  MesPrint("&outflag option is illegal in FindLoop");
4943  error = 1;
4944  }
4945  if ( mode == REPLACELOOP && outflag == 0 ) goto syntax;
4946  if ( aflag == 0 || lflag == 0 ) goto syntax;
4947  comfindloop[3] = funnum;
4948  comfindloop[4] = nloop;
4949  comfindloop[5] = nargs;
4950  comfindloop[6] = outfun;
4951  comfindloop[1] = 7;
4952  if ( indflag ) {
4953  if ( mode == 0 ) comfindloop[2] = indexnum + 5;
4954  else comfindloop[2] = -indexnum - 5;
4955  }
4956  else comfindloop[2] = mode;
4957  AddNtoL(comfindloop[1],comfindloop);
4958  return(error);
4959 }
4960 
4961 /*
4962  #] DoFindLoop :
4963  #[ CoFindLoop :
4964 */
4965 
4966 int CoFindLoop(UBYTE *inp)
4967 { return(DoFindLoop(inp,FINDLOOP)); }
4968 
4969 /*
4970  #] CoFindLoop :
4971  #[ CoReplaceLoop :
4972 */
4973 
4974 int CoReplaceLoop(UBYTE *inp)
4975 { return(DoFindLoop(inp,REPLACELOOP)); }
4976 
4977 /*
4978  #] CoReplaceLoop :
4979  #[ CoFunPowers :
4980 */
4981 
4982 static UBYTE *FunPowOptions[] = {
4983  (UBYTE *)"nofunpowers"
4984  ,(UBYTE *)"commutingonly"
4985  ,(UBYTE *)"allfunpowers"
4986  };
4987 
4988 int CoFunPowers(UBYTE *inp)
4989 {
4990  UBYTE *option, c;
4991  int i, maxoptions = sizeof(FunPowOptions)/sizeof(UBYTE *);
4992  while ( *inp == ',' ) inp++;
4993  option = inp;
4994  inp = SkipAName(inp); c = *inp; *inp = 0;
4995  for ( i = 0; i < maxoptions; i++ ) {
4996  if ( StrICont(option,FunPowOptions[i]) == 0 ) {
4997  if ( c ) {
4998  *inp = c;
4999  MesPrint("&Illegal FunPowers statement");
5000  return(1);
5001  }
5002  AC.funpowers = i;
5003  return(0);
5004  }
5005  }
5006  MesPrint("&Illegal option in FunPowers statement: %s",option);
5007  return(1);
5008 }
5009 
5010 /*
5011  #] CoFunPowers :
5012  #[ CoUnitTrace :
5013 */
5014 
5015 int CoUnitTrace(UBYTE *s)
5016 {
5017  WORD num;
5018  if ( FG.cTable[*s] == 1 ) {
5019  ParseNumber(num,s)
5020  if ( *s != 0 ) {
5021 nogood: MesPrint("&Value of UnitTrace should be a (positive) number or a symbol");
5022  return(1);
5023  }
5024  AC.lUniTrace[0] = SNUMBER;
5025  AC.lUniTrace[2] = num;
5026  }
5027  else {
5028  if ( GetName(AC.varnames,s,&num,WITHAUTO) == CSYMBOL ) {
5029  AC.lUniTrace[0] = SYMBOL;
5030  AC.lUniTrace[2] = num;
5031  num = -num;
5032  }
5033  else goto nogood;
5034  s = SkipAName(s);
5035  if ( *s ) goto nogood;
5036  }
5037  AC.lUnitTrace = num;
5038  return(0);
5039 }
5040 
5041 /*
5042  #] CoUnitTrace :
5043  #[ CoTerm :
5044 
5045  Note: termstack holds the offset of the term statement in the compiler
5046  buffer. termsortstack holds the offset of the last sort statement
5047  (or the corresponding term statement)
5048 */
5049 
5050 int CoTerm(UBYTE *s)
5051 {
5052  GETIDENTITY
5053  WORD *w = AT.WorkPointer;
5054  int error = 0;
5055  while ( *s == ',' ) s++;
5056  if ( *s ) {
5057  MesPrint("&Illegal syntax for Term statement");
5058  return(1);
5059  }
5060  if ( AC.termlevel+1 >= AC.maxtermlevel ) {
5061  if ( AC.maxtermlevel <= 0 ) {
5062  AC.maxtermlevel = 20;
5063  AC.termstack = (LONG *)Malloc1(AC.maxtermlevel*sizeof(LONG),"termstack");
5064  AC.termsortstack = (LONG *)Malloc1(AC.maxtermlevel*sizeof(LONG),"termsortstack");
5065  AC.termsumcheck = (WORD *)Malloc1(AC.maxtermlevel*sizeof(WORD),"termsumcheck");
5066  }
5067  else {
5068  DoubleBuffer((void **)AC.termstack,(void **)AC.termstack+AC.maxtermlevel,
5069  sizeof(LONG),"doubling termstack");
5070  DoubleBuffer((void **)AC.termsortstack,
5071  (void **)AC.termsortstack+AC.maxtermlevel,
5072  sizeof(LONG),"doubling termsortstack");
5073  DoubleBuffer((void **)AC.termsumcheck,
5074  (void **)AC.termsumcheck+AC.maxtermlevel,
5075  sizeof(LONG),"doubling termsumcheck");
5076  AC.maxtermlevel *= 2;
5077  }
5078  }
5079  AC.termsumcheck[AC.termlevel] = NestingChecksum();
5080  AC.termstack[AC.termlevel] = cbuf[AC.cbufnum].Pointer
5081  - cbuf[AC.cbufnum].Buffer + 2;
5082  AC.termsortstack[AC.termlevel] = AC.termstack[AC.termlevel] + 1;
5083  AC.termlevel++;
5084  *w++ = TYPETERM;
5085  w++;
5086  *w++ = cbuf[AC.cbufnum].numlhs;
5087  *w++ = cbuf[AC.cbufnum].numlhs;
5088  AT.WorkPointer[1] = w - AT.WorkPointer;
5089  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
5090  return(error);
5091 }
5092 
5093 /*
5094  #] CoTerm :
5095  #[ CoEndTerm :
5096 */
5097 
5098 int CoEndTerm(UBYTE *s)
5099 {
5100  CBUF *C = cbuf+AC.cbufnum;
5101  while ( *s == ',' ) s++;
5102  if ( *s ) {
5103  MesPrint("&Illegal syntax for EndTerm statement");
5104  return(1);
5105  }
5106  if ( AC.termlevel <= 0 ) {
5107  MesPrint("&EndTerm without corresponding Argument statement");
5108  return(1);
5109  }
5110  AC.termlevel--;
5111  cbuf[AC.cbufnum].Buffer[AC.termstack[AC.termlevel]] = C->numlhs;
5112  cbuf[AC.cbufnum].Buffer[AC.termsortstack[AC.termlevel]] = C->numlhs;
5113  if ( AC.termsumcheck[AC.termlevel] != NestingChecksum() ) {
5114  MesNesting();
5115  return(1);
5116  }
5117  return(0);
5118 }
5119 
5120 /*
5121  #] CoEndTerm :
5122  #[ CoSort :
5123 */
5124 
5125 int CoSort(UBYTE *s)
5126 {
5127  GETIDENTITY
5128  WORD *w = AT.WorkPointer;
5129  int error = 0;
5130  while ( *s == ',' ) s++;
5131  if ( *s ) {
5132  MesPrint("&Illegal syntax for Sort statement");
5133  error = 1;
5134  }
5135  if ( AC.termlevel <= 0 ) {
5136  MesPrint("&The Sort statement can only be used inside a term environment");
5137  error = 1;
5138  }
5139  if ( error ) return(error);
5140  *w++ = TYPESORT;
5141  w++;
5142  w++;
5143  cbuf[AC.cbufnum].Buffer[AC.termsortstack[AC.termlevel-1]] =
5144  *w = cbuf[AC.cbufnum].numlhs+1;
5145  w++;
5146  AC.termsortstack[AC.termlevel-1] = cbuf[AC.cbufnum].Pointer
5147  - cbuf[AC.cbufnum].Buffer + 3;
5148  if ( AC.termsumcheck[AC.termlevel-1] != NestingChecksum() - 1 ) {
5149  MesNesting();
5150  return(1);
5151  }
5152  AT.WorkPointer[1] = w - AT.WorkPointer;
5153  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
5154  return(error);
5155 }
5156 
5157 /*
5158  #] CoSort :
5159  #[ CoPolyFun :
5160 
5161  Collect,functionname
5162 */
5163 
5164 int CoPolyFun(UBYTE *s)
5165 {
5166  GETIDENTITY
5167  WORD numfun;
5168  int type;
5169  UBYTE *t;
5170  AR.PolyFun = AC.lPolyFun = 0;
5171  AR.PolyFunInv = AC.lPolyFunInv = 0;
5172  AR.PolyFunType = AC.lPolyFunType = 0;
5173  AR.PolyFunExp = AC.lPolyFunExp = 0;
5174  AR.PolyFunVar = AC.lPolyFunVar = 0;
5175  AR.PolyFunPow = AC.lPolyFunPow = 0;
5176  if ( *s == 0 ) { return(0); }
5177  t = SkipAName(s);
5178  if ( t == 0 || *t != 0 ) {
5179  MesPrint("&PolyFun statement needs a single commuting function for its argument");
5180  return(1);
5181  }
5182  if ( ( ( type = GetName(AC.varnames,s,&numfun,WITHAUTO) ) != CFUNCTION )
5183  || ( functions[numfun].spec != 0 ) || ( functions[numfun].commute != 0 ) ) {
5184  MesPrint("&%s should be a regular commuting function",s);
5185  if ( type < 0 ) {
5186  if ( GetName(AC.exprnames,s,&numfun,NOAUTO) == NAMENOTFOUND )
5187  AddFunction(s,0,0,0,0,0,-1,-1);
5188  }
5189  return(1);
5190  }
5191  AR.PolyFun = AC.lPolyFun = numfun+FUNCTION;
5192  AR.PolyFunType = AC.lPolyFunType = 1;
5193  return(0);
5194 }
5195 
5196 /*
5197  #] CoPolyFun :
5198  #[ CoPolyRatFun :
5199 
5200  PolyRatFun [,functionname[,functionname](option)]
5201 */
5202 
5203 int CoPolyRatFun(UBYTE *s)
5204 {
5205  GETIDENTITY
5206  WORD numfun;
5207  int type;
5208  UBYTE *t, c;
5209  AR.PolyFun = AC.lPolyFun = 0;
5210  AR.PolyFunInv = AC.lPolyFunInv = 0;
5211  AR.PolyFunType = AC.lPolyFunType = 0;
5212  AR.PolyFunExp = AC.lPolyFunExp = 0;
5213  AR.PolyFunVar = AC.lPolyFunVar = 0;
5214  AR.PolyFunPow = AC.lPolyFunPow = 0;
5215  if ( *s == 0 ) return(0);
5216  t = SkipAName(s);
5217  if ( t == 0 ) goto NumErr;
5218  c = *t; *t = 0;
5219  if ( ( ( type = GetName(AC.varnames,s,&numfun,WITHAUTO) ) != CFUNCTION )
5220  || ( functions[numfun].spec != 0 ) || ( functions[numfun].commute != 0 ) ) {
5221  MesPrint("&%s should be a regular commuting function",s);
5222  if ( type < 0 ) {
5223  if ( GetName(AC.exprnames,s,&numfun,NOAUTO) == NAMENOTFOUND )
5224  AddFunction(s,0,0,0,0,0,-1,-1);
5225  }
5226  return(1);
5227  }
5228  AR.PolyFun = AC.lPolyFun = numfun+FUNCTION;
5229  AR.PolyFunInv = AC.lPolyFunInv = 0;
5230  AR.PolyFunType = AC.lPolyFunType = 2;
5231  AC.PolyRatFunChanged = 1;
5232  if ( c == 0 ) return(0);
5233  *t = c;
5234  if ( *t == '-' ) { AC.PolyRatFunChanged = 0; t++; }
5235  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5236  if ( *t == 0 ) return(0);
5237  if ( *t != '(' ) {
5238  s = t;
5239  t = SkipAName(s);
5240  if ( t == 0 ) goto NumErr;
5241  c = *t; *t = 0;
5242  if ( ( ( type = GetName(AC.varnames,s,&numfun,WITHAUTO) ) != CFUNCTION )
5243  || ( functions[numfun].spec != 0 ) || ( functions[numfun].commute != 0 ) ) {
5244  MesPrint("&%s should be a regular commuting function",s);
5245  if ( type < 0 ) {
5246  if ( GetName(AC.exprnames,s,&numfun,NOAUTO) == NAMENOTFOUND )
5247  AddFunction(s,0,0,0,0,0,-1,-1);
5248  }
5249  return(1);
5250  }
5251  AR.PolyFunInv = AC.lPolyFunInv = numfun+FUNCTION;
5252  if ( c == 0 ) return(0);
5253  *t = c;
5254  if ( *t == '-' ) { AC.PolyRatFunChanged = 0; t++; }
5255  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5256  if ( *t == 0 ) return(0);
5257  }
5258  if ( *t == '(' ) {
5259  t++;
5260  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5261 /*
5262  Next we need a keyword like
5263  (divergence,ep)
5264  (expand,ep,maxpow)
5265 */
5266  s = t;
5267  t = SkipAName(s);
5268  if ( t == 0 ) goto NumErr;
5269  c = *t; *t = 0;
5270  if ( ( StrICmp(s,(UBYTE *)"divergence") == 0 )
5271  || ( StrICmp(s,(UBYTE *)"finddivergence") == 0 ) ) {
5272  if ( c != ',' ) {
5273  MesPrint("&Illegal option field in PolyRatFun statement.");
5274  return(1);
5275  }
5276  *t = c;
5277  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5278  s = t;
5279  t = SkipAName(s);
5280  if ( t == 0 ) goto NumErr;
5281  c = *t; *t = 0;
5282  if ( ( type = GetName(AC.varnames,s,&AC.lPolyFunVar,WITHAUTO) ) != CSYMBOL ) {
5283  MesPrint("&Illegal symbol %s in option field in PolyRatFun statement.",s);
5284  return(1);
5285  }
5286  *t = c;
5287  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5288  if ( *t != ')' ) {
5289  MesPrint("&Illegal termination of option in PolyRatFun statement.");
5290  return(1);
5291  }
5292  AR.PolyFunExp = AC.lPolyFunExp = 1;
5293  AR.PolyFunVar = AC.lPolyFunVar;
5294  symbols[AC.lPolyFunVar].minpower = -MAXPOWER;
5295  symbols[AC.lPolyFunVar].maxpower = MAXPOWER;
5296  }
5297  else if ( StrICmp(s,(UBYTE *)"expand") == 0 ) {
5298  WORD x = 0, etype = 2;
5299  if ( c != ',' ) {
5300  MesPrint("&Illegal option field in PolyRatFun statement.");
5301  return(1);
5302  }
5303  *t = c;
5304  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5305  s = t;
5306  t = SkipAName(s);
5307  if ( t == 0 ) goto NumErr;
5308  c = *t; *t = 0;
5309  if ( ( type = GetName(AC.varnames,s,&AC.lPolyFunVar,WITHAUTO) ) != CSYMBOL ) {
5310  MesPrint("&Illegal symbol %s in option field in PolyRatFun statement.",s);
5311  return(1);
5312  }
5313  *t = c;
5314  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5315  if ( *t > '9' || *t < '0' ) {
5316  MesPrint("&Illegal option field in PolyRatFun statement.");
5317  return(1);
5318  }
5319  while ( *t <= '9' && *t >= '0' ) x = 10*x + *t++ - '0';
5320  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5321  if ( *t != ')' ) {
5322  s = t;
5323  t = SkipAName(s);
5324  if ( t == 0 ) goto ParErr;
5325  c = *t; *t = 0;
5326  if ( StrICmp(s,(UBYTE *)"fixed") == 0 ) {
5327  etype = 3;
5328  }
5329  else if ( StrICmp(s,(UBYTE *)"relative") == 0 ) {
5330  etype = 2;
5331  }
5332  else {
5333  MesPrint("&Illegal termination of option in PolyRatFun statement.");
5334  return(1);
5335  }
5336  *t = c;
5337  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5338  if ( *t != ')' ) {
5339  MesPrint("&Illegal termination of option in PolyRatFun statement.");
5340  return(1);
5341  }
5342  }
5343  AR.PolyFunExp = AC.lPolyFunExp = etype;
5344  AR.PolyFunVar = AC.lPolyFunVar;
5345  AR.PolyFunPow = AC.lPolyFunPow = x;
5346  symbols[AC.lPolyFunVar].minpower = -MAXPOWER;
5347  symbols[AC.lPolyFunVar].maxpower = MAXPOWER;
5348  }
5349  else {
5350 ParErr: MesPrint("&Illegal option %s in PolyRatFun statement.",s);
5351  return(1);
5352  }
5353  t++;
5354  while ( *t == ',' || *t == ' ' || *t == '\t' ) t++;
5355  if ( *t == 0 ) return(0);
5356  }
5357 NumErr:;
5358  MesPrint("&PolyRatFun statement needs one or two commuting function(s) for its argument(s)");
5359  return(1);
5360 }
5361 
5362 /*
5363  #] CoPolyRatFun :
5364  #[ CoMerge :
5365 */
5366 
5367 int CoMerge(UBYTE *inp)
5368 {
5369  UBYTE *s = inp;
5370  int type;
5371  WORD numfunc, option = 0;
5372  if ( tolower(s[0]) == 'o' && tolower(s[1]) == 'n' && tolower(s[2]) == 'c' &&
5373  tolower(s[3]) == 'e' && tolower(s[4]) == ',' ) {
5374  option = 1; s += 5;
5375  }
5376  else if ( tolower(s[0]) == 'a' && tolower(s[1]) == 'l' && tolower(s[2]) == 'l' &&
5377  tolower(s[3]) == ',' ) {
5378  option = 0; s += 4;
5379  }
5380  if ( *s == '$' ) {
5381  if ( ( type = GetName(AC.dollarnames,s+1,&numfunc,NOAUTO) ) == CDOLLAR )
5382  numfunc = -numfunc;
5383  else {
5384  MesPrint("&%s is undefined",s);
5385  numfunc = AddDollar(s+1,DOLINDEX,&one,1);
5386  return(1);
5387  }
5388 tests: s = SkipAName(s);
5389  if ( *s != 0 ) {
5390  MesPrint("&Merge/shuffle should have a single function or $variable for its argument");
5391  return(1);
5392  }
5393  }
5394  else if ( ( type = GetName(AC.varnames,s,&numfunc,WITHAUTO) ) == CFUNCTION ) {
5395  numfunc += FUNCTION;
5396  goto tests;
5397  }
5398  else if ( type != -1 ) {
5399  if ( type != CDUBIOUS ) {
5400  NameConflict(type,s);
5401  type = MakeDubious(AC.varnames,s,&numfunc);
5402  }
5403  return(1);
5404  }
5405  else {
5406  MesPrint("&%s is not a function",s);
5407  numfunc = AddFunction(s,0,0,0,0,0,-1,-1) + FUNCTION;
5408  return(1);
5409  }
5410  Add4Com(TYPEMERGE,numfunc,option);
5411  return(0);
5412 }
5413 
5414 /*
5415  #] CoMerge :
5416  #[ CoStuffle :
5417 
5418  Important for future options: The bit, given by 256 (bit 8) is reserved
5419  internally for keeping track of the sign in the number of Stuffle
5420  additions.
5421 */
5422 
5423 int CoStuffle(UBYTE *inp)
5424 {
5425  UBYTE *s = inp, *ss, c;
5426  int type;
5427  WORD numfunc, option = 0;
5428  if ( tolower(s[0]) == 'o' && tolower(s[1]) == 'n' && tolower(s[2]) == 'c' &&
5429  tolower(s[3]) == 'e' && tolower(s[4]) == ',' ) {
5430  option = 1; s += 5;
5431  }
5432  else if ( tolower(s[0]) == 'a' && tolower(s[1]) == 'l' && tolower(s[2]) == 'l' &&
5433  tolower(s[3]) == ',' ) {
5434  option = 0; s += 4;
5435  }
5436  ss = SkipAName(s);
5437  c = *ss; *ss = 0;
5438  if ( *s == '$' ) {
5439  if ( ( type = GetName(AC.dollarnames,s+1,&numfunc,NOAUTO) ) == CDOLLAR )
5440  numfunc = -numfunc;
5441  else {
5442  MesPrint("&%s is undefined",s);
5443  numfunc = AddDollar(s+1,DOLINDEX,&one,1);
5444  return(1);
5445  }
5446 tests: *ss = c;
5447  if ( *ss != '+' && *ss != '-' && ss[1] != 0 ) {
5448  MesPrint("&Stuffle should have a single function or $variable for its argument, followed by either + or -");
5449  return(1);
5450  }
5451  if ( *ss == '-' ) option += 2;
5452  }
5453  else if ( ( type = GetName(AC.varnames,s,&numfunc,WITHAUTO) ) == CFUNCTION ) {
5454  numfunc += FUNCTION;
5455  goto tests;
5456  }
5457  else if ( type != -1 ) {
5458  if ( type != CDUBIOUS ) {
5459  NameConflict(type,s);
5460  type = MakeDubious(AC.varnames,s,&numfunc);
5461  }
5462  return(1);
5463  }
5464  else {
5465  MesPrint("&%s is not a function",s);
5466  numfunc = AddFunction(s,0,0,0,0,0,-1,-1) + FUNCTION;
5467  return(1);
5468  }
5469  Add4Com(TYPESTUFFLE,numfunc,option);
5470  return(0);
5471 }
5472 
5473 /*
5474  #] CoStuffle :
5475  #[ CoProcessBucket :
5476 */
5477 
5478 int CoProcessBucket(UBYTE *s)
5479 {
5480  LONG x;
5481  while ( *s == ',' || *s == '=' ) s++;
5482  ParseNumber(x,s)
5483  if ( *s && *s != ' ' && *s != '\t' ) {
5484  MesPrint("&Numerical value expected for ProcessBucketSize");
5485  return(1);
5486  }
5487  AC.ProcessBucketSize = x;
5488  return(0);
5489 }
5490 
5491 /*
5492  #] CoProcessBucket :
5493  #[ CoThreadBucket :
5494 */
5495 
5496 int CoThreadBucket(UBYTE *s)
5497 {
5498  LONG x;
5499  while ( *s == ',' || *s == '=' ) s++;
5500  ParseNumber(x,s)
5501  if ( *s && *s != ' ' && *s != '\t' ) {
5502  MesPrint("&Numerical value expected for ThreadBucketSize");
5503  return(1);
5504  }
5505  if ( x <= 0 ) {
5506  Warning("Negative of zero value not allowed for ThreadBucketSize. Adjusted to 1.");
5507  x = 1;
5508  }
5509  AC.ThreadBucketSize = x;
5510 #ifdef WITHPTHREADS
5511  if ( AS.MultiThreaded ) MakeThreadBuckets(-1,1);
5512 #endif
5513  return(0);
5514 }
5515 
5516 /*
5517  #] CoThreadBucket :
5518  #[ DoArgPlode :
5519 
5520  Syntax: a list of functions.
5521  If the functions have an argument it must be a function.
5522  In the case f(g) we treat f(g(...)) with g any argument.
5523  (not yet implemented)
5524 */
5525 
5526 int DoArgPlode(UBYTE *s, int par)
5527 {
5528  GETIDENTITY
5529  WORD numfunc, type, error = 0, *w, n;
5530  UBYTE *t,c;
5531  int i;
5532  w = AT.WorkPointer;
5533  *w++ = par;
5534  w++;
5535  while ( *s == ',' ) s++;
5536  while ( *s ) {
5537  if ( *s == '$' ) {
5538  MesPrint("&We don't do dollar variables yet in ArgImplode/ArgExplode");
5539  return(1);
5540  }
5541  t = s;
5542  if ( ( s = SkipAName(s) ) == 0 ) return(1);
5543  c = *s; *s = 0;
5544  if ( ( type = GetName(AC.varnames,t,&numfunc,WITHAUTO) ) == CFUNCTION ) {
5545  numfunc += FUNCTION;
5546  }
5547  else if ( type != -1 ) {
5548  if ( type != CDUBIOUS ) {
5549  NameConflict(type,t);
5550  type = MakeDubious(AC.varnames,t,&numfunc);
5551  }
5552  error = 1;
5553  }
5554  else {
5555  MesPrint("&%s is not a function",t);
5556  numfunc = AddFunction(s,0,0,0,0,0,-1,-1) + FUNCTION;
5557  return(1);
5558  }
5559  *s = c;
5560  *w++ = numfunc;
5561  *w++ = FUNHEAD;
5562 #if FUNHEAD > 2
5563  for ( i = 2; i < FUNHEAD; i++ ) *w++ = 0;
5564 #endif
5565  if ( *s && *s != ',' ) {
5566  MesPrint("&Illegal character in ArgImplode/ArgExplode statement: %s",s);
5567  return(1);
5568  }
5569  while ( *s == ',' ) s++;
5570  }
5571  n = w - AT.WorkPointer;
5572  AT.WorkPointer[1] = n;
5573  AddNtoL(n,AT.WorkPointer);
5574  return(error);
5575 }
5576 
5577 /*
5578  #] DoArgPlode :
5579  #[ CoArgExplode :
5580 */
5581 
5582 int CoArgExplode(UBYTE *s) { return(DoArgPlode(s,TYPEARGEXPLODE)); }
5583 
5584 /*
5585  #] CoArgExplode :
5586  #[ CoArgImplode :
5587 */
5588 
5589 int CoArgImplode(UBYTE *s) { return(DoArgPlode(s,TYPEARGIMPLODE)); }
5590 
5591 /*
5592  #] CoArgImplode :
5593  #[ CoClearTable :
5594 */
5595 
5596 int CoClearTable(UBYTE *s)
5597 {
5598  UBYTE c, *t;
5599  int j, type, error = 0;
5600  WORD numfun;
5601  TABLES T, TT;
5602  if ( *s == 0 ) {
5603  MesPrint("&The ClearTable statement needs at least one (table) argument.");
5604  return(1);
5605  }
5606  while ( *s ) {
5607  t = s;
5608  s = SkipAName(s);
5609  c = *s; *s = 0;
5610  if ( ( ( type = GetName(AC.varnames,t,&numfun,WITHAUTO) ) != CFUNCTION )
5611  && type != CDUBIOUS ) {
5612 nofunc: MesPrint("&%s is not a table",t);
5613  error = 4;
5614  if ( type < 0 ) numfun = AddFunction(t,0,0,0,0,0,-1,-1);
5615  *s = c;
5616  if ( *s == ',' ) s++;
5617  continue;
5618  }
5619 /*
5620  else if ( ( ( T = functions[numfun].tabl ) == 0 )
5621  || ( T->sparse == 0 ) ) goto nofunc;
5622 */
5623  else if ( ( T = functions[numfun].tabl ) == 0 ) goto nofunc;
5624  numfun += FUNCTION;
5625  *s = c;
5626  if ( *s == ',' ) s++;
5627 /*
5628  Now we clear the table.
5629 */
5630  if ( T->sparse ) {
5631  if ( T->boomlijst ) M_free(T->boomlijst,"TableTree");
5632  for (j = 0; j < T->buffersfill; j++ ) { /* was <= */
5633  finishcbuf(T->buffers[j]);
5634  }
5635  if ( T->buffers ) M_free(T->buffers,"Table buffers");
5636  finishcbuf(T->bufnum);
5637 
5638  T->boomlijst = 0;
5639  T->numtree = 0; T->rootnum = 0; T->MaxTreeSize = 0;
5640  T->boomlijst = 0;
5641  T->bufnum = inicbufs();
5642  T->bufferssize = 8;
5643  T->buffers = (WORD *)Malloc1(sizeof(WORD)*T->bufferssize,"Table buffers");
5644  T->buffersfill = 0;
5645  T->buffers[T->buffersfill++] = T->bufnum;
5646 
5647  T->totind = 0; /* At the moment there are this many */
5648  T->reserved = 0;
5649 
5650  ClearTableTree(T);
5651 
5652  if ( T->spare ) {
5653  if ( T->tablepointers ) M_free(T->tablepointers,"tablepointers");
5654  T->tablepointers = 0;
5655  TT = T->spare;
5656  if ( TT->tablepointers ) M_free(TT->tablepointers,"tablepointers");
5657  for (j = 0; j < TT->buffersfill; j++ ) {
5658  finishcbuf(TT->buffers[j]);
5659  }
5660  if ( TT->boomlijst ) M_free(TT->boomlijst,"TableTree");
5661  if ( TT->buffers )M_free(TT->buffers,"Table buffers");
5662  if ( TT->mm ) M_free(TT->mm,"tableminmax");
5663  if ( TT->flags ) M_free(TT->flags,"tableflags");
5664  M_free(TT,"table");
5665  SpareTable(T);
5666  }
5667  }
5668  else EmptyTable(T);
5669  }
5670  return(error);
5671 }
5672 
5673 /*
5674  #] CoClearTable :
5675  #[ CoDenominators :
5676 */
5677 
5678 int CoDenominators(UBYTE *s)
5679 {
5680  WORD numfun;
5681  int type;
5682  UBYTE *t = SkipAName(s), *t1;
5683  if ( t == 0 ) goto syntaxerror;
5684  t1 = t; while ( *t1 == ',' || *t1 == ' ' || *t1 == '\t' ) t1++;
5685  if ( *t1 ) goto syntaxerror;
5686  *t = 0;
5687  if ( ( ( type = GetName(AC.varnames,s,&numfun,WITHAUTO) ) != CFUNCTION )
5688  || ( functions[numfun].spec != 0 ) ) {
5689  if ( type < 0 ) {
5690  if ( GetName(AC.exprnames,s,&numfun,NOAUTO) == NAMENOTFOUND )
5691  AddFunction(s,0,0,0,0,0,-1,-1);
5692  }
5693  goto syntaxerror;
5694  }
5695  Add3Com(TYPEDENOMINATORS,numfun+FUNCTION);
5696  return(0);
5697 syntaxerror:
5698  MesPrint("&Denominators statement needs one regular function for its argument");
5699  return(1);
5700 }
5701 
5702 /*
5703  #] CoDenominators :
5704  #[ CoDropCoefficient :
5705 */
5706 
5707 int CoDropCoefficient(UBYTE *s)
5708 {
5709  if ( *s == 0 ) {
5710  Add2Com(TYPEDROPCOEFFICIENT)
5711  return(0);
5712  }
5713  MesPrint("&Illegal argument in DropCoefficient statement: '%s'",s);
5714  return(1);
5715 }
5716 /*
5717  #] CoDropCoefficient :
5718  #[ CoDropSymbols :
5719 */
5720 
5721 int CoDropSymbols(UBYTE *s)
5722 {
5723  if ( *s == 0 ) {
5724  Add2Com(TYPEDROPSYMBOLS)
5725  return(0);
5726  }
5727  MesPrint("&Illegal argument in DropSymbols statement: '%s'",s);
5728  return(1);
5729 }
5730 /*
5731  #] CoDropSymbols :
5732  #[ CoToPolynomial :
5733 
5734  Converts the current term as much as possible to symbols.
5735  Keeps a list of all objects converted to symbols in AM.sbufnum.
5736  Note that this cannot be executed in parallel because we have only
5737  a single compiler buffer for this. Hence we switch on the noparallel
5738  module option.
5739 
5740  Option(s):
5741  OnlyFunctions [,name1][,name2][,...,namem];
5742 */
5743 
5744 int CoToPolynomial(UBYTE *inp)
5745 {
5746  int error = 0;
5747  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
5748  if ( ( AC.topolynomialflag & ~TOPOLYNOMIALFLAG ) != 0 ) {
5749  MesPrint("&ToPolynomial statement and FactArg statement are not allowed in the same module");
5750  return(1);
5751  }
5752  if ( AO.OptimizeResult.code != NULL ) {
5753  MesPrint("&Using ToPolynomial statement when there are still optimization results active.");
5754  MesPrint("&Please use #ClearOptimize instruction first.");
5755  MesPrint("&This will loose the optimized expression.");
5756  return(1);
5757  }
5758  if ( *inp == 0 ) {
5759  Add3Com(TYPETOPOLYNOMIAL,DOALL)
5760  }
5761  else {
5762  int numargs = 0;
5763  WORD *funnums = 0, type, num;
5764  UBYTE *s, c;
5765  s = SkipAName(inp);
5766  if ( s == 0 ) return(1);
5767  c = *s; *s = 0;
5768  if ( StrICmp(inp,(UBYTE *)"onlyfunctions") ) {
5769  MesPrint("&Illegal option %s in ToPolynomial statement",inp);
5770  *s = c;
5771  return(1);
5772  }
5773  *s = c;
5774  inp = s;
5775  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
5776  s = inp;
5777  while ( *s ) s++;
5778 /*
5779  Get definitely enough space for the numbers of the functions
5780 */
5781  funnums = (WORD *)Malloc1(((LONG)(s-inp)+3)*sizeof(WORD),"ToPlynomial");
5782  while ( *inp ) {
5783  s = SkipAName(inp);
5784  if ( s == 0 ) return(1);
5785  c = *s; *s = 0;
5786  type = GetName(AC.varnames,inp,&num,WITHAUTO);
5787  if ( type != CFUNCTION ) {
5788  MesPrint("&%s is not a function in ToPolynomial statement",inp);
5789  error = 1;
5790  }
5791  funnums[3+numargs++] = num+FUNCTION;
5792  *s = c;
5793  inp = s;
5794  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
5795  }
5796  funnums[0] = TYPETOPOLYNOMIAL;
5797  funnums[1] = numargs+3;
5798  funnums[2] = ONLYFUNCTIONS;
5799 
5800  AddNtoL(numargs+3,funnums);
5801  if ( funnums ) M_free(funnums,"ToPolynomial");
5802  }
5803  AC.topolynomialflag |= TOPOLYNOMIALFLAG;
5804 #ifdef WITHMPI
5805  /* In ParFORM, ToPolynomial has to be executed on the master. */
5806  AC.mparallelflag |= NOPARALLEL_CONVPOLY;
5807 #endif
5808  return(error);
5809 }
5810 
5811 /*
5812  #] CoToPolynomial :
5813  #[ CoFromPolynomial :
5814 
5815  Converts the current term as much as possible back from extra symbols
5816  to their original values. Does not look inside functions.
5817 */
5818 
5819 int CoFromPolynomial(UBYTE *inp)
5820 {
5821  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
5822  if ( *inp == 0 ) {
5823  if ( AO.OptimizeResult.code != NULL ) {
5824  MesPrint("&Using FromPolynomial statement when there are still optimization results active.");
5825  MesPrint("&Please use #ClearOptimize instruction first.");
5826  MesPrint("&This will loose the optimized expression.");
5827  return(1);
5828  }
5829  Add2Com(TYPEFROMPOLYNOMIAL)
5830  return(0);
5831  }
5832  MesPrint("&Illegal argument in FromPolynomial statement: '%s'",inp);
5833  return(1);
5834 }
5835 
5836 /*
5837  #] CoFromPolynomial :
5838  #[ CoArgToExtraSymbol :
5839 
5840  Converts the specified function arguments into extra symbols.
5841 
5842  Syntax: ArgToExtraSymbol [ToNumber] [<argument specifications>]
5843 */
5844 
5845 int CoArgToExtraSymbol(UBYTE *s)
5846 {
5847  CBUF *C = cbuf + AC.cbufnum;
5848  WORD *lhs;
5849 
5850  /* TODO: resolve interference with rational arithmetic. (#138) */
5851  if ( ( AC.topolynomialflag & ~TOPOLYNOMIALFLAG ) != 0 ) {
5852  MesPrint("&ArgToExtraSymbol statement and FactArg statement are not allowed in the same module");
5853  return(1);
5854  }
5855  if ( AO.OptimizeResult.code != NULL ) {
5856  MesPrint("&Using ArgToExtraSymbol statement when there are still optimization results active.");
5857  MesPrint("&Please use #ClearOptimize instruction first.");
5858  MesPrint("&This will loose the optimized expression.");
5859  return(1);
5860  }
5861 
5862  SkipSpaces(&s);
5863  int tonumber = ConsumeOption(&s, "tonumber");
5864 
5865  int ret = DoArgument(s,TYPEARGTOEXTRASYMBOL);
5866  if ( ret ) return(ret);
5867 
5868  /*
5869  * The "scale" parameter is unused. Instead, we put the "tonumber"
5870  * parameter.
5871  */
5872  lhs = C->lhs[C->numlhs];
5873  if ( lhs[4] != 1 ) {
5874  Warning("scale parameter (^n) is ignored in ArgToExtraSymbol");
5875  }
5876  lhs[4] = tonumber;
5877 
5878  AC.topolynomialflag |= TOPOLYNOMIALFLAG; /* This flag is also used in ParFORM. */
5879 #ifdef WITHMPI
5880  /*
5881  * In ParFORM, the conversion to extra symbols has to be performed on
5882  * the master.
5883  */
5884  AC.mparallelflag |= NOPARALLEL_CONVPOLY;
5885 #endif
5886 
5887  return(0);
5888 }
5889 
5890 /*
5891  #] CoArgToExtraSymbol :
5892  #[ CoExtraSymbols :
5893 */
5894 
5895 int CoExtraSymbols(UBYTE *inp)
5896 {
5897  UBYTE *arg1, *arg2, c, *s;
5898  WORD i, j, type, number;
5899  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
5900  if ( FG.cTable[*inp] != 0 ) {
5901  MesPrint("&Illegal argument in ExtraSymbols statement: '%s'",inp);
5902  return(1);
5903  }
5904  arg1 = inp;
5905  while ( FG.cTable[*inp] == 0 ) inp++;
5906  c = *inp; *inp = 0;
5907  if ( ( StrICmp(arg1,(UBYTE *)"array") == 0 )
5908  || ( StrICmp(arg1,(UBYTE *)"vector") == 0 ) ) {
5909  AC.extrasymbols = 1;
5910  }
5911  else if ( StrICmp(arg1,(UBYTE *)"underscore") == 0 ) {
5912  AC.extrasymbols = 0;
5913  }
5914 /*
5915  else if ( StrICmp(arg1,(UBYTE *)"nothing") == 0 ) {
5916  AC.extrasymbols = 2;
5917  }
5918 */
5919  else {
5920  MesPrint("&Illegal keyword in ExtraSymbols statement: '%s'",arg1);
5921  return(1);
5922  }
5923  *inp = c;
5924  while ( *inp == ' ' || *inp == ',' || *inp == '\t' ) inp++;
5925  if ( FG.cTable[*inp] != 0 ) {
5926  MesPrint("&Illegal argument in ExtraSymbols statement: '%s'",inp);
5927  return(1);
5928  }
5929  arg2 = inp;
5930  while ( FG.cTable[*inp] <= 1 ) inp++;
5931  if ( *inp != 0 ) {
5932  MesPrint("&Illegal end of ExtraSymbols statement: '%s'",inp);
5933  return(1);
5934  }
5935 /*
5936  Now check whether this object has been declared already.
5937  That would not be allowed.
5938 */
5939  if ( AC.extrasymbols == 1 ) {
5940  type = GetName(AC.varnames,arg2,&number,NOAUTO);
5941  if ( type != NAMENOTFOUND ) {
5942  MesPrint("&ExtraSymbols statement: '%s' has already been declared before",arg2);
5943  return(1);
5944  }
5945  }
5946  else if ( AC.extrasymbols == 0 ) {
5947  if ( *arg2 == 'N' ) {
5948  s = arg2+1;
5949  while ( FG.cTable[*s] == 1 ) s++;
5950  if ( *s == 0 ) {
5951  MesPrint("&ExtraSymbols statement: '%s' creates conflicts with summed indices",arg2);
5952  return(1);
5953  }
5954  }
5955  }
5956  if ( AC.extrasym ) { M_free(AC.extrasym,"extrasym"); AC.extrasym = 0; }
5957  i = inp - arg2 + 1;
5958  AC.extrasym = (UBYTE *)Malloc1(i*sizeof(UBYTE),"extrasym");
5959  for ( j = 0; j < i; j++ ) AC.extrasym[j] = arg2[j];
5960  return(0);
5961 }
5962 
5963 /*
5964  #] CoExtraSymbols :
5965  #[ GetIfDollarFactor :
5966 */
5967 
5968 WORD *GetIfDollarFactor(UBYTE **inp, WORD *w)
5969 {
5970  LONG x;
5971  WORD number;
5972  UBYTE *name, c, *s;
5973  s = *inp;
5974  if ( FG.cTable[*s] == 1 ) {
5975  x = 0;
5976  while ( FG.cTable[*s] == 1 ) {
5977  x = 10*x + *s++ - '0';
5978  if ( x >= MAXPOSITIVE ) {
5979  MesPrint("&Value in dollar factor too large");
5980  while ( FG.cTable[*s] == 1 ) s++;
5981  *inp = s;
5982  return(0);
5983  }
5984  }
5985  *w++ = IFDOLLAREXTRA;
5986  *w++ = 3;
5987  *w++ = -x-1;
5988  *inp = s;
5989  return(w);
5990  }
5991  if ( *s != '$' ) {
5992  MesPrint("&Factor indicator for $-variable should be a number or a $-variable.");
5993  return(0);
5994  }
5995  s++; name = s;
5996  while ( FG.cTable[*s] < 2 ) s++;
5997  c = *s; *s = 0;
5998  if ( GetName(AC.dollarnames,name,&number,NOAUTO) == NAMENOTFOUND ) {
5999  MesPrint("&dollar in if statement should have been defined previously");
6000  return(0);
6001  }
6002  *s = c;
6003  *w++ = IFDOLLAREXTRA;
6004  *w++ = 3;
6005  *w++ = number;
6006  if ( c == '[' ) {
6007  s++;
6008  *inp = s;
6009  if ( ( w = GetIfDollarFactor(inp,w) ) == 0 ) return(0);
6010  s = *inp;
6011  if ( *s != ']' ) {
6012  MesPrint("&unmatched [] in $ in if statement");
6013  return(0);
6014  }
6015  s++;
6016  *inp = s;
6017  }
6018  return(w);
6019 }
6020 
6021 /*
6022  #] GetIfDollarFactor :
6023  #[ GetDoParam :
6024 */
6025 
6026 UBYTE *GetDoParam(UBYTE *inp, WORD **wp, int par)
6027 {
6028  LONG x;
6029  WORD number;
6030  UBYTE *name, c;
6031  if ( FG.cTable[*inp] == 1 ) {
6032  x = 0;
6033  while ( *inp >= '0' && *inp <= '9' ) {
6034  x = 10*x + *inp++ - '0';
6035  if ( x > MAXPOSITIVE ) {
6036  if ( par == -1 ) {
6037  MesPrint("&Value in dollar factor too large");
6038  }
6039  else {
6040  MesPrint("&Value in do loop boundaries too large");
6041  }
6042  while ( FG.cTable[*inp] == 1 ) inp++;
6043  return(0);
6044  }
6045  }
6046  if ( par > 0 ) {
6047  *(*wp)++ = SNUMBER;
6048  *(*wp)++ = (WORD)x;
6049  }
6050  else {
6051  *(*wp)++ = DOLLAREXPR2;
6052  *(*wp)++ = -((WORD)x)-1;
6053  }
6054  return(inp);
6055  }
6056  if ( *inp != '$' ) {
6057  return(0);
6058  }
6059  inp++; name = inp;
6060  while ( FG.cTable[*inp] < 2 ) inp++;
6061  c = *inp; *inp = 0;
6062  if ( GetName(AC.dollarnames,name,&number,NOAUTO) == NAMENOTFOUND ) {
6063  if ( par == -1 ) {
6064  MesPrint("&dollar in print statement should have been defined previously");
6065  }
6066  else {
6067  MesPrint("&dollar in do loop boundaries should have been defined previously");
6068  }
6069  return(0);
6070  }
6071  *inp = c;
6072  if ( par > 0 ) {
6073  *(*wp)++ = DOLLAREXPRESSION;
6074  *(*wp)++ = number;
6075  }
6076  else {
6077  *(*wp)++ = DOLLAREXPR2;
6078  *(*wp)++ = number;
6079  }
6080  if ( c == '[' ) {
6081  inp++;
6082  inp = GetDoParam(inp,wp,0);
6083  if ( inp == 0 ) return(0);
6084  if ( *inp != ']' ) {
6085  if ( par == -1 ) {
6086  MesPrint("&unmatched [] in $ in print statement");
6087  }
6088  else {
6089  MesPrint("&unmatched [] in do loop boundaries");
6090  }
6091  return(0);
6092  }
6093  inp++;
6094  }
6095  return(inp);
6096 }
6097 
6098 /*
6099  #] GetDoParam :
6100  #[ CoDo :
6101 */
6102 
6103 int CoDo(UBYTE *inp)
6104 {
6105  GETIDENTITY
6106  CBUF *C = cbuf+AC.cbufnum;
6107  WORD *w, numparam;
6108  int error = 0, i;
6109  UBYTE *name, c;
6110  if ( AC.doloopstack == 0 ) {
6111  AC.doloopstacksize = 20;
6112  AC.doloopstack = (WORD *)Malloc1(AC.doloopstacksize*2*sizeof(WORD),"doloop stack");
6113  AC.doloopnest = AC.doloopstack + AC.doloopstacksize;
6114  }
6115  if ( AC.dolooplevel >= AC.doloopstacksize ) {
6116  WORD *newstack, *newnest, newsize;
6117  newsize = AC.doloopstacksize * 2;
6118  newstack = (WORD *)Malloc1(newsize*2*sizeof(WORD),"doloop stack");
6119  newnest = newstack + newsize;
6120  for ( i = 0; i < newsize; i++ ) {
6121  newstack[i] = AC.doloopstack[i];
6122  newnest[i] = AC.doloopnest[i];
6123  }
6124  M_free(AC.doloopstack,"doloop stack");
6125  AC.doloopstack = newstack;
6126  AC.doloopnest = newnest;
6127  AC.doloopstacksize = newsize;
6128  }
6129  AC.doloopnest[AC.dolooplevel] = NestingChecksum();
6130 
6131  w = AT.WorkPointer;
6132  *w++ = TYPEDOLOOP;
6133  w++; /* Space for the length of the statement */
6134 /*
6135  Now the $loopvariable
6136 */
6137  while ( *inp == ',' ) inp++;
6138  if ( *inp != '$' ) {
6139  error = 1;
6140  MesPrint("&do loop parameter should be a dollar variable");
6141  }
6142  else {
6143  inp++;
6144  name = inp;
6145  if ( FG.cTable[*inp] != 0 ) {
6146  error = 1;
6147  MesPrint("&illegal name for do loop parameter");
6148  }
6149  while ( FG.cTable[*inp] < 2 ) inp++;
6150  c = *inp; *inp = 0;
6151  if ( GetName(AC.dollarnames,name,&numparam,NOAUTO) == NAMENOTFOUND ) {
6152  numparam = AddDollar(name,DOLUNDEFINED,0,0);
6153  }
6154  *w++ = numparam;
6155  *inp = c;
6156  AddPotModdollar(numparam);
6157  }
6158  w++; /* space for the level of the enddo statement */
6159  while ( *inp == ',' ) inp++;
6160  if ( *inp != '=' ) goto IllSyntax;
6161  inp++;
6162  while ( *inp == ',' ) inp++;
6163 /*
6164  The start value
6165 */
6166  inp = GetDoParam(inp,&w,1);
6167  if ( inp == 0 || *inp != ',' ) goto IllSyntax;
6168  while ( *inp == ',' ) inp++;
6169 /*
6170  The end value
6171 */
6172  inp = GetDoParam(inp,&w,1);
6173  if ( inp == 0 || ( *inp != 0 && *inp != ',' ) ) goto IllSyntax;
6174 /*
6175  The increment value
6176 */
6177  if ( *inp != ',' ) {
6178  if ( *inp == 0 ) { *w++ = SNUMBER; *w++ = 1; }
6179  else goto IllSyntax;
6180  }
6181  else {
6182  while ( *inp == ',' ) inp++;
6183  inp = GetDoParam(inp,&w,1);
6184  }
6185  if ( inp == 0 || *inp != 0 ) goto IllSyntax;
6186  *w = 0;
6187  AT.WorkPointer[1] = w - AT.WorkPointer;
6188 /*
6189  Put away and set information for placing enddo information.
6190 */
6191  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
6192  AC.doloopstack[AC.dolooplevel++] = C->numlhs;
6193 
6194  return(error);
6195 
6196 IllSyntax:
6197  MesPrint("&Illegal syntax for do statement");
6198  return(1);
6199 }
6200 
6201 /*
6202  #] CoDo :
6203  #[ CoEndDo :
6204 */
6205 
6206 int CoEndDo(UBYTE *inp)
6207 {
6208  CBUF *C = cbuf+AC.cbufnum;
6209  WORD scratch[3];
6210  while ( *inp == ',' ) inp++;
6211  if ( *inp ) {
6212  MesPrint("&Illegal syntax for EndDo statement");
6213  return(1);
6214  }
6215  if ( AC.dolooplevel <= 0 ) {
6216  MesPrint("&EndDo without corresponding Do statement");
6217  return(1);
6218  }
6219  AC.dolooplevel--;
6220  scratch[0] = TYPEENDDOLOOP;
6221  scratch[1] = 3;
6222  scratch[2] = AC.doloopstack[AC.dolooplevel];
6223  AddNtoL(3,scratch);
6224  cbuf[AC.cbufnum].lhs[AC.doloopstack[AC.dolooplevel]][3] = C->numlhs;
6225  if ( AC.doloopnest[AC.dolooplevel] != NestingChecksum() ) {
6226  MesNesting();
6227  return(1);
6228  }
6229  return(0);
6230 }
6231 
6232 /*
6233  #] CoEndDo :
6234  #[ CoFactDollar :
6235 */
6236 
6237 int CoFactDollar(UBYTE *inp)
6238 {
6239  WORD numdollar;
6240  if ( *inp == '$' ) {
6241  if ( GetName(AC.dollarnames,inp+1,&numdollar,NOAUTO) != CDOLLAR ) {
6242  MesPrint("&%s is undefined",inp);
6243  numdollar = AddDollar(inp+1,DOLINDEX,&one,1);
6244  return(1);
6245  }
6246  inp = SkipAName(inp+1);
6247  if ( *inp != 0 ) {
6248  MesPrint("&FactDollar should have a single $variable for its argument");
6249  return(1);
6250  }
6251  AddPotModdollar(numdollar);
6252  }
6253  else {
6254  MesPrint("&%s is not a $-variable",inp);
6255  return(1);
6256  }
6257  Add3Com(TYPEFACTOR,numdollar);
6258  return(0);
6259 }
6260 
6261 /*
6262  #] CoFactDollar :
6263  #[ CoFactorize :
6264 */
6265 
6266 int CoFactorize(UBYTE *s) { return(DoFactorize(s,1)); }
6267 
6268 /*
6269  #] CoFactorize :
6270  #[ CoNFactorize :
6271 */
6272 
6273 int CoNFactorize(UBYTE *s) { return(DoFactorize(s,0)); }
6274 
6275 /*
6276  #] CoNFactorize :
6277  #[ CoUnFactorize :
6278 */
6279 
6280 int CoUnFactorize(UBYTE *s) { return(DoFactorize(s,3)); }
6281 
6282 /*
6283  #] CoUnFactorize :
6284  #[ CoNUnFactorize :
6285 */
6286 
6287 int CoNUnFactorize(UBYTE *s) { return(DoFactorize(s,2)); }
6288 
6289 /*
6290  #] CoNUnFactorize :
6291  #[ DoFactorize :
6292 */
6293 
6294 int DoFactorize(UBYTE *s,int par)
6295 {
6296  EXPRESSIONS e;
6297  WORD i;
6298  WORD number;
6299  UBYTE *t, c;
6300  int error = 0, keepzeroflag = 0;
6301  if ( *s == '(' ) {
6302  s++;
6303  while ( *s != ')' && *s ) {
6304  if ( FG.cTable[*s] == 0 ) {
6305  t = s; while ( FG.cTable[*s] == 0 ) s++;
6306  c = *s; *s = 0;
6307  if ( StrICmp((UBYTE *)"keepzero",t) == 0 ) {
6308  keepzeroflag = 1;
6309  }
6310  else {
6311  MesPrint("&Illegal option in [N][Un]Factorize statement: %s",t);
6312  error = 1;
6313  }
6314  *s = c;
6315  }
6316  while ( *s == ',' ) s++;
6317  if ( *s && *s != ')' && FG.cTable[*s] != 0 ) {
6318  MesPrint("&Illegal character in option field of [N][Un]Factorize statement");
6319  error = 1;
6320  return(error);
6321  }
6322  }
6323  if ( *s ) s++;
6324  while ( *s == ',' || *s == ' ' ) s++;
6325  }
6326  if ( *s == 0 ) {
6327  for ( i = NumExpressions-1; i >= 0; i-- ) {
6328  e = Expressions+i;
6329  if ( e->replace >= 0 ) {
6330  e = Expressions + e->replace;
6331  }
6332  if ( e->status == LOCALEXPRESSION || e->status == GLOBALEXPRESSION
6333  || e->status == UNHIDELEXPRESSION || e->status == UNHIDEGEXPRESSION
6334  || e->status == INTOHIDELEXPRESSION || e->status == INTOHIDEGEXPRESSION
6335  ) {
6336  switch ( par ) {
6337  case 0:
6338  e->vflags &= ~TOBEFACTORED;
6339  break;
6340  case 1:
6341  e->vflags |= TOBEFACTORED;
6342  e->vflags &= ~TOBEUNFACTORED;
6343  break;
6344  case 2:
6345  e->vflags &= ~TOBEUNFACTORED;
6346  break;
6347  case 3:
6348  e->vflags |= TOBEUNFACTORED;
6349  e->vflags &= ~TOBEFACTORED;
6350  break;
6351  }
6352  }
6353  if ( ( e->vflags & TOBEFACTORED ) != 0 ) {
6354  if ( keepzeroflag ) e->vflags |= KEEPZERO;
6355  else e->vflags &= ~KEEPZERO;
6356  }
6357  else e->vflags &= ~KEEPZERO;
6358  }
6359  }
6360  else {
6361  for(;;) { /* Look for a (comma separated) list of variables */
6362  while ( *s == ',' ) s++;
6363  if ( *s == 0 ) break;
6364  if ( *s == '[' || FG.cTable[*s] == 0 ) {
6365  t = s;
6366  if ( ( s = SkipAName(s) ) == 0 ) {
6367  MesPrint("&Improper name for an expression: '%s'",t);
6368  return(1);
6369  }
6370  c = *s; *s = 0;
6371  if ( GetName(AC.exprnames,t,&number,NOAUTO) == CEXPRESSION ) {
6372  e = Expressions+number;
6373  if ( e->replace >= 0 ) {
6374  e = Expressions + e->replace;
6375  }
6376  if ( e->status == LOCALEXPRESSION || e->status == GLOBALEXPRESSION
6377  || e->status == UNHIDELEXPRESSION || e->status == UNHIDEGEXPRESSION
6378  || e->status == INTOHIDELEXPRESSION || e->status == INTOHIDEGEXPRESSION
6379  ) {
6380  switch ( par ) {
6381  case 0:
6382  e->vflags &= ~TOBEFACTORED;
6383  break;
6384  case 1:
6385  e->vflags |= TOBEFACTORED;
6386  e->vflags &= ~TOBEUNFACTORED;
6387  break;
6388  case 2:
6389  e->vflags &= ~TOBEUNFACTORED;
6390  break;
6391  case 3:
6392  e->vflags |= TOBEUNFACTORED;
6393  e->vflags &= ~TOBEFACTORED;
6394  break;
6395  }
6396  }
6397  if ( ( e->vflags & TOBEFACTORED ) != 0 ) {
6398  if ( keepzeroflag ) e->vflags |= KEEPZERO;
6399  else e->vflags &= ~KEEPZERO;
6400  }
6401  else e->vflags &= ~KEEPZERO;
6402  }
6403  else if ( GetName(AC.varnames,t,&number,NOAUTO) != NAMENOTFOUND ) {
6404  MesPrint("&%s is not an expression",t);
6405  error = 1;
6406  }
6407  *s = c;
6408  }
6409  else {
6410  MesPrint("&Illegal object in (N)Factorize statement");
6411  error = 1;
6412  while ( *s && *s != ',' ) s++;
6413  if ( *s == 0 ) break;
6414  }
6415  }
6416 
6417  }
6418  return(error);
6419 }
6420 
6421 /*
6422  #] DoFactorize :
6423  #[ CoOptimizeOption :
6424 
6425 */
6426 
6427 int CoOptimizeOption(UBYTE *s)
6428 {
6429  UBYTE *name, *t1, *t2, c1, c2, *value, *u;
6430  int error = 0, x;
6431  double d;
6432  while ( *s == ' ' || *s == ',' || *s == '\t' ) s++;
6433  while ( *s ) {
6434  name = s; while ( FG.cTable[*s] == 0 ) s++;
6435  t1 = s; c1 = *t1;
6436  while ( *s == ' ' || *s == '\t' ) s++;
6437  if ( *s != '=' ) {
6438 correctuse:
6439  MesPrint("&Correct use in Format,Optimize statement is Optionname=value");
6440  error = 1;
6441  while ( *s == ' ' || *s == ',' || *s == '\t' || *s == '=' ) s++;
6442  *t1 = c1;
6443  continue;
6444  }
6445  *t1 = 0;
6446  s++;
6447  while ( *s == ' ' || *s == '\t' ) s++;
6448  if ( *s == 0 ) goto correctuse;
6449  value = s;
6450  while ( FG.cTable[*s] <= 1 || *s=='.' || *s=='*' || *s == '(' || *s == ')' ) {
6451  if ( *s == '(' ) { SKIPBRA4(s) }
6452  s++;
6453  }
6454  t2 = s; c2 = *t2;
6455  while ( *s == ' ' || *s == '\t' ) s++;
6456  if ( *s && *s != ',' ) goto correctuse;
6457  if ( *s ) {
6458  s++;
6459  while ( *s == ' ' || *s == '\t' ) s++;
6460  }
6461  *t2 = 0;
6462 /*
6463  Now we have name=value with name and value zero terminated strings.
6464 */
6465  if ( StrICmp(name,(UBYTE *)"horner") == 0 ) {
6466  if ( StrICmp(value,(UBYTE *)"occurrence") == 0 ) {
6467  AO.Optimize.horner = O_OCCURRENCE;
6468  }
6469  else if ( StrICmp(value,(UBYTE *)"mcts") == 0 ) {
6470  AO.Optimize.horner = O_MCTS;
6471  }
6472  else if ( StrICmp(value,(UBYTE *)"sa") == 0 ) {
6473  AO.Optimize.horner = O_SIMULATED_ANNEALING;
6474  }
6475  else {
6476  AO.Optimize.horner = -1;
6477  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6478  error = 1;
6479  }
6480  }
6481  else if ( StrICmp(name,(UBYTE *)"hornerdirection") == 0 ) {
6482  if ( StrICmp(value,(UBYTE *)"forward") == 0 ) {
6483  AO.Optimize.hornerdirection = O_FORWARD;
6484  }
6485  else if ( StrICmp(value,(UBYTE *)"backward") == 0 ) {
6486  AO.Optimize.hornerdirection = O_BACKWARD;
6487  }
6488  else if ( StrICmp(value,(UBYTE *)"forwardorbackward") == 0 ) {
6489  AO.Optimize.hornerdirection = O_FORWARDORBACKWARD;
6490  }
6491  else if ( StrICmp(value,(UBYTE *)"forwardandbackward") == 0 ) {
6492  AO.Optimize.hornerdirection = O_FORWARDANDBACKWARD;
6493  }
6494  else {
6495  AO.Optimize.method = -1;
6496  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6497  error = 1;
6498  }
6499  }
6500  else if ( StrICmp(name,(UBYTE *)"method") == 0 ) {
6501  if ( StrICmp(value,(UBYTE *)"none") == 0 ) {
6502  AO.Optimize.method = O_NONE;
6503  }
6504  else if ( StrICmp(value,(UBYTE *)"cse") == 0 ) {
6505  AO.Optimize.method = O_CSE;
6506  }
6507  else if ( StrICmp(value,(UBYTE *)"csegreedy") == 0 ) {
6508  AO.Optimize.method = O_CSEGREEDY;
6509  }
6510  else if ( StrICmp(value,(UBYTE *)"greedy") == 0 ) {
6511  AO.Optimize.method = O_GREEDY;
6512  }
6513  else {
6514  AO.Optimize.method = -1;
6515  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6516  error = 1;
6517  }
6518  }
6519  else if ( StrICmp(name,(UBYTE *)"timelimit") == 0 ) {
6520  x = 0;
6521  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6522  if ( *u != 0 ) {
6523  MesPrint("&Option TimeLimit in Format,Optimize statement should be a positive number: %s",value);
6524  AO.Optimize.mctstimelimit = 0;
6525  AO.Optimize.greedytimelimit = 0;
6526  error = 1;
6527  }
6528  else {
6529  AO.Optimize.mctstimelimit = x/2;
6530  AO.Optimize.greedytimelimit = x/2;
6531  }
6532  }
6533  else if ( StrICmp(name,(UBYTE *)"mctstimelimit") == 0 ) {
6534  x = 0;
6535  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6536  if ( *u != 0 ) {
6537  MesPrint("&Option MCTSTimeLimit in Format,Optimize statement should be a positive number: %s",value);
6538  AO.Optimize.mctstimelimit = 0;
6539  error = 1;
6540  }
6541  else {
6542  AO.Optimize.mctstimelimit = x;
6543  }
6544  }
6545  else if ( StrICmp(name,(UBYTE *)"mctsnumexpand") == 0 ) {
6546  int y;
6547  x = 0;
6548  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6549  if ( *u == '*' || *u == 'x' || *u == 'X' ) {
6550  u++; y = x;
6551  x = 0;
6552  while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6553  }
6554  else { y = 1; }
6555  if ( *u != 0 ) {
6556  MesPrint("&Option MCTSNumExpand in Format,Optimize statement should be a positive number: %s",value);
6557  AO.Optimize.mctsnumexpand= 0;
6558  AO.Optimize.mctsnumrepeat= 1;
6559  error = 1;
6560  }
6561  else {
6562  AO.Optimize.mctsnumexpand= x;
6563  AO.Optimize.mctsnumrepeat= y;
6564  }
6565  }
6566  else if ( StrICmp(name,(UBYTE *)"mctsnumrepeat") == 0 ) {
6567  x = 0;
6568  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6569  if ( *u != 0 ) {
6570  MesPrint("&Option MCTSNumExpand in Format,Optimize statement should be a positive number: %s",value);
6571  AO.Optimize.mctsnumrepeat= 1;
6572  error = 1;
6573  }
6574  else {
6575  AO.Optimize.mctsnumrepeat= x;
6576  }
6577  }
6578  else if ( StrICmp(name,(UBYTE *)"mctsnumkeep") == 0 ) {
6579  x = 0;
6580  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6581  if ( *u != 0 ) {
6582  MesPrint("&Option MCTSNumKeep in Format,Optimize statement should be a positive number: %s",value);
6583  AO.Optimize.mctsnumkeep= 0;
6584  error = 1;
6585  }
6586  else {
6587  AO.Optimize.mctsnumkeep= x;
6588  }
6589  }
6590  else if ( StrICmp(name,(UBYTE *)"mctsconstant") == 0 ) {
6591  d = 0;
6592  if ( sscanf ((char*)value, "%lf", &d) != 1 ) {
6593  MesPrint("&Option MCTSConstant in Format,Optimize statement should be a positive number: %s",value);
6594  AO.Optimize.mctsconstant.fval = 0;
6595  error = 1;
6596  }
6597  else {
6598  AO.Optimize.mctsconstant.fval = d;
6599  }
6600  }
6601  else if ( StrICmp(name,(UBYTE *)"greedytimelimit") == 0 ) {
6602  x = 0;
6603  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6604  if ( *u != 0 ) {
6605  MesPrint("&Option GreedyTimeLimit in Format,Optimize statement should be a positive number: %s",value);
6606  AO.Optimize.greedytimelimit = 0;
6607  error = 1;
6608  }
6609  else {
6610  AO.Optimize.greedytimelimit = x;
6611  }
6612  }
6613  else if ( StrICmp(name,(UBYTE *)"greedyminnum") == 0 ) {
6614  x = 0;
6615  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6616  if ( *u != 0 ) {
6617  MesPrint("&Option GreedyMinNum in Format,Optimize statement should be a positive number: %s",value);
6618  AO.Optimize.greedyminnum= 0;
6619  error = 1;
6620  }
6621  else {
6622  AO.Optimize.greedyminnum= x;
6623  }
6624  }
6625  else if ( StrICmp(name,(UBYTE *)"greedymaxperc") == 0 ) {
6626  x = 0;
6627  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6628  if ( *u != 0 ) {
6629  MesPrint("&Option GreedyMaxPerc in Format,Optimize statement should be a positive number: %s",value);
6630  AO.Optimize.greedymaxperc= 0;
6631  error = 1;
6632  }
6633  else {
6634  AO.Optimize.greedymaxperc= x;
6635  }
6636  }
6637  else if ( StrICmp(name,(UBYTE *)"stats") == 0 ) {
6638  if ( StrICmp(value,(UBYTE *)"on") == 0 ) {
6639  AO.Optimize.printstats = 1;
6640  }
6641  else if ( StrICmp(value,(UBYTE *)"off") == 0 ) {
6642  AO.Optimize.printstats = 0;
6643  }
6644  else {
6645  AO.Optimize.printstats = 0;
6646  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6647  error = 1;
6648  }
6649  }
6650  else if ( StrICmp(name,(UBYTE *)"printscheme") == 0 ) {
6651  if ( StrICmp(value,(UBYTE *)"on") == 0 ) {
6652  AO.Optimize.schemeflags |= 1;
6653  }
6654  else if ( StrICmp(value,(UBYTE *)"off") == 0 ) {
6655  AO.Optimize.schemeflags &= ~1;
6656  }
6657  else {
6658  AO.Optimize.schemeflags &= ~1;
6659  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6660  error = 1;
6661  }
6662  }
6663  else if ( StrICmp(name,(UBYTE *)"debugflag") == 0 ) {
6664 /*
6665  This option is for debugging purposes only. Not in the manual!
6666  0x1: Print statements in reverse order.
6667  0x2: Print the scheme of the variables.
6668 */
6669  x = 0;
6670  u = value;
6671  if ( FG.cTable[*u] == 1 ) {
6672  while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6673  if ( *u != 0 ) {
6674  MesPrint("&Numerical value for DebugFlag in Format,Optimize statement should be a nonnegative number: %s",value);
6675  AO.Optimize.debugflags = 0;
6676  error = 1;
6677  }
6678  else {
6679  AO.Optimize.debugflags = x;
6680  }
6681  }
6682  else if ( StrICmp(value,(UBYTE *)"on") == 0 ) {
6683  AO.Optimize.debugflags = 1;
6684  }
6685  else if ( StrICmp(value,(UBYTE *)"off") == 0 ) {
6686  AO.Optimize.debugflags = 0;
6687  }
6688  else {
6689  AO.Optimize.debugflags = 0;
6690  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6691  error = 1;
6692  }
6693  }
6694  else if ( StrICmp(name,(UBYTE *)"scheme") == 0 ) {
6695  UBYTE *ss, *s1, c;
6696  WORD type, numsym;
6697  AO.schemenum = 0;
6698  u = value;
6699  if ( *u != '(' ) {
6700 noscheme:
6701  MesPrint("&Option Scheme in Format,Optimize statement should be an array of names or integers between (): %s",value);
6702  error = 1;
6703  break;
6704  }
6705  u++; ss = u;
6706  while ( *ss == ' ' || *ss == '\t' || *ss == ',' ) ss++;
6707  if ( FG.cTable[*ss] == 0 || *ss == '$' || *ss == '[' ) { /* Name */
6708  s1 = u; SKIPBRA3(s1)
6709  if ( *s1 != ')' ) goto noscheme;
6710  while ( ss < s1 ) { if ( *ss++ == ',' ) AO.schemenum++; }
6711  *ss++ = 0; while ( *ss == ' ' ) ss++;
6712  if ( *ss != 0 ) goto noscheme;
6713  ss = u;
6714  if ( AO.schemenum < 1 ) {
6715  MesPrint("&Option Scheme in Format,Optimize statement should have at least one name or number between ()");
6716  error = 1;
6717  break;
6718  }
6719  if ( AO.inscheme ) M_free(AO.inscheme,"Horner input scheme");
6720  AO.inscheme = (WORD *)Malloc1((AO.schemenum+1)*sizeof(WORD),"Horner input scheme");
6721  while ( *ss == ' ' || *ss == '\t' || *ss == ',' ) ss++;
6722  AO.schemenum = 0;
6723  for(;;) {
6724  if ( *ss == 0 ) break;
6725  s1 = ss; ss = SkipAName(s1); c = *ss; *ss = 0;
6726 
6727  if ( ss[-1] == '_' ) {
6728 /*
6729  Now AC.extrasym followed by a number and _
6730 */
6731  UBYTE *u1, *u2;
6732  u1 = s1; u2 = AC.extrasym;
6733  while ( *u1 == *u2 ) { u1++; u2++; }
6734  if ( *u2 == 0 ) { /* Good start */
6735  numsym = 0;
6736  while ( *u1 >= '0' && *u1 <= '9' ) numsym = 10*numsym + *u1++ - '0';
6737  if ( u1 != ss-1 || numsym == 0 || AC.extrasymbols != 0 ) {
6738  MesPrint("&Improper use of extra symbol in scheme format option");
6739  goto noscheme;
6740  }
6741  numsym = MAXVARIABLES-numsym;
6742  ss++;
6743  goto GotTheNumber;
6744  }
6745  }
6746  else if ( *s1 == '$' ) {
6747  GETIDENTITY
6748  int numdollar;
6749  if ( ( numdollar = GetDollar(s1+1) ) < 0 ) {
6750  MesPrint("&Undefined variable %s",s1);
6751  error = 5;
6752  }
6753  else if ( ( numsym = DolToSymbol(BHEAD numdollar) ) < 0 ) {
6754  MesPrint("&$%s does not evaluate to a symbol",s1);
6755  error = 5;
6756  }
6757  *ss = c;
6758  goto GotTheNumber;
6759  }
6760  else if ( c == '(' ) {
6761  if ( StrCmp(s1,AC.extrasym) == 0 ) {
6762  if ( (AC.extrasymbols&1) != 1 ) {
6763  MesPrint("&Improper use of extra symbol in scheme format option");
6764  goto noscheme;
6765  }
6766  *ss++ = c;
6767  numsym = 0;
6768  while ( *ss >= '0' && *ss <= '9' ) numsym = 10*numsym + *ss++ - '0';
6769  if ( *ss != ')' ) {
6770  MesPrint("&Extra symbol should have a number for its argument.");
6771  goto noscheme;
6772  }
6773  numsym = MAXVARIABLES-numsym;
6774  ss++;
6775  goto GotTheNumber;
6776  }
6777  }
6778  type = GetName(AC.varnames,s1,&numsym,WITHAUTO);
6779  if ( ( type != CSYMBOL ) && type != CDUBIOUS ) {
6780  MesPrint("&%s is not a symbol",s1);
6781  error = 4;
6782  if ( type < 0 ) numsym = AddSymbol(s1,-MAXPOWER,MAXPOWER,0,0);
6783  }
6784  *ss = c;
6785 GotTheNumber:
6786  AO.inscheme[AO.schemenum++] = numsym;
6787  while ( *ss == ' ' || *ss == '\t' || *ss == ',' ) ss++;
6788  }
6789  }
6790  }
6791  else if ( StrICmp(name,(UBYTE *)"mctsdecaymode") == 0 ) {
6792  x = 0;
6793  u = value;
6794  if ( FG.cTable[*u] == 1 ) {
6795  while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6796  if ( *u != 0 ) {
6797  MesPrint("&Option MCTSDecayMode in Format,Optimize statement should be a nonnegative integer: %s",value);
6798  AO.Optimize.mctsdecaymode = 0;
6799  error = 1;
6800  }
6801  else {
6802  AO.Optimize.mctsdecaymode = x;
6803  }
6804  }
6805  else {
6806  AO.Optimize.mctsdecaymode = 0;
6807  MesPrint("&Unrecognized option value in Format,Optimize statement: %s=%s",name,value);
6808  error = 1;
6809  }
6810  }
6811  else if ( StrICmp(name,(UBYTE *)"saiter") == 0 ) {
6812  x = 0;
6813  u = value; while ( *u >= '0' && *u <= '9' ) x = 10*x + *u++ - '0';
6814  if ( *u != 0 ) {
6815  MesPrint("&Option SAIter in Format,Optimize statement should be a positive integer: %s",value);
6816  AO.Optimize.saIter = 0;
6817  error = 1;
6818  }
6819  else {
6820  AO.Optimize.saIter= x;
6821  }
6822  }
6823  else if ( StrICmp(name,(UBYTE *)"samaxt") == 0 ) {
6824  d = 0;
6825  if ( sscanf ((char*)value, "%lf", &d) != 1 ) {
6826  MesPrint("&Option SAMaxT in Format,Optimize statement should be a positive number: %s",value);
6827  AO.Optimize.saMaxT.fval = 0;
6828  error = 1;
6829  }
6830  else {
6831  AO.Optimize.saMaxT.fval = d;
6832  }
6833  }
6834  else if ( StrICmp(name,(UBYTE *)"samint") == 0 ) {
6835  d = 0;
6836  if ( sscanf ((char*)value, "%lf", &d) != 1 ) {
6837  MesPrint("&Option SAMinT in Format,Optimize statement should be a positive number: %s",value);
6838  AO.Optimize.saMinT.fval = 0;
6839  error = 1;
6840  }
6841  else {
6842  AO.Optimize.saMinT.fval = d;
6843  }
6844  }
6845  else {
6846  MesPrint("&Unrecognized option name in Format,Optimize statement: %s",name);
6847  error = 1;
6848  }
6849  *t1 = c1; *t2 = c2;
6850  }
6851  return(error);
6852 }
6853 
6854 /*
6855  #] CoOptimizeOption :
6856  #[ DoPutInside :
6857 
6858  Syntax:
6859  PutIn[side],functionname[,brackets] -> par = 1
6860  AntiPutIn[side],functionname,antibrackets -> par = -1
6861 */
6862 
6863 int CoPutInside(UBYTE *inp) { return(DoPutInside(inp,1)); }
6864 int CoAntiPutInside(UBYTE *inp) { return(DoPutInside(inp,-1)); }
6865 
6866 int DoPutInside(UBYTE *inp, int par)
6867 {
6868  GETIDENTITY
6869  UBYTE *p, c;
6870  WORD *to, type, c1,c2,funnum, *WorkSave;
6871  int error = 0;
6872  while ( *inp == ' ' || *inp == '\t' || *inp == ',' ) inp++;
6873 /*
6874  First we need the name of a function. (Not a tensor or table!)
6875 */
6876  p = SkipAName(inp);
6877  if ( p == 0 ) return(1);
6878  c = *p; *p = 0;
6879  type = GetName(AC.varnames,inp,&funnum,WITHAUTO);
6880  if ( type != CFUNCTION || functions[funnum].tabl != 0 || functions[funnum].spec ) {
6881  MesPrint("&PutInside/AntiPutInside expects a regular function for its first argument");
6882  MesPrint("&Argument is %s",inp);
6883  error = 1;
6884  }
6885  funnum += FUNCTION;
6886  *p = c;
6887  inp = p;
6888  while ( *inp == ' ' || *inp == '\t' || *inp == ',' ) inp++;
6889  if ( *inp == 0 ) {
6890  if ( par == 1 ) {
6891  WORD tocompiler[4];
6892  tocompiler[0] = TYPEPUTINSIDE;
6893  tocompiler[1] = 4;
6894  tocompiler[2] = 0;
6895  tocompiler[3] = funnum;
6896  AddNtoL(4,tocompiler);
6897  }
6898  else {
6899  MesPrint("&AntiPutInside needs inside information.");
6900  error = 1;
6901  }
6902  return(error);
6903  }
6904  WorkSave = to = AT.WorkPointer;
6905  *to++ = TYPEPUTINSIDE;
6906  *to++ = 4;
6907  *to++ = par;
6908  *to++ = funnum;
6909  to++;
6910  while ( *inp ) {
6911  while ( *inp == ' ' || *inp == '\t' || *inp == ',' ) inp++;
6912  if ( *inp == 0 ) break;
6913  p = SkipAName(inp);
6914  if ( p == 0 ) { error = 1; break; }
6915  c = *p; *p = 0;
6916  type = GetName(AC.varnames,inp,&c1,WITHAUTO);
6917  if ( c == '.' ) {
6918  if ( type == CVECTOR || type == CDUBIOUS ) {
6919  *p++ = c;
6920  inp = p;
6921  p = SkipAName(inp);
6922  if ( p == 0 ) return(1);
6923  c = *p; *p = 0;
6924  type = GetName(AC.varnames,inp,&c2,WITHAUTO);
6925  if ( type != CVECTOR && type != CDUBIOUS ) {
6926  MesPrint("&Not a vector in dotproduct in PutInside/AntiPutInside statement: %s",inp);
6927  error = 1;
6928  }
6929  else type = CDOTPRODUCT;
6930  }
6931  else {
6932  MesPrint("&Illegal use of . after %s in PutInside/AntiPutInside statement",inp);
6933  error = 1;
6934  *p = c; inp = p;
6935  continue;
6936  }
6937  }
6938  switch ( type ) {
6939  case CSYMBOL :
6940  *to++ = SYMBOL; *to++ = 4; *to++ = c1; *to++ = 1; break;
6941  case CVECTOR :
6942  *to++ = INDEX; *to++ = 3; *to++ = AM.OffsetVector + c1; break;
6943  case CFUNCTION :
6944  *to++ = c1+FUNCTION; *to++ = FUNHEAD; *to++ = 0;
6945  FILLFUN3(to)
6946  break;
6947  case CDOTPRODUCT :
6948  *to++ = DOTPRODUCT; *to++ = 5; *to++ = c1 + AM.OffsetVector;
6949  *to++ = c2 + AM.OffsetVector; *to++ = 1; break;
6950  case CDELTA :
6951  *to++ = DELTA; *to++ = 4; *to++ = EMPTYINDEX; *to++ = EMPTYINDEX; break;
6952  default :
6953  MesPrint("&Illegal variable request for %s in PutInside/AntiPutInside statement",inp);
6954  error = 1; break;
6955  }
6956  *p = c;
6957  inp = p;
6958  }
6959  *to++ = 1; *to++ = 1; *to++ = 3;
6960  AT.WorkPointer[1] = to - AT.WorkPointer;
6961  AT.WorkPointer[4] = AT.WorkPointer[1]-4;
6962  AT.WorkPointer = to;
6963  AC.BracketNormalize = 1;
6964  if ( Normalize(BHEAD WorkSave+4) ) { error = 1; }
6965  else {
6966  WorkSave[1] = WorkSave[4]+4;
6967  to = WorkSave + WorkSave[1] - 1;
6968  c1 = ABS(*to);
6969  WorkSave[1] -= c1;
6970  WorkSave[4] -= c1;
6971  AddNtoL(WorkSave[1],WorkSave);
6972  }
6973  AC.BracketNormalize = 0;
6974  AT.WorkPointer = WorkSave;
6975  return(error);
6976 }
6977 
6978 /*
6979  #] DoPutInside :
6980 */
WORD bufferssize
Definition: structs.h:366
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
int numtree
Definition: structs.h:362
int sparse
Definition: structs.h:361
struct TaBlEs * spare
Definition: structs.h:351
int inicbufs(VOID)
Definition: comtool.c:47
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition: comtool.c:143
WORD ** lhs
Definition: structs.h:925
Definition: structs.h:921
WORD * Pointer
Definition: structs.h:924
int AddNtoL(int n, WORD *array)
Definition: comtool.c:288
WORD * tablepointers
Definition: structs.h:338
int MaxTreeSize
Definition: structs.h:364
WORD bufnum
Definition: structs.h:365
WORD * AddLHS(int num)
Definition: comtool.c:188
WORD buffersfill
Definition: structs.h:367
MINMAX * mm
Definition: structs.h:346
VOID LowerSortLevel()
Definition: sort.c:4610
COMPTREE * boomlijst
Definition: structs.h:348
WORD * Buffer
Definition: structs.h:922
int MakeInverses()
Definition: reken.c:1430
WORD NewSort(PHEAD0)
Definition: sort.c:589
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3034
WORD * Top
Definition: structs.h:923
int rootnum
Definition: structs.h:363
WORD * flags
Definition: structs.h:347
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:675