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