FORM v5.0.2-2-gfb12f2e
proces.c
Go to the documentation of this file.
1
6/* #[ License : */
7/*
8 * Copyright (C) 1984-2026 J.A.M. Vermaseren
9 * When using this file you are requested to refer to the publication
10 * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
11 * This is considered a matter of courtesy as the development was paid
12 * for by FOM the Dutch physics granting agency and we would like to
13 * be able to track its scientific use to convince FOM of its value
14 * for the community.
15 *
16 * This file is part of FORM.
17 *
18 * FORM is free software: you can redistribute it and/or modify it under the
19 * terms of the GNU General Public License as published by the Free Software
20 * Foundation, either version 3 of the License, or (at your option) any later
21 * version.
22 *
23 * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
24 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
25 * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
26 * details.
27 *
28 * You should have received a copy of the GNU General Public License along
29 * with FORM. If not, see <http://www.gnu.org/licenses/>.
30 */
31/* #] License : */
32/*
33#define HIDEDEBUG
34 #[ Includes : proces.c
35*/
36
37#include "form3.h"
38
39WORD printscratch[2];
40
41/*
42 #] Includes :
43 #[ Processor :
44 #[ Processor : WORD Processor()
45*/
64int Processor(void)
65{
66 GETIDENTITY
67 WORD *term, *t, i, size;
68 int retval = 0;
69 EXPRESSIONS e;
70 POSITION position;
71 WORD last, LastExpression, fromspectator;
72 LONG dd = 0;
73 CBUF *C = cbuf+AC.cbufnum;
74 int firstterm;
75 CBUF *CC = cbuf+AT.ebufnum;
76 WORD **w, *cpo, *cbo;
77 FILEHANDLE *curfile, *oldoutfile = AR.outfile;
78 WORD oldBracketOn = AR.BracketOn;
79 WORD *oldBrackBuf = AT.BrackBuf;
80 WORD oldbracketindexflag = AT.bracketindexflag;
81#ifdef WITHPTHREADS
82 int OldMultiThreaded = AS.MultiThreaded, Oldmparallelflag = AC.mparallelflag;
83#endif
84 if ( CC->numrhs > 0 || CC->numlhs > 0 ) {
85 if ( CC->rhs ) {
86 w = CC->rhs; i = CC->numrhs;
87 do { *w++ = 0; } while ( --i > 0 );
88 }
89 if ( CC->lhs ) {
90 w = CC->lhs; i = CC->numlhs;
91 do { *w++ = 0; } while ( --i > 0 );
92 }
93 CC->numlhs = CC->numrhs = 0;
94 ClearTree(AT.ebufnum);
95 CC->Pointer = CC->Buffer;
96 }
97
98 if ( NumExpressions == 0 ) return(0);
99 AR.expflags = 0;
100 AR.CompressPointer = AR.CompressBuffer;
101 AR.NoCompress = AC.NoCompress;
102 term = AT.WorkPointer;
103 if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer) ) > AT.WorkTop ) {
104 MesWork();
105 }
106 UpdatePositions();
107 C->rhs[C->numrhs+1] = C->Pointer;
108 AR.KeptInHold = 0;
109 if ( AC.CollectFun ) AR.DeferFlag = 0;
110 AR.outtohide = 0;
111 AN.PolyFunTodo = 0;
112#ifdef HIDEDEBUG
113 MesPrint("Status at the start of Processor (HideLevel = %d)",AC.HideLevel);
114 MesPrint("File %s POfill %l POfull %l POsize %l", AR.infile->name ,AR.infile->POfill -AR.infile->PObuffer ,AR.infile->POfull -AR.infile->PObuffer ,AR.infile->POsize/sizeof(WORD) );
115 MesPrint("File %s POfill %l POfull %l POsize %l", AR.outfile->name ,AR.outfile->POfill -AR.outfile->PObuffer ,AR.outfile->POfull -AR.outfile->PObuffer ,AR.outfile->POsize/sizeof(WORD) );
116 MesPrint("File %s POfill %l POfull %l POsize %l", AR.hidefile->name ,AR.hidefile->POfill-AR.hidefile->PObuffer,AR.hidefile->POfull-AR.hidefile->PObuffer,AR.hidefile->POsize/sizeof(WORD));
117 for ( i = 0; i < NumExpressions; i++ ) {
118 e = Expressions+i;
119 ExprStatus(e);
120 }
121#endif
122/*
123 Next determine the last expression. This is used for removing the
124 input file when the final stage of the sort of this expression is
125 reached. That can save up to 1/3 in disk space.
126*/
127 for ( i = NumExpressions-1; i >= 0; i-- ) {
128 e = Expressions+i;
129 if ( e->status == LOCALEXPRESSION || e->status == GLOBALEXPRESSION
130 || e->status == HIDELEXPRESSION || e->status == HIDEGEXPRESSION
131 || e->status == SKIPLEXPRESSION || e->status == SKIPGEXPRESSION
132 || e->status == UNHIDELEXPRESSION || e->status == UNHIDEGEXPRESSION
133 || e->status == INTOHIDELEXPRESSION || e->status == INTOHIDEGEXPRESSION
134 ) break;
135 }
136 last = i;
137 for ( i = NumExpressions-1; i >= 0; i-- ) {
138 AS.OldOnFile[i] = Expressions[i].onfile;
139 AS.OldNumFactors[i] = Expressions[i].numfactors;
140/* AS.Oldvflags[i] = e[i].vflags; */
141 AS.Oldvflags[i] = Expressions[i].vflags;
142 AS.Olduflags[i] = Expressions[i].uflags;
143 Expressions[i].vflags &= ~(ISUNMODIFIED|ISZERO);
144 }
145#ifdef WITHPTHREADS
146/*
147 When we run with threads we have to make sure that all local input
148 buffers are pointed correctly. Of course this isn't needed if we
149 run on a single thread only.
150*/
151 if ( AC.partodoflag && AM.totalnumberofthreads > 1 ) {
152 AS.MultiThreaded = 1; AC.mparallelflag = PARALLELFLAG;
153 }
154 if ( AS.MultiThreaded && AC.mparallelflag == PARALLELFLAG ) {
155 SetWorkerFiles();
156 }
157/*
158 We start with running the expressions with expr->partodo in parallel.
159 The current model is: give each worker an expression. Wait for
160 workers to finish and tell them where to write.
161 Then give them a new expression. Workers may have to wait for each
162 other. This is also the case with the last one.
163*/
164 if ( AS.MultiThreaded && AC.mparallelflag == PARALLELFLAG ) {
165 if ( InParallelProcessor() ) {
166 retval = 1;
167 }
168 AS.MultiThreaded = OldMultiThreaded;
169 AC.mparallelflag = Oldmparallelflag;
170 }
171#endif
172#ifdef WITHMPI
173 if ( AC.RhsExprInModuleFlag && PF.rhsInParallel && (AC.mparallelflag == PARALLELFLAG || AC.partodoflag) ) {
174 if ( PF_BroadcastRHS() ) {
175 retval = -1;
176 }
177 }
178 PF.exprtodo = -1; /* This means, the slave does not perform inparallel */
179 if ( AC.partodoflag > 0 ) {
180 if ( PF_InParallelProcessor() ) {
181 retval = -1;
182 }
183 }
184#endif
185 for ( i = 0; i < NumExpressions; i++ ) {
186#ifdef INNERTEST
187 if ( AC.InnerTest ) {
188 if ( StrCmp(AC.TestValue,(UBYTE *)INNERTEST) == 0 ) {
189 MesPrint("Testing(Processor): value = %s",AC.TestValue);
190 }
191 }
192#endif
193 e = Expressions+i;
194#ifdef WITHPTHREADS
195 if ( AC.partodoflag > 0 && e->partodo > 0 && AM.totalnumberofthreads > 2 ) {
196 e->partodo = 0;
197 continue;
198 }
199#endif
200#ifdef WITHMPI
201 if ( AC.partodoflag > 0 && e->partodo > 0 && PF.numtasks > 2 ) {
202 e->partodo = 0;
203 continue;
204 }
205#endif
206 AS.CollectOverFlag = 0;
207 AR.expchanged = 0;
208 if ( i == last ) LastExpression = 1;
209 else LastExpression = 0;
210 if ( e->inmem ) {
211/*
212 #[ in memory : Memory allocated by poly.c only thusfar.
213 Here GetTerm cannot work.
214 For the moment we ignore this for parallelization.
215*/
216 WORD j;
217
218 AR.GetFile = 0;
219 SetScratch(AR.infile,&(e->onfile));
220 if ( GetTerm(BHEAD term) <= 0 ) {
221/* INTERNAL_ERROR_EXCL_START */
222 MesPrint("!>(1) Expression %d has problems in scratchfile",i);
223 retval = -1;
224 break;
225/* INTERNAL_ERROR_EXCL_STOP */
226 }
227 term[3] = i;
228 AR.CurExpr = i;
229 SeekScratch(AR.outfile,&position);
230 e->onfile = position;
231 if ( PutOut(BHEAD term,&position,AR.outfile,0) < 0 ) goto ProcErr;
232 AR.DeferFlag = AC.ComDefer;
233 NewSort(BHEAD0);
234 AN.ninterms = 0;
235 t = e->inmem;
236 while ( *t ) {
237 for ( j = 0; j < *t; j++ ) term[j] = t[j];
238 t += *t;
239 AN.ninterms++; dd = AN.deferskipped;
240 if ( AC.CollectFun && *term <= (AM.MaxTer/(2*(LONG)(sizeof(WORD)))) ) {
241 if ( GetMoreFromMem(term,&t) ) {
242 LowerSortLevel(); goto ProcErr;
243 }
244 }
245 AT.WorkPointer = term + *term;
246 AN.RepPoint = AT.RepCount + 1;
247 AN.IndDum = AM.IndDum;
248 AR.CurDum = ReNumber(BHEAD term);
249 if ( AC.SymChangeFlag ) MarkDirty(term,DIRTYSYMFLAG);
250 if ( AN.ncmod ) {
251 if ( ( AC.modmode & ALSOFUNARGS ) != 0 ) MarkDirty(term,DIRTYFLAG);
252 else if ( AR.PolyFun ) PolyFunDirty(BHEAD term);
253 }
254 else if ( AC.PolyRatFunChanged ) PolyFunDirty(BHEAD term);
255 if ( Generator(BHEAD term,0) ) {
256 LowerSortLevel(); goto ProcErr;
257 }
258 AN.ninterms += dd;
259 }
260 AN.ninterms += dd;
261 if ( EndSort(BHEAD AM.S0->sBuffer,0) < 0 ) goto ProcErr;
262 if ( AM.S0->TermsLeft ) e->vflags &= ~ISZERO;
263 else e->vflags |= ISZERO;
264 if ( AR.expchanged == 0 ) e->vflags |= ISUNMODIFIED;
265 if ( AM.S0->TermsLeft ) AR.expflags |= ISZERO;
266 if ( AR.expchanged ) AR.expflags |= ISUNMODIFIED;
267 AR.GetFile = 0;
268/*
269 #] in memory :
270*/
271 }
272 else {
273 AR.CurExpr = i;
274 switch ( e->status ) {
275 case UNHIDELEXPRESSION:
276 case UNHIDEGEXPRESSION:
277 AR.GetFile = 2;
278#ifdef WITHMPI
279 if ( PF.me == MASTER ) SetScratch(AR.hidefile,&(e->onfile));
280#else
281 SetScratch(AR.hidefile,&(e->onfile));
282 AR.InHiBuf = AR.hidefile->POfull-AR.hidefile->POfill;
283#ifdef HIDEDEBUG
284 MesPrint("Hidefile: onfile: %15p, POposition: %15p, filesize: %15p",&(e->onfile)
285 ,&(AR.hidefile->POposition),&(AR.hidefile->filesize));
286 MesPrint("Set hidefile to buffer position %l/%l; AR.InHiBuf = %l"
287 ,(AR.hidefile->POfill-AR.hidefile->PObuffer)*sizeof(WORD)
288 ,(AR.hidefile->POfull-AR.hidefile->PObuffer)*sizeof(WORD)
289 ,AR.InHiBuf
290 );
291#endif
292#endif
293 curfile = AR.hidefile;
294 goto commonread;
295 case INTOHIDELEXPRESSION:
296 case INTOHIDEGEXPRESSION:
297 AR.outtohide = 1;
298/*
299 BugFix 12-feb-2016
300 This may not work when the file is open and we move around.
301 AR.hidefile->POfill = AR.hidefile->POfull;
302*/
303 SetEndHScratch(AR.hidefile,&position);
304 /* fall through */
305 case LOCALEXPRESSION:
306 case GLOBALEXPRESSION:
307 AR.GetFile = 0;
308/*[20oct2009 mt]:*/
309#ifdef WITHMPI
310 if( ( PF.me == MASTER ) || (PF.mkSlaveInfile) )
311#endif
312 SetScratch(AR.infile,&(e->onfile));
313/*:[20oct2009 mt]*/
314 curfile = AR.infile;
315commonread:;
316#ifdef WITHMPI
317 if ( PF_Processor(e,i,LastExpression) ) {
318 MesPrint("Error in PF_Processor");
319 goto ProcErr;
320 }
321/*[20oct2009 mt]:*/
322 if ( AC.mparallelflag != PARALLELFLAG ){
323 if(PF.me != MASTER)
324 break;
325#endif
326/*:[20oct2009 mt]*/
327 if ( GetTerm(BHEAD term) <= 0 ) {
328#ifdef HIDEDEBUG
329 MesPrint("Error condition 1a");
330 ExprStatus(e);
331#endif
332/* INTERNAL_ERROR_EXCL_START */
333 MesPrint("!>(2) Expression %d has problems in scratchfile(process)",i);
334 retval = -1;
335 break;
336/* INTERNAL_ERROR_EXCL_STOP */
337 }
338 term[3] = i;
339 if ( term[5] < 0 ) { /* Fill with spectator */
340 fromspectator = -term[5];
341 PUTZERO(AM.SpectatorFiles[fromspectator-1].readpos);
342 term[5] = AC.cbufnum;
343 }
344 else fromspectator = 0;
345 if ( AR.outtohide ) {
346 SeekScratch(AR.hidefile,&position);
347 e->onfile = position;
348 if ( PutOut(BHEAD term,&position,AR.hidefile,0) < 0 ) goto ProcErr;
349 }
350 else {
351 SeekScratch(AR.outfile,&position);
352 e->onfile = position;
353 if ( PutOut(BHEAD term,&position,AR.outfile,0) < 0 ) goto ProcErr;
354 }
355 AR.DeferFlag = AC.ComDefer;
356 AR.Eside = RHSIDE;
357 if ( ( e->vflags & ISFACTORIZED ) != 0 ) {
358 AR.BracketOn = 1;
359 AT.BrackBuf = AM.BracketFactors;
360 AT.bracketindexflag = 1;
361 }
362 if ( AT.bracketindexflag > 0 ) OpenBracketIndex(i);
363#ifdef WITHPTHREADS
364 if ( AS.MultiThreaded && AC.mparallelflag == PARALLELFLAG ) {
365 if ( ThreadsProcessor(e,LastExpression,fromspectator) ) {
366/* INTERNAL_ERROR_EXCL_START */
367 MesPrint("!>Error in ThreadsProcessor");
368 goto ProcErr;
369/* INTERNAL_ERROR_EXCL_STOP */
370 }
371 if ( AR.outtohide ) {
372 AR.outfile = oldoutfile;
373 AR.hidefile->POfull = AR.hidefile->POfill;
374 }
375 }
376 else
377#endif
378 {
379 NewSort(BHEAD0);
380 AR.MaxDum = AM.IndDum;
381 AN.ninterms = 0;
382 for(;;) {
383 if ( fromspectator ) size = GetFromSpectator(term,fromspectator-1);
384 else size = GetTerm(BHEAD term);
385 if ( size <= 0 ) break;
386 SeekScratch(curfile,&position);
387 if ( ( e->vflags & ISFACTORIZED ) != 0 && term[1] == HAAKJE ) {
388 StoreTerm(BHEAD term);
389 }
390 else {
391 AN.ninterms++; dd = AN.deferskipped;
392 if ( AC.CollectFun && *term <= (AM.MaxTer/(2*(LONG)(sizeof(WORD)))) ) {
393 if ( GetMoreTerms(term) < 0 ) {
394 LowerSortLevel(); goto ProcErr;
395 }
396 SeekScratch(curfile,&position);
397 }
398 AT.WorkPointer = term + *term;
399 AN.RepPoint = AT.RepCount + 1;
400 if ( AR.DeferFlag ) {
401 AN.IndDum = Expressions[AR.CurExpr].numdummies + AM.IndDum;
402 AR.CurDum = AN.IndDum;
403 }
404 else {
405 AN.IndDum = AM.IndDum;
406 AR.CurDum = ReNumber(BHEAD term);
407 }
408 if ( AC.SymChangeFlag ) MarkDirty(term,DIRTYSYMFLAG);
409 if ( AN.ncmod ) {
410 if ( ( AC.modmode & ALSOFUNARGS ) != 0 ) MarkDirty(term,DIRTYFLAG);
411 else if ( AR.PolyFun ) PolyFunDirty(BHEAD term);
412 }
413 else if ( AC.PolyRatFunChanged ) PolyFunDirty(BHEAD term);
414 if ( ( AR.PolyFunType == 2 ) && ( AC.PolyRatFunChanged == 0 )
415 && ( e->status == LOCALEXPRESSION || e->status == GLOBALEXPRESSION ) ) {
416 PolyFunClean(BHEAD term);
417 }
418 if ( Generator(BHEAD term,0) ) {
419 LowerSortLevel(); goto ProcErr;
420 }
421 AN.ninterms += dd;
422 }
423 SetScratch(curfile,&position);
424 if ( AR.GetFile == 2 ) {
425 AR.InHiBuf = (curfile->POfull-curfile->PObuffer)
426 -DIFBASE(position,curfile->POposition)/sizeof(WORD);
427 }
428 else {
429 AR.InInBuf = (curfile->POfull-curfile->PObuffer)
430 -DIFBASE(position,curfile->POposition)/sizeof(WORD);
431 }
432 }
433 AN.ninterms += dd;
434 if ( LastExpression ) {
435 UpdateMaxSize();
436 if ( AR.infile->handle >= 0 ) {
437 CloseFile(AR.infile->handle);
438 AR.infile->handle = -1;
439 remove(AR.infile->name);
440 PUTZERO(AR.infile->POposition);
441 }
442 AR.infile->POfill = AR.infile->POfull = AR.infile->PObuffer;
443 }
444 if ( AR.outtohide ) AR.outfile = AR.hidefile;
445 if ( EndSort(BHEAD AM.S0->sBuffer,0) < 0 ) goto ProcErr;
446 if ( AR.outtohide ) {
447 AR.outfile = oldoutfile;
448 AR.hidefile->POfull = AR.hidefile->POfill;
449 }
450 e->numdummies = AR.MaxDum - AM.IndDum;
451 UpdateMaxSize();
452 }
453 AR.BracketOn = oldBracketOn;
454 AT.BrackBuf = oldBrackBuf;
455 if ( ( e->vflags & TOBEFACTORED ) != 0 ) {
456 poly_factorize_expression(e);
457 }
458 else if ( ( ( e->vflags & TOBEUNFACTORED ) != 0 )
459 && ( ( e->vflags & ISFACTORIZED ) != 0 ) ) {
460 poly_unfactorize_expression(e);
461 }
462 AT.bracketindexflag = oldbracketindexflag;
463 if ( AM.S0->TermsLeft ) e->vflags &= ~ISZERO;
464 else e->vflags |= ISZERO;
465 if ( AR.expchanged == 0 ) e->vflags |= ISUNMODIFIED;
466 if ( AM.S0->TermsLeft ) AR.expflags |= ISZERO;
467 if ( AR.expchanged ) AR.expflags |= ISUNMODIFIED;
468 AR.GetFile = 0;
469 AR.outtohide = 0;
470/*[20oct2009 mt]:*/
471#ifdef WITHMPI
472 }
473#endif
474#ifdef WITHPTHREADS
475 if ( e->status == INTOHIDELEXPRESSION ||
476 e->status == INTOHIDEGEXPRESSION ) {
477 SetHideFiles();
478 }
479#endif
480 break;
481 case SKIPLEXPRESSION:
482 case SKIPGEXPRESSION:
483/*
484 This can be greatly improved of course by file-to-file copy.
485*/
486#ifdef WITHMPI
487 if ( PF.me != MASTER ) break;
488#endif
489 AR.GetFile = 0;
490 SetScratch(AR.infile,&(e->onfile));
491 if ( GetTerm(BHEAD term) <= 0 ) {
492#ifdef HIDEDEBUG
493 MesPrint("Error condition 1b");
494 ExprStatus(e);
495#endif
496/* INTERNAL_ERROR_EXCL_START */
497 MesPrint("!>(3) Expression %d has problems in scratchfile",i);
498 retval = -1;
499 break;
500/* INTERNAL_ERROR_EXCL_STOP */
501 }
502 term[3] = i;
503 AR.DeferFlag = 0;
504 SeekScratch(AR.outfile,&position);
505 e->onfile = position;
506 *AM.S0->sBuffer = 0; firstterm = -1;
507 do {
508 WORD *oldipointer = AR.CompressPointer;
509 WORD *comprtop = AR.ComprTop;
510 AR.ComprTop = AM.S0->sTop;
511 AR.CompressPointer = AM.S0->sBuffer;
512 if ( firstterm > 0 ) {
513 if ( PutOut(BHEAD term,&position,AR.outfile,1) < 0 ) goto ProcErr;
514 }
515 else if ( firstterm < 0 ) {
516 if ( PutOut(BHEAD term,&position,AR.outfile,0) < 0 ) goto ProcErr;
517 firstterm++;
518 }
519 else {
520 if ( PutOut(BHEAD term,&position,AR.outfile,-1) < 0 ) goto ProcErr;
521 firstterm++;
522 }
523 AR.CompressPointer = oldipointer;
524 AR.ComprTop = comprtop;
525 } while ( GetTerm(BHEAD term) );
526 if ( FlushOut(&position,AR.outfile,1) ) goto ProcErr;
527 UpdateMaxSize();
528 break;
529 case HIDELEXPRESSION:
530 case HIDEGEXPRESSION:
531#ifdef WITHMPI
532 if ( PF.me != MASTER ) break;
533#endif
534 AR.GetFile = 0;
535 SetScratch(AR.infile,&(e->onfile));
536 if ( GetTerm(BHEAD term) <= 0 ) {
537#ifdef HIDEDEBUG
538 MesPrint("Error condition 1c");
539 ExprStatus(e);
540#endif
541/* INTERNAL_ERROR_EXCL_START */
542 MesPrint("!>(4) Expression %d has problems in scratchfile",i);
543 retval = -1;
544 break;
545/* INTERNAL_ERROR_EXCL_STOP */
546 }
547 term[3] = i;
548 AR.DeferFlag = 0;
549 SetEndHScratch(AR.hidefile,&position);
550 e->onfile = position;
551#ifdef HIDEDEBUG
552 if ( AR.hidefile->handle >= 0 ) {
553 POSITION possize,pos;
554 PUTZERO(possize);
555 PUTZERO(pos);
556 SeekFile(AR.hidefile->handle,&pos,SEEK_CUR);
557 SeekFile(AR.hidefile->handle,&possize,SEEK_END);
558 SeekFile(AR.hidefile->handle,&pos,SEEK_SET);
559 MesPrint("Processor Hide1: filesize(th) = %12p, filesize(ex) = %12p",&(position),
560 &(possize));
561 MesPrint(" in buffer: %l",(AR.hidefile->POfill-AR.hidefile->PObuffer)*sizeof(WORD));
562 }
563#endif
564 *AM.S0->sBuffer = 0; firstterm = -1;
565 cbo = cpo = AM.S0->sBuffer;
566 do {
567 WORD *oldipointer = AR.CompressPointer;
568 WORD *oldibuffer = AR.CompressBuffer;
569 WORD *comprtop = AR.ComprTop;
570 AR.ComprTop = AM.S0->sTop;
571 AR.CompressPointer = cpo;
572 AR.CompressBuffer = cbo;
573 if ( firstterm > 0 ) {
574 if ( PutOut(BHEAD term,&position,AR.hidefile,1) < 0 ) goto ProcErr;
575 }
576 else if ( firstterm < 0 ) {
577 if ( PutOut(BHEAD term,&position,AR.hidefile,0) < 0 ) goto ProcErr;
578 firstterm++;
579 }
580 else {
581 if ( PutOut(BHEAD term,&position,AR.hidefile,-1) < 0 ) goto ProcErr;
582 firstterm++;
583 }
584 cpo = AR.CompressPointer;
585 cbo = AR.CompressBuffer;
586 AR.CompressPointer = oldipointer;
587 AR.CompressBuffer = oldibuffer;
588 AR.ComprTop = comprtop;
589 } while ( GetTerm(BHEAD term) );
590#ifdef HIDEDEBUG
591 if ( AR.hidefile->handle >= 0 ) {
592 POSITION possize,pos;
593 PUTZERO(possize);
594 PUTZERO(pos);
595 SeekFile(AR.hidefile->handle,&pos,SEEK_CUR);
596 SeekFile(AR.hidefile->handle,&possize,SEEK_END);
597 SeekFile(AR.hidefile->handle,&pos,SEEK_SET);
598 MesPrint("Processor Hide2: filesize(th) = %12p, filesize(ex) = %12p",&(position),
599 &(possize));
600 MesPrint(" in buffer: %l",(AR.hidefile->POfill-AR.hidefile->PObuffer)*sizeof(WORD));
601 }
602#endif
603 if ( FlushOut(&position,AR.hidefile,1) ) goto ProcErr;
604 AR.hidefile->POfull = AR.hidefile->POfill;
605#ifdef HIDEDEBUG
606 if ( AR.hidefile->handle >= 0 ) {
607 POSITION possize,pos;
608 PUTZERO(possize);
609 PUTZERO(pos);
610 SeekFile(AR.hidefile->handle,&pos,SEEK_CUR);
611 SeekFile(AR.hidefile->handle,&possize,SEEK_END);
612 SeekFile(AR.hidefile->handle,&pos,SEEK_SET);
613 MesPrint("Processor Hide3: filesize(th) = %12p, filesize(ex) = %12p",&(position),
614 &(possize));
615 MesPrint(" in buffer: %l",(AR.hidefile->POfill-AR.hidefile->PObuffer)*sizeof(WORD));
616 }
617#endif
618/*
619 Because we direct the e->onfile already to the hide file, we
620 need to change the status of the expression. Otherwise the use
621 of parts (or the whole) of the expression looks in the infile
622 while the position is that of the hide file.
623 We choose to get everything from the hide file. On average that
624 should give least file activity.
625*/
626 if ( e->status == HIDELEXPRESSION ) {
627 e->status = HIDDENLEXPRESSION;
628 AS.OldOnFile[i] = e->onfile;
629 AS.OldNumFactors[i] = Expressions[i].numfactors;
630 }
631 if ( e->status == HIDEGEXPRESSION ) {
632 e->status = HIDDENGEXPRESSION;
633 AS.OldOnFile[i] = e->onfile;
634 AS.OldNumFactors[i] = Expressions[i].numfactors;
635 }
636#ifdef WITHPTHREADS
637 SetHideFiles();
638#endif
639 UpdateMaxSize();
640 break;
641 case DROPPEDEXPRESSION:
642 case DROPLEXPRESSION:
643 case DROPGEXPRESSION:
644 case DROPHLEXPRESSION:
645 case DROPHGEXPRESSION:
646 case STOREDEXPRESSION:
647 case HIDDENLEXPRESSION:
648 case HIDDENGEXPRESSION:
649 case SPECTATOREXPRESSION:
650 default:
651 break;
652 }
653 }
654 AR.KeptInHold = 0;
655 }
656 AR.DeferFlag = 0;
657 AT.WorkPointer = term;
658#ifdef HIDEDEBUG
659 MesPrint("Status at the end of Processor (HideLevel = %d)",AC.HideLevel);
660 MesPrint("File %s POfill %l POfull %l POsize %l", AR.infile->name ,AR.infile->POfill -AR.infile->PObuffer ,AR.infile->POfull -AR.infile->PObuffer ,AR.infile->POsize/sizeof(WORD) );
661 MesPrint("File %s POfill %l POfull %l POsize %l", AR.outfile->name ,AR.outfile->POfill -AR.outfile->PObuffer ,AR.outfile->POfull -AR.outfile->PObuffer ,AR.outfile->POsize/sizeof(WORD) );
662 MesPrint("File %s POfill %l POfull %l POsize %l", AR.hidefile->name ,AR.hidefile->POfill-AR.hidefile->PObuffer,AR.hidefile->POfull-AR.hidefile->PObuffer,AR.hidefile->POsize/sizeof(WORD));
663 for ( i = 0; i < NumExpressions; i++ ) {
664 e = Expressions+i;
665 ExprStatus(e);
666 }
667#endif
668 return(retval);
669ProcErr:
670 AT.WorkPointer = term;
671 if ( AM.tracebackflag ) MesCall("Processor");
672 return(-1);
673}
674/*
675 #] Processor :
676 #[ TestSub : WORD TestSub(term,level)
677*/
701#define DONE(x) { retvalue = x; goto Done; }
702
703WORD TestSub(PHEAD WORD *term, WORD level)
704{
705 GETBIDENTITY
706 WORD *m, *t, *r, retvalue = 0, funflag, j, oldncmod, nexpr, *Tpattern = 0;
707 WORD *stop, *t1, *t2, funnum, wilds, tbufnum, stilldirty = 0;
708 NESTING n;
709 CBUF *C = cbuf+AT.ebufnum;
710 LONG isp, i, sizedelta, propagated, oldargsize, oldfunsize, oldtermsize;
711 WORD *oldendnest;
712 TABLES T;
713 COMPARE oldcompareroutine = (COMPARE)(AR.CompareRoutine);
714 WORD oldsorttype = AR.SortType;
715 const WORD oldRecFlag = AT.RecFlag;
716ReStart:
717 tbufnum = 0; i = 0; retvalue = 0;
718 AT.TMbuff = AM.rbufnum;
719 funflag = 0;
720 t = term;
721 r = t + *t - 1;
722 m = r - ABS(*r) + 1;
723 t++;
724 if ( t < m ) do {
725 if ( *t == SUBEXPRESSION ) {
726 /*
727 Subexpression encountered
728 There may be more than one.
729 The old strategy was to take the last.
730 A newer strategy was to take the lowest power first.
731 The current strategy is that we compute the number of terms
732 generated by this subexpression and take the minimum of that.
733 */
734
735#ifdef WHICHSUBEXPRESSION
736
737 WORD *tmin = t, AN.nbino;
738/* LONG minval = MAXLONG; */
739 LONG minval = -1;
740 LONG mm, mnum1 = 1;
741 if ( AN.BinoScrat == 0 ) {
742 AN.BinoScrat = (UWORD *)Malloc1((AM.MaxTal+2)*sizeof(UWORD),"GetBinoScrat");
743 }
744#endif
745 if ( t[3] ) {
746 r = t + t[1];
747 while ( AN.subsubveto == 0 &&
748 *r == SUBEXPRESSION && r < m && r[3] ) {
749#ifdef WHICHSUBEXPRESSION
750 mnum1++;
751#endif
752 if ( r[1] == t[1] && r[2] == t[2] && r[4] == t[4] ) {
753 j = t[1] - SUBEXPSIZE;
754 t1 = t + SUBEXPSIZE;
755 t2 = r + SUBEXPSIZE;
756 while ( j > 0 && *t1++ == *t2++ ) j--;
757 if ( j <= 0 ) {
758 t[3] += r[3];
759 if ( t[3] == 0 ) {
760 t1 = r + r[1];
761 t2 = term + *term;
762 *term -= r[1]+t[1];
763 r = t;
764 while ( t1 < t2 ) *r++ = *t1++;
765 goto ReStart;
766 }
767 else {
768 t1 = r + r[1];
769 t2 = term + *term;
770 *term -= r[1];
771 m -= r[1];
772 while ( t1 < t2 ) *r++ = *t1++;
773 r = t;
774 }
775 }
776 }
777#ifdef WHICHSUBEXPRESSION
778
779 else if ( t[2] >= 0 ) {
780/*
781 Compute Binom(numterms+power-1,power-1)
782 We need potentially long arithmetic.
783 That is why we had to allocate AN.BinoScrat
784*/
785 if ( AN.last1 == t[3] && AN.last2 == cbuf[t[4]].NumTerms[t[2]] + t[3] - 1 ) {
786 if ( AN.last3 > minval ) {
787 minval = AN.last3; tmin = t;
788 }
789 }
790 else {
791 AN.last1 = t[3]; mm = AN.last2 = cbuf[t[4]].NumTerms[t[2]] + t[3] - 1;
792 if ( t[3] == 1 ) {
793 if ( mm > minval ) {
794 minval = mm; tmin = t;
795 }
796 }
797 else if ( t[3] > 0 ) {
798 if ( mm > MAXPOSITIVE ) goto TooMuch;
799 GetBinom(AN.BinoScrat,&AN.nbino,(WORD)mm,t[3]);
800 if ( AN.nbino > 2 ) goto TooMuch;
801 if ( AN.nbino == 2 ) {
802 mm = AN.BinoScrat[1];
803 mm = ( mm << BITSINWORD ) + AN.BinoScrat[0];
804 }
805 else if ( AN.nbino == 1 ) mm = AN.BinoScrat[0];
806 else mm = 0;
807 if ( mm > minval ) {
808 minval = mm; tmin = t;
809 }
810 }
811 AN.last3 = mm;
812 }
813 }
814#endif
815 t = r;
816 r += r[1];
817 }
818#ifdef WHICHSUBEXPRESSION
819 if ( mnum1 > 1 && t[2] >= 0 ) {
820/*
821 To keep the flowcontrol simple we duplicate some code here
822*/
823 if ( AN.last1 == t[3] && AN.last2 == cbuf[t[4]].NumTerms[t[2]] + t[3] - 1 ) {
824 if ( AN.last3 > minval ) {
825 minval = AN.last3; tmin = t;
826 }
827 }
828 else {
829 AN.last1 = t[3]; mm = AN.last2 = cbuf[t[4]].NumTerms[t[2]] + t[3] - 1;
830 if ( t[3] == 1 ) {
831 if ( mm > minval ) {
832 minval = mm; tmin = t;
833 }
834 }
835 else if ( t[3] > 0 ) {
836 if ( mm > MAXPOSITIVE ) {
837/*
838 We will generate more terms than we can count
839*/
840TooMuch:;
841/* INTERNAL_ERROR_EXCL_START */
842 MLOCK(ErrorMessageLock);
843 MesPrint("!>Attempt to generate more terms than FORM can count");
844 MUNLOCK(ErrorMessageLock);
845 Terminate(-1);
846/* INTERNAL_ERROR_EXCL_STOP */
847 }
848 GetBinom(AN.BinoScrat,&AN.nbino,(WORD)mm,t[3]);
849 if ( AN.nbino > 2 ) goto TooMuch;
850 if ( AN.nbino == 2 ) {
851 mm = AN.BinoScrat[1];
852 mm = ( mm << BITSINWORD ) + AN.BinoScrat[0];
853 }
854 else if ( AN.nbino == 1 ) mm = AN.BinoScrat[0];
855 else mm = 0;
856 if ( mm > minval ) {
857 minval = mm; tmin = t;
858 }
859 }
860 AN.last3 = mm;
861 }
862 }
863 t = tmin;
864#endif
865/* AR.TePos = 0; */
866 AR.TePos = WORDDIF(t,term);
867 AT.TMbuff = t[4];
868 if ( t[4] == AM.dbufnum && (t+t[1]) < m && t[t[1]] == DOLLAREXPR2 ) {
869 if ( t[t[1]+2] < 0 ) AT.TMdolfac = -t[t[1]+2];
870 else { /* resolve the element number */
871 AT.TMdolfac = GetDolNum(BHEAD t+t[1],m)+1;
872 }
873 }
874 else AT.TMdolfac = 0;
875 if ( t[3] < 0 ) {
876 AN.TeInFun = 1;
877 AR.TePos = WORDDIF(t,term);
878 DONE(t[2])
879 }
880 else {
881 AN.TeInFun = 0;
882 AN.TeSuOut = t[3];
883 }
884 if ( t[2] < 0 ) {
885 AN.TeSuOut = -t[3];
886 DONE(-t[2])
887 }
888 DONE(t[2])
889 }
890 }
891 else if ( *t == EXPRESSION ) {
892 WORD *toTMaddr;
893 i = -t[2] - 1;
894 if ( t[3] < 0 ) {
895 AN.TeInFun = 1;
896 AR.TePos = WORDDIF(t,term);
897 DONE(i)
898 }
899 nexpr = t[3];
900 toTMaddr = m = AT.WorkPointer;
901 AN.Frozen = 0;
902/*
903 We have to be very careful with respect to setting variables
904 like AN.TeInFun, because we may still call Generator and that
905 may change those variables. That is why we set them at the
906 last moment only.
907*/
908 j = t[1];
909 AT.WorkPointer += j;
910 r = t;
911 NCOPY(m,r,j);
912 r = t + t[1];
913 t += SUBEXPSIZE;
914 while ( t < r ) {
915 if ( *t == FROMBRAC ) {
916 WORD *ttstop,*tttstop;
917/*
918 Note: Convention is that wildcards are done
919 after the expression has been picked up. So
920 no wildcard substitutions are needed here.
921*/
922 t += 2;
923 AN.Frozen = m = AT.WorkPointer;
924/*
925 We should check now for subexpressions and if necessary
926 we substitute them. Keep in mind: only one term allowed!
927
928 In retrospect (26-jan-2010): take also functions that
929 have a dirty flag on
930*/
931 j = *t; tttstop = t + j;
932 GETSTOP(t,ttstop);
933 *m++ = j; t++;
934 while ( t < ttstop ) {
935 if ( *t == SUBEXPRESSION ) break;
936 if ( *t >= FUNCTION && ( ( t[2] & DIRTYFLAG ) == DIRTYFLAG ) ) break;
937 j = t[1]; NCOPY(m,t,j);
938 }
939 if ( t < ttstop ) {
940/*
941 We ran into a subexpression or a function with a
942 'dirty' argument. It could also be a $ or
943 just e[(a^2)*b]. In all cases we should evaluate
944*/
945 while ( t < tttstop ) *m++ = *t++;
946 *AT.WorkPointer = m-AT.WorkPointer;
947 m = AT.WorkPointer;
948 AT.WorkPointer = m + *m;
949 NewSort(BHEAD0);
950 if ( Generator(BHEAD m,AR.Cnumlhs) ) {
951 LowerSortLevel(); goto EndTest;
952 }
953 if ( EndSort(BHEAD m,0) < 0 ) goto EndTest;
954 AN.Frozen = m;
955 if ( *m == 0 ) {
956 *m++ = 4; *m++ = 1; *m++ = 1; *m++ = 3;
957 }
958 else if ( m[*m] != 0 ) {
959 MLOCK(ErrorMessageLock);
960 MesPrint("Bracket specification in expression should be one single term");
961 MUNLOCK(ErrorMessageLock);
962 Terminate(-1);
963 }
964 else {
965 m += *m;
966 m -= ABS(m[-1]);
967 *m++ = 1; *m++ = 1; *m++ = 3;
968 *AN.Frozen = m - AN.Frozen;
969 }
970 }
971 else {
972 while ( t < tttstop ) *m++ = *t++;
973 *AT.WorkPointer = m-AT.WorkPointer;
974 m = AT.WorkPointer;
975 AT.WorkPointer = m + *m;
976 if ( Normalize(BHEAD m) ) {
977/* INTERNAL_ERROR_EXCL_START */
978 MLOCK(ErrorMessageLock);
979 MesPrint("!>Error while picking up contents of bracket");
980 MUNLOCK(ErrorMessageLock);
981 Terminate(-1);
982/* INTERNAL_ERROR_EXCL_STOP */
983 }
984 if ( !*m ) {
985 *m++ = 4; *m++ = 1; *m++ = 1; *m++ = 3;
986 }
987 else m += *m;
988 }
989 AT.WorkPointer = m;
990 break;
991 }
992 t += t[1];
993 }
994 AN.TeInFun = 0;
995 AR.TePos = 0;
996 AN.TeSuOut = nexpr;
997 AT.TMaddr = toTMaddr;
998 DONE(i)
999 }
1000 else if ( *t >= FUNCTION ) {
1001 if ( t[0] == EXPONENT ) {
1002 if ( t[1] == FUNHEAD+4 && t[FUNHEAD] == -SYMBOL &&
1003 t[FUNHEAD+2] == -SNUMBER && t[FUNHEAD+3] < MAXPOWER
1004 && t[FUNHEAD+3] > -MAXPOWER ) {
1005 t[0] = SYMBOL;
1006 t[1] = 4;
1007 t[2] = t[FUNHEAD+1];
1008 t[3] = t[FUNHEAD+3];
1009 r = term + *term;
1010 m = t + FUNHEAD+4;
1011 t += 4;
1012 while ( m < r ) *t++ = *m++;
1013 *term = WORDDIF(t,term);
1014 goto ReStart;
1015 }
1016 else if ( t[1] == FUNHEAD+ARGHEAD+11 && t[FUNHEAD] == ARGHEAD+9
1017 && t[FUNHEAD+ARGHEAD] == 9 && t[FUNHEAD+ARGHEAD+1] == DOTPRODUCT
1018 && t[FUNHEAD+ARGHEAD+8] == 3
1019 && t[FUNHEAD+ARGHEAD+7] == 1
1020 && t[FUNHEAD+ARGHEAD+6] == 1
1021 && t[FUNHEAD+ARGHEAD+5] == 1
1022 && t[FUNHEAD+ARGHEAD+9] == -SNUMBER
1023 && t[FUNHEAD+ARGHEAD+10] < MAXPOWER
1024 && t[FUNHEAD+ARGHEAD+10] > -MAXPOWER ) {
1025 t[0] = DOTPRODUCT;
1026 t[1] = 5;
1027 t[2] = t[FUNHEAD+ARGHEAD+3];
1028 t[3] = t[FUNHEAD+ARGHEAD+4];
1029 t[4] = t[FUNHEAD+ARGHEAD+10];
1030 r = term + *term;
1031 m = t + FUNHEAD+ARGHEAD+11;
1032 t += 5;
1033 while ( m < r ) *t++ = *m++;
1034 *term = WORDDIF(t,term);
1035 goto ReStart;
1036 }
1037 }
1038 funnum = *t;
1039 if ( *t >= FUNCTION + WILDOFFSET ) funnum -= WILDOFFSET;
1040 if ( *t == EXPONENT ) {
1041/*
1042 Test whether the second argument is an integer
1043*/
1044 r = t+FUNHEAD;
1045 NEXTARG(r)
1046 if ( *r == -SNUMBER && r[1] < MAXPOWER && r+2 == t+t[1] &&
1047 t[FUNHEAD] > -FUNCTION && ( t[FUNHEAD] != -SNUMBER
1048 || t[FUNHEAD+1] != 0 ) && t[FUNHEAD] != ARGHEAD ) {
1049 if ( r[1] == 0 ) {
1050 if ( t[FUNHEAD] == -SNUMBER && t[FUNHEAD+1] == 0 ) {
1051 MLOCK(ErrorMessageLock);
1052 MesPrint("Encountered 0^0. Fatal error.");
1053 MUNLOCK(ErrorMessageLock);
1054 SETERROR(-1);
1055 }
1056 *t = DUMMYFUN;
1057/*
1058 Now mark it clean to avoid further interference.
1059 Normalize will remove this object.
1060*/
1061 t[2] = 0;
1062 }
1063 else {
1064 /* Note that the case 0^ is treated in Normalize */
1065
1066 t1 = AddRHS(AT.ebufnum,1);
1067 m = t + FUNHEAD;
1068 if ( *m > 0 ) {
1069 m += ARGHEAD;
1070 i = t[FUNHEAD] - ARGHEAD;
1071 while ( (t1 + i + 10) > C->Top )
1072 t1 = DoubleCbuffer(AT.ebufnum,t1,9);
1073 while ( --i >= 0 ) *t1++ = *m++;
1074 }
1075 else {
1076 if ( (t1 + 20) > C->Top )
1077 t1 = DoubleCbuffer(AT.ebufnum,t1,10);
1078 ToGeneral(m,t1,1);
1079 t1 += *t1;
1080 }
1081 *t1++ = 0;
1082 C->rhs[C->numrhs+1] = t1;
1083 C->Pointer = t1;
1084
1085 /* No provisions yet for commuting objects */
1086
1087 C->CanCommu[C->numrhs] = 1;
1088 *t++ = SUBEXPRESSION;
1089 *t++ = SUBEXPSIZE;
1090 *t++ = C->numrhs;
1091 *t++ = r[1];
1092 *t++ = AT.ebufnum;
1093#if SUBEXPSIZE > 5
1094Important: we may not have enough spots here
1095#endif
1096 FILLSUB(t) /* Important: We have maybe only 5 spots! */
1097 r += 2;
1098 m = term + *term;
1099 do { *t++ = *r++; } while ( r < m );
1100 *term -= WORDDIF(r,t);
1101 goto ReStart;
1102 }
1103 }
1104 }
1105 else if ( *t == SUMF1 || *t == SUMF2 ) {
1106/*
1107 What we are looking for is:
1108 1-st argument: Single symbol or index.
1109 2-nd argument: Number.
1110 3-rd argument: Number.
1111 (4-th argument):Number.
1112 One more argument.
1113 This would activate the summation procedure.
1114 Note that the initiated recursion here can be done
1115 without upsetting the regular procedures.
1116*/
1117 WORD *tstop, lcounter, lcmin, lcmax, lcinc;
1118 tstop = t + t[1];
1119 r = t+FUNHEAD;
1120 if ( r+6 < tstop && r[2] == -SNUMBER && r[4] == -SNUMBER
1121 && ( ( r[0] == -SYMBOL )
1122 || ( r[0] == -INDEX && r[1] >= AM.OffsetIndex
1123 && r[3] >= 0 && r[3] < AM.OffsetIndex
1124 && r[5] >= 0 && r[5] < AM.OffsetIndex ) ) ) {
1125 lcounter = r[0] == -INDEX ? -r[1]: r[1]; /* The loop counter */
1126 lcmin = r[3];
1127 lcmax = r[5];
1128 r += 6;
1129 if ( *r == -SNUMBER && r+2 < tstop ) {
1130 lcinc = r[1];
1131 r += 2;
1132 }
1133 else lcinc = 1;
1134 if ( r < tstop && ( ( *r > 0 && (r+*r) == tstop )
1135 || ( *r <= -FUNCTION && r+1 == tstop )
1136 || ( *r > -FUNCTION && *r < 0 && r+2 == tstop ) ) ) {
1137 m = AddRHS(AT.ebufnum,1);
1138 if ( *r > 0 ) {
1139 i = *r - ARGHEAD;
1140 r += ARGHEAD;
1141 while ( (m + i + 10) > C->Top )
1142 m = DoubleCbuffer(AT.ebufnum,m,11);
1143 while ( --i >= 0 ) *m++ = *r++;
1144 }
1145 else {
1146 while ( (m + 20) > C->Top )
1147 m = DoubleCbuffer(AT.ebufnum,m,12);
1148 ToGeneral(r,m,1);
1149 m += *m;
1150 }
1151 *m++ = 0;
1152 C->rhs[C->numrhs+1] = m;
1153 C->Pointer = m;
1154 m = AT.TMout;
1155 *m++ = 6;
1156 if ( *t == SUMF1 ) *m++ = SUMNUM1;
1157 else *m++ = SUMNUM2;
1158 *m++ = lcounter;
1159 *m++ = lcmin;
1160 *m++ = lcmax;
1161 *m++ = lcinc;
1162 m = t + t[1];
1163 r = C->rhs[C->numrhs];
1164/*
1165 Test now if the argument was already evaluated.
1166 In that case it needs a new subexpression prototype.
1167 In either case we replace the function now by a
1168 subexpression prototype.
1169*/
1170 if ( *r >= (SUBEXPSIZE+4)
1171 && ABS(*(r+*r-1)) < (*r - 1)
1172 && r[1] == SUBEXPRESSION ) {
1173 r++;
1174 i = r[1] - 5;
1175 *t++ = *r++; *t++ = *r++; *t++ = C->numrhs;
1176 r++; *t++ = *r++; *t++ = AT.ebufnum; r++;
1177 while ( --i >= 0 ) *t++ = *r++;
1178 }
1179 else {
1180 *t++ = SUBEXPRESSION;
1181 *t++ = 4+SUBEXPSIZE;
1182 *t++ = C->numrhs;
1183 *t++ = 1;
1184 *t++ = AT.ebufnum;
1185 FILLSUB(t)
1186 if ( lcounter < 0 ) {
1187 *t++ = INDTOIND;
1188 *t++ = 4;
1189 *t++ = -lcounter;
1190 }
1191 else {
1192 *t++ = SYMTONUM;
1193 *t++ = 4;
1194 *t++ = lcounter;
1195 }
1196 *t++ = lcmin;
1197 }
1198 t2 = term + *term;
1199 while ( m < t2 ) *t++ = *m++;
1200 *term = WORDDIF(t,term);
1201 AN.TeInFun = -C->numrhs;
1202 AR.TePos = 0;
1203 AN.TeSuOut = 0;
1204 AT.TMbuff = AT.ebufnum;
1205 DONE(C->numrhs)
1206 }
1207 }
1208 }
1209 else if ( *t == TOPOLOGIES ) {
1210 MesPrint("&The topologies_ function was removed in FORM 5.0.");
1211 MesPrint("&See the TopologiesOnly_ option of diagrams_.");
1212 Terminate(-1);
1213 }
1214 else if ( *t == DIAGRAMS ) {
1215/*
1216 Syntax:
1217 diagrams_(model,setinparticles,setoutparticles,
1218 setextmomenta,setintmomenta,couplings or loops)
1219*/
1220 if ( AC.nummodels > 0 ) { /* No model, no diagrams */
1221 t1 = t+FUNHEAD; t2 = t+t[1];
1222 if (
1223 t1[0] == -SETSET && Sets[t1[1]].type == CMODEL &&
1224 t1[2] == -SETSET && ( Sets[t1[3]].type == CFUNCTION
1225 || ( Sets[t1[3]].type == ANYTYPE && ( Sets[t1[3]].first == Sets[t1[3]].last ) ) ) &&
1226 t1[4] == -SETSET && ( Sets[t1[5]].type == CFUNCTION
1227 || ( Sets[t1[5]].type == ANYTYPE && ( Sets[t1[5]].first == Sets[t1[5]].last ) ) ) &&
1228 t1[6] == -SETSET && ( Sets[t1[7]].type == CVECTOR
1229 || ( Sets[t1[7]].type == ANYTYPE && ( Sets[t1[7]].first == Sets[t1[7]].last ) ) ) &&
1230 t1[8] == -SETSET && ( Sets[t1[9]].type == CVECTOR
1231 || ( Sets[t1[9]].type == ANYTYPE && ( Sets[t1[9]].first == Sets[t1[9]].last ) ) ) &&
1232 t1+12 <= t2 ) {
1233/*
1234 Test that the sets of particles correspond to particles
1235 of the set model.
1236*/
1237 MODEL *m = AC.models[SetElements[Sets[t1[1]].first]];
1238 int nn0,nn1,nn2;
1239 for ( nn0 = 3; nn0 <= 5; nn0 += 2 ) {
1240 for ( nn1 = Sets[t1[nn0]].first; nn1 < Sets[t1[nn0]].last; nn1++ ) {
1241 for ( nn2 = 0; nn2 < m->nparticles; nn2++ ) {
1242 if ( m->vertices[nn2]->particles[0].number == SetElements[nn1]
1243 || m->vertices[nn2]->particles[1].number == SetElements[nn1] ) break;
1244 }
1245 if ( nn2 >= m->nparticles ) goto doesnotwork;
1246 }
1247 }
1248/*
1249 Now test for a single argument indicating the order
1250 in perturbation theory.
1251*/
1252 if ( ( t1[10] == -SNUMBER && t1[11] >= 0 && t1+12 == t2 )
1253 || ( t1[10] == -SYMBOL && t1+12 == t2 )
1254 || ( t1+10+t1[10] == t2 && t1+10+ARGHEAD+t1[10+ARGHEAD] == t2
1255 && t1[11+ARGHEAD] == SYMBOL ) ) {
1256/*
1257 Now test that all symbols are valid coupling constants.
1258*/
1259 if ( t1+12 > t2 ) {
1260 WORD *tt1 = t1+13+ARGHEAD, im;
1261 t2 -= ABS(t2[-1]);
1262 while ( tt1 < t2 ) {
1263 for ( im = 0; im < m->ncouplings; im++ ) {
1264 if ( *tt1 == m->couplings[im] ) break;
1265 }
1266 if ( im >= m->ncouplings ) goto doesnotwork;
1267 tt1 += 2;
1268 }
1269 }
1270 AN.TeInFun = -15;
1271 AN.TeSuOut = 0;
1272 AR.TePos = -1;
1273 AR.funoffset = t - term;
1274 DONE(1)
1275 }
1276 else if ( ( ( t1[10] == -SNUMBER && t1[11] >= 0 && t1+12 == t2-2 )
1277 || ( t1[10] == -SYMBOL && t1+12 == t2-2 )
1278 || ( t1+10+t1[10] == t2-2 && t1+10+ARGHEAD+t1[10+ARGHEAD] == t2-2
1279 && t1[11+ARGHEAD] == SYMBOL ) ) && t2[-2] == -SNUMBER ) {
1280/*
1281 With options at t2[-2],t2[-1]
1282 Now test that all symbols are valid coupling constants.
1283*/
1284 t2 -= 2;
1285 if ( t1+12 > t2 ) {
1286 WORD *tt1 = t1+13+ARGHEAD, im;
1287 t2 -= ABS(t2[-1]);
1288 while ( tt1 < t2 ) {
1289 for ( im = 0; im < m->ncouplings; im++ ) {
1290 if ( *tt1 == m->couplings[im] ) break;
1291 }
1292 if ( im >= m->ncouplings ) goto doesnotwork;
1293 tt1 += 2;
1294 }
1295 }
1296 AN.TeInFun = -15;
1297 AN.TeSuOut = 0;
1298 AR.TePos = -1;
1299 AR.funoffset = t - term;
1300 DONE(1)
1301 }
1302doesnotwork:;
1303 }
1304 }
1305 }
1306 if ( functions[funnum-FUNCTION].spec <= 0
1307 || ( t[2] & (DIRTYFLAG|MUSTCLEANPRF) ) != 0 ) {
1308 funflag = 1;
1309 }
1310 if ( *t <= MAXBUILTINFUNCTION ) {
1311 if ( *t <= DELTAP && *t >= THETA ) { /* Speeds up by 2 or 3 compares */
1312 if ( *t == THETA || *t == THETA2 ) {
1313 WORD *tstop, *tt2, kk;
1314 tstop = t + t[1];
1315 tt2 = t + FUNHEAD;
1316 while ( tt2 < tstop ) {
1317 if ( *tt2 > 0 && tt2[1] != 0 ) goto DoSpec;
1318 NEXTARG(tt2)
1319 }
1320 if ( !AT.RecFlag ) {
1321 if ( ( kk = DoTheta(BHEAD t) ) == 0 ) {
1322 *term = 0;
1323 DONE(0)
1324 }
1325 else if ( kk > 0 ) {
1326 m = t + t[1];
1327 r = term + *term;
1328 while ( m < r ) *t++ = *m++;
1329 *term = WORDDIF(t,term);
1330 goto ReStart;
1331 }
1332 }
1333 }
1334 else if ( *t == DELTA2 || *t == DELTAP ) {
1335 WORD *tstop, *tt2, kk;
1336 tstop = t + t[1];
1337 tt2 = t + FUNHEAD;
1338 while ( tt2 < tstop ) {
1339 if ( *tt2 > 0 && tt2[1] != 0 ) goto DoSpec;
1340 NEXTARG(tt2)
1341 }
1342 if ( !AT.RecFlag ) {
1343 if ( ( kk = DoDelta(t) ) == 0 ) {
1344 *term = 0;
1345 DONE(0)
1346 }
1347 else if ( kk > 0 ) {
1348 m = t + t[1];
1349 r = term + *term;
1350 while ( m < r ) *t++ = *m++;
1351 *term = WORDDIF(t,term);
1352 goto ReStart;
1353 }
1354 }
1355 } }
1356 else if ( *t == DISTRIBUTION && t[FUNHEAD] == -SNUMBER
1357 && t[FUNHEAD+1] >= -2 && t[FUNHEAD+1] <= 2
1358 && t[FUNHEAD+2] == -SNUMBER
1359 && t[FUNHEAD+4] <= -FUNCTION
1360 && t[FUNHEAD+5] <= -FUNCTION ) {
1361 WORD *ttt = t+FUNHEAD+6, *tttstop = t+t[1];
1362 while ( ttt < tttstop ) {
1363 if ( *ttt == -DOLLAREXPRESSION ) break;
1364 NEXTARG(ttt);
1365 }
1366 if ( ttt >= tttstop ) {
1367 AN.TeInFun = -1;
1368 AN.TeSuOut = 0;
1369 AR.TePos = -1;
1370 DONE(1)
1371 }
1372 }
1373 else if ( *t == DELTA3 && ((t[1]-FUNHEAD) & 1 ) == 0 ) {
1374 AN.TeInFun = -2;
1375 AN.TeSuOut = 0;
1376 AR.TePos = -1;
1377 DONE(1)
1378 }
1379 else if ( ( *t == TABLEFUNCTION ) && ( t[FUNHEAD] <= -FUNCTION )
1380 && ( T = functions[-t[FUNHEAD]-FUNCTION].tabl ) != 0
1381 && ( t[1] >= FUNHEAD+1+2*ABS(T->numind) )
1382 && ( t[FUNHEAD+1] == -SYMBOL ) ) {
1383/*
1384 The case of table_(tab,sym1,...,symn)
1385*/
1386 for ( isp = 0; isp < ABS(T->numind); isp++ ) {
1387 if ( t[FUNHEAD+1+2*isp] != -SYMBOL ) break;
1388 }
1389 if ( isp >= ABS(T->numind) ) {
1390 AN.TeInFun = -3;
1391 AN.TeSuOut = 0;
1392 AR.TePos = -1;
1393 DONE(1)
1394 }
1395 }
1396 else if ( *t == TABLEFUNCTION && t[FUNHEAD] <= -FUNCTION
1397 && ( T = functions[-t[FUNHEAD]-FUNCTION].tabl ) != 0
1398 && ( t[1] == FUNHEAD+2 )
1399 && ( t[FUNHEAD+1] <= -FUNCTION ) ) {
1400/*
1401 The case of table_(tab,fun)
1402*/
1403 AN.TeInFun = -3;
1404 AN.TeSuOut = 0;
1405 AR.TePos = -1;
1406 DONE(1)
1407 }
1408 else if ( *t == FACTORIN ) {
1409 if ( t[1] == FUNHEAD+2 && t[FUNHEAD] == -DOLLAREXPRESSION ) {
1410 AN.TeInFun = -4;
1411 AN.TeSuOut = 0;
1412 AR.TePos = -1;
1413 DONE(1)
1414 }
1415 else if ( t[1] == FUNHEAD+2 && t[FUNHEAD] == -EXPRESSION ) {
1416 AN.TeInFun = -5;
1417 AN.TeSuOut = 0;
1418 AR.TePos = -1;
1419 DONE(1)
1420 }
1421 }
1422 else if ( *t == TERMSINBRACKET ) {
1423 if ( t[1] == FUNHEAD || (
1424 t[1] == FUNHEAD+2
1425 && t[FUNHEAD] == -SNUMBER
1426 && t[FUNHEAD+1] == 0
1427 ) ) {
1428 AN.TeInFun = -6;
1429 AN.TeSuOut = 0;
1430 AR.TePos = -1;
1431 DONE(1)
1432 }
1433/*
1434 The other cases have not yet been implemented
1435 We still have to add the case of short arguments
1436 First the different bracket in same expression
1437
1438 else if ( t[1] > FUNHEAD+ARGHEAD
1439 && t[FUNHEAD] == t[1]-FUNHEAD
1440 && t[FUNHEAD+ARGHEAD] == t[1]-FUNHEAD-ARGHEAD
1441 && t[t[1]-1] == 3
1442 && t[t[1]-2] == 1
1443 && t[t[1]-3] == 1 ) {
1444 AN.TeInFun = -6;
1445 AN.TeSuOut = 0;
1446 AR.TePos = -1;
1447 DONE(1)
1448 }
1449
1450 Next the bracket in an other expression
1451
1452 else if ( t[1] > FUNHEAD+ARGHEAD+2
1453 && t[FUNHEAD] == -EXPRESSION
1454 && t[FUNHEAD+2] == t[1]-FUNHEAD-2
1455 && t[FUNHEAD+ARGHEAD+2] == t[1]-FUNHEAD-ARGHEAD-2
1456 && t[t[1]-1] == 3
1457 && t[t[1]-2] == 1
1458 && t[t[1]-3] == 1 ) {
1459 AN.TeInFun = -6;
1460 AN.TeSuOut = 0;
1461 AR.TePos = -1;
1462 DONE(1)
1463 }
1464*/
1465 }
1466 else if ( *t == EXTRASYMFUN ) {
1467 if ( t[1] == FUNHEAD+2 && (
1468 ( t[FUNHEAD] == -SNUMBER && t[FUNHEAD+1] <= cbuf[AM.sbufnum].numrhs
1469 && t[FUNHEAD+1] > 0 ) ||
1470 ( t[FUNHEAD] == -SYMBOL && t[FUNHEAD+1] < MAXVARIABLES
1471 && t[FUNHEAD+1] >= MAXVARIABLES-cbuf[AM.sbufnum].numrhs ) ) ) {
1472 AN.TeInFun = -7;
1473 AN.TeSuOut = 0;
1474 AR.TePos = -1;
1475 DONE(1)
1476 }
1477 else if ( t[1] == FUNHEAD ) {
1478 AN.TeInFun = -7;
1479 AN.TeSuOut = 0;
1480 AR.TePos = -1;
1481 DONE(1)
1482 }
1483 }
1484 else if ( *t == DIVFUNCTION || *t == REMFUNCTION
1485 || *t == INVERSEFUNCTION || *t == MULFUNCTION
1486 || *t == GCDFUNCTION ) {
1487 WORD *tf;
1488 int todo = 1, numargs = 0;
1489 tf = t + FUNHEAD;
1490 while ( tf < t + t[1] ) {
1491 DOLLARS d;
1492 if ( *tf == -DOLLAREXPRESSION ) {
1493 d = Dollars + tf[1];
1494 if ( d->type == DOLWILDARGS ) {
1495 WORD *tterm = AT.WorkPointer, *tw;
1496 WORD *ta = term, *tb = tterm, *tc, *td = term + *term;
1497 while ( ta < t ) *tb++ = *ta++;
1498 tc = tb;
1499 while ( ta < tf ) *tb++ = *ta++;
1500 tw = d->where+1;
1501 while ( *tw ) {
1502 if ( *tw < 0 ) {
1503 if ( *tw > -FUNCTION ) *tb++ = *tw++;
1504 *tb++ = *tw++;
1505 }
1506 else {
1507 int ia;
1508 for ( ia = 0; ia < *tw; ia++ ) *tb++ = *tw++;
1509 }
1510 }
1511 NEXTARG(ta)
1512 while ( ta < t+t[1] ) *tb++ = *ta++;
1513 tc[1] = tb-tc;
1514 while ( ta < td ) *tb++ = *ta++;
1515 *tterm = tb - tterm;
1516 {
1517 int ia, na = *tterm;
1518 ta = tterm; tb = term;
1519 for ( ia = 0; ia < na; ia++ ) *tb++ = *ta++;
1520 }
1521 if ( tb > AT.WorkTop ) {
1522 MLOCK(ErrorMessageLock);
1523 MesWork();
1524 goto EndTest2;
1525 }
1526 AT.WorkPointer = tb;
1527 goto ReStart;
1528 }
1529 }
1530 NEXTARG(tf);
1531 }
1532 tf = t + FUNHEAD;
1533 while ( tf < t + t[1] ) {
1534 numargs++;
1535 if ( *tf > 0 && tf[1] != 0 ) todo = 0;
1536 NEXTARG(tf);
1537 }
1538 if ( todo && numargs == 2 ) {
1539 if ( *t == DIVFUNCTION ) AN.TeInFun = -9;
1540 else if ( *t == REMFUNCTION ) AN.TeInFun = -10;
1541 else if ( *t == INVERSEFUNCTION ) AN.TeInFun = -11;
1542 else if ( *t == MULFUNCTION ) AN.TeInFun = -14;
1543 else if ( *t == GCDFUNCTION ) AN.TeInFun = -8;
1544 AN.TeSuOut = 0;
1545 AR.TePos = -1;
1546 DONE(1)
1547 }
1548 else if ( todo && numargs == 3 ) {
1549 if ( *t == DIVFUNCTION ) AN.TeInFun = -9;
1550 else if ( *t == REMFUNCTION ) AN.TeInFun = -10;
1551 else if ( *t == GCDFUNCTION ) AN.TeInFun = -8;
1552 AN.TeSuOut = 0;
1553 AR.TePos = -1;
1554 DONE(1)
1555 }
1556 else if ( todo && *t == GCDFUNCTION ) {
1557 AN.TeInFun = -8;
1558 AN.TeSuOut = 0;
1559 AR.TePos = -1;
1560 DONE(1)
1561 }
1562 }
1563 else if ( *t == PERMUTATIONS && ( ( t[1] >= FUNHEAD+1
1564 && t[FUNHEAD] <= -FUNCTION ) || ( t[1] >= FUNHEAD+3
1565 && t[FUNHEAD] == -SNUMBER && t[FUNHEAD+2] <= -FUNCTION ) ) ) {
1566 AN.TeInFun = -12;
1567 AN.TeSuOut = 0;
1568 AR.TePos = -1;
1569 DONE(1)
1570 }
1571 else if ( *t == PARTITIONS ) {
1572 if ( TestPartitions(t,&(AT.partitions)) ) {
1573 AT.partitions.where = t-term;
1574 AN.TeInFun = -13;
1575 AN.TeSuOut = 0;
1576 AR.TePos = -1;
1577 DONE(1)
1578 }
1579 }
1580 }
1581 }
1582 t += t[1];
1583 } while ( t < m );
1584 if ( funflag ) { /* Search in functions */
1585DoSpec:
1586 t = term;
1587 AT.NestPoin->termsize = t;
1588 if ( AT.NestPoin == AT.Nest ) AN.EndNest = t + *t;
1589 t++;
1590 oldncmod = AN.ncmod;
1591 if ( t < m ) do {
1592 if ( *t < FUNCTION ) {
1593 t += t[1]; continue;
1594 }
1595 if ( AN.ncmod && ( ( AC.modmode & ALSOFUNARGS ) == 0 ) ) {
1596 if ( *t != AR.PolyFun ) AN.ncmod = 0;
1597 else AN.ncmod = oldncmod;
1598 }
1599 r = t + t[1];
1600 funnum = *t;
1601 if ( *t >= FUNCTION + WILDOFFSET ) funnum -= WILDOFFSET;
1602 if ( ( *t == NUMFACTORS || *t == FIRSTTERM || *t == CONTENTTERM )
1603 && t[1] == FUNHEAD+2 &&
1604 ( t[FUNHEAD] == -EXPRESSION || t[FUNHEAD] == -DOLLAREXPRESSION ) ) {
1605/*
1606 if ( *t == NUMFACTORS ) {
1607 This we leave for Normalize
1608 }
1609*/
1610 }
1611 else if ( functions[funnum-FUNCTION].spec <= 0 ) {
1612 AT.NestPoin->funsize = t + 1;
1613 t1 = t;
1614 t += FUNHEAD;
1615 while ( t < r ) { /* Sum over arguments */
1616 if ( *t > 0 && t[1] ) { /* Argument is dirty */
1617 AT.NestPoin->argsize = t;
1618 AT.NestPoin++;
1619 if ( AT.NestPoin - AT.Nest >= AM.maxFlevels ) {
1620 MLOCK(ErrorMessageLock);
1621 // When we read maxFlevels from the setup, we add 1. So print
1622 // maxFlevels-1 here, so that the error message does not appear
1623 // inconsistent with what the user might have set.
1624 MesPrint("&FunctionLevels limit (%d) reached. Increase in setup.",
1625 AM.maxFlevels-1);
1626 MUNLOCK(ErrorMessageLock);
1627 Terminate(-1);
1628 }
1629 t2 = t;
1630 t += ARGHEAD;
1631 while ( t < AT.NestPoin[-1].argsize+*(AT.NestPoin[-1].argsize) ) {
1632 /* Sum over terms */
1633 AT.RecFlag++;
1634 i = *t;
1635 oldargsize = *t2;
1636 oldfunsize = t1[1];
1637 oldtermsize = *term;
1638 oldendnest = AN.EndNest;
1639 AN.subsubveto = 1;
1640 retvalue = TestSub(BHEAD t,level);
1641 if ( retvalue != 0 ) {
1642 sizedelta = *t - i;
1643 // A deeper argument may already have been resized by Normalising
1644 // in the WorkSpace; in this case the size change has already been
1645 // propagated through the whole nesting stack (see the Normalize +
1646 // Sort code below).
1647 // Remove the size shift that was already propagated, before dealing
1648 // with any remaining size change:
1649 propagated = *t2 - oldargsize;
1650 if ( ( t1[1] - oldfunsize == propagated )
1651 && ( *term - oldtermsize == propagated )
1652 && ( (LONG)(AN.EndNest - oldendnest) == propagated ) ) {
1653 sizedelta -= propagated;
1654 }
1655 if ( sizedelta < 0 ) {
1656 // The term became shorter. Fix the sizes at the current
1657 // level of nesting. Outer levels will each be fixed as
1658 // we leave the TestSub recursion.
1659 i = - sizedelta;
1660 *t2 -= i;
1661 t1[1] -= i;
1662 t += *t;
1663 r = t + i;
1664 m = term + *term;
1665 while ( r < m ) *t++ = *r++;
1666 *term -= i;
1667 }
1668 else if ( sizedelta > 0 ) {
1669/* INTERNAL_ERROR_EXCL_START */
1670 // The term became longer, in a way which was not already
1671 // propagated through the nesting stack. Can this ever happen?
1672 // The code here has never handled this case.
1673 MLOCK(ErrorMessageLock);
1674 MesPrint("!>TestSub: unexpected term size increase during recursion.");
1675 MUNLOCK(ErrorMessageLock);
1676 Terminate(-1);
1677/* INTERNAL_ERROR_EXCL_STOP */
1678 }
1679 AN.subsubveto = 0;
1680 t1[2] = 1;
1681 if ( *t1 == AR.PolyFun && AR.PolyFunType == 2 )
1682 t1[2] |= MUSTCLEANPRF;
1683 AT.RecFlag--;
1684 AT.NestPoin--;
1685 AN.TeInFun++;
1686 AR.TePos = 0;
1687 AN.ncmod = oldncmod;
1688 DONE(retvalue)
1689 }
1690 else {
1691 // For a long time, Normalize was called in-place here. This was
1692 // very dangerous, since Normalize can increase the size of the
1693 // term, and overwrite term data at outer nesting levels. We
1694 // can instead just rely on the Normalize call (which uses the
1695 // WorkSpace) just before calling StoreTerm later.
1696 WORD *tend = t + *t, *tt = t+1;
1697 stilldirty = 0;
1698 tend -= ABS(tend[-1]);
1699 while ( tt < tend ) {
1700 if ( *tt == SUBEXPRESSION || *tt == EXPRESSION ) {
1701 stilldirty = 1; break;
1702 }
1703 tt += tt[1];
1704 }
1705 }
1706 AN.subsubveto = 0;
1707 AT.RecFlag--;
1708 t += *t;
1709 }
1710 AT.NestPoin--;
1711/*
1712 Argument contains no subexpressions.
1713 It should be normalized and sorted.
1714 The main problem is the storage: we need to Normalize a copy of the
1715 term data in the WorkSpace, since Normalize can increase the size
1716 of the term, which would overwrite the data which follows!
1717*/
1718 t = AT.NestPoin->argsize;
1719 j = *t;
1720 t += ARGHEAD;
1721 NewSort(BHEAD0);
1722 if ( *t1 == AR.PolyFun && AR.PolyFunType == 2 ) {
1723 AR.CompareRoutine = (COMPAREDUMMY)(&CompareSymbols);
1724 AR.SortType = SORTHIGHFIRST;
1725 }
1726 if ( AT.WorkPointer < term + *term )
1727 AT.WorkPointer = term + *term;
1728
1729 while ( t < AT.NestPoin->argsize+*(AT.NestPoin->argsize) ) {
1730 m = AT.WorkPointer;
1731 r = t + *t;
1732 do { *m++ = *t++; } while ( t < r );
1733 r = AT.WorkPointer;
1734 AT.WorkPointer = r + *r;
1735 if ( Normalize(BHEAD r) ) {
1736 if ( *t1 == AR.PolyFun && AR.PolyFunType == 2 ) {
1737 AR.SortType = oldsorttype;
1738 AR.CompareRoutine = (COMPAREDUMMY)oldcompareroutine;
1739 t1[2] |= MUSTCLEANPRF;
1740 }
1741 LowerSortLevel(); goto EndTest;
1742 }
1743 if ( AN.ncmod != 0 ) {
1744 if ( *r ) {
1745 if ( Modulus(r) ) {
1746 LowerSortLevel();
1747 AT.WorkPointer = r;
1748 if ( *t1 == AR.PolyFun && AR.PolyFunType == 2 ) {
1749 AR.SortType = oldsorttype;
1750 AR.CompareRoutine = (COMPAREDUMMY)oldcompareroutine;
1751 t1[2] |= MUSTCLEANPRF;
1752 }
1753 goto EndTest;
1754 }
1755 }
1756 }
1757 if ( AR.PolyFun > 0 ) {
1758 if ( PrepPoly(BHEAD r,1) != 0 ) goto EndTest;
1759 }
1760 if ( *r ) StoreTerm(BHEAD r);
1761 AT.WorkPointer = r;
1762 }
1763 if ( EndSort(BHEAD AT.WorkPointer+ARGHEAD,1) < 0 ) goto EndTest;
1764 m = AT.WorkPointer+ARGHEAD;
1765 if ( *t1 == AR.PolyFun && AR.PolyFunType == 2 ) {
1766 AR.SortType = oldsorttype;
1767 AR.CompareRoutine = (COMPAREDUMMY)oldcompareroutine;
1768 t1[2] |= MUSTCLEANPRF;
1769 }
1770 while ( *m ) m += *m;
1771 i = WORDDIF(m,AT.WorkPointer);
1772 *AT.WorkPointer = i;
1773 AT.WorkPointer[1] = stilldirty;
1774 if ( ToFast(AT.WorkPointer,AT.WorkPointer) ) {
1775 m = AT.WorkPointer;
1776 if ( *m <= -FUNCTION ) { m++; i = 1; }
1777 else { m += 2; i = 2; }
1778 }
1779 j = i - j;
1780 if ( j > 0 ) {
1781 r = m + j;
1782 if ( r > AT.WorkTop ) {
1783 MLOCK(ErrorMessageLock);
1784 MesWork();
1785 goto EndTest2;
1786 }
1787 do { *--r = *--m; } while ( m > AT.WorkPointer );
1788 AT.WorkPointer = r;
1789 m = AN.EndNest;
1790 r = m + j;
1791 stop = AT.NestPoin->argsize+*(AT.NestPoin->argsize);
1792 do { *--r = *--m; } while ( m >= stop );
1793 }
1794 else if ( j < 0 ) {
1795 m = AT.NestPoin->argsize+*(AT.NestPoin->argsize);
1796 r = m + j;
1797 do { *r++ = *m++; } while ( m < AN.EndNest );
1798 }
1799 m = AT.NestPoin->argsize;
1800 r = AT.WorkPointer;
1801 while ( --i >= 0 ) *m++ = *r++;
1802 n = AT.Nest;
1803 while ( n <= AT.NestPoin ) {
1804 if ( *(n->argsize) > 0 && n != AT.NestPoin )
1805 *(n->argsize) += j;
1806 *(n->funsize) += j;
1807 *(n->termsize) += j;
1808 n++;
1809 }
1810 AN.EndNest += j;
1811/* (AT.NestPoin->argsize)[1] = 0; */
1812 if ( funnum == DENOMINATOR || funnum == EXPONENT ) {
1813 if ( Normalize(BHEAD term) ) {
1814/*
1815 In this case something has been substituted
1816 Either a $ or a replace_?????
1817 Originally we had here:
1818
1819 goto EndTest;
1820
1821 It seems better to restart.
1822*/
1823 AN.ncmod = oldncmod;
1824 goto ReStart;
1825 }
1826/*
1827 And size changes here?????
1828*/
1829 }
1830 AN.ncmod = oldncmod;
1831 goto ReStart;
1832 }
1833 else if ( *t == -DOLLAREXPRESSION ) {
1834 if ( ( *t1 == TERMSINEXPR || *t1 == SIZEOFFUNCTION )
1835 && t1[1] == FUNHEAD+2 ) {}
1836 else {
1837 if ( AR.Eside != LHSIDE ) {
1838 AN.TeInFun = 1; AR.TePos = 0;
1839 AT.TMbuff = AM.dbufnum; t1[2] |= DIRTYFLAG;
1840 AN.ncmod = oldncmod;
1841 DONE(1)
1842 }
1843 AC.lhdollarflag = 1;
1844 }
1845 }
1846 else if ( *t == -TERMSINBRACKET ) {
1847 if ( AR.Eside != LHSIDE ) {
1848 AN.TeInFun = 1; AR.TePos = 0;
1849 t1[2] |= DIRTYFLAG;
1850 AN.ncmod = oldncmod;
1851 DONE(1)
1852 }
1853 }
1854 else if ( AN.ncmod != 0 && *t == -SNUMBER ) {
1855 if ( AN.ncmod == 1 || AN.ncmod == -1 ) {
1856 isp = (UWORD)(AC.cmod[0]);
1857 isp = t[1] % isp;
1858 if ( ( AC.modmode & POSNEG ) != 0 ) {
1859 if ( isp > (UWORD)(AC.cmod[0])/2 ) isp = isp - (UWORD)(AC.cmod[0]);
1860 else if ( -isp > (UWORD)(AC.cmod[0])/2 ) isp = isp + (UWORD)(AC.cmod[0]);
1861 }
1862 else {
1863 if ( isp < 0 ) isp += (UWORD)(AC.cmod[0]);
1864 }
1865 if ( isp <= MAXPOSITIVE && isp >= -MAXPOSITIVE ) {
1866 t[1] = isp;
1867 }
1868 }
1869 }
1870 NEXTARG(t)
1871 }
1872 if ( funnum >= FUNCTION && functions[funnum-FUNCTION].tabl ) {
1873/*
1874 Test whether the table catches
1875 Test 1: index arguments and range. i will be the number
1876 of the element in the table.
1877*/
1878 WORD rhsnumber, *oldwork = AT.WorkPointer;
1879 WORD ii, *p, *pp, *ppstop;
1880 MINMAX *mm;
1881 T = functions[funnum-FUNCTION].tabl;
1882/*
1883 Because of tables with a variable number of indices
1884 we need to make a copy of the pattern.
1885 If we do this in the WorkSpace we get problems with EndNest.
1886 This is why we use TermMalloc.
1887 Now Tpattern is a copy that can be modified.
1888*/
1889#ifdef WITHPTHREADS
1890 pp = T->pattern[AT.identity];
1891#else
1892 pp = T->pattern;
1893#endif
1894 if ( Tpattern == 0 ) Tpattern = TermMalloc("Tpattern");
1895 p = Tpattern;
1896 ii = pp[1];
1897 for ( i = 0; i < ii; i++ ) *p++ = *pp++;
1898
1899 p = Tpattern + FUNHEAD+1;
1900 mm = T->mm;
1901 if ( T->sparse ) {
1902 WORD xx;
1903 t = t1+FUNHEAD;
1904 if ( T->numind == 0 ) { isp = 0; xx = 0; }
1905 else {
1906 if ( T->numind < 0 ) {
1907 if ( *t != -SNUMBER && t[2] != -SNUMBER ) {
1908 xx = ABS(T->numind);
1909 goto teststrict;
1910 }
1911 xx = t[1]+1;
1912 if ( xx < 2 || xx > -T->numind ) goto teststrict;
1913 }
1914 else xx = T->numind;
1915 for ( i = 0; i < xx; i++, t += 2 ) {
1916 if ( *t != -SNUMBER ) break;
1917 }
1918 if ( i < xx ) goto teststrict;
1919 isp = FindTableTree(T,t1+FUNHEAD,2);
1920 }
1921 if ( isp < 0 ) {
1922teststrict: if ( T->strict == -2 ) {
1923 rhsnumber = AM.zerorhs;
1924 tbufnum = AM.zbufnum;
1925 }
1926 else if ( T->strict == -3 ) {
1927 rhsnumber = AM.onerhs;
1928 tbufnum = AM.zbufnum;
1929 }
1930 else if ( T->strict < 0 ) goto NextFun;
1931 else {
1932 MLOCK(ErrorMessageLock);
1933 MesPrint("Element in table is undefined");
1934 if ( Tpattern ) {
1935 TermFree(Tpattern,"Tpattern");
1936 Tpattern = 0;
1937 }
1938 goto showtable;
1939 }
1940/*
1941 Copy the indices;
1942*/
1943 t = t1+FUNHEAD+1;
1944 for ( i = 0; i < xx; i++ ) {
1945 *p = *t; p+=2; t+=2;
1946 }
1947 }
1948 else {
1949 rhsnumber = T->tablepointers[isp+ABS(T->numind)];
1950#if ( TABLEEXTENSION == 2 )
1951 tbufnum = T->bufnum;
1952#else
1953 tbufnum = T->tablepointers[isp+ABS(T->numind)+1];
1954#endif
1955 t = t1+FUNHEAD+1;
1956 ii = xx;
1957 while ( --ii >= 0 ) {
1958 *p = *t; t += 2; p += 2;
1959 }
1960 }
1961 if ( xx < ABS(T->numind) ) {
1962 p--; ppstop = Tpattern+Tpattern[1];
1963 pp = p+2*(-T->numind-xx);
1964 while ( pp < ppstop ) *p++ = *pp++;
1965 Tpattern[1] = p - Tpattern;
1966 }
1967 goto caughttable;
1968 }
1969 else {
1970 i = 0;
1971 t = t1 + FUNHEAD;
1972 j = T->numind;
1973 while ( --j >= 0 ) {
1974 if ( *t != -SNUMBER ) goto NextFun;
1975 t++;
1976 if ( *t < mm->mini || *t > mm->maxi ) {
1977 if ( T->bounds ) {
1978 MLOCK(ErrorMessageLock);
1979 MesPrint("Table boundary check. Argument %d",
1980 T->numind-j);
1981showtable: AO.OutFill = AO.OutputLine = (UBYTE *)m;
1982 AO.OutSkip = 8;
1983 IniLine(0);
1984 WriteSubTerm(t1,1);
1985 FiniLine();
1986 MUNLOCK(ErrorMessageLock);
1987 if ( Tpattern ) {
1988 TermFree(Tpattern,"Tpattern");
1989 Tpattern = 0;
1990 }
1991 SETERROR(-1)
1992 }
1993 if ( Tpattern ) {
1994 TermFree(Tpattern,"Tpattern");
1995 Tpattern = 0;
1996 }
1997 goto NextFun;
1998 }
1999 i += ( *t - mm->mini ) * (LONG)(mm->size);
2000 *p = *t++;
2001 p += 2;
2002 mm++;
2003 }
2004/*
2005 Test now whether the entry exists.
2006*/
2007 i *= TABLEEXTENSION;
2008 if ( T->tablepointers[i] == -1 ) {
2009 if ( T->strict == -2 ) {
2010 rhsnumber = AM.zerorhs;
2011 tbufnum = AM.zbufnum;
2012 }
2013 else if ( T->strict == -3 ) {
2014 rhsnumber = AM.onerhs;
2015 tbufnum = AM.zbufnum;
2016 }
2017 else if ( T->strict < 0 ) {
2018 if ( Tpattern ) {
2019 TermFree(Tpattern,"Tpattern");
2020 Tpattern = 0;
2021 }
2022 goto NextFun;
2023 }
2024 else {
2025 MLOCK(ErrorMessageLock);
2026 MesPrint("Element in table is undefined");
2027 if ( Tpattern ) {
2028 TermFree(Tpattern,"Tpattern");
2029 Tpattern = 0;
2030 }
2031 goto showtable;
2032 }
2033 }
2034 else {
2035 rhsnumber = T->tablepointers[i];
2036#if ( TABLEEXTENSION == 2 )
2037 tbufnum = T->bufnum;
2038#else
2039 tbufnum = T->tablepointers[i+1];
2040#endif
2041 }
2042 }
2043/*
2044 If there are more arguments we have to do some
2045 pattern matching. This should be easy. We adapted the
2046 pattern, so that the array indices match already.
2047 Note that if there is no match the program will become
2048 very slow.
2049*/
2050caughttable:
2051#ifdef WITHPTHREADS
2052 AN.FullProto = T->prototype[AT.identity];
2053#else
2054 AN.FullProto = T->prototype;
2055#endif
2056 AN.WildValue = AN.FullProto + SUBEXPSIZE;
2057 AN.WildStop = AN.FullProto+AN.FullProto[1];
2058 ClearWild(BHEAD0);
2059 AN.RepFunNum = 0;
2060 AN.RepFunList = AN.EndNest;
2061 AT.WorkPointer = (WORD *)(((UBYTE *)(AN.EndNest)) + AM.MaxTer/2);
2062 if ( AT.WorkPointer >= AT.WorkTop ) {
2063 MLOCK(ErrorMessageLock);
2064 MesWork();
2065 MUNLOCK(ErrorMessageLock);
2066 }
2067 wilds = 0;
2068 if ( MatchFunction(BHEAD Tpattern,t1,&wilds) > 0 ) {
2069 AT.WorkPointer = oldwork;
2070 if ( AT.NestPoin != AT.Nest ) {
2071 AN.ncmod = oldncmod;
2072 if ( Tpattern ) {
2073 TermFree(Tpattern,"Tpattern");
2074 Tpattern = 0;
2075 }
2076 DONE(1)
2077 }
2078
2079 m = AN.FullProto;
2080 retvalue = m[2] = rhsnumber;
2081 m[4] = tbufnum;
2082 t = t1;
2083 j = t[1];
2084 i = m[1];
2085 if ( j > i ) {
2086 j = i - j;
2087 NCOPY(t,m,i);
2088 m = term + *term;
2089 while ( r < m ) *t++ = *r++;
2090 *term += j;
2091 }
2092 else if ( j < i ) {
2093 j = i-j;
2094 t = term + *term;
2095 while ( t >= r ) { t[j] = *t; t--; }
2096 t = t1;
2097 NCOPY(t,m,i);
2098 *term += j;
2099 }
2100 else {
2101 NCOPY(t,m,j);
2102 }
2103 AN.TeInFun = 0;
2104 AR.TePos = 0;
2105 AN.TeSuOut = -1;
2106 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
2107 AT.TMbuff = tbufnum;
2108 AN.ncmod = oldncmod;
2109 DONE(retvalue);
2110 }
2111 AT.WorkPointer = oldwork;
2112 if ( Tpattern ) {
2113 TermFree(Tpattern,"Tpattern");
2114 Tpattern = 0;
2115 }
2116 }
2117NextFun:;
2118 }
2119 else if ( ( t[2] & DIRTYFLAG ) != 0 ) {
2120 t += FUNHEAD;
2121 while ( t < r ) {
2122 if ( *t == FUNNYDOLLAR ) {
2123 if ( AR.Eside != LHSIDE ) {
2124 AN.TeInFun = 1;
2125 AR.TePos = 0;
2126 AT.TMbuff = AM.dbufnum;
2127 AN.ncmod = oldncmod;
2128 DONE(1)
2129 }
2130 AC.lhdollarflag = 1;
2131 }
2132 t++;
2133 }
2134 }
2135 t = r;
2136 AN.ncmod = oldncmod;
2137 } while ( t < m );
2138 }
2139Done:
2140 if ( Tpattern ) {
2141 TermFree(Tpattern,"Tpattern");
2142 Tpattern = 0;
2143 }
2144 if ( AT.RecFlag != oldRecFlag ) {
2145/* INTERNAL_ERROR_EXCL_START */
2146 MLOCK(ErrorMessageLock);
2147 MesPrint("!>Error in TestSub: bookkeeping problem in RecFlag");
2148 MUNLOCK(ErrorMessageLock);
2149 Terminate(-1);
2150/* INTERNAL_ERROR_EXCL_STOP */
2151 }
2152 return(retvalue);
2153EndTest:;
2154 MLOCK(ErrorMessageLock);
2155EndTest2:;
2156 MesCall("TestSub");
2157 MUNLOCK(ErrorMessageLock);
2158 SETERROR(-1)
2159}
2160
2161/*
2162 #] TestSub :
2163 #[ InFunction : WORD InFunction(term,termout)
2164*/
2177int InFunction(PHEAD WORD *term, WORD *termout)
2178{
2179 GETBIDENTITY
2180 WORD *m, *t, *r, *rr, sign = 1, oldncmod;
2181 WORD *u, *v, *w, *from, *to,
2182 ipp, olddefer = AR.DeferFlag, oldPolyFun = AR.PolyFun, i, j;
2183 LONG numterms;
2184 from = t = term;
2185 r = t + *t - 1;
2186 m = r - ABS(*r) + 1;
2187 t++;
2188 while ( t < m ) {
2189 if ( *t >= FUNCTION+WILDOFFSET ) ipp = *t - WILDOFFSET;
2190 else ipp = *t;
2191 if ( AR.TePos ) {
2192 if ( ( term + AR.TePos ) == t ) {
2193 m = termout;
2194 while ( from < t ) *m++ = *from++;
2195 *m++ = DENOMINATOR;
2196 *m++ = t[1] + 4 + FUNHEAD + ARGHEAD;
2197 *m++ = DIRTYFLAG;
2198 FILLFUN3(m)
2199 *m++ = t[1] + 4 + ARGHEAD;
2200 *m++ = 1;
2201 FILLARG(m)
2202 *m++ = t[1] + 4;
2203 t[3] = -t[3];
2204 v = t + t[1];
2205 while ( t < v ) *m++ = *t++;
2206 from[3] = -from[3];
2207 *m++ = 1;
2208 *m++ = 1;
2209 *m++ = 3;
2210 r = term + *term;
2211 while ( t < r ) *m++ = *t++;
2212 if ( (m-termout) > (LONG)(AM.MaxTer/sizeof(WORD)) ) {
2213 MLOCK(ErrorMessageLock);
2214 MesPrint("Output term too large (%d words) (MaxTermSize: %d words)", m-termout, AM.MaxTer/sizeof(WORD));
2215 MUNLOCK(ErrorMessageLock);
2216 goto TooLarge;
2217 }
2218 *termout = WORDDIF(m,termout);
2219 return(0);
2220 }
2221 }
2222 else if ( ( *t >= FUNCTION && functions[ipp-FUNCTION].spec <= 0 )
2223 && ( t[2] & DIRTYFLAG ) == DIRTYFLAG ) {
2224 m = termout;
2225 r = t + t[1];
2226 u = t;
2227 t += FUNHEAD;
2228 oldncmod = AN.ncmod;
2229 while ( t < r ) { /* t points at an argument */
2230 if ( *t > 0 && t[1] ) { /* Argument has been modified */
2231 WORD oldsorttype = AR.SortType;
2232 /* This whole argument must be redone */
2233
2234 if ( ( AN.ncmod != 0 )
2235 && ( ( AC.modmode & ALSOFUNARGS ) == 0 )
2236 && ( *u != AR.PolyFun ) ) { AN.ncmod = 0; }
2237 AR.DeferFlag = 0;
2238 v = t + *t;
2239 t += ARGHEAD; /* First term */
2240 LONG copy = t - from;
2241 const LONG size = t - u;
2242 NCOPY(m, from, copy);
2243 w = m - size;
2244 to = m;
2245 NewSort(BHEAD0);
2246 if ( *u == AR.PolyFun && AR.PolyFunType == 2 ) {
2247 AR.CompareRoutine = (COMPAREDUMMY)(&CompareSymbols);
2248 AR.SortType = SORTHIGHFIRST;
2249 }
2250/*
2251 AR.PolyFun = 0;
2252*/
2253 while ( t < v ) {
2254 i = *t;
2255 NCOPY(m,t,i);
2256 m = to;
2257 if ( AT.WorkPointer < m+*m ) AT.WorkPointer = m + *m;
2258 if ( Generator(BHEAD m,AR.Cnumlhs) ) {
2259 AN.ncmod = oldncmod;
2260 LowerSortLevel(); goto InFunc;
2261 }
2262 }
2263 /* w = the function */
2264 /* v = the next argument */
2265 /* u = the function */
2266 /* to is new argument */
2267
2268 to -= ARGHEAD;
2269 if ( EndSort(BHEAD m,1) < 0 ) {
2270 AN.ncmod = oldncmod;
2271 goto InFunc;
2272 }
2273 AR.PolyFun = oldPolyFun;
2274 if ( *u == AR.PolyFun && AR.PolyFunType == 2 ) {
2275 AR.CompareRoutine = (COMPAREDUMMY)(&Compare1);
2276 AR.SortType = oldsorttype;
2277 }
2278 while ( *m ) m += *m;
2279 *to = WORDDIF(m,to);
2280 to[1] = 1; /* ??????? or rather 0?. 24-mar-2006 JV */
2281 if ( ToFast(to,to) ) {
2282 if ( *to <= -FUNCTION ) m = to+1;
2283 else m = to+2;
2284 }
2285 w[1] = WORDDIF(m,w) + WORDDIF(r,v);
2286 r = term + *term;
2287 t = v;
2288 while ( t < r ) *m++ = *t++;
2289 if ( (m-termout) > (LONG)(AM.MaxTer/sizeof(WORD)) ) {
2290 MLOCK(ErrorMessageLock);
2291 MesPrint("Output term too large (%d words) (MaxTermSize: %d words)", m-termout, AM.MaxTer/sizeof(WORD));
2292 MUNLOCK(ErrorMessageLock);
2293 goto TooLarge;
2294 }
2295 *termout = WORDDIF(m,termout);
2296 AR.DeferFlag = olddefer;
2297 AN.ncmod = oldncmod;
2298 return(0);
2299 }
2300 else if ( *t == -DOLLAREXPRESSION ) {
2301 if ( AR.Eside == LHSIDE ) {
2302 NEXTARG(t)
2303 AC.lhdollarflag = 1;
2304 }
2305 else {
2306/*
2307 This whole argument must be redone
2308*/
2309 DOLLARS d = Dollars + t[1];
2310#ifdef WITHPTHREADS
2311 int nummodopt, dtype = -1;
2312 if ( AS.MultiThreaded ) {
2313 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2314 if ( t[1] == ModOptdollars[nummodopt].number ) break;
2315 }
2316 if ( nummodopt < NumModOptdollars ) {
2317 dtype = ModOptdollars[nummodopt].type;
2318 if ( DollarLocalCopy(dtype) ) {
2319 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2320 }
2321 else {
2322 LOCK(d->pthreadslock);
2323 }
2324 }
2325 }
2326#endif
2327 oldncmod = AN.ncmod;
2328 if ( ( AN.ncmod != 0 )
2329 && ( ( AC.modmode & ALSOFUNARGS ) == 0 )
2330 && ( *u != AR.PolyFun ) ) { AN.ncmod = 0; }
2331 AR.DeferFlag = 0;
2332 v = t + 2;
2333 LONG copy = t - from;
2334 const LONG size = t - u;
2335 NCOPY(m, from, copy);
2336 w = m - size;
2337 to = m;
2338 switch ( d->type ) {
2339 case DOLINDEX:
2340 if ( d->index >= 0 && d->index < AM.OffsetIndex ) {
2341 *m++ = -SNUMBER; *m++ = d->index;
2342 }
2343 else { *m++ = -INDEX; *m++ = d->index; }
2344 break;
2345 case DOLZERO:
2346 *m++ = -SNUMBER; *m++ = 0; break;
2347 case DOLNUMBER:
2348 if ( d->where[0] == 4 &&
2349 ( d->where[1] & MAXPOSITIVE ) == d->where[1] ) {
2350 *m++ = -SNUMBER;
2351 if ( d->where[3] >= 0 ) *m++ = d->where[1];
2352 else *m++ = -d->where[1];
2353 break;
2354 }
2355 /* fall through */
2356 case DOLTERMS:
2357/*
2358 Here we have the special case of the PolyRatFun
2359 That function may have a different sort of the
2360 terms in the argument.
2361*/
2362 to = m; r = d->where;
2363 *m++ = 0; *m++ = 1;
2364 FILLARG(m)
2365 while ( *r ) {
2366 i = *r; NCOPY(m,r,i)
2367 }
2368 *to = m-to;
2369 if ( ToFast(to,to) ) {
2370 if ( *to <= -FUNCTION ) m = to+1;
2371 else m = to+2;
2372 }
2373 else if ( *u == AR.PolyFun && AR.PolyFunType == 2 ) {
2374 AR.PolyFun = 0;
2375 NewSort(BHEAD0);
2376 AR.CompareRoutine = (COMPAREDUMMY)(&CompareSymbols);
2377 r = to + ARGHEAD;
2378 while ( r < m ) {
2379 rr = r; r += *r;
2380 if ( SymbolNormalize(rr) ) goto InFunc;
2381 if ( StoreTerm(BHEAD rr) ) {
2382 AR.CompareRoutine = (COMPAREDUMMY)(&Compare1);
2383 LowerSortLevel();
2384 Terminate(-1);
2385 }
2386 }
2387 if ( EndSort(BHEAD to+ARGHEAD,1) < 0 ) goto InFunc;
2388 AR.PolyFun = oldPolyFun;
2389 AR.CompareRoutine = (COMPAREDUMMY)(&Compare1);
2390 m = to+ARGHEAD;
2391 if ( *m == 0 ) {
2392 *to = -SNUMBER;
2393 to[1] = 0;
2394 m = to + 2;
2395 }
2396 else {
2397 while ( *m ) m += *m;
2398 *t = m - to;
2399 if ( ToFast(to,to) ) {
2400 if ( *to <= -FUNCTION ) m = to+1;
2401 else m = to+2;
2402 }
2403 }
2404 }
2405 w[1] = w[1] - 2 + (m-to);
2406 break;
2407 case DOLSUBTERM:
2408 to = m; r = d->where;
2409 i = r[1];
2410 *m++ = i+4+ARGHEAD; *m++ = 1;
2411 FILLARG(m)
2412 *m++ = i+4;
2413 while ( --i >= 0 ) *m++ = *r++;
2414 *m++ = 1; *m++ = 1; *m++ = 3;
2415 if ( ToFast(to,to) ) {
2416 if ( *to <= -FUNCTION ) m = to+1;
2417 else m = to+2;
2418 }
2419 w[1] = w[1] - 2 + (m-to);
2420 break;
2421 case DOLARGUMENT:
2422 to = m; r = d->where;
2423 if ( *r > 0 ) {
2424 i = *r - 2;
2425 *m++ = *r++; *m++ = 1; r++;
2426 while ( --i >= 0 ) *m++ = *r++;
2427 }
2428 else if ( *r <= -FUNCTION ) *m++ = *r++;
2429 else { *m++ = *r++; *m++ = *r++; }
2430 w[1] = w[1] - 2 + (m-to);
2431 break;
2432 case DOLWILDARGS:
2433 to = m; r = d->where;
2434 if ( *r > 0 ) { /* Tensor arguments */
2435 i = *r++;
2436 while ( --i >= 0 ) {
2437 if ( *r < 0 ) {
2438 *m++ = -VECTOR; *m++ = *r++;
2439 }
2440 else if ( *r >= AM.OffsetIndex ) {
2441 *m++ = -INDEX; *m++ = *r++;
2442 }
2443 else { *m++ = -SNUMBER; *m++ = *r++; }
2444 }
2445 }
2446 else { /* Regular arguments */
2447 r++;
2448 while ( *r ) {
2449 if ( *r > 0 ) {
2450 i = *r - 2;
2451 *m++ = *r++; *m++ = 1; r++;
2452 while ( --i >= 0 ) *m++ = *r++;
2453 }
2454 else if ( *r <= -FUNCTION ) *m++ = *r++;
2455 else { *m++ = *r++; *m++ = *r++; }
2456 }
2457 }
2458 w[1] = w[1] - 2 + (m-to);
2459 break;
2460 case DOLUNDEFINED:
2461 default:
2462 MLOCK(ErrorMessageLock);
2463 MesPrint("!!!Undefined $-variable: $%s!!!",
2464 AC.dollarnames->namebuffer+d->name);
2465 MUNLOCK(ErrorMessageLock);
2466#ifdef WITHPTHREADS
2467 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
2468#endif
2469 Terminate(-1);
2470 }
2471#ifdef WITHPTHREADS
2472 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
2473#endif
2474 r = term + *term;
2475 t = v;
2476 while ( t < r ) *m++ = *t++;
2477 if ( (m-termout) > (LONG)(AM.MaxTer/sizeof(WORD)) ) {
2478 MLOCK(ErrorMessageLock);
2479 MesPrint("Output term too large (%d words) (MaxTermSize: %d words)", m-termout, AM.MaxTer/sizeof(WORD));
2480 MUNLOCK(ErrorMessageLock);
2481 goto TooLarge;
2482 }
2483 *termout = WORDDIF(m,termout);
2484 AR.DeferFlag = olddefer;
2485 AN.ncmod = oldncmod;
2486 return(0);
2487 }
2488 }
2489 else if ( *t == -TERMSINBRACKET ) {
2490 if ( AC.ComDefer ) numterms = CountTerms1(BHEAD0);
2491 else numterms = 1;
2492/*
2493 Compose the output term
2494 First copy the part till this function argument
2495 m points at the output term space
2496 u points at the start of the function
2497 t points at the start of the argument
2498*/
2499 LONG copy = t - from;
2500 const LONG size = t - u;
2501 NCOPY(m, from, copy);
2502 w = m - size;
2503 if ( ( numterms & MAXPOSITIVE ) == numterms ) {
2504 *m++ = -SNUMBER; *m++ = numterms & MAXPOSITIVE;
2505 w[1] += 1;
2506 }
2507 else if ( ( i = numterms >> BITSINWORD ) == 0 ) {
2508 *m++ = ARGHEAD+4;
2509 for ( j = 1; j < ARGHEAD; j++ ) *m++ = 0;
2510 *m++ = 4; *m++ = numterms & WORDMASK; *m++ = 1; *m++ = 3;
2511 w[1] += ARGHEAD+3;
2512 }
2513 else {
2514 *m++ = ARGHEAD+6;
2515 for ( j = 1; j < ARGHEAD; j++ ) *m++ = 0;
2516 *m++ = 6; *m++ = numterms & WORDMASK;
2517 *m++ = i; *m++ = 1; *m++ = 0; *m++ = 5;
2518 w[1] += ARGHEAD+5;
2519 }
2520 from++; /* Skip our function */
2521 r = term + *term;
2522 while ( from < r ) *m++ = *from++;
2523 if ( (m-termout) > (LONG)(AM.MaxTer/sizeof(WORD)) ) {
2524 MLOCK(ErrorMessageLock);
2525 MesPrint("Output term too large (%d words) (MaxTermSize: %d words)", m-termout, AM.MaxTer/sizeof(WORD));
2526 MUNLOCK(ErrorMessageLock);
2527 goto TooLarge;
2528 }
2529 *termout = WORDDIF(m,termout);
2530 return(0);
2531 }
2532 else { NEXTARG(t) }
2533 }
2534 t = u;
2535 }
2536 else if ( ( *t >= FUNCTION && functions[ipp-FUNCTION].spec > 0 )
2537 && ( t[2] & DIRTYFLAG ) == DIRTYFLAG ) { /* Could be FUNNYDOLLAR */
2538 u = t; v = t + t[1];
2539 t += FUNHEAD;
2540 while ( t < v ) {
2541 if ( *t == FUNNYDOLLAR ) {
2542 if ( AR.Eside != LHSIDE ) {
2543 DOLLARS d = Dollars + t[1];
2544#ifdef WITHPTHREADS
2545 int nummodopt, dtype = -1;
2546 if ( AS.MultiThreaded ) {
2547 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2548 if ( t[1] == ModOptdollars[nummodopt].number ) break;
2549 }
2550 if ( nummodopt < NumModOptdollars ) {
2551 dtype = ModOptdollars[nummodopt].type;
2552 if ( DollarLocalCopy(dtype) ) {
2553 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2554 }
2555 else {
2556 LOCK(d->pthreadslock);
2557 }
2558 }
2559 }
2560#endif
2561 oldncmod = AN.ncmod;
2562 if ( ( AN.ncmod != 0 )
2563 && ( ( AC.modmode & ALSOFUNARGS ) == 0 )
2564 && ( *u != AR.PolyFun ) ) { AN.ncmod = 0; }
2565 m = termout;
2566 LONG copy = t - from;
2567 const LONG size = t - u;
2568 NCOPY(m, from, copy);
2569 w = m - size;
2570 to = m;
2571 switch ( d->type ) {
2572 case DOLINDEX:
2573 *m++ = d->index; break;
2574 case DOLZERO:
2575 *m++ = 0; break;
2576 case DOLNUMBER:
2577 case DOLTERMS:
2578 if ( d->where[0] == 4 && d->where[4] == 0
2579 && d->where[3] == 3 && d->where[2] == 1
2580 && d->where[1] < AM.OffsetIndex ) {
2581 *m++ = d->where[1];
2582 }
2583 else {
2584wrongtype:;
2585#ifdef WITHPTHREADS
2586 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
2587#endif
2588 MLOCK(ErrorMessageLock);
2589 MesPrint("$%s has wrong type for tensor substitution",
2590 AC.dollarnames->namebuffer+d->name);
2591 MUNLOCK(ErrorMessageLock);
2592 AN.ncmod = oldncmod;
2593 return(-1);
2594 }
2595 break;
2596 case DOLARGUMENT:
2597 if ( d->where[0] == -INDEX ) {
2598 *m++ = d->where[1]; break;
2599 }
2600 else if ( d->where[0] == -VECTOR ) {
2601 *m++ = d->where[1]; break;
2602 }
2603 else if ( d->where[0] == -MINVECTOR ) {
2604 *m++ = d->where[1];
2605 sign = -sign;
2606 break;
2607 }
2608 else if ( d->where[0] == -SNUMBER ) {
2609 if ( d->where[1] >= 0
2610 && d->where[1] < AM.OffsetIndex ) {
2611 *m++ = d->where[1]; break;
2612 }
2613 }
2614 goto wrongtype;
2615 case DOLWILDARGS:
2616 if ( d->where[0] > 0 ) {
2617 r = d->where; i = *r++;
2618 while ( --i >= 0 ) *m++ = *r++;
2619 }
2620 else {
2621 r = d->where + 1;
2622 while ( *r ) {
2623 if ( *r == -INDEX ) {
2624 *m++ = r[1]; r += 2; continue;
2625 }
2626 else if ( *r == -VECTOR ) {
2627 *m++ = r[1]; r += 2; continue;
2628 }
2629 else if ( *r == -MINVECTOR ) {
2630 *m++ = r[1]; r += 2;
2631 sign = -sign; continue;
2632 }
2633 else if ( *r == -SNUMBER ) {
2634 if ( r[1] >= 0
2635 && r[1] < AM.OffsetIndex ) {
2636 *m++ = r[1]; r += 2; continue;
2637 }
2638 }
2639 goto wrongtype;
2640 }
2641 }
2642 break;
2643 case DOLSUBTERM:
2644 r = d->where;
2645 if ( *r == INDEX && r[1] == 3 ) {
2646 *m++ = r[2];
2647 }
2648 else goto wrongtype;
2649 break;
2650 case DOLUNDEFINED:
2651#ifdef WITHPTHREADS
2652 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
2653#endif
2654 MLOCK(ErrorMessageLock);
2655 MesPrint("$%s is undefined in tensor substitution",
2656 AC.dollarnames->namebuffer+d->name);
2657 MUNLOCK(ErrorMessageLock);
2658 AN.ncmod = oldncmod;
2659 return(-1);
2660 }
2661#ifdef WITHPTHREADS
2662 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
2663#endif
2664 w[1] = w[1] - 2 + (m-to);
2665 from += 2;
2666 term += *term;
2667 while ( from < term ) *m++ = *from++;
2668 if ( sign < 0 ) m[-1] = -m[-1];
2669 if ( (m-termout) > (LONG)(AM.MaxTer/sizeof(WORD)) ) {
2670 MLOCK(ErrorMessageLock);
2671 MesPrint("Output term too large (%d words) (MaxTermSize: %d words)", m-termout, AM.MaxTer/sizeof(WORD));
2672 MUNLOCK(ErrorMessageLock);
2673 goto TooLarge;
2674 }
2675 *termout = m - termout;
2676 AN.ncmod = oldncmod;
2677 return(0);
2678 }
2679 else {
2680 AC.lhdollarflag = 1;
2681 }
2682 }
2683 t++;
2684 }
2685 t = u;
2686 }
2687 t += t[1];
2688 }
2689/* INTERNAL_ERROR_EXCL_START */
2690 MLOCK(ErrorMessageLock);
2691 MesPrint("!>Internal error in InFunction: Function not encountered.");
2692 if ( AM.tracebackflag ) {
2693 MesPrint("%w: AR.TePos = %d",AR.TePos);
2694 MesPrint("%w: AN.TeInFun = %d",AN.TeInFun);
2695 termout = term;
2696 AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer + AM.MaxTer;
2697 AO.OutSkip = 3;
2698 FiniLine();
2699 i = *termout;
2700 while ( --i >= 0 ) {
2701 TalToLine((UWORD)(*termout++));
2702 TokenToLine((UBYTE *)" ");
2703 }
2704 AO.OutSkip = 0;
2705 FiniLine();
2706 MesCall("InFunction");
2707 }
2708 MUNLOCK(ErrorMessageLock);
2709 return(1);
2710/* INTERNAL_ERROR_EXCL_STOP */
2711
2712InFunc:
2713 MLOCK(ErrorMessageLock);
2714 MesCall("InFunction");
2715 MUNLOCK(ErrorMessageLock);
2716 SETERROR(-1)
2717
2718TooLarge:
2719 MLOCK(ErrorMessageLock);
2720 MesCall("InFunction");
2721 MUNLOCK(ErrorMessageLock);
2722 SETERROR(-1)
2723}
2724
2725/*
2726 #] InFunction :
2727 #[ InsertTerm : WORD InsertTerm(term,replac,extractbuff,position,termout)
2728*/
2746int InsertTerm(PHEAD WORD *term, WORD replac, WORD extractbuff, WORD *position, WORD *termout,
2747 WORD tepos)
2748{
2749 GETBIDENTITY
2750 WORD *m, *t, *r, i, l2, j;
2751 WORD *u, *v, l1, *coef;
2752 coef = AT.WorkPointer;
2753 if ( ( AT.WorkPointer = coef + 2*AM.MaxTal ) > AT.WorkTop ) {
2754 MLOCK(ErrorMessageLock);
2755 MesWork();
2756 MUNLOCK(ErrorMessageLock);
2757 return(-1);
2758 }
2759 t = term;
2760 r = t + *t;
2761 l1 = l2 = r[-1];
2762 m = r - ABS(l2);
2763 if ( tepos > 0 ) {
2764 t = term + tepos;
2765 goto foundit;
2766 }
2767 t++;
2768 while ( t < m ) {
2769 if ( *t == SUBEXPRESSION && t[2] == replac && t[3] && t[4] == extractbuff ) {
2770 r = t + t[1];
2771 while ( *r == SUBEXPRESSION && r[2] == replac && r[3] && r < m && r[4] == extractbuff ) {
2772 t = r; r += r[1];
2773 }
2774foundit:;
2775 u = m;
2776 r = term;
2777 m = termout;
2778 do { *m++ = *r++; } while ( r < t );
2779 if ( t[1] > SUBEXPSIZE ) {
2780/*
2781 if this is a dollar expression there are no wildcards
2782*/
2783 i = *--m;
2784 if ( ( l2 = WildFill(BHEAD m,position,t) ) < 0 ) goto InsCall;
2785 *m = i;
2786 m += l2-1;
2787 l2 = *m;
2788 i = ( j = ABS(l2) ) - 1;
2789 r = coef + i;
2790 do { *--r = *--m; } while ( --i > 0 );
2791 }
2792 else {
2793 v = t;
2794 t = position;
2795 r = t + *t;
2796 l2 = r[-1];
2797 r -= ( j = ABS(l2) );
2798 t++;
2799 if ( t < r ) do { *m++ = *t++; } while ( t < r );
2800 t = v;
2801 }
2802 t += t[1];
2803 while ( t < u && *t == DOLLAREXPR2 ) t += t[1];
2804ComAct: if ( t < u ) do { *m++ = *t++; } while ( t < u );
2805 if ( *r == 1 && r[1] == 1 && j == 3 ) {
2806 if ( l2 < 0 ) l1 = -l1;
2807 i = ABS(l1)-1;
2808 NCOPY(m,t,i);
2809 *m++ = l1;
2810 }
2811 else {
2812 if ( MulRat(BHEAD (UWORD *)u,REDLENG(l1),(UWORD *)r,REDLENG(l2),
2813 (UWORD *)m,&l1) ) goto InsCall;
2814 l2 = l1;
2815 l2 *= 2;
2816 if ( l2 < 0 ) {
2817 m -= l2;
2818 *m++ = l2-1;
2819 }
2820 else {
2821 m += l2;
2822 *m++ = l2+1;
2823 }
2824 }
2825 *termout = WORDDIF(m,termout);
2826 if ( (*termout)*((LONG)sizeof(WORD)) > AM.MaxTer ) {
2827 MLOCK(ErrorMessageLock);
2828 MesPrint("Term too complex during substitution (%d words). MaxTermSize (%l words) is too small.", *termout, AM.MaxTer/(LONG)sizeof(WORD) );
2829 goto InsCall2;
2830 }
2831 AT.WorkPointer = coef;
2832 return(0);
2833 }
2834 t += t[1];
2835 }
2836/*
2837 The next action is for when there is no subexpression pointer.
2838 We append the extra term. Effectively the routine becomes now a
2839 merge routine for two terms.
2840*/
2841 v = t;
2842 u = m;
2843 r = term;
2844 m = termout;
2845 do { *m++ = *r++; } while ( r < t );
2846 t = position;
2847 r = t + *t;
2848 l2 = r[-1];
2849 r -= ( j = ABS(l2) );
2850 t++;
2851 if ( t < r ) do { *m++ = *t++; } while ( t < r );
2852 t = v;
2853 goto ComAct;
2854
2855InsCall:
2856 MLOCK(ErrorMessageLock);
2857InsCall2:
2858 MesCall("InsertTerm");
2859 MUNLOCK(ErrorMessageLock);
2860 SETERROR(-1)
2861}
2862
2863/*
2864 #] InsertTerm :
2865 #[ PasteFile : WORD PasteFile(num,acc,pos,accf,renum,freeze,nexpr)
2866*/
2882LONG PasteFile(PHEAD WORD number, WORD *accum, POSITION *position, WORD **accfill,
2883 RENUMBER renumber, WORD *freeze, WORD nexpr)
2884{
2885 GETBIDENTITY
2886 WORD *r, l, *m, i;
2887 WORD *stop, *s1, *s2;
2888/* POSITION AccPos; bug 12-apr-2008 JV */
2889 WORD InCompState;
2890 WORD *oldipointer;
2891 LONG retlength;
2892 stop = (WORD *)(((UBYTE *)(accum)) + 2*AM.MaxTer);
2893 *accum++ = number;
2894 while ( --number >= 0 ) accum += *accum;
2895 if ( freeze ) {
2896/* AccPos = *position; bug 12-apr-2008 JV */
2897 oldipointer = AR.CompressPointer;
2898 do {
2899 AR.CompressPointer = oldipointer;
2900/* if ( ( l = GetFromStore(accum,&AccPos,renumber,&InCompState,nexpr) ) < 0 ) bug 12-apr-2008 JV */
2901 if ( ( l = GetFromStore(accum,position,renumber,&InCompState,nexpr) ) < 0 )
2902 goto PasErr;
2903 if ( !l ) { *accum = 0; return(0); }
2904 r = accum;
2905 m = r + *r;
2906 m -= ABS(m[-1]);
2907 r++;
2908 while ( r < m && *r != HAAKJE ) r += r[1];
2909 if ( r >= m ) {
2910 if ( *freeze != 4 ) l = -1;
2911 }
2912 else {
2913/*
2914 The algorithm for accepting terms with a given (freeze)
2915 representation outside brackets is rather crude. A refinement
2916 would be to store the part outside the bracket and skip the
2917 term when this part doesn't alter (and is unacceptable).
2918 Once accepting one can keep accepting till the bracket alters
2919 and then one may stop the generation. It is necessary to
2920 set up a struct to remember the bracket and the progress
2921 status.
2922*/
2923 m = AT.WorkPointer;
2924 s2 = r;
2925 r = accum;
2926 *m++ = WORDDIF(s2,r) + 3;
2927 r++;
2928 while ( r < s2 ) *m++ = *r++;
2929 *m++ = 1; *m++ = 1; *m++ = 3;
2930 m = AT.WorkPointer;
2931 if ( Normalize(BHEAD AT.WorkPointer) ) goto PasErr;
2932 r = freeze;
2933 i = *m;
2934 while ( --i >= 0 && *m++ == *r++ ) {}
2935 if ( i > 0 ) {
2936 l = -1;
2937 }
2938 else { /* Term to be accepted */
2939 r = accum;
2940 s1 = r + *r;
2941 r++;
2942 m = s2;
2943 m += m[1];
2944 do { *r++ = *m++; } while ( m < s1 );
2945 *accum = l = WORDDIF(r,accum);
2946 }
2947 }
2948 } while ( l < 0 );
2949 retlength = InCompState;
2950/* retlength = DIFBASE(AccPos,*position) / sizeof(WORD); bug 12-apr-2008 JV */
2951 }
2952 else {
2953 if ( ( l = GetFromStore(accum,position,renumber,&InCompState,nexpr) ) < 0 ) {
2954 MLOCK(ErrorMessageLock);
2955 MesCall("PasteFile");
2956 MUNLOCK(ErrorMessageLock);
2957 SETERROR(-1)
2958 }
2959 if ( l == 0 ) { *accum = 0; return(0); }
2960 retlength = InCompState;
2961 }
2962 accum += l;
2963 if ( accum > stop ) {
2964/* INTERNAL_ERROR_EXCL_START */
2965 MLOCK(ErrorMessageLock);
2966 MesPrint("!>Buffer too small in PasteFile");
2967 MUNLOCK(ErrorMessageLock);
2968 SETERROR(-1)
2969/* INTERNAL_ERROR_EXCL_STOP */
2970 }
2971 *accum = 0;
2972 *accfill = accum;
2973 return(retlength);
2974PasErr:
2975 MLOCK(ErrorMessageLock);
2976 MesCall("PasteFile");
2977 MUNLOCK(ErrorMessageLock);
2978 SETERROR(-1)
2979}
2980
2981/*
2982 #] PasteFile :
2983 #[ PasteTerm : WORD PasteTerm(number,accum,position,times,divby)
2984*/
3006WORD *PasteTerm(PHEAD WORD number, WORD *accum, WORD *position, WORD times, WORD divby)
3007{
3008 GETBIDENTITY
3009 WORD *t, *r, x, y, z;
3010 WORD *m, *u, l1, a[2];
3011 m = (WORD *)(((UBYTE *)(accum)) + AM.MaxTer);
3012/* m = (WORD *)(((UBYTE *)(accum)) + 2*AM.MaxTer); */
3013 *accum++ = number;
3014 while ( --number >= 0 ) accum += *accum;
3015 if ( times == divby ) {
3016 t = position;
3017 r = t + *t;
3018 if ( t < r ) do { *accum++ = *t++; } while ( t < r );
3019 }
3020 else {
3021 u = accum;
3022 t = position;
3023 r = t + *t - 1;
3024 l1 = *r;
3025 r -= ABS(*r) - 1;
3026 if ( t < r ) do { *accum++ = *t++; } while ( t < r );
3027 if ( divby > times ) { x = divby; y = times; }
3028 else { x = times; y = divby; }
3029 z = x%y;
3030 while ( z ) { x = y; y = z; z = x%y; }
3031 if ( y != 1 ) { divby /= y; times /= y; }
3032 a[1] = divby;
3033 a[0] = times;
3034 if ( MulRat(BHEAD (UWORD *)t,REDLENG(l1),(UWORD *)a,1,(UWORD *)accum,&l1) ) {
3035 MLOCK(ErrorMessageLock);
3036 MesCall("PasteTerm");
3037 MUNLOCK(ErrorMessageLock);
3038 return(0);
3039 }
3040 x = l1;
3041 x *= 2;
3042 if ( x < 0 ) { accum -= x; *accum++ = x - 1; }
3043 else { accum += x; *accum++ = x + 1; }
3044 *u = WORDDIF(accum,u);
3045 }
3046 if ( accum >= m ) {
3047/* INTERNAL_ERROR_EXCL_START */
3048 MLOCK(ErrorMessageLock);
3049 MesPrint("!>Buffer too small in PasteTerm");
3050 MUNLOCK(ErrorMessageLock);
3051 return(0);
3052/* INTERNAL_ERROR_EXCL_STOP */
3053 }
3054 *accum = 0;
3055 return(accum);
3056}
3057
3058/*
3059 #] PasteTerm :
3060 #[ FiniTerm : WORD FiniTerm(term,accum,termout,number)
3061*/
3073int FiniTerm(PHEAD WORD *term, WORD *accum, WORD *termout, WORD number, WORD tepos)
3074{
3075 GETBIDENTITY
3076 WORD *m, *t, *r, i, numacc, l2, ipp;
3077 WORD *u, *v, l1, *coef = AT.WorkPointer, *oldaccum;
3078 if ( ( AT.WorkPointer = coef + 2*AM.MaxTal ) > AT.WorkTop ) {
3079 MLOCK(ErrorMessageLock);
3080 MesWork();
3081 MUNLOCK(ErrorMessageLock);
3082 return(-1);
3083 }
3084 oldaccum = accum;
3085 t = term;
3086 m = t + *t - 1;
3087 l1 = REDLENG(*m);
3088 i = ABS(*m) - 1;
3089 r = coef + i;
3090 do { *--r = *--m; } while ( --i > 0 ); /* Copies coefficient */
3091 if ( tepos > 0 ) {
3092 t = term + tepos;
3093 goto foundit;
3094 }
3095 t++;
3096 if ( t < m ) do {
3097 if ( ( ( *t == SUBEXPRESSION && ( *(r=t+t[1]) != SUBEXPRESSION
3098 || r >= m || !r[3] ) ) || *t == EXPRESSION ) && t[2] == number && t[3] ) {
3099foundit:;
3100 u = m;
3101 r = term;
3102 m = termout;
3103 if ( r < t ) do { *m++ = *r++; } while ( r < t );
3104 numacc = *accum++;
3105 if ( numacc >= 0 ) do {
3106 if ( *t == EXPRESSION ) {
3107 v = t + t[1];
3108 r = t + SUBEXPSIZE;
3109 while ( r < v ) {
3110 if ( *r == WILDCARDS ) {
3111 r += 2;
3112 i = *--m;
3113 if ( ( l2 = WildFill(BHEAD m,accum,r) ) < 0 ) goto FiniCall;
3114 goto AllWild;
3115 }
3116 r += r[1];
3117 }
3118 goto NoWild;
3119 }
3120 else if ( t[1] > SUBEXPSIZE && t[SUBEXPSIZE] != FROMBRAC ) {
3121 i = *--m;
3122 if ( ( l2 = WildFill(BHEAD m,accum,t) ) < 0 ) goto FiniCall;
3123AllWild: *m = i;
3124 m += l2-1;
3125 l2 = *m;
3126 m -= ABS(l2) - 1;
3127 r = m;
3128 }
3129 else {
3130NoWild: r = accum;
3131 v = r + *r - 1;
3132 l2 = *v;
3133 v -= ABS(l2) - 1;
3134 r++;
3135 if ( r < v ) do { *m++ = *r++; } while ( r < v );
3136 }
3137 if ( *r == 1 && r[1] == 1 && ABS(l2) == 3 ) {
3138 if ( l2 < 0 ) l1 = -l1;
3139 }
3140 else {
3141 l2 = REDLENG(l2);
3142 if ( l2 == 0 ) {
3143 t = oldaccum;
3144 numacc = *t++;
3145 AO.OutSkip = 3;
3146 FiniLine();
3147 while ( --numacc >= 0 ) {
3148 i = *t;
3149 while ( --i >= 0 ) {
3150 TalToLine((UWORD)(*t++));
3151 TokenToLine((UBYTE *)" ");
3152 }
3153 }
3154 AO.OutSkip = 0;
3155 FiniLine();
3156 goto FiniCall;
3157 }
3158 if ( MulRat(BHEAD (UWORD *)coef,l1,(UWORD *)r,l2,(UWORD *)coef,&l1) ) goto FiniCall;
3159 if ( AN.ncmod != 0 && TakeModulus((UWORD *)coef,&l1,AC.cmod,AN.ncmod,UNPACK|AC.modmode) ) goto FiniCall;
3160 }
3161 accum += *accum;
3162 } while ( --numacc >= 0 );
3163 if ( *t == SUBEXPRESSION ) {
3164 while ( t+t[1] < u && t[t[1]] == DOLLAREXPR2 ) t += t[1];
3165 }
3166 t += t[1];
3167 if ( t < u ) do { *m++ = *t++; } while ( t < u );
3168 l2 = l1;
3169/*
3170 Code to economize when taking x = (a+b)/2
3171*/
3172 r = termout+1;
3173 while ( r < m ) {
3174 if ( *r == SUBEXPRESSION ) {
3175 t = r + r[1];
3176 l1 = (WORD)(cbuf[r[4]].CanCommu[r[2]]);
3177 while ( t < m ) {
3178 if ( *t == SUBEXPRESSION &&
3179 t[1] == r[1] && t[2] == r[2] && t[4] == r[4] ) {
3180 i = t[1] - SUBEXPSIZE;
3181 u = r + SUBEXPSIZE; v = t + SUBEXPSIZE;
3182 while ( i > 0 ) {
3183 if ( *v++ != *u++ ) break;
3184 i--;
3185 }
3186 if ( i <= 0 ) {
3187 u = r;
3188 r[3] += t[3];
3189 r = t + t[1];
3190 while ( r < m ) *t++ = *r++;
3191 m = t;
3192 r = u;
3193 goto Nextr;
3194 }
3195 if ( l1 && cbuf[t[4]].CanCommu[t[2]] ) break;
3196 while ( t+t[1] < m && t[t[1]] == DOLLAREXPR2 ) t += t[1];
3197 }
3198 else if ( l1 ) {
3199 if ( *t == SUBEXPRESSION && cbuf[t[4]].CanCommu[t[2]] )
3200 break;
3201 if ( *t >= FUNCTION+WILDOFFSET )
3202 ipp = *t - WILDOFFSET;
3203 else ipp = *t;
3204 if ( *t >= FUNCTION
3205 && functions[ipp-FUNCTION].commute && l1 ) break;
3206 if ( *t == EXPRESSION ) break;
3207 }
3208 t += t[1];
3209 }
3210 r += r[1];
3211 }
3212 else r += r[1];
3213Nextr:;
3214 }
3215
3216 i = ABS(l2);
3217 i *= 2;
3218 i++;
3219 l2 = ( l2 >= 0 ) ? i: -i;
3220 r = coef;
3221 while ( --i > 0 ) *m++ = *r++;
3222 *m++ = l2;
3223 *termout = WORDDIF(m,termout);
3224 AT.WorkPointer = coef;
3225 return(0);
3226 }
3227 t += t[1];
3228 } while ( t < m );
3229 AT.WorkPointer = coef;
3230 return(1);
3231
3232FiniCall:
3233 MLOCK(ErrorMessageLock);
3234 MesCall("FiniTerm");
3235 MUNLOCK(ErrorMessageLock);
3236 SETERROR(-1)
3237}
3238
3239/*
3240 #] FiniTerm :
3241 #[ Generator : WORD Generator(BHEAD term,level)
3242*/
3243
3244static WORD zeroDollar[] = { 0, 0 };
3245/*
3246static LONG debugcounter = 0;
3247*/
3248
3272int Generator(PHEAD WORD *term, WORD level)
3273{
3274 GETBIDENTITY
3275 WORD replac, *accum, *termout, *t, i, j, tepos, applyflag = 0, *StartBuf;
3276 WORD *a, power, power1, DumNow = AR.CurDum, oldtoprhs, oldatoprhs, extractbuff;
3277 int ret;
3278 int *RepSto = AN.RepPoint, iscopy = 0;
3279 CBUF *C = cbuf+AM.rbufnum, *CC = cbuf + AT.ebufnum, *CCC = cbuf + AT.aebufnum;
3280 LONG posisub, oldcpointer, oldacpointer;
3281 DOLLARS d = 0;
3282 WORD numfac[5], idfunctionflag;
3283#ifdef WITHPTHREADS
3284 int nummodopt, dtype = -1, id;
3285#endif
3286 oldtoprhs = CC->numrhs;
3287 oldcpointer = CC->Pointer - CC->Buffer;
3288 oldatoprhs = CCC->numrhs;
3289 oldacpointer = CCC->Pointer - CCC->Buffer;
3290ReStart:
3291 if ( ( replac = TestSub(BHEAD term,level) ) == 0 ) {
3292 if ( applyflag ) { TableReset(); applyflag = 0; }
3293/*
3294 if ( AN.PolyNormFlag > 1 ) {
3295 if ( PolyFunMul(BHEAD term) < 0 ) goto GenCall;
3296 AN.PolyNormFlag = 0;
3297 if ( !*term ) goto Return0;
3298 }
3299*/
3300Renormalize:
3301 AN.PolyNormFlag = 0;
3302 AN.idfunctionflag = 0;
3303 if ( ( ret = Normalize(BHEAD term) ) != 0 ) {
3304 if ( ret > 0 ) {
3305 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
3306 goto ReStart;
3307 }
3308 goto GenCall;
3309 }
3310 idfunctionflag = AN.idfunctionflag;
3311 if ( !*term ) { AN.PolyNormFlag = 0; goto Return0; }
3312
3313 if ( AN.PolyNormFlag ) {
3314 if ( AN.PolyFunTodo == 0 ) {
3315 if ( PolyFunMul(BHEAD term) < 0 ) goto GenCall;
3316 if ( !*term ) { AN.PolyNormFlag = 0; goto Return0; }
3317 }
3318 else {
3319 WORD oldPolyFunExp = AR.PolyFunExp;
3320 AR.PolyFunExp = 0;
3321 if ( PolyFunMul(BHEAD term) < 0 ) goto GenCall;
3322 AT.WorkPointer = term+*term;
3323 AR.PolyFunExp = oldPolyFunExp;
3324 if ( !*term ) { AN.PolyNormFlag = 0; goto Return0; }
3325 if ( Normalize(BHEAD term) < 0 ) goto GenCall;
3326 if ( !*term ) { AN.PolyNormFlag = 0; goto Return0; }
3327 AT.WorkPointer = term+*term;
3328 if ( AN.PolyNormFlag ) {
3329 if ( PolyFunMul(BHEAD term) < 0 ) goto GenCall;
3330 if ( !*term ) { AN.PolyNormFlag = 0; goto Return0; }
3331 AT.WorkPointer = term+*term;
3332 }
3333 AN.PolyFunTodo = 0;
3334 }
3335 }
3336 if ( idfunctionflag > 0 ) {
3337 if ( TakeIDfunction(BHEAD term) ) {
3338 AT.WorkPointer = term + *term;
3339 goto ReStart;
3340 }
3341 }
3342 if ( AT.WorkPointer < (WORD *)(((UBYTE *)(term)) + AM.MaxTer) )
3343 AT.WorkPointer = (WORD *)(((UBYTE *)(term)) + AM.MaxTer);
3344 do {
3345SkipCount: level++;
3346 if ( level > AR.Cnumlhs ) {
3347 if ( AR.DeferFlag && AR.sLevel <= 0 ) {
3348#ifdef WITHMPI
3349 if ( PF.me != MASTER && AC.mparallelflag == PARALLELFLAG && PF.exprtodo < 0 ) {
3350 if ( PF_Deferred(term,level) ) goto GenCall;
3351 }
3352 else
3353#endif
3354 {
3355 if ( Deferred(BHEAD term,level) ) goto GenCall;
3356 }
3357 goto Return0;
3358 }
3359 if ( AN.ncmod != 0 ) {
3360 if ( Modulus(term) ) goto GenCall;
3361 if ( !*term ) goto Return0;
3362 }
3363 if ( AR.CurDum > AM.IndDum && AR.sLevel <= 0 ) {
3364 WORD olddummies = AN.IndDum;
3365 AN.IndDum = AM.IndDum;
3366 ReNumber(BHEAD term);
3367 Normalize(BHEAD term);
3368 AN.IndDum = olddummies;
3369 if ( !*term ) goto Return0;
3370 olddummies = DetCurDum(BHEAD term);
3371 if ( olddummies > AR.MaxDum ) AR.MaxDum = olddummies;
3372 }
3373 if ( AR.PolyFun > 0 && ( AR.sLevel <= 0 || AN.FunSorts[AR.sLevel]->PolyFlag > 0 ) ) {
3374 if ( PrepPoly(BHEAD term,0) != 0 ) goto Return0;
3375 }
3376 else if ( AR.PolyFun > 0 ) {
3377 if ( PrepPoly(BHEAD term,1) != 0 ) goto Return0;
3378 }
3379 if ( AR.sLevel <= 0 && AR.BracketOn ) {
3380 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
3381 termout = AT.WorkPointer;
3382 if ( AT.WorkPointer + *term + 3 > AT.WorkTop ) goto OverWork;
3383 if ( PutBracket(BHEAD term) ) return(-1);
3384 AN.RepPoint = RepSto;
3385 *AT.WorkPointer = 0;
3386 ret = StoreTerm(BHEAD termout);
3387 AT.WorkPointer = termout;
3388 CC->numrhs = oldtoprhs;
3389 CC->Pointer = CC->Buffer + oldcpointer;
3390 CCC->numrhs = oldatoprhs;
3391 CCC->Pointer = CCC->Buffer + oldacpointer;
3392 return(ret);
3393 }
3394 else {
3395 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
3396 if ( AT.WorkPointer >= AT.WorkTop ) goto OverWork;
3397 *AT.WorkPointer = 0;
3398 AN.RepPoint = RepSto;
3399 ret = StoreTerm(BHEAD term);
3400 CC->numrhs = oldtoprhs;
3401 CC->Pointer = CC->Buffer + oldcpointer;
3402 CCC->numrhs = oldatoprhs;
3403 CCC->Pointer = CCC->Buffer + oldacpointer;
3404 return(ret);
3405 }
3406 }
3407 i = C->lhs[level][0];
3408 if ( i >= TYPECOUNT ) {
3409/*
3410 #[ Special action :
3411*/
3412 switch ( i ) {
3413 case TYPECOUNT:
3414 if ( CountDo(term,C->lhs[level]) < C->lhs[level][2] ) {
3415 AT.WorkPointer = term + *term;
3416 goto Return0;
3417 }
3418 break;
3419 case TYPEMULT:
3420 if ( MultDo(BHEAD term,C->lhs[level]) ) goto GenCall;
3421 goto ReStart;
3422 case TYPEGOTO:
3423 level = AC.Labels[C->lhs[level][2]];
3424 break;
3425 case TYPEDISCARD:
3426 AT.WorkPointer = term + *term;
3427 goto Return0;
3428 case TYPEIF:
3429#ifdef WITHPTHREADS
3430 {
3431/*
3432 We may be writing in the space here when wildcards
3433 are involved in a match(). Hence we have to make
3434 a private copy here!!!!
3435*/
3436 WORD ic, jc, *ifcode, *jfcode;
3437 jfcode = C->lhs[level]; jc = jfcode[1];
3438 ifcode = AT.WorkPointer; AT.WorkPointer += jc;
3439 for ( ic = 0; ic < jc; ic++ ) ifcode[ic] = jfcode[ic];
3440 while ( !DoIfStatement(BHEAD ifcode,term) ) {
3441 level = C->lhs[level][2];
3442 if ( C->lhs[level][0] != TYPEELIF ) break;
3443 }
3444 AT.WorkPointer = ifcode;
3445 }
3446#else
3447 while ( !DoIfStatement(BHEAD C->lhs[level],term) ) {
3448 level = C->lhs[level][2];
3449 if ( C->lhs[level][0] != TYPEELIF ) break;
3450 }
3451#endif
3452 break;
3453 case TYPEELIF:
3454 do {
3455 level = C->lhs[level][2];
3456 } while ( C->lhs[level][0] == TYPEELIF );
3457 break;
3458 case TYPEELSE:
3459 case TYPEENDIF:
3460 level = C->lhs[level][2];
3461 break;
3462 case TYPESUMFIX:
3463 {
3464 WORD *cp = AR.CompressPointer, *op = AR.CompressPointer;
3465 WORD *tlhs = C->lhs[level] + 3, *m, jlhs;
3466 WORD theindex = C->lhs[level][2];
3467 if ( theindex < 0 ) { /* $-variable */
3468#ifdef WITHPTHREADS
3469 int ddtype = -1;
3470 theindex = -theindex;
3471 d = Dollars + theindex;
3472 if ( AS.MultiThreaded ) {
3473 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3474 if ( theindex == ModOptdollars[nummodopt].number ) break;
3475 }
3476 if ( nummodopt < NumModOptdollars ) {
3477 ddtype = ModOptdollars[nummodopt].type;
3478 if ( DollarLocalCopy(ddtype) ) {
3479 d = ModOptdollars[nummodopt].dstruct+AT.identity;
3480 }
3481 else {
3482 LOCK(d->pthreadslock);
3483 }
3484 }
3485 }
3486#else
3487 theindex = -theindex;
3488 d = Dollars + theindex;
3489#endif
3490
3491 if ( d->type != DOLINDEX
3492 || d->index < AM.OffsetIndex
3493 || d->index >= AM.OffsetIndex + WILDOFFSET ) {
3494 MLOCK(ErrorMessageLock);
3495 MesPrint("$%s should have been an index"
3496 ,AC.dollarnames->namebuffer+d->name);
3497 AN.currentTerm = term;
3498 MesPrint("Current term: %t");
3499 AN.listinprint = printscratch;
3500 printscratch[0] = DOLLAREXPRESSION;
3501 printscratch[1] = theindex;
3502 MesPrint("$%s = %$"
3503 ,AC.dollarnames->namebuffer+d->name);
3504 MUNLOCK(ErrorMessageLock);
3505#ifdef WITHPTHREADS
3506 if ( ddtype > 0 && ! DollarLocalCopy(ddtype) ) { UNLOCK(d->pthreadslock); }
3507#endif
3508 goto GenCall;
3509 }
3510 theindex = d->index;
3511#ifdef WITHPTHREADS
3512 if ( ddtype > 0 && ! DollarLocalCopy(ddtype) ) { UNLOCK(d->pthreadslock); }
3513#endif
3514 }
3515 cp[1] = SUBEXPSIZE+4;
3516 cp += SUBEXPSIZE;
3517 *cp++ = INDTOIND;
3518 *cp++ = 4;
3519 *cp++ = theindex;
3520 i = C->lhs[level][1] - 3;
3521 cp++;
3522 AR.CompressPointer = cp;
3523 while ( --i >= 0 ) {
3524 cp[-1] = *tlhs++;
3525 termout = AT.WorkPointer;
3526 if ( ( jlhs = WildFill(BHEAD termout,term,op)) < 0 )
3527 goto GenCall;
3528 m = term;
3529 jlhs = *m;
3530 while ( --jlhs >= 0 ) {
3531 if ( *m++ != *termout++ ) break;
3532 }
3533 if ( jlhs >= 0 ) {
3534 termout = AT.WorkPointer;
3535 AT.WorkPointer = termout + *termout;
3536 if ( Generator(BHEAD termout,level) ) goto GenCall;
3537 AT.WorkPointer = termout;
3538 }
3539 else {
3540 AR.CompressPointer = op;
3541 goto SkipCount;
3542 }
3543 }
3544 AR.CompressPointer = op;
3545 goto CommonEnd;
3546 }
3547 case TYPESUM:
3548 {
3549 WORD *wp, *cp = AR.CompressPointer, *op = AR.CompressPointer;
3550 WORD theindex;
3551 WORD *ow;
3552/*
3553 At this point it is safest to determine CurDum
3554*/
3555 AR.CurDum = DetCurDum(BHEAD term);
3556 i = C->lhs[level][1]-2;
3557 wp = C->lhs[level] + 2;
3558 cp[1] = SUBEXPSIZE+4*i;
3559 cp += SUBEXPSIZE;
3560 while ( --i >= 0 ) {
3561 theindex = *wp++;
3562 if ( theindex < 0 ) { /* $-variable */
3563#ifdef WITHPTHREADS
3564 int ddtype = -1;
3565 theindex = -theindex;
3566 d = Dollars + theindex;
3567 if ( AS.MultiThreaded ) {
3568 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3569 if ( theindex == ModOptdollars[nummodopt].number ) break;
3570 }
3571 if ( nummodopt < NumModOptdollars ) {
3572 ddtype = ModOptdollars[nummodopt].type;
3573 if ( DollarLocalCopy(ddtype) ) {
3574 d = ModOptdollars[nummodopt].dstruct+AT.identity;
3575 }
3576 else {
3577 LOCK(d->pthreadslock);
3578 }
3579 }
3580 }
3581#else
3582 theindex = -theindex;
3583 d = Dollars + theindex;
3584#endif
3585 if ( d->type != DOLINDEX
3586 || d->index < AM.OffsetIndex
3587 || d->index >= AM.OffsetIndex + WILDOFFSET ) {
3588 MLOCK(ErrorMessageLock);
3589 MesPrint("$%s should have been an index"
3590 ,AC.dollarnames->namebuffer+d->name);
3591 AN.currentTerm = term;
3592 MesPrint("Current term: %t");
3593 AN.listinprint = printscratch;
3594 printscratch[0] = DOLLAREXPRESSION;
3595 printscratch[1] = theindex;
3596 MesPrint("$%s = %$"
3597 ,AC.dollarnames->namebuffer+d->name);
3598 MUNLOCK(ErrorMessageLock);
3599#ifdef WITHPTHREADS
3600 if ( ddtype > 0 && ! DollarLocalCopy(ddtype) ) { UNLOCK(d->pthreadslock); }
3601#endif
3602 goto GenCall;
3603 }
3604 theindex = d->index;
3605#ifdef WITHPTHREADS
3606 if ( ddtype > 0 && ! DollarLocalCopy(ddtype) ) { UNLOCK(d->pthreadslock); }
3607#endif
3608 }
3609 *cp++ = INDTOIND;
3610 *cp++ = 4;
3611 *cp++ = theindex;
3612 *cp++ = ++AR.CurDum;
3613 }
3614 ow = AT.WorkPointer;
3615 AR.CompressPointer = cp;
3616 if ( WildFill(BHEAD ow,term,op) < 0 ) goto GenCall;
3617 AR.CompressPointer = op;
3618 i = ow[0];
3619 WORD term_changed = 0;
3620 for ( j = 0; j < i; j++ ) {
3621 if ( term[j] != ow[j] ) term_changed = 1;
3622 term[j] = ow[j];
3623 }
3624 // If the term was modified by WildFill, set RepCount.
3625 if ( term_changed ) *AN.RepPoint = 1;
3626 AT.WorkPointer = ow;
3627 // Most other calls to ReNumber reset AN.IndDum to AM.IndDum first. Here it is
3628 // not done, but doing it is one way to fix Issue #710. The fix that is actually
3629 // implemented is to change a comparison in FunLevel and then a reset of
3630 // AN.IndDum appears unnecessary here. But maybe one day this comment is useful.
3631 ReNumber(BHEAD term);
3632 goto Renormalize;
3633 }
3634 case TYPECHISHOLM:
3635 if ( Chisholm(BHEAD term,level) ) goto GenCall;
3636CommonEnd:
3637 AT.WorkPointer = term + *term;
3638 goto Return0;
3639 case TYPEARG:
3640 if ( ( i = execarg(BHEAD term,level) ) < 0 ) goto GenCall;
3641 level = C->lhs[level][2];
3642 if ( i > 0 ) goto ReStart;
3643 break;
3644 case TYPENORM:
3645 case TYPENORM2:
3646 case TYPENORM3:
3647 case TYPENORM4:
3648 case TYPESPLITARG:
3649 case TYPESPLITARG2:
3650 case TYPESPLITFIRSTARG:
3651 case TYPESPLITLASTARG:
3652 case TYPEARGTOEXTRASYMBOL:
3653 if ( execarg(BHEAD term,level) < 0 ) goto GenCall;
3654 level = C->lhs[level][2];
3655 break;
3656 case TYPEFACTARG:
3657 case TYPEFACTARG2:
3658 { WORD jjj;
3659 if ( ( jjj = execarg(BHEAD term,level) ) < 0 ) goto GenCall;
3660 if ( jjj > 0 ) goto ReStart;
3661 level = C->lhs[level][2];
3662 break; }
3663 case TYPEEXIT:
3664 if ( C->lhs[level][2] > 0 ) {
3665 MLOCK(ErrorMessageLock);
3666 MesPrint("%s",C->lhs[level]+3);
3667 MUNLOCK(ErrorMessageLock);
3668 }
3669 Terminate(-1);
3670 goto GenCall;
3671 case TYPESETEXIT:
3672 AM.exitflag = 1; /* no danger of race conditions */
3673 break;
3674 case TYPEPRINT:
3675 AN.currentTerm = term;
3676 AN.numlistinprint = (C->lhs[level][1] - C->lhs[level][4] - 5)/2;
3677 AN.listinprint = C->lhs[level]+5+C->lhs[level][4];
3678 MLOCK(ErrorMessageLock);
3679 AO.ErrorBlock = 1;
3680 MesPrint((char *)(C->lhs[level]+5));
3681 AO.ErrorBlock = 0;
3682 MUNLOCK(ErrorMessageLock);
3683 break;
3684 case TYPEFPRINT:
3685 {
3686 int oldFOflag;
3687 WORD oldPrintType, oldLogHandle = AC.LogHandle;
3688 AC.LogHandle = C->lhs[level][2];
3689 MLOCK(ErrorMessageLock);
3690 oldFOflag = AM.FileOnlyFlag;
3691 oldPrintType = AO.PrintType;
3692 if ( AC.LogHandle >= 0 ) {
3693 AM.FileOnlyFlag = 1;
3694 AO.PrintType |= PRINTLFILE;
3695 }
3696 AO.PrintType |= C->lhs[level][3];
3697 AN.currentTerm = term;
3698 AN.numlistinprint = (C->lhs[level][1] - C->lhs[level][4] - 5)/2;
3699 AN.listinprint = C->lhs[level]+5+C->lhs[level][4];
3700 MesPrint((char *)(C->lhs[level]+5));
3701 AO.PrintType = oldPrintType;
3702 AM.FileOnlyFlag = oldFOflag;
3703 MUNLOCK(ErrorMessageLock);
3704 AC.LogHandle = oldLogHandle;
3705 }
3706 break;
3707 case TYPEREDEFPRE:
3708 j = C->lhs[level][2];
3709#ifdef WITHMPI
3710 {
3711 /*
3712 * Regardless of parallel/nonparallel switch, we need to set
3713 * AC.inputnumbers[ii], which indicates that the corresponding
3714 * preprocessor variable is redefined and so we need to
3715 * send/broadcast it.
3716 */
3717 int ii;
3718 for ( ii = 0; ii < AC.numpfirstnum; ii++ ) {
3719 if ( AC.pfirstnum[ii] == j ) break;
3720 }
3721 AC.inputnumbers[ii] = AN.ninterms;
3722 }
3723#endif
3724#ifdef WITHPTHREADS
3725 if ( AS.MultiThreaded ) {
3726 int ii;
3727 for ( ii = 0; ii < AC.numpfirstnum; ii++ ) {
3728 if ( AC.pfirstnum[ii] == j ) break;
3729 }
3730 if ( AN.inputnumber < AC.inputnumbers[ii] ) break;
3731 LOCK(AP.PreVarLock);
3732 if ( AN.inputnumber >= AC.inputnumbers[ii] ) {
3733 a = C->lhs[level]+4;
3734 if ( a[a[-1]] == 0 )
3735 PutPreVar(PreVar[j].name,(UBYTE *)(a),0,1);
3736 else
3737 PutPreVar(PreVar[j].name,(UBYTE *)(a)
3738 ,(UBYTE *)(a+a[-1]+1),1);
3739/*
3740 PutPreVar(PreVar[j].name,(UBYTE *)(C->lhs[level]+4),0,1);
3741*/
3742 AC.inputnumbers[ii] = AN.inputnumber;
3743 }
3744 UNLOCK(AP.PreVarLock);
3745 }
3746 else
3747#endif
3748 {
3749 a = C->lhs[level]+4;
3750 LOCK(AP.PreVarLock);
3751 if ( a[a[-1]] == 0 )
3752 PutPreVar(PreVar[j].name,(UBYTE *)(a),0,1);
3753 else
3754 PutPreVar(PreVar[j].name,(UBYTE *)(a)
3755 ,(UBYTE *)(a+a[-1]+1),1);
3756 UNLOCK(AP.PreVarLock);
3757 }
3758 break;
3759 case TYPERENUMBER:
3760 AT.WorkPointer = term + *term;
3761 if ( FullRenumber(BHEAD term,C->lhs[level][2]) ) goto GenCall;
3762 AT.WorkPointer = term + *term;
3763 if ( *term == 0 ) goto Return0;
3764 break;
3765 case TYPETRY:
3766 if ( TryDo(BHEAD term,C->lhs[level],level) ) goto GenCall;
3767 AT.WorkPointer = term + *term;
3768 goto Return0;
3769 case TYPEASSIGN:
3770 { WORD onc = AR.NoCompress, oldEside = AR.Eside;
3771 WORD oldrepeat = *AN.RepPoint;
3772/*
3773 Here we have to assign an expression to a $ variable.
3774*/
3775 AR.Eside = RHSIDE;
3776 AR.NoCompress = 1;
3777 AN.cTerm = AN.currentTerm = term;
3778 AT.WorkPointer = term + *term;
3779 *AT.WorkPointer++ = 0;
3780 if ( AssignDollar(BHEAD term,level) ) goto GenCall;
3781 AT.WorkPointer = term + *term;
3782 AN.cTerm = 0;
3783 *AN.RepPoint = oldrepeat;
3784 AR.NoCompress = onc;
3785 AR.Eside = oldEside;
3786 break;
3787 }
3788 case TYPEFINDLOOP:
3789 if ( Lus(term,C->lhs[level][3],C->lhs[level][4],
3790 C->lhs[level][5],C->lhs[level][6],C->lhs[level][2]) ) {
3791 AT.WorkPointer = term + *term;
3792 goto Renormalize;
3793 }
3794 break;
3795 case TYPEINSIDE:
3796 if ( InsideDollar(BHEAD C->lhs[level],level) < 0 ) goto GenCall;
3797 level = C->lhs[level][2];
3798 break;
3799 case TYPETERM:
3800 ret = execterm(BHEAD term,level);
3801 AN.RepPoint = RepSto;
3802 AR.CurDum = DumNow;
3803 CC->numrhs = oldtoprhs;
3804 CC->Pointer = CC->Buffer + oldcpointer;
3805 CCC->numrhs = oldatoprhs;
3806 CCC->Pointer = CCC->Buffer + oldacpointer;
3807 return(ret);
3808 case TYPEDETCURDUM:
3809 AT.WorkPointer = term + *term;
3810 AR.CurDum = DetCurDum(BHEAD term);
3811 break;
3812 case TYPEINEXPRESSION:
3813 {WORD *ll = C->lhs[level];
3814 int numexprs = (int)(ll[1]-3);
3815 ll += 3;
3816 while ( numexprs-- >= 0 ) {
3817 if ( *ll == AR.CurExpr ) break;
3818 ll++;
3819 }
3820 if ( numexprs < 0 ) level = C->lhs[level][2];
3821 }
3822 break;
3823 case TYPEMERGE:
3824 AT.WorkPointer = term + *term;
3825 if ( DoShuffle(term,level,C->lhs[level][2],C->lhs[level][3]) )
3826 goto GenCall;
3827 AT.WorkPointer = term + *term;
3828 goto Return0;
3829 case TYPESTUFFLE:
3830 AT.WorkPointer = term + *term;
3831 if ( DoStuffle(term,level,C->lhs[level][2],C->lhs[level][3]) )
3832 goto GenCall;
3833 AT.WorkPointer = term + *term;
3834 goto Return0;
3835 case TYPETESTUSE:
3836 AT.WorkPointer = term + *term;
3837 if ( TestUse(term,level) ) goto GenCall;
3838 AT.WorkPointer = term + *term;
3839 break;
3840 case TYPEAPPLY:
3841 AT.WorkPointer = term + *term;
3842 if ( ApplyExec(term,C->lhs[level][2],level) < C->lhs[level][2] ) {
3843 AT.WorkPointer = term + *term;
3844 *AN.RepPoint = 1;
3845 goto ReStart;
3846 }
3847 AT.WorkPointer = term + *term;
3848 break;
3849/*
3850 case TYPEAPPLYRESET:
3851 AT.WorkPointer = term + *term;
3852 if ( ApplyReset(level) ) goto GenCall;
3853 AT.WorkPointer = term + *term;
3854 break;
3855*/
3856 case TYPECHAININ:
3857 { int lter = *term;
3858 AT.WorkPointer = term + *term;
3859 if ( ChainIn(BHEAD term,C->lhs[level][2]) ) goto GenCall;
3860 AT.WorkPointer = term + *term;
3861 /* Symmetry properties might mean the term has vanished */
3862 if ( *term == 0 ) goto Return0;
3863 if ( *term != lter ) *AN.RepPoint = 1;
3864 }
3865 break;
3866 case TYPECHAINOUT:
3867 { int lter = *term;
3868 AT.WorkPointer = term + *term;
3869 if ( ChainOut(BHEAD term,C->lhs[level][2]) ) goto GenCall;
3870 AT.WorkPointer = term + *term;
3871 if ( *term != lter ) *AN.RepPoint = 1;
3872 }
3873 break;
3874 case TYPEFACTOR:
3875 AT.WorkPointer = term + *term;
3876 if ( DollarFactorize(BHEAD C->lhs[level][2]) ) goto GenCall;
3877 AT.WorkPointer = term + *term;
3878 break;
3879 case TYPEARGIMPLODE:
3880 AT.WorkPointer = term + *term;
3881 if ( ArgumentImplode(BHEAD term,C->lhs[level]) ) goto GenCall;
3882 AT.WorkPointer = term + *term;
3883 break;
3884 case TYPEARGEXPLODE:
3885 AT.WorkPointer = term + *term;
3886 if ( ArgumentExplode(BHEAD term,C->lhs[level]) ) goto GenCall;
3887 AT.WorkPointer = term + *term;
3888 break;
3889 case TYPEDENOMINATORS:
3890 if ( DenToFunction(term,C->lhs[level][2]) ) goto ReStart;
3891 break;
3892 case TYPEDROPCOEFFICIENT:
3893 DropCoefficient(BHEAD term);
3894 break;
3895 case TYPETRANSFORM:
3896 AT.WorkPointer = term + *term;
3897 if ( RunTransform(BHEAD term,C->lhs[level]+2) ) goto GenCall;
3898 AT.WorkPointer = term + *term;
3899 if ( *term == 0 ) goto Return0;
3900 goto ReStart;
3901 case TYPETOPOLYNOMIAL:
3902 AT.WorkPointer = term + *term;
3903 termout = AT.WorkPointer;
3904 if ( ConvertToPoly(BHEAD term,termout,C->lhs[level],0) < 0 ) goto GenCall;
3905 if ( *termout == 0 ) goto Return0;
3906 i = termout[0]; t = term; NCOPY(t,termout,i);
3907 AT.WorkPointer = term + *term;
3908 break;
3909 case TYPEFROMPOLYNOMIAL:
3910 AT.WorkPointer = term + *term;
3911 termout = AT.WorkPointer;
3912 if ( ConvertFromPoly(BHEAD term,termout,0,numxsymbol,0,0) < 0 ) goto GenCall;
3913 if ( *term == 0 ) goto Return0;
3914 i = termout[0]; t = term; NCOPY(t,termout,i);
3915 AT.WorkPointer = term + *term;
3916 goto ReStart;
3917 case TYPEDOLOOP:
3918 level = TestDoLoop(BHEAD C->lhs[level],level);
3919 if ( level < 0 ) goto GenCall;
3920 break;
3921 case TYPEENDDOLOOP:
3922 level = TestEndDoLoop(BHEAD C->lhs[C->lhs[level][2]],C->lhs[level][2]);
3923 if ( level < 0 ) goto GenCall;
3924 break;
3925 case TYPEDROPSYMBOLS:
3926 DropSymbols(BHEAD term);
3927 break;
3928 case TYPEPUTINSIDE:
3929 AT.WorkPointer = term + *term;
3930 if ( PutInside(BHEAD term,C->lhs[level]) < 0 ) goto GenCall;
3931 AT.WorkPointer = term + *term;
3932 /*
3933 * We need to call Generator() to convert slow notation to
3934 * fast notation, which fixes Issue #30.
3935 */
3936 if ( Generator(BHEAD term,level) < 0 ) goto GenCall;
3937 goto Return0;
3938 case TYPETOSPECTATOR:
3939 if ( PutInSpectator(term,C->lhs[level][2]) < 0 ) goto GenCall;
3940 goto Return0;
3941 case TYPECANONICALIZE:
3942 AT.WorkPointer = term + *term;
3943 if ( DoCanonicalize(BHEAD term,C->lhs[level]) ) goto GenCall;
3944 AT.WorkPointer = term + *term;
3945 if ( *term == 0 ) goto Return0;
3946 break;
3947 case TYPESWITCH:
3948 AT.WorkPointer = term + *term;
3949 if ( DoSwitch(BHEAD term,C->lhs[level]) ) goto GenCall;
3950 goto Return0;
3951 case TYPEENDSWITCH:
3952 AT.WorkPointer = term + *term;
3953 if ( DoEndSwitch(BHEAD term,C->lhs[level]) ) goto GenCall;
3954 goto Return0;
3955 case TYPESETUSERFLAG:
3956 Expressions[AR.CurExpr].uflags |= 1 << (C->lhs[level][2]);
3957 break;
3958 case TYPECLEARUSERFLAG:
3959 Expressions[AR.CurExpr].uflags &= ~(1 << (C->lhs[level][2]));
3960 break;
3961 case TYPEALLLOOPS:
3962 AT.WorkPointer = term + *term;
3963 if ( AllLoops(BHEAD term,level) ) goto GenCall;
3964 goto Return0;
3965 case TYPEALLPATHS:
3966 AT.WorkPointer = term + *term;
3967 if ( AllPaths(BHEAD term,level) ) goto GenCall;
3968 goto Return0;
3969#ifdef WITHFLOAT
3970 case TYPEEVALUATE:
3971 AT.WorkPointer = term + *term;
3972 if ( C->lhs[level][2] == MZV
3973 || C->lhs[level][2] == EULER
3974 || C->lhs[level][2] == MZVHALF
3975 || C->lhs[level][2] == ALLMZVFUNCTIONS
3976 ) {
3977 if ( EvaluateEuler(BHEAD term,level,C->lhs[level][2]) ) goto GenCall;
3978 }
3979 else {
3980 if ( EvaluateFun(BHEAD term,level,C->lhs[level]) ) goto GenCall;
3981 }
3982/*
3983 else if ( C->lhs[level][2] == SQRTFUNCTION ) {
3984 if ( EvaluateSqrt(BHEAD term,level,C->lhs[level][2]) ) goto GenCall;
3985 }
3986 else {
3987 MLOCK(ErrorMessageLock);
3988 MesPrint("Illegal function %d in evaluate statement.",C->lhs[level][2]);
3989 MUNLOCK(ErrorMessageLock);
3990 goto GenCall;
3991 }
3992*/
3993 goto Return0;
3994 case TYPETOFLOAT:
3995 AT.WorkPointer = term + *term;
3996 if ( ToFloat(BHEAD term,level) ) goto GenCall;
3997 goto Return0;
3998 case TYPETORAT:
3999 AT.WorkPointer = term + *term;
4000 if ( ToRat(BHEAD term,level) ) goto GenCall;
4001 goto Return0;
4002 case TYPESTRICTROUNDING:
4003 AT.WorkPointer = term + *term;
4004 if ( StrictRounding(BHEAD term,level,C->lhs[level][2],C->lhs[level][3]) ) goto GenCall;
4005 goto Return0;
4006 case TYPECHOP:
4007 AT.WorkPointer = term + *term;
4008 if ( Chop(BHEAD term,level) ) goto GenCall;
4009 goto Return0;
4010#endif
4011 }
4012 goto SkipCount;
4013/*
4014 #] Special action :
4015*/
4016 }
4017 } while ( ( i = TestMatch(BHEAD term,&level) ) == 0 );
4018 if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
4019 if ( i > 0 ) replac = TestSub(BHEAD term,level);
4020 else replac = i;
4021 if ( replac >= 0 || AT.TMout[1] != SYMMETRIZE ) {
4022 *AN.RepPoint = 1;
4023 AR.expchanged = 1;
4024 }
4025 if ( replac < 0 ) { /* Terms come from automatic generation */
4026AutoGen: i = *AT.TMout;
4027 t = termout = AT.WorkPointer;
4028 if ( ( AT.WorkPointer += i ) > AT.WorkTop ) goto OverWork;
4029 accum = AT.TMout;
4030 while ( --i >= 0 ) *t++ = *accum++;
4031 if ( (*(FG.Operation[termout[1]]))(BHEAD term,termout,replac,level) ) goto GenCall;
4032 AT.WorkPointer = termout;
4033 goto Return0;
4034 }
4035 }
4036 if ( applyflag ) { TableReset(); applyflag = 0; }
4037
4038 if ( AN.TeInFun ) { /* Match in function argument */
4039 if ( AN.TeInFun < 0 && !AN.TeSuOut ) {
4040
4041 if ( AR.TePos >= 0 ) goto AutoGen;
4042 switch ( AN.TeInFun ) {
4043 case -1:
4044 if ( DoDistrib(BHEAD term,level) ) goto GenCall;
4045 break;
4046 case -2:
4047 if ( DoDelta3(BHEAD term,level) ) goto GenCall;
4048 break;
4049 case -3:
4050 if ( DoTableExpansion(term,level) ) goto GenCall;
4051 break;
4052 case -4:
4053 if ( FactorIn(BHEAD term,level) ) goto GenCall;
4054 break;
4055 case -5:
4056 if ( FactorInExpr(BHEAD term,level) ) goto GenCall;
4057 break;
4058 case -6:
4059 if ( TermsInBracket(BHEAD term,level) < 0 ) goto GenCall;
4060 break;
4061 case -7:
4062 if ( ExtraSymFun(BHEAD term,level) < 0 ) goto GenCall;
4063 break;
4064 case -8:
4065 if ( GCDfunction(BHEAD term,level) < 0 ) goto GenCall;
4066 break;
4067 case -9:
4068 if ( DIVfunction(BHEAD term,level,0) < 0 ) goto GenCall;
4069 break;
4070 case -10:
4071 if ( DIVfunction(BHEAD term,level,1) < 0 ) goto GenCall;
4072 break;
4073 case -11:
4074 if ( DIVfunction(BHEAD term,level,2) < 0 ) goto GenCall;
4075 break;
4076 case -12:
4077 if ( DoPermutations(BHEAD term,level) ) goto GenCall;
4078 break;
4079 case -13:
4080 if ( DoPartitions(BHEAD term,level) ) goto GenCall;
4081 break;
4082 case -14:
4083 if ( DIVfunction(BHEAD term,level,3) < 0 ) goto GenCall;
4084 break;
4085 case -15:
4086 if ( GenDiagrams(BHEAD term,level) < 0 ) goto GenCall;
4087 break;
4088 }
4089 }
4090 else {
4091 termout = AT.WorkPointer;
4092 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
4093 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4094 if ( InFunction(BHEAD term,termout) ) goto GenCall;
4095 AT.WorkPointer = termout + *termout;
4096 *AN.RepPoint = 1;
4097 AR.expchanged = 1;
4098 if ( *termout && Generator(BHEAD termout,level) < 0 ) goto GenCall;
4099 AT.WorkPointer = termout;
4100 }
4101 }
4102 else if ( replac > 0 ) {
4103 power = AN.TeSuOut;
4104 tepos = AR.TePos;
4105 if ( power < 0 ) { /* Table expansion */
4106 power = -power; tepos = 0;
4107 }
4108 extractbuff = AT.TMbuff;
4109 if ( extractbuff == AM.dbufnum ) {
4110 d = DolToTerms(BHEAD replac);
4111 if ( d && d->where != 0 ) {
4112 iscopy = 1;
4113 if ( AT.TMdolfac > 0 ) { /* We need a factor */
4114 if ( AT.TMdolfac == 1 ) {
4115 if ( d->nfactors ) {
4116 numfac[0] = 4;
4117 numfac[1] = d->nfactors;
4118 numfac[2] = 1;
4119 numfac[3] = 3;
4120 numfac[4] = 0;
4121 }
4122 else {
4123 numfac[0] = 0;
4124 }
4125 StartBuf = numfac;
4126 }
4127 else {
4128 if ( (AT.TMdolfac-1) > d->nfactors && d->nfactors > 0 ) {
4129 MLOCK(ErrorMessageLock);
4130 MesPrint("Attempt to use an nonexisting factor %d of a $-variable",(WORD)(AT.TMdolfac-1));
4131 if ( d->nfactors == 1 )
4132 MesPrint("There is only one factor");
4133 else
4134 MesPrint("There are only %d factors",(WORD)(d->nfactors));
4135 MUNLOCK(ErrorMessageLock);
4136 goto GenCall;
4137 }
4138 if ( d->nfactors > 1 ) {
4139 DOLLARS dd;
4140 LONG dsize;
4141 WORD *td1, *td2;
4142 dd = Dollars + replac;
4143#ifdef WITHPTHREADS
4144 {
4145 int nummodopt, dtype = -1;
4146 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
4147 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
4148 if ( replac == ModOptdollars[nummodopt].number ) break;
4149 }
4150 if ( nummodopt < NumModOptdollars ) {
4151 dtype = ModOptdollars[nummodopt].type;
4152 if ( DollarLocalCopy(dtype) ) {
4153 dd = ModOptdollars[nummodopt].dstruct+AT.identity;
4154 }
4155 }
4156 }
4157 }
4158#endif
4159 dsize = dd->factors[AT.TMdolfac-2].size;
4160/*
4161 We copy only the factor we need
4162*/
4163 if ( dsize == 0 ) {
4164 numfac[0] = 4;
4165 numfac[1] = d->factors[AT.TMdolfac-2].value;
4166 numfac[2] = 1;
4167 numfac[3] = 3;
4168 numfac[4] = 0;
4169 StartBuf = numfac;
4170 if ( numfac[1] < 0 ) {
4171 numfac[1] = -numfac[1];
4172 numfac[3] = -numfac[3];
4173 }
4174 }
4175 else {
4176 d->factors[AT.TMdolfac-2].where = td2 = (WORD *)Malloc1(
4177 (dsize+1)*sizeof(WORD),"Copy of factor");
4178 td1 = dd->factors[AT.TMdolfac-2].where;
4179 StartBuf = td2;
4180 d->size = dsize; d->type = DOLTERMS;
4181 NCOPY(td2,td1,dsize);
4182 *td2 = 0;
4183 }
4184 }
4185 else if ( d->nfactors == 1 ) {
4186 StartBuf = d->where;
4187 }
4188 else {
4189 MLOCK(ErrorMessageLock);
4190 if ( d->nfactors == 0 ) {
4191 MesPrint("Attempt to use factor %d of an unfactored $-variable",(WORD)(AT.TMdolfac-1));
4192 }
4193 else {
4194/* INTERNAL_ERROR_EXCL_START */
4195 MesPrint("!>Internal error. Illegal number of factors for $-variable");
4196/* INTERNAL_ERROR_EXCL_STOP */
4197 }
4198 MUNLOCK(ErrorMessageLock);
4199 goto GenCall;
4200 }
4201 }
4202 }
4203 else StartBuf = d->where;
4204 }
4205 else {
4206 d = Dollars + replac;
4207 StartBuf = zeroDollar;
4208 }
4209 posisub = 0;
4210 i = DetCommu(d->where);
4211#ifdef WITHPTHREADS
4212 if ( AS.MultiThreaded ) {
4213 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
4214 if ( replac == ModOptdollars[nummodopt].number ) break;
4215 }
4216 if ( nummodopt < NumModOptdollars ) {
4217 dtype = ModOptdollars[nummodopt].type;
4218 if ( dtype == MODMAX || dtype == MODMIN ) {
4219 if ( StartBuf[0] && StartBuf[StartBuf[0]] ) {
4220 MLOCK(ErrorMessageLock);
4221 MesPrint("A dollar variable with modoption max or min can have only one term");
4222 MUNLOCK(ErrorMessageLock);
4223 goto GenCall;
4224 }
4225 }
4226 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) {
4227 LOCK(d->pthreadslock);
4228 }
4229 }
4230 }
4231#endif
4232 }
4233 else {
4234 StartBuf = cbuf[extractbuff].Buffer;
4235 posisub = cbuf[extractbuff].rhs[replac] - StartBuf;
4236 i = (WORD)cbuf[extractbuff].CanCommu[replac];
4237 }
4238 if ( power == 1 ) { /* Just a single power */
4239 termout = AT.WorkPointer;
4240 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
4241 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4242 while ( StartBuf[posisub] ) {
4243 if ( extractbuff == AT.allbufnum ) WildDollars(BHEAD &(StartBuf[posisub]));
4244 AT.WorkPointer = (WORD *)(((UBYTE *)(termout)) + AM.MaxTer);
4245 if ( InsertTerm(BHEAD term,replac,extractbuff,
4246 &(StartBuf[posisub]),termout,tepos) < 0 ) goto GenCall;
4247 AT.WorkPointer = termout + *termout;
4248 *AN.RepPoint = 1;
4249 AR.expchanged = 1;
4250 posisub += StartBuf[posisub];
4251/*
4252 For multiple table substitutions it may be better to
4253 do modulus arithmetic right here
4254 Turns out to be not very effective.
4255
4256 if ( AN.ncmod != 0 ) {
4257 if ( Modulus(termout) ) goto GenCall;
4258 if ( !*termout ) goto Return0;
4259 }
4260*/
4261#ifdef WITHPTHREADS
4262 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
4263 if ( ( AS.Balancing && CC->numrhs == 0 ) && StartBuf[posisub] ) {
4264/* UNFINISHED_FEATURE_EXCL_START */
4265 if ( ( id = ConditionalGetAvailableThread() ) >= 0 ) {
4266 if ( BalanceRunThread(BHEAD id,termout,level) < 0 ) goto GenCall;
4267 }
4268/* UNFINISHED_FEATURE_EXCL_STOP */
4269 }
4270 else
4271#endif
4272 if ( Generator(BHEAD termout,level) < 0 ) goto GenCall;
4273#ifdef WITHPTHREADS
4274 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { dtype = 0; break; }
4275#endif
4276 if ( iscopy == 0 && ( extractbuff != AM.dbufnum ) ) {
4277/*
4278 There are cases in which a bigger buffer is created
4279 on the fly, like with wildcard buffers.
4280 We play it safe here. Maybe we can be more selective
4281 in some distant future?
4282*/
4283 StartBuf = cbuf[extractbuff].Buffer;
4284 }
4285 }
4286 if ( extractbuff == AT.allbufnum ) {
4287 CBUF *Ce = cbuf + extractbuff;
4288 Ce->Pointer = Ce->rhs[Ce->numrhs--];
4289 }
4290#ifdef WITHPTHREADS
4291 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); dtype = 0; }
4292#endif
4293 if ( iscopy ) {
4294 if ( d->nfactors > 1 ) {
4295 int j;
4296 for ( j = 0; j < d->nfactors; j++ ) {
4297 if ( d->factors[j].where ) M_free(d->factors[j].where,"Copy of factor");
4298 }
4299 M_free(d->factors,"Dollar factors");
4300 }
4301 M_free(d,"Copy of dollar variable");
4302 d = 0; iscopy = 0;
4303 }
4304 AT.WorkPointer = termout;
4305 }
4306 else if ( i <= 1 ) { /* Use binomials */
4307 LONG posit, olw;
4308 WORD *same, *ow = AT.WorkPointer;
4309 LONG olpw = AT.posWorkPointer;
4310 power1 = power+1;
4311 WantAddLongs(power1);
4312 olw = posit = AT.lWorkPointer; AT.lWorkPointer += power1;
4313 same = ++AT.WorkPointer;
4314 a = accum = ( AT.WorkPointer += power1+1 );
4315 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2*AM.MaxTer);
4316 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4317 AT.lWorkSpace[posit] = posisub;
4318 same[-1] = 0;
4319 *same = 1;
4320 *accum = 0;
4321 tepos = AR.TePos;
4322 i = 1;
4323 do {
4324 if ( StartBuf[AT.lWorkSpace[posit]] ) {
4325 if ( ( a = PasteTerm(BHEAD i-1,accum,
4326 &(StartBuf[AT.lWorkSpace[posit]]),i,*same) ) == 0 )
4327 goto GenCall;
4328 AT.lWorkSpace[posit+1] = AT.lWorkSpace[posit];
4329 same[1] = *same + 1;
4330 if ( i > 1 && AT.lWorkSpace[posit] < AT.lWorkSpace[posit-1] ) *same = 1;
4331 AT.lWorkSpace[posit] += StartBuf[AT.lWorkSpace[posit]];
4332 i++;
4333 posit++;
4334 same++;
4335 }
4336 else {
4337 i--; posit--; same--;
4338 }
4339 if ( i > power ) {
4340 termout = AT.WorkPointer = a;
4341 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2*AM.MaxTer);
4342 if ( AT.WorkPointer > AT.WorkTop )
4343 goto OverWork;
4344 if ( FiniTerm(BHEAD term,accum,termout,replac,tepos) ) goto GenCall;
4345 AT.WorkPointer = termout + *termout;
4346 *AN.RepPoint = 1;
4347 AR.expchanged = 1;
4348#ifdef WITHPTHREADS
4349 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
4350/* UNFINISHED_FEATURE_EXCL_START */
4351 if ( ( AS.Balancing && CC->numrhs == 0 ) && ( i > 0 )
4352 && ( id = ConditionalGetAvailableThread() ) >= 0 ) {
4353 if ( BalanceRunThread(BHEAD id,termout,level) < 0 ) goto GenCall;
4354 }
4355/* UNFINISHED_FEATURE_EXCL_STOP */
4356 else
4357#endif
4358 if ( Generator(BHEAD termout,level) ) goto GenCall;
4359#ifdef WITHPTHREADS
4360 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { dtype = 0; break; }
4361#endif
4362 if ( iscopy == 0 && ( extractbuff != AM.dbufnum ) )
4363 StartBuf = cbuf[extractbuff].Buffer;
4364 i--; posit--; same--;
4365 }
4366 } while ( i > 0 );
4367#ifdef WITHPTHREADS
4368 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); dtype = 0; }
4369#endif
4370 if ( iscopy ) {
4371 if ( d->nfactors > 1 ) {
4372 int j;
4373 for ( j = 0; j < d->nfactors; j++ ) {
4374 if ( d->factors[j].where ) M_free(d->factors[j].where,"Copy of factor");
4375 }
4376 M_free(d->factors,"Dollar factors");
4377 }
4378 M_free(d,"Copy of dollar variable");
4379 d = 0; iscopy = 0;
4380 }
4381 AT.WorkPointer = ow; AT.lWorkPointer = olw; AT.posWorkPointer = olpw;
4382 }
4383 else { /* No binomials */
4384 LONG posit, olw, olpw = AT.posWorkPointer;
4385 WantAddLongs(power);
4386 posit = olw = AT.lWorkPointer; AT.lWorkPointer += power;
4387 a = accum = AT.WorkPointer;
4388 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2*AM.MaxTer);
4389 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4390 for ( i = 0; i < power; i++ ) AT.lWorkSpace[posit++] = posisub;
4391 posit = olw;
4392 *accum = 0;
4393 tepos = AR.TePos;
4394 i = 0;
4395 while ( i >= 0 ) {
4396 if ( StartBuf[AT.lWorkSpace[posit]] ) {
4397 if ( ( a = PasteTerm(BHEAD i,accum,
4398 &(StartBuf[AT.lWorkSpace[posit]]),1,1) ) == 0 ) goto GenCall;
4399 AT.lWorkSpace[posit] += StartBuf[AT.lWorkSpace[posit]];
4400 i++; posit++;
4401 }
4402 else {
4403 AT.lWorkSpace[posit--] = posisub;
4404 i--;
4405 }
4406 if ( i >= power ) {
4407 termout = AT.WorkPointer = a;
4408 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2*AM.MaxTer);
4409 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4410 if ( FiniTerm(BHEAD term,accum,termout,replac,tepos) ) goto GenCall;
4411 AT.WorkPointer = termout + *termout;
4412 *AN.RepPoint = 1;
4413 AR.expchanged = 1;
4414#ifdef WITHPTHREADS
4415 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); }
4416 if ( ( AS.Balancing && CC->numrhs == 0 ) && ( i > 0 ) && ( id = ConditionalGetAvailableThread() ) >= 0 ) {
4417/* UNFINISHED_FEATURE_EXCL_START */
4418 if ( BalanceRunThread(BHEAD id,termout,level) < 0 ) goto GenCall;
4419/* UNFINISHED_FEATURE_EXCL_STOP */
4420 }
4421 else
4422#endif
4423 if ( Generator(BHEAD termout,level) ) goto GenCall;
4424#ifdef WITHPTHREADS
4425 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { dtype = 0; break; }
4426#endif
4427 if ( iscopy == 0 && ( extractbuff != AM.dbufnum ) )
4428 StartBuf = cbuf[extractbuff].Buffer;
4429 i--; posit--;
4430 }
4431 }
4432#ifdef WITHPTHREADS
4433 if ( dtype > 0 && ! DollarLocalCopy(dtype) ) { UNLOCK(d->pthreadslock); dtype = 0; }
4434#endif
4435 if ( iscopy ) {
4436 if ( d->nfactors > 1 ) {
4437 int j;
4438 for ( j = 0; j < d->nfactors; j++ ) {
4439 if ( d->factors[j].where ) M_free(d->factors[j].where,"Copy of factor");
4440 }
4441 M_free(d->factors,"Dollar factors");
4442 }
4443 M_free(d,"Copy of dollar variable");
4444 d = 0; iscopy = 0;
4445 }
4446 AT.WorkPointer = accum;
4447 AT.lWorkPointer = olw;
4448 AT.posWorkPointer = olpw;
4449 }
4450 }
4451 else { /* Expression from disk */
4452 POSITION StartPos;
4453 LONG position, olpw, opw, comprev, extra;
4454 RENUMBER renumber;
4455 WORD *Freeze, *aa, *dummies;
4456 replac = -replac-1;
4457 power = AN.TeSuOut;
4458 Freeze = AN.Frozen;
4459 if ( Expressions[replac].status == STOREDEXPRESSION ) {
4460 POSITION firstpos;
4461 SETSTARTPOS(firstpos);
4462
4463/* Note that AT.TMaddr is needed for GetTable just once! */
4464/*
4465 We need space for the previous term in the compression
4466 This is made available in AR.CompressBuffer, although we may get
4467 problems with this sooner or later. Hence we need to keep
4468 a set of pointers in AR.CompressBuffer
4469 Note that after the last call there has been no use made
4470 of AR.CompressPointer, so it points automatically at its original
4471 position!
4472*/
4473 WantAddPointers(power+1);
4474 comprev = opw = AT.pWorkPointer;
4475 AT.pWorkPointer += power+1;
4476 WantAddPositions(power+1);
4477 position = olpw = AT.posWorkPointer;
4478 AT.posWorkPointer += power + 1;
4479
4480 AT.pWorkSpace[comprev++] = AR.CompressPointer;
4481
4482 for ( i = 0; i < power; i++ ) {
4483 PUTZERO(AT.posWorkSpace[position]); position++;
4484 }
4485 position = olpw;
4486 if ( ( renumber = GetTable(replac,&(AT.posWorkSpace[position]),1) ) == 0 ) goto GenCall;
4487 dummies = AT.WorkPointer;
4488 *dummies++ = AR.CurDum;
4489 AT.WorkPointer += power+2;
4490 accum = AT.WorkPointer;
4491 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2*AM.MaxTer);
4492 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4493 aa = AT.WorkPointer;
4494 *accum = 0;
4495 i = 0; StartPos = AT.posWorkSpace[position];
4496 dummies[i] = AR.CurDum;
4497 while ( i >= 0 ) {
4498skippedfirst:
4499 AR.CompressPointer = AT.pWorkSpace[comprev-1];
4500 if ( ( extra = PasteFile(BHEAD i,accum,&(AT.posWorkSpace[position])
4501 ,&a,renumber,Freeze,replac) ) < 0 ) goto GenCall;
4502 if ( Expressions[replac].numdummies > 0 ) {
4503 AR.CurDum = dummies[i] + Expressions[replac].numdummies;
4504 }
4505 if ( NOTSTARTPOS(firstpos) ) {
4506 if ( ISMINPOS(firstpos) || ISEQUALPOS(firstpos,AT.posWorkSpace[position]) ) {
4507 firstpos = AT.posWorkSpace[position];
4508/*
4509 ADDPOS(AT.posWorkSpace[position],extra * sizeof(WORD));
4510*/
4511 goto skippedfirst;
4512 }
4513 }
4514 if ( extra ) {
4515/*
4516 ADDPOS(AT.posWorkSpace[position],extra * sizeof(WORD));
4517*/
4518 i++; AT.posWorkSpace[++position] = StartPos;
4519 AT.pWorkSpace[comprev++] = AR.CompressPointer;
4520 dummies[i] = AR.CurDum;
4521 }
4522 else {
4523 PUTZERO(AT.posWorkSpace[position]); position--; i--;
4524 AR.CurDum = dummies[i];
4525 comprev--;
4526 }
4527 if ( i >= power ) {
4528 termout = AT.WorkPointer = a;
4529 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2*AM.MaxTer);
4530 if ( AT.WorkPointer > AT.WorkTop ) goto OverWork;
4531 if ( FiniTerm(BHEAD term,accum,termout,replac,0) ) goto GenCall;
4532 if ( *termout ) {
4533 AT.WorkPointer = termout + *termout;
4534 *AN.RepPoint = 1;
4535 AR.expchanged = 1;
4536#ifdef WITHPTHREADS
4537 if ( ( AS.Balancing && CC->numrhs == 0 ) && ( i > 0 ) && ( id = ConditionalGetAvailableThread() ) >= 0 ) {
4538/* UNFINISHED_FEATURE_EXCL_START */
4539 if ( BalanceRunThread(BHEAD id,termout,level) < 0 ) goto GenCall;
4540/* UNFINISHED_FEATURE_EXCL_STOP */
4541 }
4542 else
4543#endif
4544 if ( Generator(BHEAD termout,level) ) goto GenCall;
4545 }
4546 i--; position--;
4547 AR.CurDum = dummies[i];
4548 comprev--;
4549 }
4550 AT.WorkPointer = aa;
4551 }
4552 AT.WorkPointer = accum;
4553 AT.posWorkPointer = olpw;
4554 AT.pWorkPointer = opw;
4555/*
4556 Bug fix. See also GetTable
4557#ifdef WITHPTHREADS
4558 M_free(renumber->symb.lo,"VarSpace");
4559 M_free(renumber,"Renumber");
4560#endif
4561*/
4562 if ( renumber->symb.lo != AN.dummyrenumlist )
4563 M_free(renumber->symb.lo,"VarSpace");
4564 M_free(renumber,"Renumber");
4565
4566 }
4567 else { /* Active expression */
4568 aa = accum = AT.WorkPointer;
4569 if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + 2 * AM.MaxTer + sizeof(WORD)) ) > AT.WorkTop )
4570 goto OverWork;
4571 *accum++ = -1; AT.WorkPointer++;
4572 if ( DoOnePow(BHEAD term,power,replac,accum,aa,level,Freeze) ) goto GenCall;
4573 AT.WorkPointer = aa;
4574 }
4575 }
4576Return0:
4577 AR.CurDum = DumNow;
4578 AN.RepPoint = RepSto;
4579 CC->numrhs = oldtoprhs;
4580 CC->Pointer = CC->Buffer + oldcpointer;
4581 CCC->numrhs = oldatoprhs;
4582 CCC->Pointer = CCC->Buffer + oldacpointer;
4583 return(0);
4584
4585GenCall:
4586 if ( AM.tracebackflag ) {
4587 termout = term;
4588 MLOCK(ErrorMessageLock);
4589 AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer;
4590 AO.OutSkip = 3;
4591 FiniLine();
4592 i = *termout;
4593 while ( --i >= 0 ) {
4594 TalToLine((UWORD)(*termout++));
4595 TokenToLine((UBYTE *)" ");
4596 }
4597 AO.OutSkip = 0;
4598 FiniLine();
4599 MesCall("Generator");
4600 MUNLOCK(ErrorMessageLock);
4601 }
4602 CC->numrhs = oldtoprhs;
4603 CC->Pointer = CC->Buffer + oldcpointer;
4604 CCC->numrhs = oldatoprhs;
4605 CCC->Pointer = CCC->Buffer + oldacpointer;
4606 return(-1);
4607OverWork:
4608 CC->numrhs = oldtoprhs;
4609 CC->Pointer = CC->Buffer + oldcpointer;
4610 CCC->numrhs = oldatoprhs;
4611 CCC->Pointer = CCC->Buffer + oldacpointer;
4612 MLOCK(ErrorMessageLock);
4613 MesWork();
4614 MUNLOCK(ErrorMessageLock);
4615 return(-1);
4616}
4617
4618/*
4619 #] Generator :
4620 #[ DoOnePow : WORD DoOnePow(term,power,nexp,accum,aa,level,freeze)
4621*/
4646#ifdef WITHPTHREADS
4647char freezestring[] = "freeze<-xxxx";
4648#endif
4649
4650int DoOnePow(PHEAD WORD *term, WORD power, WORD nexp, WORD * accum,
4651 WORD *aa, WORD level, WORD *freeze)
4652{
4653 GETBIDENTITY
4654 POSITION oldposition, startposition;
4655 WORD *acc, *termout, fromfreeze = 0;
4656 WORD *oldipointer = AR.CompressPointer;
4657 FILEHANDLE *fi;
4658 WORD type, retval;
4659 WORD oldGetOneFile = AR.GetOneFile;
4660 WORD olddummies = AR.CurDum;
4661 WORD extradummies = Expressions[nexp].numdummies;
4662/*
4663 The next code is for some tricky debugging. (5-jan-2010 JV)
4664 Normally it should be disabled.
4665*/
4666/*
4667#ifdef WITHPTHREADS
4668 if ( freeze ) {
4669 MLOCK(ErrorMessageLock);
4670 if ( AT.identity < 10 ) {
4671 freezestring[8] = '0'+AT.identity;
4672 freezestring[9] = '>';
4673 freezestring[10] = 0;
4674 }
4675 else if ( AT.identity < 100 ) {
4676 freezestring[8] = '0'+AT.identity/10;
4677 freezestring[9] = '0'+AT.identity%10;
4678 freezestring[10] = '>';
4679 freezestring[11] = 0;
4680 }
4681 else {
4682 freezestring[8] = 0;
4683 }
4684 PrintTerm(freeze,freezestring);
4685 MUNLOCK(ErrorMessageLock);
4686 }
4687#else
4688 if ( freeze ) PrintTerm(freeze,"freeze");
4689#endif
4690*/
4691 type = Expressions[nexp].status;
4692 if ( type == HIDDENLEXPRESSION || type == HIDDENGEXPRESSION
4693 || type == DROPHLEXPRESSION || type == DROPHGEXPRESSION
4694 || type == UNHIDELEXPRESSION || type == UNHIDEGEXPRESSION ) {
4695 AR.GetOneFile = 2; fi = AR.hidefile;
4696 }
4697 else {
4698 AR.GetOneFile = 0; fi = AR.infile;
4699 }
4700 if ( fi->handle >= 0 ) {
4701 PUTZERO(oldposition);
4702#ifdef WITHSEEK
4703 LOCK(AS.inputslock);
4704 SeekFile(fi->handle,&oldposition,SEEK_CUR);
4705 UNLOCK(AS.inputslock);
4706#endif
4707 }
4708 else {
4709 SETBASEPOSITION(oldposition,fi->POfill-fi->PObuffer);
4710 }
4711 if ( freeze && ( Expressions[nexp].bracketinfo != 0 ) ) {
4712 POSITION *brapos;
4713/*
4714 There is a bracket index
4715 AR.CompressPointer = oldipointer;
4716*/
4717 (*aa)++;
4718 power--;
4719 if ( ( brapos = FindBracket(nexp,freeze) ) == 0 )
4720 goto EndExpr;
4721 startposition = *brapos;
4722 goto doterms;
4723 }
4724 startposition = AS.OldOnFile[nexp];
4725 retval = GetOneTerm(BHEAD accum,fi,&startposition,0);
4726 if ( retval > 0 ) { /* Skip prototype */
4727 (*aa)++;
4728 power--;
4729doterms:
4730 AR.CompressPointer = oldipointer;
4731 for (;;) {
4732 retval = GetOneTerm(BHEAD accum,fi,&startposition,0);
4733 if ( retval <= 0 ) break;
4734/*
4735 Here should come the code to test for [].
4736*/
4737 if ( freeze ) {
4738 WORD *t, *m, *r, *mstop;
4739 WORD *tset;
4740 t = accum;
4741 m = freeze;
4742 m += *m;
4743 m -= ABS(m[-1]);
4744 mstop = m;
4745 m = freeze + 1;
4746 r = t;
4747 r += *t;
4748 r -= ABS(r[-1]);
4749 t++;
4750 tset = t;
4751 while ( t < r && *t != HAAKJE ) t += t[1];
4752 if ( t >= r ) {
4753 if ( m < mstop ) {
4754 if ( fromfreeze ) goto EndExpr;
4755 goto NextTerm;
4756 }
4757 t = tset;
4758 }
4759 else {
4760 r = tset;
4761 while ( r < t && m < mstop ) {
4762 if ( *r == *m ) { m++; r++; }
4763 else {
4764 if ( fromfreeze ) goto EndExpr;
4765 goto NextTerm;
4766 }
4767 }
4768 if ( r < t || m < mstop ) {
4769 if ( fromfreeze ) goto EndExpr;
4770 goto NextTerm;
4771 }
4772 }
4773 fromfreeze = 1;
4774 r = tset;
4775 m = accum;
4776 m += *m;
4777 while ( t < m ) *r++ = *t++;
4778 *accum = WORDDIF(r,accum);
4779 }
4780 if ( extradummies > 0 ) {
4781 if ( olddummies > AM.IndDum ) {
4782 MoveDummies(BHEAD accum,olddummies-AM.IndDum);
4783 }
4784 AR.CurDum = olddummies+extradummies;
4785 }
4786 acc = accum;
4787 acc += *acc;
4788 if ( power <= 0 ) {
4789 termout = acc;
4790 AT.WorkPointer = (WORD *)(((UBYTE *)(acc)) + 2*AM.MaxTer);
4791 if ( AT.WorkPointer > AT.WorkTop ) {
4792 MLOCK(ErrorMessageLock);
4793 MesWork();
4794 MUNLOCK(ErrorMessageLock);
4795 return(-1);
4796 }
4797 if ( FiniTerm(BHEAD term,aa,termout,nexp,0) ) goto PowCall;
4798 if ( *termout ) {
4799 MarkPolyRatFunDirty(termout)
4800/* PolyFunDirty(BHEAD termout); */
4801 AT.WorkPointer = termout + *termout;
4802 *AN.RepPoint = 1;
4803 AR.expchanged = 1;
4804 if ( Generator(BHEAD termout,level) ) goto PowCall;
4805 }
4806 }
4807 else {
4808 if ( acc > AT.WorkTop ) {
4809 MLOCK(ErrorMessageLock);
4810 MesWork();
4811 MUNLOCK(ErrorMessageLock);
4812 return(-1);
4813 }
4814 if ( DoOnePow(BHEAD term,power,nexp,acc,aa,level,freeze) ) goto PowCall;
4815 }
4816NextTerm:;
4817 AR.CompressPointer = oldipointer;
4818 }
4819EndExpr:
4820 (*aa)--;
4821 }
4822 AR.CompressPointer = oldipointer;
4823 if ( fi->handle >= 0 ) {
4824#ifdef WITHSEEK
4825 LOCK(AS.inputslock);
4826 SeekFile(fi->handle,&oldposition,SEEK_SET);
4827 UNLOCK(AS.inputslock);
4828 if ( ISNEGPOS(oldposition) ) {
4829/* INTERNAL_ERROR_EXCL_START */
4830 MLOCK(ErrorMessageLock);
4831 MesPrint("!>File error");
4832 goto PowCall2;
4833/* INTERNAL_ERROR_EXCL_STOP */
4834 }
4835#endif
4836 }
4837 else {
4838 fi->POfill = fi->PObuffer + BASEPOSITION(oldposition);
4839 }
4840 AR.GetOneFile = oldGetOneFile;
4841 AR.CurDum = olddummies;
4842 return(0);
4843PowCall:;
4844 MLOCK(ErrorMessageLock);
4845#ifdef WITHSEEK
4846PowCall2:;
4847#endif
4848 MesCall("DoOnePow");
4849 MUNLOCK(ErrorMessageLock);
4850 SETERROR(-1)
4851}
4852
4853/*
4854 #] DoOnePow :
4855 #[ Deferred : WORD Deferred(term,level)
4856*/
4873int Deferred(PHEAD WORD *term, WORD level)
4874{
4875 GETBIDENTITY
4876 POSITION startposition;
4877 WORD *t, *m, *mstop, *tstart, decr, oldb, *termout, i, *oldwork, retval;
4878 WORD *oldipointer = AR.CompressPointer, *oldPOfill = AR.infile->POfill;
4879 WORD oldGetOneFile = AR.GetOneFile;
4880 AR.GetOneFile = 1;
4881 oldwork = AT.WorkPointer;
4882 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
4883 termout = AT.WorkPointer;
4884 AR.DeferFlag = 0;
4885 startposition = AR.DefPosition;
4886/*
4887 Store old position
4888*/
4889 if ( AR.infile->handle >= 0 ) {
4890/*
4891 PUTZERO(oldposition);
4892 SeekFile(AR.infile->handle,&oldposition,SEEK_CUR);
4893*/
4894 }
4895 else {
4896/*
4897 SETBASEPOSITION(oldposition,AR.infile->POfill-AR.infile->PObuffer);
4898*/
4899 AR.infile->POfill = (WORD *)((UBYTE *)(AR.infile->PObuffer)
4900 +BASEPOSITION(startposition));
4901 }
4902/*
4903 Look in the CompressBuffer where the bracket contents start
4904*/
4905 t = m = AR.CompressBuffer;
4906 t += *t;
4907 mstop = t - ABS(t[-1]);
4908 m++;
4909 while ( *m != HAAKJE && m < mstop ) m += m[1];
4910 if ( m >= mstop ) { /* No deferred action! */
4911 AT.WorkPointer = term + *term;
4912 if ( Generator(BHEAD term,level) ) goto DefCall;
4913 AR.DeferFlag = 1;
4914 AT.WorkPointer = oldwork;
4915 AR.GetOneFile = oldGetOneFile;
4916 return(0);
4917 }
4918 mstop = m + m[1];
4919 decr = WORDDIF(mstop,AR.CompressBuffer)-1;
4920 tstart = AR.CompressPointer + decr;
4921
4922 m = AR.CompressBuffer;
4923 t = AR.CompressPointer;
4924 i = *m;
4925 NCOPY(t,m,i);
4926 oldb = *tstart;
4927 AR.TePos = 0;
4928 AN.TeSuOut = 0;
4929/*
4930 Status:
4931 First bracket content starts at mstop.
4932 Next term starts at startposition.
4933 Decompression information is in AR.CompressPointer.
4934 The outside of the bracket runs from AR.CompressBuffer+1 to mstop.
4935*/
4936 for(;;) {
4937 *tstart = *(AR.CompressPointer)-decr;
4938 AR.CompressPointer = AR.CompressPointer+AR.CompressPointer[0];
4939 if ( InsertTerm(BHEAD term,0,AM.rbufnum,tstart,termout,0) < 0 ) {
4940 goto DefCall;
4941 }
4942 *tstart = oldb;
4943 AT.WorkPointer = termout + *termout;
4944 if ( Generator(BHEAD termout,level) ) goto DefCall;
4945 AR.CompressPointer = oldipointer;
4946 AT.WorkPointer = termout;
4947 retval = GetOneTerm(BHEAD AT.WorkPointer,AR.infile,&startposition,0);
4948 if ( retval >= 0 ) AR.CompressPointer = oldipointer;
4949 if ( retval <= 0 ) break;
4950 t = AR.CompressPointer;
4951 if ( *t < (1 + decr + ABS(*(t+*t-1))) ) break;
4952 t++;
4953 m = AR.CompressBuffer+1;
4954 while ( m < mstop ) {
4955 if ( *m != *t ) goto Thatsit;
4956 m++; t++;
4957 }
4958 }
4959Thatsit:;
4960/*
4961 Finished. Reposition the file, restore information and return.
4962*/
4963 if ( AR.infile->handle < 0 ) AR.infile->POfill = oldPOfill;
4964 AR.DeferFlag = 1;
4965 AR.GetOneFile = oldGetOneFile;
4966 AT.WorkPointer = oldwork;
4967 return(0);
4968DefCall:;
4969 MLOCK(ErrorMessageLock);
4970 MesCall("Deferred");
4971 MUNLOCK(ErrorMessageLock);
4972 SETERROR(-1)
4973}
4974
4975/*
4976 #] Deferred :
4977 #[ PrepPoly : WORD PrepPoly(term,par)
4978*/
5001int PrepPoly(PHEAD WORD *term,WORD par)
5002{
5003 GETBIDENTITY
5004 WORD count = 0, i, jcoef, ncoef;
5005 WORD *t, *m, *r, *tstop, *poly = 0, *v, *w, *vv, *ww;
5006 WORD *oldworkpointer = AT.WorkPointer;
5007/*
5008 The problem here is that the function will be forced into 'long'
5009 notation. After this -SNUMBER,1 becomes 6,0,4,1,1,3 and the
5010 pattern matcher cannot match a short 1 with a long 1.
5011 But because this is an undocumented feature for very special
5012 purposes, we don't do anything about it. (30-aug-2011)
5013*/
5014 if ( AR.PolyFunType == 2 && AR.PolyFunExp != 2 ) {
5015 WORD oldtype = AR.SortType;
5016 AR.SortType = SORTHIGHFIRST;
5017 if ( poly_ratfun_normalize(BHEAD term) != 0 ) Terminate(-1);
5018/* if ( ReadPolyRatFun(BHEAD term) != 0 ) Terminate(-1); */
5019 oldworkpointer = AT.WorkPointer;
5020 AR.SortType = oldtype;
5021 }
5022 AT.PolyAct = 0;
5023 t = term;
5024 GETSTOP(t,tstop);
5025 t++;
5026 while ( t < tstop ) {
5027 if ( *t == AR.PolyFun ) {
5028 if ( count > 0 ) return(0);
5029 poly = t;
5030 count++;
5031 }
5032 t += t[1];
5033 }
5034 r = m = term + *term;
5035 i = ABS(m[-1]);
5036 if ( par > 0 ) {
5037 if ( count == 0 ) return(0);
5038 else if ( AR.PolyFunType == 1 || (AR.PolyFunType == 2 && AR.PolyFunExp == 2) )
5039 goto DoOne;
5040 else if ( AR.PolyFunType == 2 )
5041 goto DoTwo;
5042 else
5043 goto DoError;
5044 }
5045 else if ( count == 0 ) {
5046/*
5047 #[ Create a PolyFun :
5048*/
5049 poly = t = tstop;
5050 if ( i == 3 && m[-2] == 1 && (m[-3]&MAXPOSITIVE) == m[-3] ) {
5051 *m++ = AR.PolyFun;
5052 if ( AR.PolyFunType == 1 || (AR.PolyFunType == 2 && AR.PolyFunExp == 2) ) {
5053 *m++ = FUNHEAD+2;
5054 FILLFUN(m)
5055 *m++ = -SNUMBER;
5056 *m = m[-2-FUNHEAD] < 0 ? -m[-4-FUNHEAD]: m[-4-FUNHEAD];
5057 m++;
5058 }
5059 else if ( AR.PolyFunType == 2 ) {
5060 *m++ = FUNHEAD+4;
5061 FILLFUN(m)
5062 *m++ = -SNUMBER;
5063 *m = m[-2-FUNHEAD] < 0 ? -m[-4-FUNHEAD]: m[-4-FUNHEAD];
5064 m++;
5065 *m++ = -SNUMBER;
5066 *m++ = 1;
5067 }
5068 }
5069 else {
5070 WORD *vm;
5071 r = tstop;
5072 if ( AR.PolyFunType == 1 || (AR.PolyFunType == 2 && AR.PolyFunExp == 2) ) {
5073 *m++ = AR.PolyFun;
5074 *m++ = FUNHEAD+ARGHEAD+i+1;
5075 FILLFUN(m)
5076 *m++ = ARGHEAD+i+1;
5077 *m++ = 0;
5078 FILLARG(m)
5079 *m++ = i+1;
5080 NCOPY(m,r,i);
5081 }
5082 else if ( AR.PolyFunType == 2 ) {
5083 WORD *num, *den, size, sign, sizenum, sizeden;
5084 if ( m[-1] < 0 ) { sign = -1; size = -m[-1]; }
5085 else { sign = 1; size = m[-1]; }
5086 num = m - size; size = (size-1)/2; den = num + size;
5087 sizenum = size; while ( num[sizenum-1] == 0 ) sizenum--;
5088 sizeden = size; while ( den[sizeden-1] == 0 ) sizeden--;
5089 v = m;
5090 AT.PolyAct = WORDDIF(v,term);
5091 *v++ = AR.PolyFun;
5092 v++;
5093 FILLFUN(v);
5094 vm = v;
5095 *v++ = ARGHEAD+2*sizenum+2;
5096 *v++ = 0;
5097 FILLARG(v);
5098 *v++ = 2*sizenum+2;
5099 for ( i = 0; i < sizenum; i++ ) *v++ = num[i];
5100 *v++ = 1;
5101 for ( i = 1; i < sizenum; i++ ) *v++ = 0;
5102 *v++ = sign*(2*sizenum+1);
5103 if ( ToFast(vm,vm) ) v = vm+2;
5104 vm = v;
5105 *v++ = ARGHEAD+2*sizeden+2;
5106 *v++ = 0;
5107 FILLARG(v);
5108 *v++ = 2*sizeden+2;
5109 for ( i = 0; i < sizeden; i++ ) *v++ = den[i];
5110 *v++ = 1;
5111 for ( i = 1; i < sizeden; i++ ) *v++ = 0;
5112 *v++ = 2*sizeden+1;
5113 if ( ToFast(vm,vm) ) v = vm+2;
5114 i = v-m;
5115 m[1] = i;
5116 w = num;
5117 NCOPY(w,m,i);
5118 *w++ = 1; *w++ = 1; *w++ = 3; *term = w - term;
5119 return(0);
5120 }
5121 }
5122/*
5123 #] Create a PolyFun :
5124*/
5125 }
5126 else if ( AR.PolyFunType == 1 || (AR.PolyFunType == 2 && AR.PolyFunExp == 2) ) {
5127 DoOne:;
5128/*
5129 #[ One argument :
5130*/
5131 m = term + *term;
5132 r = poly + poly[1];
5133 if ( ( poly[1] == FUNHEAD+2 && poly[FUNHEAD+1] == 0
5134 && poly[FUNHEAD] == -SNUMBER ) || poly[1] == FUNHEAD ) return(1);
5135 t = poly + FUNHEAD;
5136 if ( t >= r ) return(0);
5137 if ( m[-1] == 3 && *tstop == 1 && tstop[1] == 1 ) {
5138 i = poly[1];
5139 t = poly;
5140 NCOPY(m,t,i);
5141 }
5142 else if ( *t <= -FUNCTION ) {
5143 if ( t+1 < r ) return(0); /* More than one argument */
5144 r = tstop;
5145 *m++ = AR.PolyFun;
5146 *m++ = FUNHEAD*2+ARGHEAD+i+1;
5147 FILLFUN(m)
5148 *m++ = FUNHEAD+ARGHEAD+i+1;
5149 *m++ = 0;
5150 FILLARG(m)
5151 *m++ = FUNHEAD+i+1;
5152 *m++ = -*t++;
5153 *m++ = FUNHEAD;
5154 FILLFUN(m)
5155 NCOPY(m,r,i);
5156 }
5157 else if ( *t < 0 ) {
5158 if ( t+2 < r ) return(0); /* More than one argument */
5159 r = tstop;
5160 if ( *t == -SNUMBER ) {
5161 if ( t[1] == 0 ) return(1); /* Term should be zero now */
5162 *m = AR.PolyFun;
5163 w = m+1;
5164 m += FUNHEAD+ARGHEAD;
5165 v = m;
5166 *m++ = 5+i;
5167 *m++ = SNUMBER;
5168 *m++ = 4;
5169 *m++ = t[1];
5170 *m++ = 1;
5171 NCOPY(m,r,i);
5172 if ( m >= AT.WorkSpace && m < AT.WorkTop )
5173 AT.WorkPointer = m;
5174 if ( Normalize(BHEAD v) ) Terminate(-1);
5175 AT.WorkPointer = oldworkpointer;
5176 m = w;
5177 if ( *v == 4 && v[2] == 1 && (v[1]&MAXPOSITIVE) == v[1] ) {
5178 *m++ = FUNHEAD+2;
5179 FILLFUN(m)
5180 *m++ = -SNUMBER;
5181 *m++ = v[3] < 0 ? -v[1] : v[1];
5182 }
5183 else if ( *v == 0 ) return(1);
5184 else {
5185 *m++ = FUNHEAD+ARGHEAD+*v;
5186 FILLFUN(m)
5187 *m++ = ARGHEAD+*v;
5188 *m++ = 0;
5189 FILLARG(m)
5190 m = v + *v;
5191 }
5192 }
5193 else if ( *t == -SYMBOL ) {
5194 *m++ = AR.PolyFun;
5195 *m++ = FUNHEAD+ARGHEAD+5+i;
5196 FILLFUN(m)
5197 *m++ = ARGHEAD+5+i;
5198 *m++ = 0;
5199 FILLARG(m)
5200 *m++ = 5+i;
5201 *m++ = SYMBOL;
5202 *m++ = 4;
5203 *m++ = t[1];
5204 *m++ = 1;
5205 NCOPY(m,r,i);
5206 }
5207 else return(0); /* Not symbol-like */
5208 }
5209 else {
5210 if ( t + *t < r ) return(0); /* More than one argument */
5211 i = m[-1];
5212 *m++ = AR.PolyFun;
5213 w = m;
5214 m += ARGHEAD+FUNHEAD-1;
5215 t += ARGHEAD;
5216 jcoef = i < 0 ? (i+1)>>1:(i-1)>>1;
5217 v = t;
5218/*
5219 Test now the scalar nature of the argument.
5220 No indices allowed.
5221*/
5222 while ( t < r ) {
5223 WORD *vstop;
5224 vv = t + *t;
5225 vstop = vv - ABS(vv[-1]);
5226 t++;
5227 while( t < vstop ) {
5228 if ( *t == INDEX ) return(0);
5229 t += t[1];
5230 }
5231 t = vv;
5232 }
5233/*
5234 Now multiply each term by the coefficient.
5235*/
5236 t = v;
5237 while ( t < r ) {
5238 ww = m;
5239 v = t + *t;
5240 ncoef = v[-1];
5241 vv = v - ABS(ncoef);
5242 if ( ncoef < 0 ) ncoef++;
5243 else ncoef--;
5244 ncoef >>= 1;
5245 while ( t < vv ) *m++ = *t++;
5246 if ( MulRat(BHEAD (UWORD *)vv,ncoef,(UWORD *)tstop,jcoef,
5247 (UWORD *)m,&ncoef) ) Terminate(-1);
5248 ncoef *= 2;
5249 m += ABS(ncoef);
5250 if ( ncoef < 0 ) ncoef--;
5251 else ncoef++;
5252 *m++ = ncoef;
5253 *ww = WORDDIF(m,ww);
5254 if ( AN.ncmod != 0 ) {
5255 if ( Modulus(ww) ) Terminate(-1);
5256 if ( *ww == 0 ) return(1);
5257 m = ww + *ww;
5258 }
5259 t = v;
5260 }
5261 *w = (WORDDIF(m,w))+1;
5262 w[FUNHEAD-1] = w[0] - FUNHEAD;
5263 w[FUNHEAD] = 0;
5264 w[1] = 0; /* omission survived for years. 23-mar-2006 JV */
5265 w += FUNHEAD-1;
5266 if ( ToFast(w,w) ) {
5267 if ( *w <= -FUNCTION ) { w[-FUNHEAD+1] = FUNHEAD+1; m = w+1; }
5268 else { w[-FUNHEAD+1] = FUNHEAD+2; m = w+2; }
5269
5270 }
5271 }
5272 t = poly + poly[1];
5273 while ( t < tstop ) *poly++ = *t++;
5274/*
5275 #] One argument :
5276*/
5277 }
5278 else if ( AR.PolyFunType == 2 ) {
5279 DoTwo:;
5280/*
5281 #[ Two arguments :
5282*/
5283 WORD *num, *den, size, sign, sizenum, sizeden;
5284/*
5285 First make sure that the PolyFun is last
5286*/
5287 m = term + *term;
5288 if ( poly + poly[1] < tstop ) {
5289 for ( i = 0; i < poly[1]; i++ ) m[i] = poly[i];
5290 t = poly; v = poly + poly[1];
5291 while ( v < tstop ) *t++ = *v++;
5292 poly = t;
5293 for ( i = 0; i < m[1]; i++ ) t[i] = m[i];
5294 t += m[1];
5295 }
5296 AT.PolyAct = WORDDIF(poly,term);
5297/*
5298 If needed we convert the coefficient into a PolyRatFun and then
5299 we call poly_ratfun_normalize
5300*/
5301 if ( m[-1] == 3 && m[-2] == 1 && m[-3] == 1 ) return(0);
5302 if ( AR.PolyFunExp != 1 ) {
5303 if ( m[-1] < 0 ) { sign = -1; size = -m[-1]; } else { sign = 1; size = m[-1]; }
5304 num = m - size; size = (size-1)/2; den = num + size;
5305 sizenum = size; while ( num[sizenum-1] == 0 ) sizenum--;
5306 sizeden = size; while ( den[sizeden-1] == 0 ) sizeden--;
5307 v = m;
5308 *v++ = AR.PolyFun;
5309 *v++ = FUNHEAD + 2*(ARGHEAD+sizenum+sizeden+2);
5310/* *v++ = MUSTCLEANPRF; */
5311 *v++ = 0;
5312 FILLFUN3(v);
5313 *v++ = ARGHEAD+2*sizenum+2;
5314 *v++ = 0;
5315 FILLARG(v);
5316 *v++ = 2*sizenum+2;
5317 for ( i = 0; i < sizenum; i++ ) *v++ = num[i];
5318 *v++ = 1;
5319 for ( i = 1; i < sizenum; i++ ) *v++ = 0;
5320 *v++ = sign*(2*sizenum+1);
5321 *v++ = ARGHEAD+2*sizeden+2;
5322 *v++ = 0;
5323 FILLARG(v);
5324 *v++ = 2*sizeden+2;
5325 for ( i = 0; i < sizeden; i++ ) *v++ = den[i];
5326 *v++ = 1;
5327 for ( i = 1; i < sizeden; i++ ) *v++ = 0;
5328 *v++ = 2*sizeden+1;
5329 w = num;
5330 i = v - m;
5331 NCOPY(w,m,i);
5332 }
5333 else {
5334 w = m-ABS(m[-1]);
5335 }
5336 *w++ = 1; *w++ = 1; *w++ = 3; *term = w - term;
5337 {
5338 WORD oldtype = AR.SortType;
5339 AR.SortType = SORTHIGHFIRST;
5340/*
5341 if ( count > 0 )
5342 poly_ratfun_normalize(BHEAD term);
5343 else
5344 ReadPolyRatFun(BHEAD term);
5345*/
5346 poly_ratfun_normalize(BHEAD term);
5347
5348/* oldworkpointer = AT.WorkPointer; */
5349 AR.SortType = oldtype;
5350 }
5351 goto endofit;
5352/*
5353 #] Two arguments :
5354*/
5355 }
5356 else {
5357/* INTERNAL_ERROR_EXCL_START */
5358 DoError:;
5359 MLOCK(ErrorMessageLock);
5360 MesPrint("!>Illegal value for PolyFunType in PrepPoly");
5361 MUNLOCK(ErrorMessageLock);
5362 Terminate(-1);
5363/* INTERNAL_ERROR_EXCL_STOP */
5364 }
5365 r = term + *term;
5366 AT.PolyAct = WORDDIF(poly,term);
5367 while ( r < m ) *poly++ = *r++;
5368 *poly++ = 1;
5369 *poly++ = 1;
5370 *poly++ = 3;
5371 *term = WORDDIF(poly,term);
5372endofit:;
5373 return(0);
5374}
5375
5376/*
5377 #] PrepPoly :
5378 #[ PolyFunMul : WORD PolyFunMul(term)
5379*/
5391int PolyFunMul(PHEAD WORD *term)
5392{
5393 GETBIDENTITY
5394 WORD *t, *fun1, *fun2, *t1, *t2, *m, *w, *ww, *tt1, *tt2, *tt4, *arg1, *arg2;
5395 WORD *tstop, i, dirty = 0, OldPolyFunPow = AR.PolyFunPow, minp1, minp2;
5396 WORD n1, n2, i1, i2, l1, l2, l3, l4, action = 0, noac = 0;
5397 int retval = 0;
5398 if ( AR.PolyFunType == 2 && AR.PolyFunExp == 1 ) {
5399 WORD pow = 0, pow1;
5400 t = term + 1; t1 = term + *term; t1 -= ABS(t1[-1]);
5401 w = t;
5402 while ( t < t1 ) {
5403 if ( *t != AR.PolyFun ) {
5404SkipFun:
5405 if ( t == w ) { t += t[1]; w = t; }
5406 else { i = t[1]; NCOPY(w,t,i) }
5407 continue;
5408 }
5409 pow1 = 0;
5410 t2 = t + t[1]; t += FUNHEAD;
5411 if ( *t < 0 ) {
5412 if ( *t == -SYMBOL && t[1] == AR.PolyFunVar ) pow1++;
5413 else if ( *t != -SNUMBER ) goto NoLegal;
5414 t += 2;
5415 }
5416 else if ( t[0] == ARGHEAD+8 && t[ARGHEAD] == 8
5417 && t[ARGHEAD+1] == SYMBOL && t[ARGHEAD+3] == AR.PolyFunVar
5418 && t[ARGHEAD+5] == 1 && t[ARGHEAD+6] == 1 && t[ARGHEAD+7] == 3 ) {
5419 pow1 += t[ARGHEAD+4];
5420 t += *t;
5421 }
5422 else {
5423NoLegal:
5424/* INTERNAL_ERROR_EXCL_START */
5425 MLOCK(ErrorMessageLock);
5426 MesPrint("!>Illegal term with divergence in PolyRatFun");
5427 MesCall("PolyFunMul");
5428 MUNLOCK(ErrorMessageLock);
5429 Terminate(-1);
5430/* INTERNAL_ERROR_EXCL_STOP */
5431 }
5432 if ( *t < 0 ) {
5433 if ( *t == -SYMBOL && t[1] == AR.PolyFunVar ) pow1--;
5434 else if ( *t != -SNUMBER ) goto NoLegal;
5435 t += 2;
5436 }
5437 else if ( t[0] == ARGHEAD+8 && t[ARGHEAD] == 8
5438 && t[ARGHEAD+1] == SYMBOL && t[ARGHEAD+3] == AR.PolyFunVar
5439 && t[ARGHEAD+5] == 1 && t[ARGHEAD+6] == 1 && t[ARGHEAD+7] == 3 ) {
5440 pow1 -= t[ARGHEAD+4];
5441 t += *t;
5442 }
5443 else goto NoLegal;
5444 if ( t == t2 ) pow += pow1;
5445 else goto SkipFun;
5446 }
5447 m = w;
5448 *w++ = AR.PolyFun; *w++ = 0; FILLFUN(w);
5449 if ( pow > 1 ) {
5450 *w++ = 8+ARGHEAD; *w++ = 0; FILLARG(w);
5451 *w++ = 8; *w++ = SYMBOL; *w++ = 4; *w++ = AR.PolyFunVar; *w++ = pow;
5452 *w++ = 1; *w++ = 1; *w++ = 3; *w++ = -SNUMBER; *w++ = 1;
5453 }
5454 else if ( pow == 1 ) {
5455 *w++ = -SYMBOL; *w++ = AR.PolyFunVar; *w++ = -SNUMBER; *w++ = 1;
5456 }
5457 else if ( pow < -1 ) {
5458 *w++ = -SNUMBER; *w++ = 1; *w++ = 8+ARGHEAD; *w++ = 0; FILLARG(w);
5459 *w++ = 8; *w++ = SYMBOL; *w++ = 4; *w++ = AR.PolyFunVar; *w++ = -pow;
5460 *w++ = 1; *w++ = 1; *w++ = 3;
5461 }
5462 else if ( pow == -1 ) {
5463 *w++ = -SNUMBER; *w++ = 1; *w++ = -SYMBOL; *w++ = AR.PolyFunVar;
5464 }
5465 else {
5466 *w++ = -SNUMBER; *w++ = 1; *w++ = -SNUMBER; *w++ = 1;
5467 }
5468 m[1] = w - m;
5469 *w++ = 1; *w++ = 1; *w++ = 3;
5470 *term = w - term;
5471 if ( w > AT.WorkSpace && w < AT.WorkTop ) AT.WorkPointer = w;
5472 return(0);
5473 }
5474ReStart:
5475 if ( AR.PolyFunType == 2 && ( ( AR.PolyFunExp != 2 )
5476 || ( AR.PolyFunExp == 2 && AN.PolyNormFlag > 1 ) ) ) {
5477 WORD count1 = 0, count2 = 0, count3;
5478 WORD oldtype = AR.SortType;
5479 t = term + 1; t1 = term + *term; t1 -= ABS(t1[-1]);
5480 while ( t < t1 ) {
5481 if ( *t == AR.PolyFun ) {
5482 if ( t[2] && dirty == 0 ) { /* Any dirty flag on? */
5483 dirty = 1;
5484/* ReadPolyRatFun(BHEAD term); */
5485/* ToPolyFunGeneral(BHEAD term); */
5486 poly_ratfun_normalize(BHEAD term);
5487 if ( term[0] == 0 ) return(0);
5488 count1 = 0;
5489 action++;
5490 goto ReStart;
5491 }
5492 t2 = t + t[1]; tt2 = t+FUNHEAD; count3 = 0;
5493 while ( tt2 < t2 ) { count3++; NEXTARG(tt2); }
5494 if ( count3 == 2 ) {
5495 count1++;
5496 if ( ( t[2] & MUSTCLEANPRF ) != 0 ) { /* Better civilize this guy */
5497 action++;
5498 w = AT.WorkPointer;
5499 AR.SortType = SORTHIGHFIRST;
5500 t2 = t + t[1]; tt2 = t+FUNHEAD;
5501 while ( tt2 < t2 ) {
5502 if ( *tt2 > 0 ) {
5503 tt4 = tt2; tt1 = tt2 + ARGHEAD; tt2 += *tt2;
5504 NewSort(BHEAD0);
5505 while ( tt1 < tt2 ) {
5506 i = *tt1; ww = w; NCOPY(ww,tt1,i);
5507 AT.WorkPointer = ww;
5508 Normalize(BHEAD w);
5509 StoreTerm(BHEAD w);
5510 }
5511 EndSort(BHEAD w,1);
5512 ww = w; while ( *ww ) ww += *ww;
5513 if ( ww-w != *tt4-ARGHEAD ) { /* Little problem */
5514/*
5515 Solution: brute force copy
5516 Maybe it will never come here????
5517*/
5518 WORD *r1 = TermMalloc("PolyFunMul");
5519 WORD ii = (ww-w)-(*tt4-ARGHEAD); /* increment */
5520 WORD *r2 = tt4+ARGHEAD, *r3, *r4 = r1;
5521 i = r2 - term; r3 = term; NCOPY(r4,r3,i);
5522 i = ww-w; ww = w; NCOPY(r4,ww,i);
5523 r3 = tt2; i = term+*term-tt2; NCOPY(r4,r3,i);
5524 *r1 = i = r4-r1; r4 = term; r3 = r1;
5525 NCOPY(r4,r3,i);
5526 t[1] += ii; t1 += ii; *tt4 += ii;
5527 tt2 = tt4 + *tt4;
5528 TermFree(r1,"PolyFunMul");
5529 }
5530 else {
5531 i = ww-w; ww = w; tt1 = tt4+ARGHEAD;
5532 NCOPY(tt1,ww,i);
5533 AT.WorkPointer = w;
5534 }
5535 }
5536 else if ( *tt2 <= -FUNCTION ) tt2++;
5537 else tt2 += 2;
5538 }
5539 AR.SortType = oldtype;
5540 }
5541 }
5542 }
5543 t += t[1];
5544 }
5545 if ( count1 <= 1 ) { goto checkaction; }
5546 if ( AR.PolyFunExp == 1 ) {
5547 t = term + *term; t -= ABS(t[-1]);
5548 *t++ = 1; *t++ = 1; *t++ = 3; *term = t - term;
5549 }
5550 {
5551 AR.SortType = SORTHIGHFIRST;
5552/* retval = ReadPolyRatFun(BHEAD term); */
5553/* ToPolyFunGeneral(BHEAD term); */
5554 retval = poly_ratfun_normalize(BHEAD term);
5555 if ( *term == 0 ) return(retval);
5556 AR.SortType = oldtype;
5557 }
5558
5559 t = term + 1; t1 = term + *term; t1 -= ABS(t1[-1]);
5560 while ( t < t1 ) {
5561 if ( *t == AR.PolyFun ) {
5562 t2 = t + t[1]; tt2 = t+FUNHEAD; count3 = 0;
5563 while ( tt2 < t2 ) { count3++; NEXTARG(tt2); }
5564 if ( count3 == 2 ) {
5565 count2++;
5566 }
5567 }
5568 t += t[1];
5569 }
5570 if ( count1 >= count2 ) {
5571 t = term + 1;
5572 while ( t < t1 ) {
5573 if ( *t == AR.PolyFun ) {
5574 t2 = t;
5575 t = t + t[1];
5576 t2[2] |= (DIRTYFLAG|MUSTCLEANPRF);
5577 t2 += FUNHEAD;
5578 while ( t2 < t ) {
5579 if ( *t2 > 0 ) t2[1] = DIRTYFLAG;
5580 NEXTARG(t2);
5581 }
5582 }
5583 else t += t[1];
5584 }
5585 }
5586
5587 w = term + *term;
5588 if ( w > AT.WorkSpace && w < AT.WorkTop ) AT.WorkPointer = w;
5589checkaction:
5590 if ( action ) retval = action;
5591 return(retval);
5592 }
5593retry:
5594 if ( term >= AT.WorkSpace && term+*term < AT.WorkTop )
5595 AT.WorkPointer = term + *term;
5596 GETSTOP(term,tstop);
5597 t = term+1;
5598 while ( *t != AR.PolyFun && t < tstop ) t += t[1];
5599 while ( t < tstop && *t == AR.PolyFun ) {
5600 if ( t[1] > FUNHEAD ) {
5601 if ( t[FUNHEAD] < 0 ) {
5602 if ( t[FUNHEAD] <= -FUNCTION && t[1] == FUNHEAD+1 ) break;
5603 if ( t[FUNHEAD] > -FUNCTION && t[1] == FUNHEAD+2 ) {
5604 if ( t[FUNHEAD] == -SNUMBER && t[FUNHEAD+1] == 0 ) {
5605 *term = 0;
5606 return(0);
5607 }
5608 break;
5609 }
5610 }
5611 else if ( t[FUNHEAD] == t[1] - FUNHEAD ) break;
5612 }
5613 noac = 1;
5614 t += t[1];
5615 }
5616 if ( *t != AR.PolyFun || t >= tstop ) goto done;
5617 fun1 = t;
5618 t += t[1];
5619 while ( t < tstop && *t == AR.PolyFun ) {
5620 if ( t[1] > FUNHEAD ) {
5621 if ( t[FUNHEAD] < 0 ) {
5622 if ( t[FUNHEAD] <= -FUNCTION && t[1] == FUNHEAD+1 ) break;
5623 if ( t[FUNHEAD] > -FUNCTION && t[1] == FUNHEAD+2 ) {
5624 if ( t[FUNHEAD] == -SNUMBER && t[FUNHEAD+1] == 0 ) {
5625 *term = 0;
5626 return(0);
5627 }
5628 break;
5629 }
5630 }
5631 else if ( t[FUNHEAD] == t[1] - FUNHEAD ) break;
5632 }
5633 noac = 1;
5634 t += t[1];
5635 }
5636 if ( *t != AR.PolyFun || t >= tstop ) goto done;
5637 fun2 = t;
5638/*
5639 We have two functions of the proper type.
5640 Count terms (needed for the specials)
5641*/
5642 t = fun1 + FUNHEAD;
5643 if ( *t < 0 ) {
5644 n1 = 1; arg1 = AT.WorkPointer;
5645 ToGeneral(t,arg1,1);
5646 AT.WorkPointer = arg1 + *arg1;
5647 }
5648 else {
5649 t += ARGHEAD;
5650 n1 = 0; t1 = fun1 + fun1[1]; arg1 = t;
5651 while ( t < t1 ) { n1++; t += *t; }
5652 }
5653 t = fun2 + FUNHEAD;
5654 if ( *t < 0 ) {
5655 n2 = 1; arg2 = AT.WorkPointer;
5656 ToGeneral(t,arg2,1);
5657 AT.WorkPointer = arg2 + *arg2;
5658 }
5659 else {
5660 t += ARGHEAD;
5661 n2 = 0; t2 = fun2 + fun2[1]; arg2 = t;
5662 while ( t < t2 ) { n2++; t += *t; }
5663 }
5664/*
5665 Now we can start the multiplications. We first multiply the terms
5666 without coefficients, then normalize, and finally put the coefficients
5667 in place. This is because one has often truncated series and the
5668 high powers may get killed, while their coefficients are the most
5669 expensive ones.
5670 Note: We may run into fun(-SNUMBER,value)
5671*/
5672 w = AT.WorkPointer;
5673 NewSort(BHEAD0);
5674 if ( AR.PolyFunType == 2 && AR.PolyFunExp == 2 ) {
5675 AT.TrimPower = 1;
5676/*
5677 We have to find the lowest power in both polynomials.
5678 This will be needed to temporarily correct the AR.PolyFunPow
5679*/
5680 minp1 = MAXPOWER;
5681 for ( t1 = arg1, i1 = 0; i1 < n1; i1++, t1 += *t1 ) {
5682 if ( *t1 == 4 ) {
5683 if ( minp1 > 0 ) minp1 = 0;
5684 }
5685 else if ( ABS(t1[*t1-1]) == (*t1-1) ) {
5686 if ( minp1 > 0 ) minp1 = 0;
5687 }
5688 else {
5689 if ( t1[1] == SYMBOL && t1[2] == 4 && t1[3] == AR.PolyFunVar ) {
5690 if ( t1[4] < minp1 ) minp1 = t1[4];
5691 }
5692 else {
5693/* INTERNAL_ERROR_EXCL_START */
5694 MesPrint("!>Illegal term in expanded polyratfun.");
5695 goto PolyCall;
5696/* INTERNAL_ERROR_EXCL_STOP */
5697 }
5698 }
5699 }
5700 minp2 = MAXPOWER;
5701 for ( t2 = arg2, i2 = 0; i2 < n2; i2++, t2 += *t2 ) {
5702 if ( *t2 == 4 ) {
5703 if ( minp2 > 0 ) minp2 = 0;
5704 }
5705 else if ( ABS(t2[*t2-1]) == (*t2-1) ) {
5706 if ( minp2 > 0 ) minp2 = 0;
5707 }
5708 else {
5709 if ( t2[1] == SYMBOL && t2[2] == 4 && t2[3] == AR.PolyFunVar ) {
5710 if ( t2[4] < minp2 ) minp2 = t2[4];
5711 }
5712 else {
5713/* INTERNAL_ERROR_EXCL_START */
5714 MesPrint("!>Illegal term in expanded polyratfun.");
5715 goto PolyCall;
5716/* INTERNAL_ERROR_EXCL_STOP */
5717 }
5718 }
5719 }
5720 AR.PolyFunPow += minp1+minp2;
5721 }
5722 for ( t1 = arg1, i1 = 0; i1 < n1; i1++, t1 += *t1 ) {
5723 for ( t2 = arg2, i2 = 0; i2 < n2; i2++, t2 += *t2 ) {
5724 m = w;
5725 m++;
5726 GETSTOP(t1,tt1);
5727 t = t1 + 1;
5728 while ( t < tt1 ) *m++ = *t++;
5729 GETSTOP(t2,tt2);
5730 t = t2+1;
5731 while ( t < tt2 ) *m++ = *t++;
5732 *m++ = 1; *m++ = 1; *m++ = 3; *w = WORDDIF(m,w);
5733 AT.WorkPointer = m;
5734 if ( Normalize(BHEAD w) ) { LowerSortLevel(); goto PolyCall; }
5735 if ( *w ) {
5736 m = w + *w;
5737 if ( m[-1] != 3 || m[-2] != 1 || m[-3] != 1 ) {
5738 l3 = REDLENG(m[-1]);
5739 m -= ABS(m[-1]);
5740 t = t1 + *t1 - 1;
5741 l1 = REDLENG(*t);
5742 if ( MulRat(BHEAD (UWORD *)m,l3,(UWORD *)tt1,l1,(UWORD *)m,&l4) ) {
5743 LowerSortLevel(); goto PolyCall; }
5744 if ( AN.ncmod != 0 && TakeModulus((UWORD *)m,&l4,AC.cmod,AN.ncmod,UNPACK|AC.modmode) ) {
5745 LowerSortLevel(); goto PolyCall; }
5746 if ( l4 == 0 ) continue;
5747 t = t2 + *t2 - 1;
5748 l2 = REDLENG(*t);
5749 if ( MulRat(BHEAD (UWORD *)m,l4,(UWORD *)tt2,l2,(UWORD *)m,&l3) ) {
5750 LowerSortLevel(); goto PolyCall; }
5751 if ( AN.ncmod != 0 && TakeModulus((UWORD *)m,&l3,AC.cmod,AN.ncmod,UNPACK|AC.modmode) ) {
5752 LowerSortLevel(); goto PolyCall; }
5753 }
5754 else {
5755 m -= 3;
5756 t = t1 + *t1 - 1;
5757 l1 = REDLENG(*t);
5758 t = t2 + *t2 - 1;
5759 l2 = REDLENG(*t);
5760 if ( MulRat(BHEAD (UWORD *)tt1,l1,(UWORD *)tt2,l2,(UWORD *)m,&l3) ) {
5761 LowerSortLevel(); goto PolyCall; }
5762 if ( AN.ncmod != 0 && TakeModulus((UWORD *)m,&l3,AC.cmod,AN.ncmod,UNPACK|AC.modmode) ) {
5763 LowerSortLevel(); goto PolyCall; }
5764 }
5765 if ( l3 == 0 ) continue;
5766 l3 = INCLENG(l3);
5767 m += ABS(l3);
5768 m[-1] = l3;
5769 *w = WORDDIF(m,w);
5770 AT.WorkPointer = m;
5771 if ( StoreTerm(BHEAD w) ) { LowerSortLevel(); goto PolyCall; }
5772 }
5773 }
5774 }
5775 if ( EndSort(BHEAD w,0) < 0 ) goto PolyCall;
5776 AR.PolyFunPow = OldPolyFunPow;
5777 AT.TrimPower = 0;
5778 if ( *w == 0 ) {
5779 *term = 0;
5780 return(0);
5781 }
5782 t = w;
5783 while ( *t ) t += *t;
5784 AT.WorkPointer = t;
5785 n1 = WORDDIF(t,w);
5786 t1 = term;
5787 while ( t1 < fun1 ) *t++ = *t1++;
5788 t2 = t;
5789 *t++ = AR.PolyFun;
5790 *t++ = FUNHEAD+ARGHEAD+n1;
5791 *t++ = 0;
5792 FILLFUN3(t)
5793 *t++ = ARGHEAD+n1;
5794 *t++ = 0;
5795 FILLARG(t)
5796 NCOPY(t,w,n1);
5797 if ( ToFast(t2+FUNHEAD,t2+FUNHEAD) ) {
5798 if ( t2[FUNHEAD] > -FUNCTION ) t2[1] = FUNHEAD+2;
5799 else t2[FUNHEAD] = FUNHEAD+1;
5800 t = t2 + t2[1];
5801 }
5802 t1 = fun1 + fun1[1];
5803 while ( t1 < fun2 ) *t++ = *t1++;
5804 t1 = fun2 + fun2[1];
5805 t2 = term + *term;
5806 while ( t1 < t2 ) *t++ = *t1++;
5807 *AT.WorkPointer = n1 = WORDDIF(t,AT.WorkPointer);
5808 if ( n1*((LONG)sizeof(WORD)) > AM.MaxTer ) {
5809 MLOCK(ErrorMessageLock);
5810 MesPrint("Term too complex (%d words). MaxTermSize (%l words) is too small.", n1, AM.MaxTer/(LONG)sizeof(WORD) );
5811 goto PolyCall2;
5812 }
5813 m = term; t = AT.WorkPointer;
5814 NCOPY(m,t,n1);
5815 action++;
5816 goto retry;
5817done:
5818 AT.WorkPointer = term + *term;
5819 if ( action && noac ) {
5820 if ( Normalize(BHEAD term) ) goto PolyCall;
5821 AT.WorkPointer = term + *term;
5822 }
5823 return(0);
5824PolyCall:;
5825 MLOCK(ErrorMessageLock);
5826PolyCall2:;
5827 AR.PolyFunPow = OldPolyFunPow;
5828 MesCall("PolyFunMul");
5829 MUNLOCK(ErrorMessageLock);
5830 SETERROR(-1)
5831}
5832
5833/*
5834 #] PolyFunMul :
5835 #] Processor :
5836*/
poly
Definition poly.h:53
AddRHS
WORD * AddRHS(int num, int type)
Definition comtool.c:210
DoubleCbuffer
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition comtool.c:143
poly_unfactorize_expression
int poly_unfactorize_expression(EXPRESSIONS)
Definition polywrap.cc:1545
PutOut
WORD PutOut(PHEAD WORD *, POSITION *, FILEHANDLE *, WORD)
Definition sort.c:1217
poly_ratfun_normalize
int poly_ratfun_normalize(PHEAD WORD *)
Definition polywrap.cc:771
EndSort
LONG EndSort(PHEAD WORD *, int)
Definition sort.c:488
LowerSortLevel
void LowerSortLevel(void)
Definition sort.c:4731
StoreTerm
int StoreTerm(PHEAD WORD *)
Definition sort.c:4311
poly_factorize_expression
int poly_factorize_expression(EXPRESSIONS)
Definition polywrap.cc:1180
NewSort
int NewSort(PHEAD0)
Definition sort.c:397
FlushOut
int FlushOut(POSITION *, FILEHANDLE *, int)
Definition sort.c:1581
Compare1
WORD Compare1(PHEAD WORD *, WORD *, WORD)
Definition sort.c:2393
TestMatch
int TestMatch(PHEAD WORD *, WORD *)
Definition pattern.c:97
PutPreVar
int PutPreVar(UBYTE *, UBYTE *, UBYTE *, int)
Definition pre.c:724
CompareSymbols
WORD CompareSymbols(PHEAD WORD *, WORD *, WORD)
Definition sort.c:2856
SymbolNormalize
int SymbolNormalize(WORD *)
Definition normal.c:5214
PF_Deferred
WORD PF_Deferred(WORD *term, WORD level)
Definition parallel.c:1201
PF_BroadcastRHS
int PF_BroadcastRHS(void)
Definition parallel.c:3580
PF_Processor
int PF_Processor(EXPRESSIONS e, WORD i, WORD LastExpression)
Definition parallel.c:1533
PF_InParallelProcessor
int PF_InParallelProcessor(void)
Definition parallel.c:3627
DONE
#define DONE(x)
Definition proces.c:701
PolyFunMul
int PolyFunMul(PHEAD WORD *term)
Definition proces.c:5391
FiniTerm
int FiniTerm(PHEAD WORD *term, WORD *accum, WORD *termout, WORD number, WORD tepos)
Definition proces.c:3073
Deferred
int Deferred(PHEAD WORD *term, WORD level)
Definition proces.c:4873
Processor
int Processor(void)
Definition proces.c:64
DoOnePow
int DoOnePow(PHEAD WORD *term, WORD power, WORD nexp, WORD *accum, WORD *aa, WORD level, WORD *freeze)
Definition proces.c:4650
Generator
int Generator(PHEAD WORD *term, WORD level)
Definition proces.c:3272
InFunction
int InFunction(PHEAD WORD *term, WORD *termout)
Definition proces.c:2177
PrepPoly
int PrepPoly(PHEAD WORD *term, WORD par)
Definition proces.c:5001
PasteFile
LONG PasteFile(PHEAD WORD number, WORD *accum, POSITION *position, WORD **accfill, RENUMBER renumber, WORD *freeze, WORD nexpr)
Definition proces.c:2882
PasteTerm
WORD * PasteTerm(PHEAD WORD number, WORD *accum, WORD *position, WORD times, WORD divby)
Definition proces.c:3006
InsertTerm
int InsertTerm(PHEAD WORD *term, WORD replac, WORD extractbuff, WORD *position, WORD *termout, WORD tepos)
Definition proces.c:2746
CbUf::Top
WORD * Top
Definition structs.h:972
CbUf::rhs
WORD ** rhs
Definition structs.h:975
CbUf::lhs
WORD ** lhs
Definition structs.h:974
CbUf::Buffer
WORD * Buffer
Definition structs.h:971
CbUf::Pointer
WORD * Pointer
Definition structs.h:973
CbUf::CanCommu
LONG * CanCommu
Definition structs.h:976
FiLe::handle
int handle
Definition structs.h:709
MiNmAx::mini
WORD mini
Definition structs.h:302
MiNmAx::size
WORD size
Definition structs.h:304
MiNmAx::maxi
WORD maxi
Definition structs.h:303
ReNuMbEr::symb
VARRENUM symb
Definition structs.h:179
TaBlEs::pattern
WORD * pattern
Definition structs.h:349
TaBlEs::tablepointers
WORD * tablepointers
Definition structs.h:343
TaBlEs::strict
int strict
Definition structs.h:365
TaBlEs::prototype
WORD * prototype
Definition structs.h:348
TaBlEs::mm
MINMAX * mm
Definition structs.h:351
TaBlEs::bufnum
WORD bufnum
Definition structs.h:370
TaBlEs::bounds
int bounds
Definition structs.h:364
TaBlEs::numind
int numind
Definition structs.h:363
TaBlEs::sparse
int sparse
Definition structs.h:366
VaRrEnUm::lo
WORD * lo
Definition structs.h:166
Generated by doxygen 1.9.8