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