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