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