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