FORM v5.0.0-35-g6318119
function.c
Go to the documentation of this file.
1
8/* #[ License : */
9/*
10 * Copyright (C) 1984-2026 J.A.M. Vermaseren
11 * When using this file you are requested to refer to the publication
12 * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
13 * This is considered a matter of courtesy as the development was paid
14 * for by FOM the Dutch physics granting agency and we would like to
15 * be able to track its scientific use to convince FOM of its value
16 * for the community.
17 *
18 * This file is part of FORM.
19 *
20 * FORM is free software: you can redistribute it and/or modify it under the
21 * terms of the GNU General Public License as published by the Free Software
22 * Foundation, either version 3 of the License, or (at your option) any later
23 * version.
24 *
25 * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
26 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
27 * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
28 * details.
29 *
30 * You should have received a copy of the GNU General Public License along
31 * with FORM. If not, see <http://www.gnu.org/licenses/>.
32 */
33/* #] License : */
34/*
35 #[ Includes : function.c
36*/
37
38#include "form3.h"
39
40/*
41 #] Includes :
42 #[ Utilities :
43 #[ MakeDirty :
44
45 Routine finds the function with the address x in it
46 and mark all arguments that contain x as dirty.
47 if par == 0 term is a full term, else term is the start of a
48 function
49*/
50
51int MakeDirty(WORD *term, WORD *x, WORD par)
52{
53 WORD *next, *n;
54 if ( !par ) {
55 next = term; next += *term;
56 next -= ABS(next[-1]);
57 term++;
58 if ( x < term ) return(0);
59 if ( x >= next ) return(0);
60 while ( term < next ) {
61 n = term + term[1];
62 if ( x < n ) break;
63 term = n;
64 }
65/* next = n; */
66 }
67 else {
68 next = term + term[1];
69 if ( x < term || x >= next ) return(0);
70 }
71 if ( *term < FUNCTION ) return(0);
72 if ( functions[*term-FUNCTION].spec >= TENSORFUNCTION ) return(0);
73 term += FUNHEAD;
74 if ( x < term ) return(0);
75 next = term; NEXTARG(next)
76 while ( x >= next ) { term = next; NEXTARG(next) }
77 if ( *term < 0 ) return(0);
78 term[1] = 1;
79 term += ARGHEAD;
80 if ( x < term ) return(1);
81 next = term + *term;
82 while ( x >= next ) { term = next; next += *next; }
83 MakeDirty(term,x,0);
84 return(1);
85}
86
87/*
88 #] MakeDirty :
89 #[ MarkDirty :
90
91 Routine marks all functions dirty with the given flags.
92 Is to be used when there is a possibility that symmetrization
93 properties of functions may have changed. In that case we play
94 it safe.
95*/
96
97void MarkDirty(WORD *term, WORD flags)
98{
99 WORD *t, *r, *m, *tstop;
100 GETSTOP(term,tstop);
101 t = term+1;
102 while ( t < tstop ) {
103 if ( *t < FUNCTION ) { t += t[1]; continue; }
104 t[2] |= flags;
105 if ( *t < FUNCTION+WILDOFFSET && functions[*t-FUNCTION].spec > 0 ) {
106 t += t[1]; continue;
107 }
108 if ( *t >= FUNCTION+WILDOFFSET && functions[*t-FUNCTION-WILDOFFSET].spec > 0 ) {
109 t += t[1]; continue;
110 }
111 r = t + FUNHEAD;
112 t += t[1];
113 while ( r < t ) {
114 if ( *r <= 0 ) {
115 if ( *r <= -FUNCTION ) r++;
116 else r += 2;
117 continue;
118 }
119 r[1] |= DIRTYFLAG;
120 m = r + ARGHEAD;
121 r += *r;
122 while ( m < r ) {
123 MarkDirty(m,flags);
124 m += *m;
125 }
126 }
127 }
128}
129
130/*
131 #] MarkDirty :
132 #[ PolyFunDirty :
133
134 Routine marks the PolyFun or the PolyRatFun dirty.
135 This is used when there is modular calculus and the modulus
136 has changed for the current module.
137*/
138
139void PolyFunDirty(PHEAD WORD *term)
140{
141 GETBIDENTITY
142 WORD *t, *tstop, *endarg;
143 tstop = term + *term;
144 tstop -= ABS(tstop[-1]);
145 t = term+1;
146 while ( t < tstop ) {
147 if ( *t == AR.PolyFun ) {
148 if ( AR.PolyFunType == 2 ) t[2] |= MUSTCLEANPRF;
149 endarg = t + t[1];
150 t[2] |= DIRTYFLAG;
151 t += FUNHEAD;
152 while ( t < endarg ) {
153 if ( *t > 0 ) {
154 t[1] |= DIRTYFLAG;
155 }
156 NEXTARG(t);
157 }
158 }
159 else {
160 t += t[1];
161 }
162 }
163}
164
165/*
166 #] PolyFunDirty :
167 #[ PolyFunClean :
168
169 Routine marks the PolyFun or the PolyRatFun clean.
170 This is used when there is modular calculus and the modulus
171 has changed for the current module.
172*/
173
174void PolyFunClean(PHEAD WORD *term)
175{
176 GETBIDENTITY
177 WORD *t, *tstop;
178 tstop = term + *term;
179 tstop -= ABS(tstop[-1]);
180 t = term+1;
181 while ( t < tstop ) {
182 if ( *t == AR.PolyFun ) {
183 t[2] &= ~MUSTCLEANPRF;
184 }
185 t += t[1];
186 }
187}
188
189/*
190 #] PolyFunClean :
191 #[ Symmetrize :
192
193 (Anti)Symmetrizes the arguments of a function.
194 Nlist tells of how many arguments are involved.
195 Nlist == 0 All arguments must be sorted.
196 Nlist > 0 Arguments mentioned are to be sorted, rest skipped.
197 type = SYMMETRIC Full symmetrization
198 type = ANTISYMMETRIC: Full symmetrization
199 type = CYCLESYMMETRIC: Cyclic
200 type = RCYCLESYMMETRIC:Cyclic or reverse
201 Return value: OR of:
202 0 even, 1 odd
203 2 equal groups
204 4 there was a permutation.
205
206 The information in Lijst tells what grouping is to be applied.
207 The information is:
208 ngroups number of groups
209 gsize size of groups
210 Lijst[0].... The groups.
211*/
212
213WORD Symmetrize(PHEAD WORD *func, WORD *Lijst, WORD ngroups, WORD gsize,
214 WORD type)
215{
216 GETBIDENTITY
217 WORD **args,**arg,nargs;
218 WORD *to, *r, *fstop;
219 WORD i, j, k, ff, exch, nexch, neq;
220 WORD *a1, *a2, *a3;
221 WORD reverseorder;
222 if ( ( type & REVERSEORDER ) != 0 ) reverseorder = -1;
223 else reverseorder = 1;
224 type &= ~REVERSEORDER;
225
226 ff = ( *func > FUNCTION ) ? functions[*func-FUNCTION].spec: 0;
227
228 if ( 2*func[1] > AN.arglistsize ) {
229 if ( AN.arglist ) M_free(AN.arglist,"Symmetrize");
230 AN.arglistsize = 2*func[1] + 8;
231 AN.arglist = (WORD **)Malloc1(AN.arglistsize*sizeof(WORD *),"Symmetrize");
232 }
233 arg = args = AN.arglist;
234 to = AT.WorkPointer;
235 r = func;
236 fstop = r + r[1];
237 r += FUNHEAD;
238 nargs = 0;
239 while ( r < fstop ) { /* Make list of arguments */
240 *arg++ = r;
241 nargs++;
242 if ( ff ) {
243 if ( *r == FUNNYWILD ) r++;
244 r++;
245 }
246 else { NEXTARG(r); }
247 }
248 exch = 0;
249 nexch = 0;
250 neq = 0;
251 a1 = Lijst;
252 if ( type == SYMMETRIC || type == ANTISYMMETRIC ) {
253 for ( i = 1; i < ngroups; i++ ) {
254 a3 = a2 = a1 + gsize;
255 k = reverseorder*CompGroup(BHEAD ff,args,a1,a2,gsize);
256 if ( k < 0 ) {
257 j = i-1;
258 for(;;) {
259 for ( k = 0; k < gsize; k++ ) {
260 r = args[a1[k]]; args[a1[k]] = args[a2[k]]; args[a2[k]] = r;
261 }
262 exch ^= 1;
263 nexch = 4;
264 if ( j <= 0 ) break;
265 a1 -= gsize;
266 a2 -= gsize;
267 k = reverseorder*CompGroup(BHEAD ff,args,a1,a2,gsize);
268 if ( k == 0 ) neq = 2;
269 if ( k >= 0 ) break;
270 j--;
271 }
272 }
273 else if ( k == 0 ) neq = 2;
274 a1 = a3;
275 }
276 }
277 else if ( type == CYCLESYMMETRIC || type == RCYCLESYMMETRIC ) {
278 WORD rev = 0, jmin = 0, ii, iimin;
279recycle:
280 for ( j = 1; j < ngroups; j++ ) {
281 for ( i = 0; i < ngroups; i++ ) {
282 iimin = jmin + i;
283 if ( iimin >= ngroups ) iimin -= ngroups;
284 ii = j + i;
285 if ( ii >= ngroups ) ii -= ngroups;
286 k = reverseorder*CompGroup(BHEAD ff,args,Lijst+gsize*iimin,Lijst+gsize*ii,gsize);
287 if ( k > 0 ) break;
288 if ( k < 0 ) { jmin = j; nexch = 4; break; }
289 }
290 }
291 if ( type == RCYCLESYMMETRIC && rev == 0 && ngroups > 1 ) {
292 for ( j = 0; j < ngroups; j++ ) {
293 for ( i = 0; i < ngroups; i++ ) {
294 iimin = jmin + i;
295 if ( iimin >= ngroups ) iimin -= ngroups;
296 ii = j - i;
297 if ( ii < 0 ) ii += ngroups;
298 k = reverseorder*CompGroup(BHEAD ff,args,Lijst+gsize*iimin,Lijst+gsize*ii,gsize);
299 if ( k > 0 ) break;
300 if ( k < 0 ) {
301 nexch = 4;
302 jmin = 0;
303 a1 = Lijst;
304 a2 = Lijst + gsize * (ngroups-1);
305 while ( a2 > a1 ) {
306 for ( k = 0; k < gsize; k++ ) {
307 r = args[a1[k]];
308 args[a1[k]] = args[a2[k]];
309 args[a2[k]] = r;
310 }
311 a1 += gsize; a2 -= gsize;
312 }
313 rev = 1;
314 goto recycle;
315 }
316 }
317 }
318 }
319 if ( jmin != 0 ) {
320 arg = AN.arglist + func[1];
321 a1 = Lijst + gsize * jmin;
322 k = gsize * ngroups;
323 a2 = Lijst + k;
324 for ( i = 0; i < k; i++ ) {
325 if ( a1 >= a2 ) a1 = Lijst;
326 *arg++ = args[*a1++];
327 }
328 arg = AN.arglist + func[1];
329 a1 = Lijst;
330 for ( i = 0; i < k; i++ ) args[*a1++] = *arg++;
331 }
332 }
333 r = func;
334 i = FUNHEAD;
335 NCOPY(to,r,i);
336 for ( i = 0; i < nargs; i++ ) {
337 if ( ff ) {
338 if ( *(args[i]) == FUNNYWILD ) {
339 *to++ = *(args[i]);
340 *to++ = args[i][1];
341 }
342 else *to++ = *(args[i]);
343 }
344 else if ( ( j = *args[i] ) < 0 ) {
345 *to++ = j;
346 if ( j > -FUNCTION ) *to++ = args[i][1];
347 }
348 else {
349 r = args[i];
350 NCOPY(to,r,j);
351 }
352 }
353 i = func[1];
354 to = func;
355 r = AT.WorkPointer;
356 NCOPY(to,r,i);
357 return ( exch | nexch | neq );
358}
359
360/*
361 #] Symmetrize :
362 #[ CompGroup :
363
364 Routine compares two groups of arguments
365 The arguments are in args[a1[i]] and args[a2[i]]
366 for i = 0 to num
367 type indicates the type of function.
368 return value: -1 if there should be an exchange
369 0 if they are equal
370 1 if they are OK.
371*/
372
373int CompGroup(PHEAD WORD type, WORD **args, WORD *a1, WORD *a2, WORD num)
374{
375 GETBIDENTITY
376 WORD *t1, *t2, i1, i2, n, k;
377
378 for ( n = 0; n < num; n++ ) {
379 t1 = args[a1[n]]; t2 = args[a2[n]];
380 if ( type >= TENSORFUNCTION ) {
381 if ( AR.Eside == LHSIDE || AR.Eside == LHSIDEX ) {
382 if ( *t1 == FUNNYWILD ) {
383 if ( *t2 == FUNNYWILD ) {
384 if ( t1[1] < t2[1] ) return(1);
385 if ( t1[1] > t2[1] ) return(-1);
386 }
387 return(-1);
388 }
389 else if ( *t2 == FUNNYWILD ) {
390 return(1);
391 }
392 else {
393 if ( *t1 < *t2 ) return(1);
394 if ( *t1 > *t2 ) return(-1);
395 }
396 }
397 else {
398 if ( *t1 < *t2 ) return(1);
399 if ( *t1 > *t2 ) return(-1);
400 }
401 }
402 else if ( type == 0 ) {
403 if ( AC.properorderflag ) {
404 k = CompArg(t1,t2);
405 if ( k < 0 ) return(1);
406 if ( k > 0 ) return(-1);
407 NEXTARG(t1)
408 NEXTARG(t2)
409 }
410 else {
411 if ( *t1 > 0 ) {
412 i1 = *t1 - ARGHEAD - 1;
413 t1 += ARGHEAD + 1;
414 if ( *t2 > 0 ) {
415 i2 = *t2 - ARGHEAD - 1;
416 t2 += ARGHEAD + 1;
417 while ( i1 > 0 && i2 > 0 ) {
418 if ( *t1 > *t2 ) return(-1);
419 else if ( *t1 < *t2 ) return(1);
420 i1--; i2--; t1++; t2++;
421 }
422 if ( i1 > 0 ) return(-1);
423 else if ( i2 > 0 ) return(1);
424 }
425/*
426 This seems to be a bug. Reported by Aneesh Monahar, 28-sep-2005
427 else return(1);
428*/
429 else return(-1);
430 }
431 else if ( *t2 > 0 ) return(1);
432 else {
433 if ( *t1 != *t2 ) {
434 if ( *t1 <= -FUNCTION && *t2 <= -FUNCTION ) {
435 if ( *t1 < *t2 ) return(-1);
436 return(1);
437 }
438 else {
439 if ( *t1 < *t2 ) return(1);
440 return(-1);
441 }
442 }
443 if ( *t1 > -FUNCTION ) {
444 if ( t1[1] != t2[1] ) {
445 if ( t1[1] < t2[1] ) return(1);
446 return(-1);
447 }
448 }
449 }
450 }
451 }
452 }
453 return(0);
454}
455
456/*
457 #] CompGroup :
458 #[ FullSymmetrize :
459
460 Relay function for Normalize to execute a full symmetrization
461 of a function fun. It hooks into Symmetrize according to the
462 calling conventions for it.
463 type = 0: Symmetrize
464 type = 1: AntiSymmetrize
465 type = 2: CycleSymmetrize
466 type = 3: RCycleSymmetrize
467 Return values:
468 bit 0: odd permutation
469 bit 1: identical arguments
470 bit 2: there was a permutation.
471*/
472
473int FullSymmetrize(PHEAD WORD *fun, int type)
474{
475 GETBIDENTITY
476 WORD *Lijst, count = 0;
477 WORD *t, *funstop, i;
478 int retval;
479
480 if ( functions[*fun-FUNCTION].spec > 0 ) {
481 count = fun[1] - FUNHEAD;
482 for ( i = fun[1]-1; i >= FUNHEAD; i-- ) {
483 if ( fun[i] == FUNNYWILD ) count--;
484 }
485 }
486 else {
487 funstop = fun + fun[1];
488 t = fun + FUNHEAD;
489 while ( t < funstop ) { count++; NEXTARG(t) }
490 }
491 if ( count < 2 ) {
492 fun[2] &= ~DIRTYSYMFLAG;
493 return(0);
494 }
495 Lijst = AT.WorkPointer;
496 for ( i = 0; i < count; i++ ) Lijst[i] = i;
497 AT.WorkPointer += count;
498 retval = Symmetrize(BHEAD fun,Lijst,count,1,type);
499 fun[2] &= ~DIRTYSYMFLAG;
500 AT.WorkPointer = Lijst;
501 return(retval);
502}
503
504/*
505 #] FullSymmetrize :
506 #[ SymGen :
507
508 Routine does the outer work in the symmetrization.
509 It locates the function(s) and loads up the parameters.
510 It also studies the result.
511
512 if params[4] = -1 and no extra -> all
513 extra -> strip groups with elements too large
514 0 -> if group with element too large: nofun
515 >0 -> must have right number of arguments
516*/
517
518int SymGen(PHEAD WORD *term, WORD *params, WORD num, WORD level)
519{
520 GETBIDENTITY
521 WORD *t, *r, *m;
522 WORD i, j, k, c1, c2, ngroup;
523 WORD *rstop, Nlist, *inLijst, *Lijst, sign = 1, sumch = 0, count;
524 DUMMYUSE(num);
525 c1 = params[3]; /* function number */
526 c2 = FUNCTION + WILDOFFSET;
527 Nlist = params[4];
528 if ( Nlist < 0 ) Nlist = 0;
529 else Nlist = params[0] - 7;
530 t = term;
531 m = t + *t;
532 m -= ABS(m[-1]);
533 t++;
534 while ( t < m ) {
535 if ( *t == c1 || c1 > c2 ) { /* Candidate function */
536 if ( *t >= FUNCTION && functions[*t-FUNCTION].spec
537 >= TENSORFUNCTION ) {
538 count = t[1] - FUNHEAD;
539 }
540 else {
541 count = 0;
542 r = t;
543 rstop = t + t[1];
544 r += FUNHEAD;
545 while ( r < rstop ) { count++; NEXTARG(r) }
546 }
547 if ( ( j = params[4] ) > 0 && j != count ) goto NextFun;
548 if ( j == 0 ) {
549 inLijst = params+7;
550 for ( i = 0; i < Nlist; i++ )
551 if ( inLijst[i] > count-1 ) goto NextFun;
552 }
553
554 if ( Nlist > (params[0] - 7) ) Nlist = params[0] - 7;
555 Lijst = AT.WorkPointer;
556 inLijst = params + 7;
557 ngroup = params[5];
558 if ( Nlist > 0 && j < 0 ) {
559 k = 0;
560 for ( i = 0; i < ngroup; i++ ) {
561 for ( j = 0; j < params[6]; j++ ) {
562 if ( inLijst[j] > count+1 ) {
563 inLijst += params[6];
564 goto NextGroup;
565 }
566 }
567 j = params[6];
568 NCOPY(Lijst,inLijst,j);
569 k++;
570NextGroup:;
571 }
572 if ( k <= 1 ) goto NextFun;
573 ngroup = k;
574 inLijst = AT.WorkPointer;
575 AT.WorkPointer = Lijst;
576 Lijst = inLijst;
577 }
578 else if ( Nlist == 0 ) {
579 for ( i = 0; i < count; i++ ) Lijst[i] = i;
580 AT.WorkPointer += count;
581 ngroup = count;
582 }
583 else {
584 for ( i = 0; i < Nlist; i++ ) Lijst[i] = inLijst[i];
585 AT.WorkPointer += Nlist;
586 }
587 j = Symmetrize(BHEAD t,Lijst,ngroup,params[6],params[2]);
588 AT.WorkPointer = Lijst;
589 if ( params[2] == 4 ) { /* antisymmetric */
590 if ( ( j & 1 ) != 0 ) sign = -sign;
591 if ( ( j & 2 ) != 0 ) return(0); /* equal arguments */
592 }
593 if ( ( j & 4 ) != 0 ) sumch++;
594 t[2] &= ~DIRTYSYMFLAG;
595 }
596NextFun:
597 t += t[1];
598 }
599 if ( sign < 0 ) {
600 t = term;
601 t += *t - 1;
602 *t = -*t;
603 }
604 if ( sumch ) {
605 if ( Normalize(BHEAD term) ) {
606 MLOCK(ErrorMessageLock);
607 MesCall("SymGen");
608 MUNLOCK(ErrorMessageLock);
609 return(-1);
610 }
611 if ( !*term ) return(0);
612 *AN.RepPoint = 1;
613 AR.expchanged = 1;
614 if ( AR.CurDum > AM.IndDum && AR.sLevel <= 0 ) ReNumber(BHEAD term);
615 }
616 return(Generator(BHEAD term,level));
617}
618
619/*
620 #] SymGen :
621 #[ SymFind :
622
623 There is a certain amount of double work here, as this routine
624 finds the function to be treated, while the SymGen routine has
625 to find it again. Note however that this way things remain
626 uniform and simple. Moreover this avoids problems with actions
627 on more than one function simultaneously.
628 Output in AT.TMout:
629 Number,sym/anti,fun,lenpar,ngroups,gsize,fields
630
631*/
632
633int SymFind(PHEAD WORD *term, WORD *params)
634{
635 GETBIDENTITY
636 WORD *t, *r, *m;
637 WORD j, c1, c2, count;
638 WORD *rstop;
639 c1 = params[4]; /* function number */
640 c2 = FUNCTION + WILDOFFSET;
641 t = term;
642 m = t + *t;
643 m -= ABS(m[-1]);
644 t++;
645 while ( t < m ) {
646 if ( *t == c1 || c1 > c2 ) { /* Candidate function */
647 if ( *t >= FUNCTION && functions[*t-FUNCTION].spec
648 >= TENSORFUNCTION ) { count = t[1] - FUNHEAD; }
649 else {
650 count = 0;
651 r = t;
652 rstop = t + t[1];
653 r += FUNHEAD;
654 while ( r < rstop ) { count++; NEXTARG(r) }
655 }
656 if ( ( j = params[5] ) > 0 && j != count ) goto NextFun;
657 if ( j == 0 ) {
658 r = params + 8;
659 rstop = params + params[1];
660 while ( r < rstop ) {
661 if ( *r > count + 1 ) goto NextFun;
662 r++;
663 }
664 }
665
666 t = AT.TMout;
667 r = params;
668 j = r[1] - 1;
669 *t++ = j;
670 *t++ = SYMMETRIZE;
671 r += 3;
672 j--;
673 NCOPY(t,r,j);
674 return(1);
675 }
676NextFun:
677 t += t[1];
678 }
679 return(0);
680}
681
682/*
683 #] SymFind :
684 #[ ChainIn :
685
686 Equivalent to repeat id f(?a)*f(?b) = f(?a,?b);
687
688 This one always takes less space.
689*/
690
691int ChainIn(PHEAD WORD *term, WORD funnum)
692{
693 GETBIDENTITY
694 WORD *t, *tend, *m, *tt, *ts;
695 int action, normFlag = 0;
696 if ( funnum < 0 ) { /* Dollar to be expanded */
697 funnum = DolToFunction(BHEAD -funnum);
698 if ( AN.ErrorInDollar || funnum <= 0 ) {
699 MLOCK(ErrorMessageLock);
700 MesPrint("Dollar variable does not evaluate to function in ChainIn statement");
701 MUNLOCK(ErrorMessageLock);
702 return(-1);
703 }
704 }
705 do {
706 action = 0;
707 tend = term+*term;
708 tend -= ABS(tend[-1]);
709 t = term+1;
710 while ( t < tend ) {
711 if ( *t != funnum ) { t += t[1]; continue; }
712 m = t;
713 t += t[1];
714 tt = t;
715 if ( t >= tend || *t != funnum ) continue;
716 action = 1;
717 normFlag = 1;
718 while ( t < tend && *t == funnum ) {
719 ts = t + t[1];
720 t += FUNHEAD;
721 while ( t < ts ) *tt++ = *t++;
722 }
723 m[1] = tt - m;
724 ts = term + *term;
725 while ( t < ts ) *tt++ = *t++;
726 *term = tt - term;
727 break;
728 }
729 } while ( action );
730
731 if ( normFlag ) {
732 /* We need to check the newly-constructed arguments w.r.t symmetry properties */
733 MarkDirty(term, DIRTYSYMFLAG);
734 AT.WorkPointer = term + *term;
735 Normalize(BHEAD term);
736 }
737
738 return(0);
739}
740
741/*
742 #] ChainIn :
743 #[ ChainOut :
744
745 Equivalent to repeat id f(x1?,x2?,?a) = f(x1)*f(x2,?a);
746*/
747
748int ChainOut(PHEAD WORD *term, WORD funnum)
749{
750 GETBIDENTITY
751 WORD *t, *tend, *tt, *ts, *w, *ws;
752 int flag = 0, i;
753 if ( funnum < 0 ) { /* Dollar to be expanded */
754 funnum = DolToFunction(BHEAD -funnum);
755 if ( AN.ErrorInDollar || funnum <= 0 ) {
756 MLOCK(ErrorMessageLock);
757 MesPrint("Dollar variable does not evaluate to function in ChainOut statement");
758 MUNLOCK(ErrorMessageLock);
759 return(-1);
760 }
761 }
762 tend = term+*term;
763 if ( AT.WorkPointer < tend ) AT.WorkPointer = tend;
764 tend -= ABS(tend[-1]);
765 t = term+1; tt = term; w = AT.WorkPointer;
766 while ( t < tend ) {
767 if ( *t != funnum || t[1] == FUNHEAD ) { t += t[1]; continue; }
768 flag = 1;
769 while ( tt < t ) *w++ = *tt++;
770 ts = t + t[1];
771 t += FUNHEAD;
772 while ( t < ts ) {
773 ws = w;
774 for ( i = 0; i < FUNHEAD; i++ ) *w++ = tt[i];
775 if ( functions[*tt-FUNCTION].spec >= TENSORFUNCTION ) {
776 *w++ = *t++;
777 }
778 else if ( *t < 0 ) {
779 if ( *t <= -FUNCTION ) *w++ = *t++;
780 else { *w++ = *t++; *w++ = *t++; }
781 }
782 else {
783 i = *t; NCOPY(w,t,i);
784 }
785 ws[1] = w - ws;
786 }
787 tt = t;
788 }
789 if ( flag == 1 ) {
790 ts = term + *term;
791 while ( tt < ts ) *w++ = *tt++;
792 *AT.WorkPointer = w - AT.WorkPointer;
793 t = term; w = AT.WorkPointer; i = *w;
794 NCOPY(t,w,i)
795 AT.WorkPointer = term + *term;
796 Normalize(BHEAD term);
797 }
798 return(0);
799}
800
801/*
802 #] ChainOut :
803 #] Utilities :
804 #[ Patterns :
805 #[ MatchFunction : WORD MatchFunction(pattern,interm,wilds)
806
807 The routine assumes that the function numbers are the same.
808 The contents are compared and a possible wildcard assignment
809 is made. Note that it may be necessary to use a wildcard
810 assignment stack to do things right.
811 The routine can become arbitrarily complicated as there is
812 no end to the possible wildcarding.
813 Examples:
814 - a: No wildcarding -> straight match
815 - b: Individual arguments (object -> object)
816 - c: whole arguments (object to subexpression)
817 - d: any argumentlist
818 e: part of an argument (object inside subexpression)
819
820 The ones with a minus sign in front have been implemented.
821
822 Note: the argument wilds allows backtracking when multiple
823 ?a,?b give a match that later turns out to be useless.
824*/
825
826int MatchFunction(PHEAD WORD *pattern, WORD *interm, WORD *wilds)
827{
828 GETBIDENTITY
829 WORD *m, *t, *r, i;
830 WORD *mstop = 0, *tstop = 0;
831 WORD *argmstop, *argtstop;
832 WORD *mtrmstop, *ttrmstop;
833 WORD *msubstop, *mnextsub;
834 WORD msizcoef, mcount, tcount, newvalue, j;
835 WORD *oldm, *oldt;
836 WORD *OldWork, numofwildarg;
837 WORD nwstore, tobeeaten, reservevalue = 0, resernum = 0, withwild;
838 WORD *wildargtaken;
839 CBUF *C = cbuf+AT.ebufnum;
840 int ntwa = AN.NumTotWildArgs;
841 LONG oldcpointer = C->Pointer - C->Buffer;
842#ifdef WITHFLOAT
843 // Pattern matching against float_ functions is currently disabled.
844 // To relax this in the future, move this early return down to where gamma
845 // functions and tensors are handled specially.
846 if ( *interm == FLOATFUN ) return(0);
847#endif
848/*
849 Test first for a straight match
850*/
851 AN.RepFunList[AN.RepFunNum+1] = 0;
852 if ( *wilds == 0 ) {
853 m = pattern; t = interm;
854
855 if ( *m != *t ) {
856 if ( *m < (FUNCTION + WILDOFFSET) ) return(0);
857 if ( *t < FUNCTION ) return(0);
858 if ( functions[*t-FUNCTION].spec !=
859 functions[*m-FUNCTION-WILDOFFSET].spec ) return(0);
860 }
861 i = m[1];
862 if ( *m >= (FUNCTION + WILDOFFSET) ) { i--; m++; t++; }
863 do { if ( *m++ != *t++ ) break; } while ( --i > 0 );
864 if ( i <= 0 ) { /* Arguments match */
865 if ( AN.SignCheck && AN.ExpectedSign ) return(0);
866 i = *pattern - WILDOFFSET;
867 if ( i >= FUNCTION ) {
868 if ( *interm != GAMMA
869 && !CheckWild(BHEAD i,FUNTOFUN,*interm,&newvalue) ) {
870 AddWild(BHEAD i,FUNTOFUN,newvalue);
871 return(1);
872 }
873 return(0);
874 }
875 else return(1);
876 }
877 }
878/*
879 Store the current Wildcard assignments
880*/
881 t = wildargtaken = OldWork = AT.WorkPointer;
882 t += ntwa;
883 m = AN.WildValue;
884 nwstore = i = (m[-SUBEXPSIZE+1]-SUBEXPSIZE)/4;
885 if ( i > 0 ) {
886 r = AT.WildMask;
887 do {
888 *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *r++;
889 } while ( --i > 0 );
890 *t++ = C->numrhs;
891 }
892 if ( t >= AT.WorkTop ) {
893 MLOCK(ErrorMessageLock);
894 MesWork();
895 MUNLOCK(ErrorMessageLock);
896 Terminate(-1);
897 }
898 AT.WorkPointer = t;
899
900 if ( *wilds ) {
901 if ( *wilds == 1 ) goto endoloop;
902 else goto enloop; /* tensors = 2 */
903 }
904 m = pattern; t = interm;
905/*
906 Single out the specials
907*/
908 if ( *t == GAMMA ) {
909/*
910 #[ GAMMA :
911
912 For the gamma's we need to do two things:
913 a: Find that there is a match
914 b: Find where the match occurs in the string
915 This last thing cannot be stored in the current conventions,
916 but once the wildcard assignments have been made it is much
917 easier to find it back.
918 Alternative: replace the function number in the term temporarily
919 by the offset inside the string. This makes things maybe easier.
920*/
921 if ( *m != GAMMA ) goto NoCaseB;
922 i = t[1] - m[1];
923 if ( m[1] == FUNHEAD+1 ) {
924 if ( i ) goto NoCaseB;
925 if ( m[FUNHEAD] < (AM.OffsetIndex+WILDOFFSET) ||
926 t[FUNHEAD] >= (AM.OffsetIndex+WILDOFFSET) ) goto NoCaseB;
927
928 if ( CheckWild(BHEAD m[FUNHEAD]-WILDOFFSET,INDTOIND,t[FUNHEAD],&newvalue) ) goto NoCaseB;
929 AddWild(BHEAD m[FUNHEAD]-WILDOFFSET,INDTOIND,newvalue);
930
931 AT.WorkPointer = OldWork;
932 if ( AN.SignCheck && AN.ExpectedSign ) return(0);
933 return(1); /* m was eaten. we have a match! */
934 }
935 if ( i < 0 ) goto NoCaseB; /* Pattern longer than target */
936 mstop = m + m[1];
937 tstop = t + t[1];
938 m += FUNHEAD; t += FUNHEAD;
939 if ( *m >= (AM.OffsetIndex+WILDOFFSET) && *t < (AM.OffsetIndex+WILDOFFSET) ) {
940 if ( CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*t,&newvalue) ) goto NoCaseB;
941 reservevalue = newvalue;
942 withwild = 1;
943 resernum = *m-WILDOFFSET;
944 AddWild(BHEAD *m-WILDOFFSET,INDTOIND,newvalue);
945 }
946 else if ( *m != *t ) goto NoCaseB;
947 else withwild = 0;
948 m++; t++;
949 oldm = m; argtstop = oldt = t;
950 j = 0; /* No wildcard assignments yet */
951 while ( i >= 0 ) {
952 if ( *m == *t ) {
953WithGamma: m++; t++;
954 if ( m >= mstop ) {
955 if ( t < tstop && mstop < AN.patstop ) {
956 WORD k;
957 mnextsub = pattern + pattern[1];
958 k = *mnextsub;
959 while ( k == GAMMA && mnextsub[FUNHEAD]
960 != pattern[FUNHEAD] ) {
961 mnextsub += mnextsub[1];
962 if ( mnextsub >= AN.patstop ) goto FullOK;
963 k = *mnextsub;
964 }
965 if ( k >= FUNCTION ) {
966 if ( k > (FUNCTION + WILDOFFSET) ) k -= WILDOFFSET;
967 if ( functions[k-FUNCTION].commute ) goto NoGamma;
968 }
969 }
970FullOK: if ( AN.SignCheck && AN.ExpectedSign ) goto NoGamma;
971 AN.RepFunList[AN.RepFunNum+1] = WORDDIF(oldt,argtstop);
972 return(1);
973 }
974 if ( t >= tstop ) goto NoCaseB;
975 }
976 else if ( *m >= (AM.OffsetIndex+WILDOFFSET)
977 && *m < (AM.OffsetIndex + (WILDOFFSET<<1)) && ( *t >= 0 ||
978 *t < MINSPEC ) ) { /* Wildcard index */
979 if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*t,&newvalue) ) {
980 AddWild(BHEAD *m-WILDOFFSET,INDTOIND,newvalue);
981 j = 1;
982 goto WithGamma;
983 }
984 else goto NoGamma;
985 }
986 else if ( *m < MINSPEC && *m >= (AM.OffsetVector+WILDOFFSET)
987 && *t < MINSPEC ) { /* Wildcard vector */
988 if ( !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*t,&newvalue) ) {
989 AddWild(BHEAD *m-WILDOFFSET,VECTOVEC,newvalue);
990 j = 1;
991 goto WithGamma;
992 }
993 else goto NoGamma;
994 }
995 else {
996NoGamma:
997 if ( j ) { /* Undo wildcards */
998 m = AN.WildValue;
999 t = OldWork + AN.NumTotWildArgs; r = AT.WildMask; j = nwstore;
1000 if ( j > 0 ) {
1001 do {
1002 *m++ = *t++; *m++ = *t++;
1003 *m++ = *t++; *m++ = *t++; *r++ = *t++;
1004 } while ( --j > 0 );
1005 C->numrhs = *t++;
1006 C->Pointer = C->Buffer + oldcpointer;
1007 }
1008 j = 0;
1009 }
1010 m = oldm; t = ++oldt; i--;
1011 if ( withwild ) {
1012 AddWild(BHEAD resernum,INDTOIND,reservevalue);
1013 }
1014 }
1015 }
1016 goto NoCaseB;
1017/*
1018 #] GAMMA :
1019 #[ Tensors :
1020*/
1021 }
1022 else if ( *t >= FUNCTION && functions[*t-FUNCTION].spec >= TENSORFUNCTION ) {
1023 mstop = m + m[1];
1024 tstop = t + t[1];
1025 mcount = 0;
1026 m += FUNHEAD;
1027 t += FUNHEAD;
1028 AN.WildArgs = 0;
1029 tcount = WORDDIF(tstop,t);
1030 while ( m < mstop ) {
1031 if ( *m == FUNNYWILD ) { m++; AN.WildArgs++; }
1032 m++; mcount++;
1033 }
1034 tobeeaten = tcount - mcount + AN.WildArgs;
1035 if ( tobeeaten ) {
1036 if ( tobeeaten < 0 || AN.WildArgs == 0 ) {
1037 AT.WorkPointer = OldWork;
1038 return(0); /* Cannot match */
1039 }
1040 }
1041 AT.WildArgTaken[0] = AN.WildEat = tobeeaten;
1042 for ( i = 1; i < AN.WildArgs; i++ ) AT.WildArgTaken[i] = 0;
1043toploop:
1044 numofwildarg = 0;
1045
1046 m = pattern; t = interm;
1047 mstop = m + m[1];
1048 if ( *m != *t ) {
1049 i = *m - WILDOFFSET;
1050 if ( CheckWild(BHEAD i,FUNTOFUN,*t,&newvalue) ) goto NoCaseB;
1051 AddWild(BHEAD i,FUNTOFUN,newvalue);
1052 }
1053 m += FUNHEAD;
1054 t += FUNHEAD;
1055 while ( m < mstop ) {
1056/*
1057 First test for an exact match
1058*/
1059 if ( *m == *t ) { m++; t++; continue; }
1060/*
1061 No exact match. Try ARGWILD
1062*/
1063 AN.argaddress = t;
1064 if ( *m == FUNNYWILD ) {
1065 tobeeaten = AT.WildArgTaken[numofwildarg++];
1066 if ( CheckWild(BHEAD m[1],ARGTOARG|EATTENSOR,tobeeaten,t) ) goto endloop;
1067 AddWild(BHEAD m[1],ARGTOARG|EATTENSOR,tobeeaten);
1068 m += 2;
1069 t += tobeeaten;
1070 continue;
1071 }
1072/*
1073 Now the various cases:
1074*/
1075 i = *m;
1076 if ( i < MINSPEC ) {
1077 if ( *t != i ) {
1078 if ( *t >= MINSPEC ) goto endloop;
1079 i -= WILDOFFSET;
1080 if ( i < AM.OffsetVector ) goto endloop;
1081 if ( CheckWild(BHEAD i,VECTOVEC,*t,&newvalue) )
1082 goto endloop;
1083 AddWild(BHEAD i,VECTOVEC,newvalue);
1084 }
1085 }
1086 else if ( i >= AM.OffsetIndex ) { /* Index */
1087 if ( i < ( AM.OffsetIndex + WILDOFFSET ) ) goto endloop;
1088 if ( i >= ( AM.OffsetIndex + (WILDOFFSET<<1) ) ) {
1089 /* Summed over index */
1090 goto endloop; /* For the moment */
1091 }
1092 i -= WILDOFFSET;
1093 if ( CheckWild(BHEAD i,INDTOIND,*t,&newvalue) )
1094 goto endloop; /* Assignment not allowed */
1095 AddWild(BHEAD i,INDTOIND,newvalue);
1096 }
1097 else goto endloop;
1098 m++; t++;
1099 }
1100 if ( AN.SignCheck && AN.ExpectedSign ) goto endloop;
1101 AT.WorkPointer = OldWork;
1102 if ( AN.WildArgs > 1 ) *wilds = 2;
1103 return(1); /* m was eaten. we have a match! */
1104
1105endloop:;
1106/*
1107 restore the current Wildcard assignments
1108*/
1109 i = nwstore;
1110 if ( i > 0 ) {
1111 m = AN.WildValue;
1112 t = OldWork + ntwa; r = AT.WildMask;
1113 do {
1114 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1115 } while ( --i > 0 );
1116 C->numrhs = *t++;
1117 C->Pointer = C->Buffer + oldcpointer;
1118 }
1119enloop:;
1120 i = AN.WildArgs - 1;
1121 if ( i <= 0 ) {
1122 AT.WorkPointer = OldWork;
1123 return(0);
1124 }
1125 while ( --i >= 0 ) {
1126 if ( AT.WildArgTaken[i] == 0 ) {
1127 if ( i == 0 ) {
1128 AT.WorkPointer = OldWork;
1129 *wilds = 0;
1130 return(0);
1131 }
1132 }
1133 else {
1134 (AT.WildArgTaken[i])--;
1135 numofwildarg = 0;
1136 for ( j = 0; j <= i; j++ ) {
1137 numofwildarg += AT.WildArgTaken[j];
1138 }
1139 AT.WildArgTaken[j] = AN.WildEat-numofwildarg;
1140 for ( j++; j < AN.WildArgs; j++ ) AT.WildArgTaken[j] = 0;
1141 break;
1142 }
1143 }
1144 goto toploop;
1145/*
1146 #] Tensors :
1147*/
1148 }
1149/*
1150 Count the number of arguments. Either equal or an argument wildcard.
1151*/
1152 mstop = m + m[1];
1153 tstop = t + t[1];
1154 mcount = 0; tcount = 0;
1155 m += FUNHEAD; t += FUNHEAD;
1156 while ( t < tstop ) { tcount++; NEXTARG(t) }
1157 AN.WildArgs = 0;
1158 while ( m < mstop ) {
1159 mcount++;
1160 if ( *m == -ARGWILD ) AN.WildArgs++;
1161 NEXTARG(m)
1162 }
1163 tobeeaten = tcount - mcount + AN.WildArgs;
1164 if ( tobeeaten ) {
1165 if ( tobeeaten < 0 || AN.WildArgs == 0 ) {
1166 AT.WorkPointer = OldWork;
1167 return(0); /* Cannot match */
1168 }
1169 }
1170/*
1171 Set up the array AT.WildArgTaken for the number of arguments that each
1172 wildarg eats.
1173*/
1174 AT.WildArgTaken[0] = AN.WildEat = tobeeaten;
1175 for ( i = 1; i < AN.WildArgs; i++ ) AT.WildArgTaken[i] = 0;
1176topofloop:
1177 numofwildarg = 0;
1178/*
1179 Test for single wildcard object/argument
1180*/
1181 m = pattern; t = interm;
1182 if ( *m != *t ) {
1183 i = *m - WILDOFFSET;
1184 if ( CheckWild(BHEAD i,FUNTOFUN,*t,&newvalue) ) goto NoCaseB;
1185 AddWild(BHEAD i,FUNTOFUN,newvalue);
1186 }
1187 mstop = m + m[1];
1188/* tstop = t + t[1]; */
1189 m += FUNHEAD;
1190 t += FUNHEAD;
1191 while ( m < mstop ) {
1192 argmstop = oldm = m;
1193 argtstop = oldt = t;
1194 NEXTARG(argmstop)
1195 NEXTARG(argtstop)
1196 if ( t == tstop ) { /* This concerns a very rare bug */
1197 if ( *m == -ARGWILD ) goto ArgAll;
1198 goto endofloop;
1199 }
1200 if ( *m < 0 && *t < 0 ) {
1201 if ( *t <= -FUNCTION ) {
1202 if ( *t == *m ) {}
1203 else if ( *m <= -FUNCTION-WILDOFFSET
1204 && functions[-*t-FUNCTION].spec
1205 == functions[-*m-FUNCTION-WILDOFFSET].spec ) {
1206 i = -*m - WILDOFFSET;
1207 if ( CheckWild(BHEAD i,FUNTOFUN,-*t,&newvalue) ) goto endofloop;
1208 AddWild(BHEAD i,FUNTOFUN,newvalue);
1209 }
1210 else if ( *m == -SYMBOL && m[1] >= 2*MAXPOWER ) {
1211 i = m[1] - 2*MAXPOWER;
1212 AN.argaddress = AT.FunArg;
1213 AT.FunArg[ARGHEAD+1] = -*t;
1214 if ( CheckWild(BHEAD i,SYMTOSUB,1,AN.argaddress) ) goto endofloop;
1215 AddWild(BHEAD i,SYMTOSUB,0);
1216 }
1217 else if ( *m == -ARGWILD ) {
1218ArgAll: i = AT.WildArgTaken[numofwildarg++];
1219 AN.argaddress = t;
1220 if ( CheckWild(BHEAD m[1],ARGTOARG,i,t) ) goto endofloop;
1221 AddWild(BHEAD m[1],ARGTOARG,i);
1222/* m += 2; */
1223 while ( --i >= 0 ) { NEXTARG(t) }
1224 argtstop = t;
1225 }
1226 else goto endofloop;
1227 }
1228 else if ( *t == *m ) {
1229 if ( t[1] == m[1] ) {}
1230 else if ( *t == -SYMBOL ) {
1231 j = SYMTOSYM;
1232SymAll:
1233 if ( ( i = m[1] - 2*MAXPOWER ) < 0 ) goto endofloop;
1234 if ( CheckWild(BHEAD i,j,t[1],&newvalue) ) goto endofloop;
1235 AddWild(BHEAD i,j,newvalue);
1236 }
1237 else if ( *t == -INDEX ) {
1238IndAll: i = m[1] - WILDOFFSET;
1239 if ( i < AM.OffsetIndex || i >= WILDOFFSET+AM.OffsetIndex )
1240 goto endofloop;
1241 /* We kill the summed over indices here */
1242 if ( CheckWild(BHEAD i,INDTOIND,t[1],&newvalue) ) goto endofloop;
1243 AddWild(BHEAD i,INDTOIND,newvalue);
1244 }
1245 else if ( *t == -VECTOR || *t == -MINVECTOR ) {
1246 i = m[1] - WILDOFFSET;
1247 if ( i < AM.OffsetVector ) goto endofloop;
1248 if ( CheckWild(BHEAD i,VECTOVEC,t[1],&newvalue) ) goto endofloop;
1249 AddWild(BHEAD i,VECTOVEC,newvalue);
1250 }
1251 else goto endofloop;
1252 }
1253 else if ( *m == -ARGWILD ) goto ArgAll;
1254 else if ( *m == -INDEX && m[1] >= AM.OffsetIndex+WILDOFFSET
1255 && m[1] < AM.OffsetIndex+(WILDOFFSET<<1) ) {
1256 if ( *t == -VECTOR ) goto IndAll;
1257 if ( *t == -SNUMBER && t[1] >= 0 && t[1] < AM.OffsetIndex ) goto IndAll;
1258 if ( *t == -MINVECTOR ) {
1259 i = m[1] - WILDOFFSET;
1260 AN.argaddress = AT.MinVecArg;
1261 AT.MinVecArg[ARGHEAD+3] = t[1];
1262 if ( CheckWild(BHEAD i,INDTOSUB,1,AN.argaddress) ) goto endofloop;
1263 AddWild(BHEAD i,INDTOSUB,(WORD)0);
1264 }
1265 else goto endofloop;
1266 }
1267 else if ( *m == -SYMBOL && m[1] >= 2*MAXPOWER && *t == -SNUMBER ) {
1268 j = SYMTONUM;
1269 goto SymAll;
1270 }
1271 else if ( *m == -VECTOR && *t == -MINVECTOR &&
1272 ( i = m[1] - WILDOFFSET ) >= AM.OffsetVector ) {
1273/*
1274================================
1275 AN.argaddress = AT.MinVecArg;
1276 AT.MinVecArg[ARGHEAD+3] = t[1];
1277 if ( CheckWild(BHEAD i,VECTOSUB,1,AN.argaddress) ) goto endofloop;
1278 AddWild(BHEAD i,VECTOSUB,(WORD)0);
1279================================
1280*/
1281 if ( CheckWild(BHEAD i,VECTOMIN,t[1],&newvalue) ) goto endofloop;
1282 AddWild(BHEAD i,VECTOMIN,newvalue);
1283
1284 }
1285 else if ( *m == -MINVECTOR && *t == -VECTOR &&
1286 ( i = m[1] - WILDOFFSET ) >= AM.OffsetVector ) {
1287/*
1288================================
1289 AN.argaddress = AT.MinVecArg;
1290 AT.MinVecArg[ARGHEAD+3] = t[1];
1291 if ( CheckWild(BHEAD i,VECTOSUB,1,AN.argaddress) ) goto endofloop;
1292 AddWild(BHEAD i,VECTOSUB,(WORD)0);
1293================================
1294*/
1295 if ( CheckWild(BHEAD i,VECTOMIN,t[1],&newvalue) ) goto endofloop;
1296 AddWild(BHEAD i,VECTOMIN,newvalue);
1297 }
1298 else goto endofloop;
1299 }
1300 else if ( *t <= -FUNCTION && *m > 0 ) {
1301 if ( ( m[ARGHEAD]+ARGHEAD == *m ) && m[*m-1] == 3
1302 && m[*m-2] == 1 && m[*m-3] == 1 && m[ARGHEAD+1] >= FUNCTION
1303 && m[ARGHEAD+2] == *m-ARGHEAD-4 ) { /* Check for f(?a) etc */
1304 WORD *mmmst, *mmm;
1305 if ( m[ARGHEAD+1] >= FUNCTION+WILDOFFSET ) {
1306/* i = *m - WILDOFFSET; */
1307 i = m[ARGHEAD+1] - WILDOFFSET;
1308 if ( CheckWild(BHEAD i,FUNTOFUN,-*t,&newvalue) ) goto endofloop;
1309 AddWild(BHEAD i,FUNTOFUN,newvalue);
1310 }
1311 else if ( m[ARGHEAD+1] != -*t ) goto endofloop;
1312/*
1313 Only arguments allowed are ?a etc.
1314*/
1315 mmmst = m+*m-3;
1316 mmm = m + ARGHEAD + FUNHEAD + 1;
1317 while ( mmm < mmmst ) {
1318 if ( *mmm != -ARGWILD ) goto endofloop;
1319 i = 0;
1320 AN.argaddress = t;
1321 if ( CheckWild(BHEAD mmm[1],ARGTOARG,i,t) ) goto endofloop;
1322 AddWild(BHEAD mmm[1],ARGTOARG,i);
1323 mmm += 2;
1324 }
1325 }
1326 else goto endofloop;
1327 }
1328 else if ( *m < 0 && *t > 0 ) {
1329 if ( *m == -SYMBOL ) { /* SYMTOSUB */
1330 if ( m[1] < 2*MAXPOWER ) goto endofloop;
1331 i = m[1] - 2*MAXPOWER;
1332 AN.argaddress = t;
1333 if ( CheckWild(BHEAD i,SYMTOSUB,1,AN.argaddress) ) goto endofloop;
1334 AddWild(BHEAD i,SYMTOSUB,0);
1335 }
1336 else if ( *m == -VECTOR ) {
1337 if ( ( i = m[1] - WILDOFFSET ) < AM.OffsetVector )
1338 goto endofloop;
1339 AN.argaddress = t;
1340 if ( CheckWild(BHEAD i,VECTOSUB,1,t) ) goto endofloop;
1341 AddWild(BHEAD i,VECTOSUB,(WORD)0);
1342 }
1343 else if ( *m == -INDEX ) {
1344 if ( ( i = m[1] - WILDOFFSET ) < AM.OffsetIndex ) goto endofloop;
1345 if ( i >= AM.OffsetIndex + WILDOFFSET ) goto endofloop;
1346 AN.argaddress = t;
1347 if ( CheckWild(BHEAD i,INDTOSUB,1,AN.argaddress) ) goto endofloop;
1348 AddWild(BHEAD i,INDTOSUB,(WORD)0);
1349 }
1350 else if ( *m == -ARGWILD ) goto ArgAll;
1351 else goto endofloop;
1352 }
1353 else if ( *m > 0 && *t > 0 ) {
1354 WORD ii = *t-*m;
1355 i = *m;
1356 do { if ( *m++ != *t++ ) break; } while ( --i > 0 );
1357 if ( i == 1 && ii == 0 ) { /* sign difference */
1358 goto endofloop;
1359 }
1360 else if ( i > 0 ) {
1361 WORD *cto, *cfrom, *csav, ci;
1362 WORD oRepFunNum;
1363 WORD *oRepFunList;
1364 WORD *oterstart,*oterstop,*opatstop;
1365 WORD oExpectedSign;
1366 WORD wildargs, wildeat;
1367/*
1368 Not an exact match here.
1369 We have to hope that the pattern contains a composite wildcard.
1370*/
1371 m = oldm; t = oldt;
1372 m += ARGHEAD; t += ARGHEAD; /* Point at (first?) term */
1373 mtrmstop = m + *m;
1374 ttrmstop = t + *t;
1375 if ( mtrmstop < argmstop ) goto endofloop;/* More than one term */
1376 msizcoef = mtrmstop[-1];
1377 if ( msizcoef < 0 ) msizcoef = -msizcoef;
1378 msubstop = mtrmstop - msizcoef;
1379 m++;
1380 if ( m >= msubstop ) goto endofloop; /* Only coefficient */
1381/*
1382 Here we have a composite term. It can match provided it
1383 matches the entire argument. This argument must be a
1384 single term also and the coefficients should match
1385 (more or less).
1386 The matching takes:
1387 1: Match the functions etc. Nothing can be left.
1388 2: Match dotproducts and symbols. ONLY must match
1389 and nothing may be left.
1390 For safety it is best to take the term out and put it
1391 in workspace.
1392*/
1393
1394 if ( argtstop > ttrmstop ) goto endofloop;
1395 m--;
1396 oterstart = AN.terstart;
1397 oterstop = AN.terstop;
1398 opatstop = AN.patstop;
1399 oRepFunList = AN.RepFunList;
1400 oRepFunNum = AN.RepFunNum;
1401 AN.RepFunNum = 0;
1402 AN.RepFunList = AT.WorkPointer;
1403 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
1404 if ( AT.WorkPointer+*t+5 > AT.WorkTop ) {
1405 MLOCK(ErrorMessageLock);
1406 MesWork();
1407 MUNLOCK(ErrorMessageLock);
1408 return(-1);
1409 }
1410 csav = cto = AT.WorkPointer;
1411 cfrom = t;
1412 ci = *t;
1413 while ( --ci >= 0 ) *cto++ = *cfrom++;
1414 AT.WorkPointer = cto;
1415 ci = msizcoef;
1416 cfrom = mtrmstop;
1417 --ci;
1418 if ( abs(*--cfrom) != abs(*--cto) ) {
1419 AT.WorkPointer = csav;
1420 AN.RepFunList = oRepFunList;
1421 AN.RepFunNum = oRepFunNum;
1422 AN.terstart = oterstart;
1423 AN.terstop = oterstop;
1424 AN.patstop = opatstop;
1425 goto endofloop;
1426 }
1427 i = (*cfrom != *cto) ? 1 : 0; /* buffer AN.ExpectedSign until we are beyond the goto */
1428 while ( --ci >= 0 ) {
1429 if ( *--cfrom != *--cto ) {
1430 AT.WorkPointer = csav;
1431 AN.RepFunList = oRepFunList;
1432 AN.RepFunNum = oRepFunNum;
1433 AN.terstart = oterstart;
1434 AN.terstop = oterstop;
1435 AN.patstop = opatstop;
1436 goto endofloop;
1437 }
1438 }
1439 oExpectedSign = AN.ExpectedSign; /* buffer AN.ExpectedSign until we are beyond FindRest/FindOnly */
1440 AN.ExpectedSign = i;
1441 *m -= msizcoef;
1442 wildargs = AN.WildArgs;
1443 wildeat = AN.WildEat;
1444 for ( i = 0; i < wildargs; i++ ) wildargtaken[i] = AT.WildArgTaken[i];
1445 AN.ForFindOnly = 0; AN.UseFindOnly = 1;
1446 AN.nogroundlevel++;
1447 if ( FindRest(BHEAD csav,m) && ( AN.UsedOtherFind || FindOnly(BHEAD csav,m) ) ) {}
1448 else {
1449nomatch:
1450 *m += msizcoef;
1451 AT.WorkPointer = csav;
1452 AN.RepFunList = oRepFunList;
1453 AN.RepFunNum = oRepFunNum;
1454 AN.terstart = oterstart;
1455 AN.terstop = oterstop;
1456 AN.patstop = opatstop;
1457 AN.WildArgs = wildargs;
1458 AN.WildEat = wildeat;
1459 AN.ExpectedSign = oExpectedSign;
1460 AN.nogroundlevel--;
1461 for ( i = 0; i < wildargs; i++ ) AT.WildArgTaken[i] = wildargtaken[i];
1462 goto endofloop;
1463 }
1464/* if ( *m == 1 || m[1] < FUNCTION || functions[m[1]-FUNCTION].spec >= TENSORFUNCTION ) { */
1465 if ( *m == 1 || m[1] < FUNCTION ) {
1466 if ( AN.ExpectedSign ) goto nomatch;
1467 }
1468 else {
1469 if ( m[1] > FUNCTION + WILDOFFSET ) {
1470 if ( functions[m[1]-FUNCTION-WILDOFFSET].spec >= TENSORFUNCTION ) {
1471 if ( AN.ExpectedSign != AN.RepFunList[AN.RepFunNum-1] ) goto nomatch;
1472 }
1473 }
1474 else {
1475 if ( AN.ExpectedSign != AN.RepFunList[AN.RepFunNum-1] ) goto nomatch;
1476/*
1477 if ( functions[m[1]-FUNCTION].spec >= TENSORFUNCTION ) {
1478 if ( AN.ExpectedSign != AN.RepFunList[AN.RepFunNum-1] ) goto nomatch;
1479 }
1480*/
1481 }
1482 }
1483 AN.nogroundlevel--;
1484 AN.ExpectedSign = oExpectedSign;
1485 AN.WildArgs = wildargs;
1486 AN.WildEat = wildeat;
1487 for ( i = 0; i < wildargs; i++ ) AT.WildArgTaken[i] = wildargtaken[i];
1488 Substitute(BHEAD csav,m,1);
1489 cto = csav;
1490 cfrom = cto + *cto - msizcoef;
1491 cto++;
1492 *m += msizcoef;
1493 AT.WorkPointer = csav;
1494 AN.RepFunList = oRepFunList;
1495 AN.RepFunNum = oRepFunNum;
1496 AN.terstart = oterstart;
1497 AN.terstop = oterstop;
1498 AN.patstop = opatstop;
1499 if ( *cto != SUBEXPRESSION ) goto endofloop;
1500 cto += cto[1];
1501 if ( cto < cfrom ) goto endofloop;
1502 }
1503 }
1504 else goto endofloop;
1505
1506 t = argtstop; /* Next argument */
1507 m = argmstop;
1508 }
1509 if ( AN.SignCheck && AN.ExpectedSign ) goto endofloop;
1510 AT.WorkPointer = OldWork;
1511 if ( AN.WildArgs > 1 ) *wilds = 1;
1512 if ( AN.SignCheck && AN.ExpectedSign ) return(0);
1513 return(1); /* m was eaten. we have a match! */
1514
1515endofloop:;
1516/*
1517 restore the current Wildcard assignments
1518*/
1519 i = nwstore;
1520 if ( i > 0 ) {
1521 m = AN.WildValue;
1522 t = OldWork + ntwa; r = AT.WildMask;
1523 do {
1524 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1525 } while ( --i > 0 );
1526 C->numrhs = *t++;
1527 C->Pointer = C->Buffer + oldcpointer;
1528 }
1529
1530endoloop:;
1531 i = AN.WildArgs-1;
1532 if ( i <= 0 ) {
1533 AT.WorkPointer = OldWork;
1534 return(0);
1535 }
1536 while ( --i >= 0 ) {
1537 if ( AT.WildArgTaken[i] == 0 ) {
1538 if ( i == 0 ) {
1539 AT.WorkPointer = OldWork;
1540 return(0);
1541 }
1542 }
1543 else {
1544 (AT.WildArgTaken[i])--;
1545 numofwildarg = 0;
1546 for ( j = 0; j <= i; j++ ) {
1547 numofwildarg += AT.WildArgTaken[j];
1548 }
1549 AT.WildArgTaken[j] = AN.WildEat-numofwildarg;
1550/* ----> bug to be replaced in other source code */
1551 for ( j++; j < AN.WildArgs; j++ ) AT.WildArgTaken[j] = 0;
1552 break;
1553 }
1554 }
1555 goto topofloop;
1556NoCaseB:
1557/*
1558 Restore the old Wildcard assignments
1559*/
1560 i = nwstore;
1561 if ( i > 0 ) {
1562 m = AN.WildValue;
1563 t = OldWork + ntwa; r = AT.WildMask;
1564 do {
1565 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1566 } while ( --i > 0 );
1567 C->numrhs = *t++;
1568 C->Pointer = C->Buffer + oldcpointer;
1569 }
1570 AT.WorkPointer = OldWork;
1571 return(0); /* no match */
1572}
1573
1574/*
1575 #] MatchFunction :
1576 #[ ScanFunctions : WORD ScanFunctions(inpat,inter,par)
1577
1578 Finds in which functions to look for a match.
1579 inpat is the start of the pattern still to be matched.
1580 inter is the start of the term still to be matched.
1581 par gives information about commutativity.
1582 par = 0: nothing special
1583 par = 1: regular noncommuting function
1584 par = 2: GAMMA function
1585
1586 AN.patstop: end of the functions field in the search pattern
1587 AN.terstop: end of the functions field in the target pattern
1588 AN.terstart: address of entire term;
1589
1590 The actual matching of the functions and their arguments is done
1591 in a number of different routines. Mainly MatchFunction when there
1592 are no symmetry properties.
1593 Also: MatchE
1594 MatchCy
1595 FunMatchSy
1596 FunMatchCy
1597
1598 The main problem here is backtracking, ie continuing with wildcard
1599 possibilities when a first assignment doesn't work.
1600 Important note: this was completely forgotten in the symmetric
1601 functions till 6-jan-2009. As of the moment this still has to
1602 be fixed. ??????21-mar-2023????? Is this still unfixed?????
1603
1604 Functions inside functions can cause problems when antisymmetric
1605 functions are involved. The sign of the term may be at stake.
1606 At the lowest level this is no problem but in f(-fas(n2,n1)) this
1607 plays a role. Next is when we have a product of functions inside
1608 an argument. The strategy must be that we test the sign only at the
1609 last function. Hence, when inpat+inpat[1] >= AN.patstop.
1610 We might relax that to the last antisymmetric function at a later stage.
1611
1612 New scheme to be implemented for non-commuting objects:
1613 When we are matching a second (or higher) function, any match can only
1614 be directly after the last matched non-commuting function or a commuting
1615 function. This will take care of whatever happens in MatchE etc.
1616*/
1617
1618int ScanFunctions(PHEAD WORD *inpat, WORD *inter, WORD par)
1619{
1620 GETBIDENTITY
1621 WORD i, *m, *t, *r, sym, psym;
1622 WORD *newpat, *newter, *instart, *oinpat = 0, *ointer = 0;
1623 WORD nwstore, offset, *OldWork, SetStop = 0, oRepFunNum = AN.RepFunNum;
1624 WORD wilds, wildargs = 0, wildeat = 0, *wildargtaken;
1625 WORD *Oterfirstcomm = AN.terfirstcomm;
1626 CBUF *C = cbuf+AT.ebufnum;
1627 int ntwa = AN.NumTotWildArgs;
1628 LONG oldcpointer = C->Pointer - C->Buffer;
1629 WORD oldSignCheck = AN.SignCheck;
1630 instart = inter;
1631/*
1632 Only active for the last function in the pattern.
1633 The actual test on the sign is in MatchFunction or the symmetric functions
1634*/
1635 if ( AN.nogroundlevel ) {
1636 AN.SignCheck = ( inpat + inpat[1] >= AN.patstop ) ? 1 : 0;
1637 }
1638 else {
1639 AN.SignCheck = 0;
1640 }
1641/*
1642 Store the current Wildcard assignments
1643*/
1644 t = wildargtaken = OldWork = AT.WorkPointer;
1645 t += ntwa;
1646 m = AN.WildValue;
1647 nwstore = i = (m[-SUBEXPSIZE+1]-SUBEXPSIZE)/4;
1648 if ( i > 0 ) {
1649 r = AT.WildMask;
1650 do {
1651 *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *r++;
1652 } while ( --i > 0 );
1653 *t++ = C->numrhs;
1654 }
1655 if ( t >= AT.WorkTop ) {
1656 MLOCK(ErrorMessageLock);
1657 MesWork();
1658 MUNLOCK(ErrorMessageLock);
1659 Terminate(-1);
1660 }
1661 AT.WorkPointer = t;
1662 do {
1663#ifndef NEWCOMMUTE
1664/*
1665 Find an eligible unsubstituted function
1666*/
1667 if ( AN.RepFunNum > 0 ) {
1668/*
1669 First try a non-commuting function, just after the last
1670 substituted non-commuting function.
1671*/
1672 if ( *inter >= FUNCTION && functions[*inter-FUNCTION].commute ) {
1673 do {
1674 offset = WORDDIF(inter,AN.terstart);
1675 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1676 if ( AN.RepFunList[i] >= offset ) break;
1677 }
1678 if ( i >= AN.RepFunNum ) break;
1679 inter += inter[1];
1680 } while ( inter < AN.terfirstcomm );
1681 if ( inter < AN.terfirstcomm ) { /* Check that it is directly after */
1682 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1683 if ( functions[AN.terstart[AN.RepFunList[i]]-FUNCTION].commute
1684 && AN.RepFunList[i]+AN.terstart[AN.RepFunList[i]+1] == offset ) break;
1685 }
1686 if ( i < AN.RepFunNum ) goto trythis;
1687 }
1688 inter = AN.terfirstcomm;
1689 }
1690/*
1691 Now try one of the commuting functions
1692*/
1693 while ( inter < AN.terstop ) {
1694 offset = WORDDIF(inter,AN.terstart);
1695 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1696 if ( AN.RepFunList[i] == offset ) break;
1697 }
1698 if ( i >= AN.RepFunNum ) break;
1699 inter += inter[1];
1700 }
1701 if ( inter >= AN.terstop ) goto Failure;
1702trythis:;
1703 }
1704 else {
1705/*
1706 The first function can be anywhere. We have no problems.
1707*/
1708 offset = WORDDIF(inter,AN.terstart);
1709 }
1710#else
1711 /* first find an unsubstituted function */
1712 do {
1713 offset = WORDDIF(inter,AN.terstart);
1714 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1715 if ( AN.RepFunList[i] == offset ) break;
1716 }
1717 if ( i >= AN.RepFunNum ) break;
1718 inter += inter[1];
1719 } while ( inter < AN.terstop );
1720 if ( inter >= AN.terstop ) goto Failure;
1721#endif
1722 wilds = 0;
1723 /* We found one */
1724 if ( *inter >= FUNCTION && *inpat >= FUNCTION ) {
1725 if ( *inpat == *inter || *inpat >= FUNCTION + WILDOFFSET ) {
1726/*
1727 if ( inter[1] == FUNHEAD ) goto rewild;
1728*/
1729 if ( functions[*inter-FUNCTION].spec >= TENSORFUNCTION
1730 && ( *inter == *inpat ||
1731 functions[*inpat-FUNCTION-WILDOFFSET].spec >= TENSORFUNCTION ) ) {
1732 sym = functions[*inter-FUNCTION].symmetric & ~REVERSEORDER;
1733 if ( *inpat == *inter ) psym = sym;
1734 else psym = functions[*inpat-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER;
1735 if ( sym == ANTISYMMETRIC || sym == SYMMETRIC
1736 || psym == SYMMETRIC || psym == ANTISYMMETRIC ) {
1737 if ( sym == ANTISYMMETRIC && psym == SYMMETRIC ) goto rewild;
1738 if ( sym == SYMMETRIC && psym == ANTISYMMETRIC ) goto rewild;
1739/*
1740 Special function call for (anti)symmetric tensors
1741*/
1742 if ( MatchE(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1743 }
1744 else if ( sym == CYCLESYMMETRIC || sym == RCYCLESYMMETRIC
1745 || psym == CYCLESYMMETRIC || psym == RCYCLESYMMETRIC ) {
1746/*
1747 Special function call for (r)cyclic tensors
1748*/
1749 if ( MatchCy(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1750 }
1751 else goto rewild;
1752 }
1753 else if ( functions[*inter-FUNCTION].spec <= 0
1754 && ( *inter == *inpat ||
1755 functions[*inpat-FUNCTION-WILDOFFSET].spec <= 0 ) ) {
1756 sym = functions[*inter-FUNCTION].symmetric & ~REVERSEORDER;
1757 if ( *inpat == *inter ) psym = sym;
1758 else psym = functions[*inpat-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER;
1759 if ( psym == SYMMETRIC || sym == SYMMETRIC
1760/*
1761 The next statement was commented out. Why????
1762 Werkt nog niet. Teken wordt nog niet bijgehouden.
1763 5-nov-2001
1764*/
1765 || psym == ANTISYMMETRIC || sym == ANTISYMMETRIC
1766 ) {
1767 if ( sym == ANTISYMMETRIC && psym == SYMMETRIC ) goto rewild;
1768 if ( sym == SYMMETRIC && psym == ANTISYMMETRIC ) goto rewild;
1769 if ( FunMatchSy(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1770 }
1771 else
1772 if ( sym == CYCLESYMMETRIC || sym == RCYCLESYMMETRIC
1773 || psym == CYCLESYMMETRIC || psym == RCYCLESYMMETRIC ) {
1774 if ( FunMatchCy(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1775 }
1776 else goto rewild;
1777 }
1778 else goto rewild;
1779 AN.terfirstcomm = Oterfirstcomm;
1780 }
1781 else if ( par > 0 ) { SetStop = 1; goto maybenext; }
1782 }
1783 else {
1784rewild:
1785 AN.terfirstcomm = Oterfirstcomm;
1786 if ( *inter != SUBEXPRESSION && MatchFunction(BHEAD inpat,inter,&wilds) ) {
1787 AN.terfirstcomm = Oterfirstcomm;
1788 if ( wilds ) {
1789/*
1790 Store wildcards to continue in MatchFunction if the current
1791 wildcards do not work out.
1792*/
1793 wildargs = AN.WildArgs;
1794 wildeat = AN.WildEat;
1795 for ( i = 0; i < wildargs; i++ ) wildargtaken[i] = AT.WildArgTaken[i];
1796 oinpat = inpat; ointer = inter;
1797 }
1798 if ( par && *inter == GAMMA && AN.RepFunList[AN.RepFunNum+1] ) {
1799 SetStop = 1; goto NoMat;
1800 }
1801 if ( par == 2 ) {
1802 if ( *inter < FUNCTION || functions[*inter-FUNCTION].commute ) {
1803 goto NoMat;
1804 }
1805 par = 1;
1806 }
1807 AN.RepFunList[AN.RepFunNum] = offset;
1808 AN.RepFunNum += 2;
1809 newpat = inpat + inpat[1];
1810 if ( newpat >= AN.patstop ) {
1811 if ( AN.UseFindOnly == 0 ) {
1812 if ( FindOnce(BHEAD AN.findTerm,AN.findPattern) ) {
1813 AN.UsedOtherFind = 1;
1814 goto OnSuccess;
1815 }
1816 AN.RepFunNum -= 2;
1817 goto NoMat;
1818 }
1819 goto OnSuccess;
1820 }
1821 if ( *inter < FUNCTION || functions[*inter-FUNCTION].commute ) {
1822 newter = inter + inter[1];
1823 if ( newter >= AN.terstop ) goto Failure;
1824 if ( *inter == GAMMA && inpat[1] <
1825 inter[1] - AN.RepFunList[AN.RepFunNum-1] ) {
1826 if ( ScanFunctions(BHEAD newpat,newter,2) ) goto OnSuccess;
1827 AN.terfirstcomm = Oterfirstcomm;
1828 }
1829 else if ( *newter == SUBEXPRESSION ) {}
1830 else if ( functions[*inter-FUNCTION].commute ) {
1831 if ( ScanFunctions(BHEAD newpat,newter,1) ) goto OnSuccess;
1832 AN.terfirstcomm = Oterfirstcomm;
1833 if ( ( *newpat < (FUNCTION+WILDOFFSET)
1834 && ( functions[*newpat-FUNCTION].commute == 0 ) ) ||
1835 ( *newpat >= (FUNCTION+WILDOFFSET)
1836 && ( functions[*newpat-FUNCTION-WILDOFFSET].commute == 0 ) ) ) {
1837 newter = AN.terfirstcomm;
1838 if ( newter < AN.terstop && ScanFunctions(BHEAD newpat,newter,1) ) goto OnSuccess;
1839 }
1840 }
1841 else {
1842 if ( ScanFunctions(BHEAD newpat,instart,1) ) goto OnSuccess;
1843 AN.terfirstcomm = Oterfirstcomm;
1844 }
1845 SetStop = par;
1846 }
1847 else {
1848/*
1849 Shouldn't this be newpat instead of inpat?????
1850*/
1851 if ( par && inter > instart && ( ( *newpat < (FUNCTION+WILDOFFSET)
1852 && functions[*newpat-FUNCTION].commute ) ||
1853 ( *newpat >= (FUNCTION+WILDOFFSET)
1854 && functions[*newpat-FUNCTION-WILDOFFSET].commute ) ) ) {
1855 SetStop = 1;
1856 }
1857 else {
1858 newter = instart;
1859 if ( ScanFunctions(BHEAD newpat,newter,par) ) goto OnSuccess;
1860 AN.terfirstcomm = Oterfirstcomm;
1861 }
1862 }
1863/*
1864 Restore the old Wildcard assignments
1865*/
1866NoMat:
1867 i = nwstore;
1868 if ( i > 0 ) {
1869 m = AN.WildValue;
1870 t = OldWork + ntwa; r = AT.WildMask;
1871 do {
1872 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1873 } while ( --i > 0 );
1874 C->numrhs = *t++;
1875 C->Pointer = C->Buffer + oldcpointer;
1876 }
1877/* AN.RepFunNum -= 2; */
1878 AN.RepFunNum = oRepFunNum;
1879 if ( wilds ) {
1880 inter = ointer; inpat = oinpat;
1881 AN.WildArgs = wildargs;
1882 AN.WildEat = wildeat;
1883 for ( i = 0; i < wildargs; i++ ) AT.WildArgTaken[i] = wildargtaken[i];
1884 goto rewild;
1885 }
1886 if ( SetStop ) break;
1887 }
1888 else if ( par ) {
1889maybenext:
1890 if ( *inpat < (FUNCTION+WILDOFFSET) ) {
1891 if ( *inpat < FUNCTION ||
1892 functions[*inpat-FUNCTION].commute ) break;
1893 }
1894 else {
1895 if ( functions[*inpat-FUNCTION-WILDOFFSET].commute ) break;
1896 }
1897 }}
1898 inter += inter[1];
1899 } while ( inter < AN.terstop );
1900Failure:
1901 AN.SignCheck = oldSignCheck;
1902 AT.WorkPointer = OldWork;
1903 return(0);
1904OnSuccess:
1905 if ( AT.idallflag && AN.nogroundlevel <= 0 ) {
1906 if ( AT.idallmaxnum > 0 && AT.idallnum >= AT.idallmaxnum ) {
1907 AN.terfirstcomm = Oterfirstcomm;
1908 AN.SignCheck = oldSignCheck;
1909 AT.WorkPointer = OldWork;
1910 return(0);
1911 }
1912 SubsInAll(BHEAD0);
1913 AT.idallnum++;
1914 if ( AT.idallmaxnum == 0 || AT.idallnum < AT.idallmaxnum ) goto NoMat;
1915 }
1916 AN.terfirstcomm = Oterfirstcomm;
1917 AN.SignCheck = oldSignCheck;
1918/*
1919 Now the disorder test
1920*/
1921 if ( AN.DisOrderFlag && AN.RepFunNum >= 4 ) {
1922 WORD k, kk;
1923 for ( i = 2; i < AN.RepFunNum; i += 2 ) {
1924/*
1925------------> We still have to copy the code from Normalize wrt properorderflag
1926*/
1927 m = AN.terstart + AN.RepFunList[i-2];
1928 t = AN.terstart + AN.RepFunList[i];
1929 if ( *m != *t ) {
1930 if ( *m > *t ) continue;
1931 goto doesmatch;
1932 }
1933 if ( *m >= FUNCTION && functions[*m-FUNCTION].spec >=
1934 TENSORFUNCTION ) {
1935 k = m[1] - FUNHEAD;
1936 kk = t[1] - FUNHEAD;
1937 m += FUNHEAD;
1938 t += FUNHEAD;
1939 }
1940 else {
1941 k = m[1] - FUNHEAD;
1942 kk = t[1] - FUNHEAD;
1943 m += FUNHEAD;
1944 t += FUNHEAD;
1945 }
1946 while ( k > 0 && kk > 0 ) {
1947 if ( *m < *t ) goto NextFor;
1948 else if ( *m++ > *t++ ) goto doesmatch;
1949 k--; kk--;
1950 }
1951 if ( k > 0 ) goto doesmatch;
1952NextFor:;
1953 }
1954 SetStop = 1;
1955 goto NoMat;
1956 }
1957doesmatch:
1958 AT.WorkPointer = OldWork;
1959 return(1);
1960}
1961
1962/*
1963 #] ScanFunctions :
1964 #] Patterns :
1965*/
Generator
int Generator(PHEAD WORD *, WORD)
Definition proces.c:3249
CbUf::Buffer
WORD * Buffer
Definition structs.h:971
CbUf::Pointer
WORD * Pointer
Definition structs.h:973
Generated by doxygen 1.9.8