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