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