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