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