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