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