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