FORM 4.3
function.c
Go to the documentation of this file.
1
8/* #[ License : */
9/*
10 * Copyright (C) 1984-2022 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
51WORD 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
373WORD 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
518WORD 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
633WORD 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;
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 while ( t < tend && *t == funnum ) {
718 ts = t + t[1];
719 t += FUNHEAD;
720 while ( t < ts ) *tt++ = *t++;
721 }
722 m[1] = tt - m;
723 ts = term + *term;
724 while ( t < ts ) *tt++ = *t++;
725 *term = tt - term;
726 break;
727 }
728 } while ( action );
729 return(0);
730}
731
732/*
733 #] ChainIn :
734 #[ ChainOut :
735
736 Equivalent to repeat id f(x1?,x2?,?a) = f(x1)*f(x2,?a);
737*/
738
739int ChainOut(PHEAD WORD *term, WORD funnum)
740{
741 GETBIDENTITY
742 WORD *t, *tend, *tt, *ts, *w, *ws;
743 int flag = 0, i;
744 if ( funnum < 0 ) { /* Dollar to be expanded */
745 funnum = DolToFunction(BHEAD -funnum);
746 if ( AN.ErrorInDollar || funnum <= 0 ) {
747 MLOCK(ErrorMessageLock);
748 MesPrint("Dollar variable does not evaluate to function in ChainOut statement");
749 MUNLOCK(ErrorMessageLock);
750 return(-1);
751 }
752 }
753 tend = term+*term;
754 if ( AT.WorkPointer < tend ) AT.WorkPointer = tend;
755 tend -= ABS(tend[-1]);
756 t = term+1; tt = term; w = AT.WorkPointer;
757 while ( t < tend ) {
758 if ( *t != funnum || t[1] == FUNHEAD ) { t += t[1]; continue; }
759 flag = 1;
760 while ( tt < t ) *w++ = *tt++;
761 ts = t + t[1];
762 t += FUNHEAD;
763 while ( t < ts ) {
764 ws = w;
765 for ( i = 0; i < FUNHEAD; i++ ) *w++ = tt[i];
766 if ( functions[*tt-FUNCTION].spec >= TENSORFUNCTION ) {
767 *w++ = *t++;
768 }
769 else if ( *t < 0 ) {
770 if ( *t <= -FUNCTION ) *w++ = *t++;
771 else { *w++ = *t++; *w++ = *t++; }
772 }
773 else {
774 i = *t; NCOPY(w,t,i);
775 }
776 ws[1] = w - ws;
777 }
778 tt = t;
779 }
780 if ( flag == 1 ) {
781 ts = term + *term;
782 while ( tt < ts ) *w++ = *tt++;
783 *AT.WorkPointer = w - AT.WorkPointer;
784 t = term; w = AT.WorkPointer; i = *w;
785 NCOPY(t,w,i)
786 AT.WorkPointer = term + *term;
787 Normalize(BHEAD term);
788 }
789 return(0);
790}
791
792/*
793 #] ChainOut :
794 #] Utilities :
795 #[ Patterns :
796 #[ MatchFunction : WORD MatchFunction(pattern,interm,wilds)
797
798 The routine assumes that the function numbers are the same.
799 The contents are compared and a possible wildcard assignment
800 is made. Note that it may be necessary to use a wildcard
801 assignment stack to do things right.
802 The routine can become arbitrarily complicated as there is
803 no end to the possible wildcarding.
804 Examples:
805 - a: No wildcarding -> straight match
806 - b: Individual arguments (object -> object)
807 - c: whole arguments (object to subexpression)
808 - d: any argumentlist
809 e: part of an argument (object inside subexpression)
810
811 The ones with a minus sign in front have been implemented.
812
813 Note: the argument wilds allows backtracking when multiple
814 ?a,?b give a match that later turns out to be useless.
815*/
816
817WORD MatchFunction(PHEAD WORD *pattern, WORD *interm, WORD *wilds)
818{
819 GETBIDENTITY
820 WORD *m, *t, *r, i;
821 WORD *mstop = 0, *tstop = 0;
822 WORD *argmstop, *argtstop;
823 WORD *mtrmstop, *ttrmstop;
824 WORD *msubstop, *mnextsub;
825 WORD msizcoef, mcount, tcount, newvalue, j;
826 WORD *oldm, *oldt;
827 WORD *OldWork, numofwildarg;
828 WORD nwstore, tobeeaten, reservevalue = 0, resernum = 0, withwild;
829 WORD *wildargtaken;
830 CBUF *C = cbuf+AT.ebufnum;
831 int ntwa = AN.NumTotWildArgs;
832 LONG oldcpointer = C->Pointer - C->Buffer;
833/*
834 Test first for a straight match
835*/
836 AN.RepFunList[AN.RepFunNum+1] = 0;
837 if ( *wilds == 0 ) {
838 m = pattern; t = interm;
839
840 if ( *m != *t ) {
841 if ( *m < (FUNCTION + WILDOFFSET) ) return(0);
842 if ( *t < FUNCTION ) return(0);
843 if ( functions[*t-FUNCTION].spec !=
844 functions[*m-FUNCTION-WILDOFFSET].spec ) return(0);
845 }
846 i = m[1];
847 if ( *m >= (FUNCTION + WILDOFFSET) ) { i--; m++; t++; }
848 do { if ( *m++ != *t++ ) break; } while ( --i > 0 );
849 if ( i <= 0 ) { /* Arguments match */
850 if ( AN.SignCheck && AN.ExpectedSign ) return(0);
851 i = *pattern - WILDOFFSET;
852 if ( i >= FUNCTION ) {
853 if ( *interm != GAMMA
854 && !CheckWild(BHEAD i,FUNTOFUN,*interm,&newvalue) ) {
855 AddWild(BHEAD i,FUNTOFUN,newvalue);
856 return(1);
857 }
858 return(0);
859 }
860 else return(1);
861 }
862 }
863/*
864 Store the current Wildcard assignments
865*/
866 t = wildargtaken = OldWork = AT.WorkPointer;
867 t += ntwa;
868 m = AN.WildValue;
869 nwstore = i = (m[-SUBEXPSIZE+1]-SUBEXPSIZE)/4;
870 if ( i > 0 ) {
871 r = AT.WildMask;
872 do {
873 *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *r++;
874 } while ( --i > 0 );
875 *t++ = C->numrhs;
876 }
877 if ( t >= AT.WorkTop ) {
878 MLOCK(ErrorMessageLock);
879 MesWork();
880 MUNLOCK(ErrorMessageLock);
881 Terminate(-1);
882 }
883 AT.WorkPointer = t;
884
885 if ( *wilds ) {
886 if ( *wilds == 1 ) goto endoloop;
887 else goto enloop; /* tensors = 2 */
888 }
889 m = pattern; t = interm;
890/*
891 Single out the specials
892*/
893 if ( *t == GAMMA ) {
894/*
895 #[ GAMMA :
896
897 For the gamma's we need to do two things:
898 a: Find that there is a match
899 b: Find where the match occurs in the string
900 This last thing cannot be stored in the current conventions,
901 but once the wildcard assignments have been made it is much
902 easier to find it back.
903 Alternative: replace the function number in the term temporarily
904 by the offset inside the string. This makes things maybe easier.
905*/
906 if ( *m != GAMMA ) goto NoCaseB;
907 i = t[1] - m[1];
908 if ( m[1] == FUNHEAD+1 ) {
909 if ( i ) goto NoCaseB;
910 if ( m[FUNHEAD] < (AM.OffsetIndex+WILDOFFSET) ||
911 t[FUNHEAD] >= (AM.OffsetIndex+WILDOFFSET) ) goto NoCaseB;
912
913 if ( CheckWild(BHEAD m[FUNHEAD]-WILDOFFSET,INDTOIND,t[FUNHEAD],&newvalue) ) goto NoCaseB;
914 AddWild(BHEAD m[FUNHEAD]-WILDOFFSET,INDTOIND,newvalue);
915
916 AT.WorkPointer = OldWork;
917 if ( AN.SignCheck && AN.ExpectedSign ) return(0);
918 return(1); /* m was eaten. we have a match! */
919 }
920 if ( i < 0 ) goto NoCaseB; /* Pattern longer than target */
921 mstop = m + m[1];
922 tstop = t + t[1];
923 m += FUNHEAD; t += FUNHEAD;
924 if ( *m >= (AM.OffsetIndex+WILDOFFSET) && *t < (AM.OffsetIndex+WILDOFFSET) ) {
925 if ( CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*t,&newvalue) ) goto NoCaseB;
926 reservevalue = newvalue;
927 withwild = 1;
928 resernum = *m-WILDOFFSET;
929 AddWild(BHEAD *m-WILDOFFSET,INDTOIND,newvalue);
930 }
931 else if ( *m != *t ) goto NoCaseB;
932 else withwild = 0;
933 m++; t++;
934 oldm = m; argtstop = oldt = t;
935 j = 0; /* No wildcard assignments yet */
936 while ( i >= 0 ) {
937 if ( *m == *t ) {
938WithGamma: m++; t++;
939 if ( m >= mstop ) {
940 if ( t < tstop && mstop < AN.patstop ) {
941 WORD k;
942 mnextsub = pattern + pattern[1];
943 k = *mnextsub;
944 while ( k == GAMMA && mnextsub[FUNHEAD]
945 != pattern[FUNHEAD] ) {
946 mnextsub += mnextsub[1];
947 if ( mnextsub >= AN.patstop ) goto FullOK;
948 k = *mnextsub;
949 }
950 if ( k >= FUNCTION ) {
951 if ( k > (FUNCTION + WILDOFFSET) ) k -= WILDOFFSET;
952 if ( functions[k-FUNCTION].commute ) goto NoGamma;
953 }
954 }
955FullOK: if ( AN.SignCheck && AN.ExpectedSign ) goto NoGamma;
956 AN.RepFunList[AN.RepFunNum+1] = WORDDIF(oldt,argtstop);
957 return(1);
958 }
959 if ( t >= tstop ) goto NoCaseB;
960 }
961 else if ( *m >= (AM.OffsetIndex+WILDOFFSET)
962 && *m < (AM.OffsetIndex + (WILDOFFSET<<1)) && ( *t >= 0 ||
963 *t < MINSPEC ) ) { /* Wildcard index */
964 if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*t,&newvalue) ) {
965 AddWild(BHEAD *m-WILDOFFSET,INDTOIND,newvalue);
966 j = 1;
967 goto WithGamma;
968 }
969 else goto NoGamma;
970 }
971 else if ( *m < MINSPEC && *m >= (AM.OffsetVector+WILDOFFSET)
972 && *t < MINSPEC ) { /* Wildcard vecor */
973 if ( !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*t,&newvalue) ) {
974 AddWild(BHEAD *m-WILDOFFSET,VECTOVEC,newvalue);
975 j = 1;
976 goto WithGamma;
977 }
978 else goto NoGamma;
979 }
980 else {
981NoGamma:
982 if ( j ) { /* Undo wildcards */
983 m = AN.WildValue;
984 t = OldWork + AN.NumTotWildArgs; r = AT.WildMask; j = nwstore;
985 if ( j > 0 ) {
986 do {
987 *m++ = *t++; *m++ = *t++;
988 *m++ = *t++; *m++ = *t++; *r++ = *t++;
989 } while ( --j > 0 );
990 C->numrhs = *t++;
991 C->Pointer = C->Buffer + oldcpointer;
992 }
993 j = 0;
994 }
995 m = oldm; t = ++oldt; i--;
996 if ( withwild ) {
997 AddWild(BHEAD resernum,INDTOIND,reservevalue);
998 }
999 }
1000 }
1001 goto NoCaseB;
1002/*
1003 #] GAMMA :
1004 #[ Tensors :
1005*/
1006 }
1007 else if ( *t >= FUNCTION && functions[*t-FUNCTION].spec >= TENSORFUNCTION ) {
1008 mstop = m + m[1];
1009 tstop = t + t[1];
1010 mcount = 0;
1011 m += FUNHEAD;
1012 t += FUNHEAD;
1013 AN.WildArgs = 0;
1014 tcount = WORDDIF(tstop,t);
1015 while ( m < mstop ) {
1016 if ( *m == FUNNYWILD ) { m++; AN.WildArgs++; }
1017 m++; mcount++;
1018 }
1019 tobeeaten = tcount - mcount + AN.WildArgs;
1020 if ( tobeeaten ) {
1021 if ( tobeeaten < 0 || AN.WildArgs == 0 ) {
1022 AT.WorkPointer = OldWork;
1023 return(0); /* Cannot match */
1024 }
1025 }
1026 AT.WildArgTaken[0] = AN.WildEat = tobeeaten;
1027 for ( i = 1; i < AN.WildArgs; i++ ) AT.WildArgTaken[i] = 0;
1028toploop:
1029 numofwildarg = 0;
1030
1031 m = pattern; t = interm;
1032 mstop = m + m[1];
1033 if ( *m != *t ) {
1034 i = *m - WILDOFFSET;
1035 if ( CheckWild(BHEAD i,FUNTOFUN,*t,&newvalue) ) goto NoCaseB;
1036 AddWild(BHEAD i,FUNTOFUN,newvalue);
1037 }
1038 m += FUNHEAD;
1039 t += FUNHEAD;
1040 while ( m < mstop ) {
1041/*
1042 First test for an exact match
1043*/
1044 if ( *m == *t ) { m++; t++; continue; }
1045/*
1046 No exact match. Try ARGWILD
1047*/
1048 AN.argaddress = t;
1049 if ( *m == FUNNYWILD ) {
1050 tobeeaten = AT.WildArgTaken[numofwildarg++];
1051 i = tobeeaten | EATTENSOR;
1052 if ( CheckWild(BHEAD m[1],ARGTOARG,i,t) ) goto endloop;
1053 AddWild(BHEAD m[1],ARGTOARG,i);
1054 m += 2;
1055 t += tobeeaten;
1056 continue;
1057 }
1058/*
1059 Now the various cases:
1060*/
1061 i = *m;
1062 if ( i < MINSPEC ) {
1063 if ( *t != i ) {
1064 if ( *t >= MINSPEC ) goto endloop;
1065 i -= WILDOFFSET;
1066 if ( i < AM.OffsetVector ) goto endloop;
1067 if ( CheckWild(BHEAD i,VECTOVEC,*t,&newvalue) )
1068 goto endloop;
1069 AddWild(BHEAD i,VECTOVEC,newvalue);
1070 }
1071 }
1072 else if ( i >= AM.OffsetIndex ) { /* Index */
1073 if ( i < ( AM.OffsetIndex + WILDOFFSET ) ) goto endloop;
1074 if ( i >= ( AM.OffsetIndex + (WILDOFFSET<<1) ) ) {
1075 /* Summed over index */
1076 goto endloop; /* For the moment */
1077 }
1078 i -= WILDOFFSET;
1079 if ( CheckWild(BHEAD i,INDTOIND,*t,&newvalue) )
1080 goto endloop; /* Assignment not allowed */
1081 AddWild(BHEAD i,INDTOIND,newvalue);
1082 }
1083 else goto endloop;
1084 m++; t++;
1085 }
1086 if ( AN.SignCheck && AN.ExpectedSign ) goto endloop;
1087 AT.WorkPointer = OldWork;
1088 if ( AN.WildArgs > 1 ) *wilds = 2;
1089 return(1); /* m was eaten. we have a match! */
1090
1091endloop:;
1092/*
1093 restore the current Wildcard assignments
1094*/
1095 i = nwstore;
1096 if ( i > 0 ) {
1097 m = AN.WildValue;
1098 t = OldWork + ntwa; r = AT.WildMask;
1099 do {
1100 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1101 } while ( --i > 0 );
1102 C->numrhs = *t++;
1103 C->Pointer = C->Buffer + oldcpointer;
1104 }
1105enloop:;
1106 i = AN.WildArgs - 1;
1107 if ( i <= 0 ) {
1108 AT.WorkPointer = OldWork;
1109 return(0);
1110 }
1111 while ( --i >= 0 ) {
1112 if ( AT.WildArgTaken[i] == 0 ) {
1113 if ( i == 0 ) {
1114 AT.WorkPointer = OldWork;
1115 *wilds = 0;
1116 return(0);
1117 }
1118 }
1119 else {
1120 (AT.WildArgTaken[i])--;
1121 numofwildarg = 0;
1122 for ( j = 0; j <= i; j++ ) {
1123 numofwildarg += AT.WildArgTaken[j];
1124 }
1125 AT.WildArgTaken[j] = AN.WildEat-numofwildarg;
1126 for ( j++; j < AN.WildArgs; j++ ) AT.WildArgTaken[j] = 0;
1127 break;
1128 }
1129 }
1130 goto toploop;
1131/*
1132 #] Tensors :
1133*/
1134 }
1135/*
1136 Count the number of arguments. Either equal or an argument wildcard.
1137*/
1138 mstop = m + m[1];
1139 tstop = t + t[1];
1140 mcount = 0; tcount = 0;
1141 m += FUNHEAD; t += FUNHEAD;
1142 while ( t < tstop ) { tcount++; NEXTARG(t) }
1143 AN.WildArgs = 0;
1144 while ( m < mstop ) {
1145 mcount++;
1146 if ( *m == -ARGWILD ) AN.WildArgs++;
1147 NEXTARG(m)
1148 }
1149 tobeeaten = tcount - mcount + AN.WildArgs;
1150 if ( tobeeaten ) {
1151 if ( tobeeaten < 0 || AN.WildArgs == 0 ) {
1152 AT.WorkPointer = OldWork;
1153 return(0); /* Cannot match */
1154 }
1155 }
1156/*
1157 Set up the array AT.WildArgTaken for the number of arguments that each
1158 wildarg eats.
1159*/
1160 AT.WildArgTaken[0] = AN.WildEat = tobeeaten;
1161 for ( i = 1; i < AN.WildArgs; i++ ) AT.WildArgTaken[i] = 0;
1162topofloop:
1163 numofwildarg = 0;
1164/*
1165 Test for single wildcard object/argument
1166*/
1167 m = pattern; t = interm;
1168 if ( *m != *t ) {
1169 i = *m - WILDOFFSET;
1170 if ( CheckWild(BHEAD i,FUNTOFUN,*t,&newvalue) ) goto NoCaseB;
1171 AddWild(BHEAD i,FUNTOFUN,newvalue);
1172 }
1173 mstop = m + m[1];
1174/* tstop = t + t[1]; */
1175 m += FUNHEAD;
1176 t += FUNHEAD;
1177 while ( m < mstop ) {
1178 argmstop = oldm = m;
1179 argtstop = oldt = t;
1180 NEXTARG(argmstop)
1181 NEXTARG(argtstop)
1182 if ( t == tstop ) { /* This concerns a very rare bug */
1183 if ( *m == -ARGWILD ) goto ArgAll;
1184 goto endofloop;
1185 }
1186 if ( *m < 0 && *t < 0 ) {
1187 if ( *t <= -FUNCTION ) {
1188 if ( *t == *m ) {}
1189 else if ( *m <= -FUNCTION-WILDOFFSET
1190 && functions[-*t-FUNCTION].spec
1191 == functions[-*m-FUNCTION-WILDOFFSET].spec ) {
1192 i = -*m - WILDOFFSET;
1193 if ( CheckWild(BHEAD i,FUNTOFUN,-*t,&newvalue) ) goto endofloop;
1194 AddWild(BHEAD i,FUNTOFUN,newvalue);
1195 }
1196 else if ( *m == -SYMBOL && m[1] >= 2*MAXPOWER ) {
1197 i = m[1] - 2*MAXPOWER;
1198 AN.argaddress = AT.FunArg;
1199 AT.FunArg[ARGHEAD+1] = -*t;
1200 if ( CheckWild(BHEAD i,SYMTOSUB,1,AN.argaddress) ) goto endofloop;
1201 AddWild(BHEAD i,SYMTOSUB,0);
1202 }
1203 else if ( *m == -ARGWILD ) {
1204ArgAll: i = AT.WildArgTaken[numofwildarg++];
1205 AN.argaddress = t;
1206 if ( CheckWild(BHEAD m[1],ARGTOARG,i,t) ) goto endofloop;
1207 AddWild(BHEAD m[1],ARGTOARG,i);
1208/* m += 2; */
1209 while ( --i >= 0 ) { NEXTARG(t) }
1210 argtstop = t;
1211 }
1212 else goto endofloop;
1213 }
1214 else if ( *t == *m ) {
1215 if ( t[1] == m[1] ) {}
1216 else if ( *t == -SYMBOL ) {
1217 j = SYMTOSYM;
1218SymAll:
1219 if ( ( i = m[1] - 2*MAXPOWER ) < 0 ) goto endofloop;
1220 if ( CheckWild(BHEAD i,j,t[1],&newvalue) ) goto endofloop;
1221 AddWild(BHEAD i,j,newvalue);
1222 }
1223 else if ( *t == -INDEX ) {
1224IndAll: i = m[1] - WILDOFFSET;
1225 if ( i < AM.OffsetIndex || i >= WILDOFFSET+AM.OffsetIndex )
1226 goto endofloop;
1227 /* We kill the summed over indices here */
1228 if ( CheckWild(BHEAD i,INDTOIND,t[1],&newvalue) ) goto endofloop;
1229 AddWild(BHEAD i,INDTOIND,newvalue);
1230 }
1231 else if ( *t == -VECTOR || *t == -MINVECTOR ) {
1232 i = m[1] - WILDOFFSET;
1233 if ( i < AM.OffsetVector ) goto endofloop;
1234 if ( CheckWild(BHEAD i,VECTOVEC,t[1],&newvalue) ) goto endofloop;
1235 AddWild(BHEAD i,VECTOVEC,newvalue);
1236 }
1237 else goto endofloop;
1238 }
1239 else if ( *m == -ARGWILD ) goto ArgAll;
1240 else if ( *m == -INDEX && m[1] >= AM.OffsetIndex+WILDOFFSET
1241 && m[1] < AM.OffsetIndex+(WILDOFFSET<<1) ) {
1242 if ( *t == -VECTOR ) goto IndAll;
1243 if ( *t == -SNUMBER && t[1] >= 0 && t[1] < AM.OffsetIndex ) goto IndAll;
1244 if ( *t == -MINVECTOR ) {
1245 i = m[1] - WILDOFFSET;
1246 AN.argaddress = AT.MinVecArg;
1247 AT.MinVecArg[ARGHEAD+3] = t[1];
1248 if ( CheckWild(BHEAD i,INDTOSUB,1,AN.argaddress) ) goto endofloop;
1249 AddWild(BHEAD i,INDTOSUB,(WORD)0);
1250 }
1251 else goto endofloop;
1252 }
1253 else if ( *m == -SYMBOL && m[1] >= 2*MAXPOWER && *t == -SNUMBER ) {
1254 j = SYMTONUM;
1255 goto SymAll;
1256 }
1257 else if ( *m == -VECTOR && *t == -MINVECTOR &&
1258 ( i = m[1] - WILDOFFSET ) >= AM.OffsetVector ) {
1259/*
1260================================
1261 AN.argaddress = AT.MinVecArg;
1262 AT.MinVecArg[ARGHEAD+3] = t[1];
1263 if ( CheckWild(BHEAD i,VECTOSUB,1,AN.argaddress) ) goto endofloop;
1264 AddWild(BHEAD i,VECTOSUB,(WORD)0);
1265================================
1266*/
1267 if ( CheckWild(BHEAD i,VECTOMIN,t[1],&newvalue) ) goto endofloop;
1268 AddWild(BHEAD i,VECTOMIN,newvalue);
1269
1270 }
1271 else if ( *m == -MINVECTOR && *t == -VECTOR &&
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 else goto endofloop;
1285 }
1286 else if ( *t <= -FUNCTION && *m > 0 ) {
1287 if ( ( m[ARGHEAD]+ARGHEAD == *m ) && m[*m-1] == 3
1288 && m[*m-2] == 1 && m[*m-3] == 1 && m[ARGHEAD+1] >= FUNCTION
1289 && m[ARGHEAD+2] == *m-ARGHEAD-4 ) { /* Check for f(?a) etc */
1290 WORD *mmmst, *mmm;
1291 if ( m[ARGHEAD+1] >= FUNCTION+WILDOFFSET ) {
1292/* i = *m - WILDOFFSET; */
1293 i = m[ARGHEAD+1] - WILDOFFSET;
1294 if ( CheckWild(BHEAD i,FUNTOFUN,-*t,&newvalue) ) goto endofloop;
1295 AddWild(BHEAD i,FUNTOFUN,newvalue);
1296 }
1297 else if ( m[ARGHEAD+1] != -*t ) goto endofloop;
1298/*
1299 Only arguments allowed are ?a etc.
1300*/
1301 mmmst = m+*m-3;
1302 mmm = m + ARGHEAD + FUNHEAD + 1;
1303 while ( mmm < mmmst ) {
1304 if ( *mmm != -ARGWILD ) goto endofloop;
1305 i = 0;
1306 AN.argaddress = t;
1307 if ( CheckWild(BHEAD mmm[1],ARGTOARG,i,t) ) goto endofloop;
1308 AddWild(BHEAD mmm[1],ARGTOARG,i);
1309 mmm += 2;
1310 }
1311 }
1312 else goto endofloop;
1313 }
1314 else if ( *m < 0 && *t > 0 ) {
1315 if ( *m == -SYMBOL ) { /* SYMTOSUB */
1316 if ( m[1] < 2*MAXPOWER ) goto endofloop;
1317 i = m[1] - 2*MAXPOWER;
1318 AN.argaddress = t;
1319 if ( CheckWild(BHEAD i,SYMTOSUB,1,AN.argaddress) ) goto endofloop;
1320 AddWild(BHEAD i,SYMTOSUB,0);
1321 }
1322 else if ( *m == -VECTOR ) {
1323 if ( ( i = m[1] - WILDOFFSET ) < AM.OffsetVector )
1324 goto endofloop;
1325 AN.argaddress = t;
1326 if ( CheckWild(BHEAD i,VECTOSUB,1,t) ) goto endofloop;
1327 AddWild(BHEAD i,VECTOSUB,(WORD)0);
1328 }
1329 else if ( *m == -INDEX ) {
1330 if ( ( i = m[1] - WILDOFFSET ) < AM.OffsetIndex ) goto endofloop;
1331 if ( i >= AM.OffsetIndex + WILDOFFSET ) goto endofloop;
1332 AN.argaddress = t;
1333 if ( CheckWild(BHEAD i,INDTOSUB,1,AN.argaddress) ) goto endofloop;
1334 AddWild(BHEAD i,INDTOSUB,(WORD)0);
1335 }
1336 else if ( *m == -ARGWILD ) goto ArgAll;
1337 else goto endofloop;
1338 }
1339 else if ( *m > 0 && *t > 0 ) {
1340 WORD ii = *t-*m;
1341 i = *m;
1342 do { if ( *m++ != *t++ ) break; } while ( --i > 0 );
1343 if ( i == 1 && ii == 0 ) { /* sign difference */
1344 goto endofloop;
1345 }
1346 else if ( i > 0 ) {
1347 WORD *cto, *cfrom, *csav, ci;
1348 WORD oRepFunNum;
1349 WORD *oRepFunList;
1350 WORD *oterstart,*oterstop,*opatstop;
1351 WORD oExpectedSign;
1352 WORD wildargs, wildeat;
1353/*
1354 Not an exact match here.
1355 We have to hope that the pattern contains a composite wildcard.
1356*/
1357 m = oldm; t = oldt;
1358 m += ARGHEAD; t += ARGHEAD; /* Point at (first?) term */
1359 mtrmstop = m + *m;
1360 ttrmstop = t + *t;
1361 if ( mtrmstop < argmstop ) goto endofloop;/* More than one term */
1362 msizcoef = mtrmstop[-1];
1363 if ( msizcoef < 0 ) msizcoef = -msizcoef;
1364 msubstop = mtrmstop - msizcoef;
1365 m++;
1366 if ( m >= msubstop ) goto endofloop; /* Only coefficient */
1367/*
1368 Here we have a composite term. It can match provided it
1369 matches the entire argument. This argument must be a
1370 single term also and the coefficients should match
1371 (more or less).
1372 The matching takes:
1373 1: Match the functions etc. Nothing can be left.
1374 2: Match dotproducts and symbols. ONLY must match
1375 and nothing may be left.
1376 For safety it is best to take the term out and put it
1377 in workspace.
1378*/
1379
1380 if ( argtstop > ttrmstop ) goto endofloop;
1381 m--;
1382 oterstart = AN.terstart;
1383 oterstop = AN.terstop;
1384 opatstop = AN.patstop;
1385 oRepFunList = AN.RepFunList;
1386 oRepFunNum = AN.RepFunNum;
1387 AN.RepFunNum = 0;
1388 AN.RepFunList = AT.WorkPointer;
1389 AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
1390 if ( AT.WorkPointer+*t+5 > AT.WorkTop ) {
1391 MLOCK(ErrorMessageLock);
1392 MesWork();
1393 MUNLOCK(ErrorMessageLock);
1394 return(-1);
1395 }
1396 csav = cto = AT.WorkPointer;
1397 cfrom = t;
1398 ci = *t;
1399 while ( --ci >= 0 ) *cto++ = *cfrom++;
1400 AT.WorkPointer = cto;
1401 ci = msizcoef;
1402 cfrom = mtrmstop;
1403 --ci;
1404 if ( abs(*--cfrom) != abs(*--cto) ) {
1405 AT.WorkPointer = csav;
1406 AN.RepFunList = oRepFunList;
1407 AN.RepFunNum = oRepFunNum;
1408 AN.terstart = oterstart;
1409 AN.terstop = oterstop;
1410 AN.patstop = opatstop;
1411 goto endofloop;
1412 }
1413 i = (*cfrom != *cto) ? 1 : 0; /* buffer AN.ExpectedSign until we are beyond the goto */
1414 while ( --ci >= 0 ) {
1415 if ( *--cfrom != *--cto ) {
1416 AT.WorkPointer = csav;
1417 AN.RepFunList = oRepFunList;
1418 AN.RepFunNum = oRepFunNum;
1419 AN.terstart = oterstart;
1420 AN.terstop = oterstop;
1421 AN.patstop = opatstop;
1422 goto endofloop;
1423 }
1424 }
1425 oExpectedSign = AN.ExpectedSign; /* buffer AN.ExpectedSign until we are beyond FindRest/FindOnly */
1426 AN.ExpectedSign = i;
1427 *m -= msizcoef;
1428 wildargs = AN.WildArgs;
1429 wildeat = AN.WildEat;
1430 for ( i = 0; i < wildargs; i++ ) wildargtaken[i] = AT.WildArgTaken[i];
1431 AN.ForFindOnly = 0; AN.UseFindOnly = 1;
1432 AN.nogroundlevel++;
1433 if ( FindRest(BHEAD csav,m) && ( AN.UsedOtherFind || FindOnly(BHEAD csav,m) ) ) {}
1434 else {
1435nomatch:
1436 *m += msizcoef;
1437 AT.WorkPointer = csav;
1438 AN.RepFunList = oRepFunList;
1439 AN.RepFunNum = oRepFunNum;
1440 AN.terstart = oterstart;
1441 AN.terstop = oterstop;
1442 AN.patstop = opatstop;
1443 AN.WildArgs = wildargs;
1444 AN.WildEat = wildeat;
1445 AN.ExpectedSign = oExpectedSign;
1446 AN.nogroundlevel--;
1447 for ( i = 0; i < wildargs; i++ ) AT.WildArgTaken[i] = wildargtaken[i];
1448 goto endofloop;
1449 }
1450/* if ( *m == 1 || m[1] < FUNCTION || functions[m[1]-FUNCTION].spec >= TENSORFUNCTION ) { */
1451 if ( *m == 1 || m[1] < FUNCTION ) {
1452 if ( AN.ExpectedSign ) goto nomatch;
1453 }
1454 else {
1455 if ( m[1] > FUNCTION + WILDOFFSET ) {
1456 if ( functions[m[1]-FUNCTION-WILDOFFSET].spec >= TENSORFUNCTION ) {
1457 if ( AN.ExpectedSign != AN.RepFunList[AN.RepFunNum-1] ) goto nomatch;
1458 }
1459 }
1460 else {
1461 if ( AN.ExpectedSign != AN.RepFunList[AN.RepFunNum-1] ) goto nomatch;
1462/*
1463 if ( functions[m[1]-FUNCTION].spec >= TENSORFUNCTION ) {
1464 if ( AN.ExpectedSign != AN.RepFunList[AN.RepFunNum-1] ) goto nomatch;
1465 }
1466*/
1467 }
1468 }
1469 AN.nogroundlevel--;
1470 AN.ExpectedSign = oExpectedSign;
1471 AN.WildArgs = wildargs;
1472 AN.WildEat = wildeat;
1473 for ( i = 0; i < wildargs; i++ ) AT.WildArgTaken[i] = wildargtaken[i];
1474 Substitute(BHEAD csav,m,1);
1475 cto = csav;
1476 cfrom = cto + *cto - msizcoef;
1477 cto++;
1478 *m += msizcoef;
1479 AT.WorkPointer = csav;
1480 AN.RepFunList = oRepFunList;
1481 AN.RepFunNum = oRepFunNum;
1482 AN.terstart = oterstart;
1483 AN.terstop = oterstop;
1484 AN.patstop = opatstop;
1485 if ( *cto != SUBEXPRESSION ) goto endofloop;
1486 cto += cto[1];
1487 if ( cto < cfrom ) goto endofloop;
1488 }
1489 }
1490 else goto endofloop;
1491
1492 t = argtstop; /* Next argument */
1493 m = argmstop;
1494 }
1495 if ( AN.SignCheck && AN.ExpectedSign ) goto endofloop;
1496 AT.WorkPointer = OldWork;
1497 if ( AN.WildArgs > 1 ) *wilds = 1;
1498 if ( AN.SignCheck && AN.ExpectedSign ) return(0);
1499 return(1); /* m was eaten. we have a match! */
1500
1501endofloop:;
1502/*
1503 restore the current Wildcard assignments
1504*/
1505 i = nwstore;
1506 if ( i > 0 ) {
1507 m = AN.WildValue;
1508 t = OldWork + ntwa; r = AT.WildMask;
1509 do {
1510 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1511 } while ( --i > 0 );
1512 C->numrhs = *t++;
1513 C->Pointer = C->Buffer + oldcpointer;
1514 }
1515
1516endoloop:;
1517 i = AN.WildArgs-1;
1518 if ( i <= 0 ) {
1519 AT.WorkPointer = OldWork;
1520 return(0);
1521 }
1522 while ( --i >= 0 ) {
1523 if ( AT.WildArgTaken[i] == 0 ) {
1524 if ( i == 0 ) {
1525 AT.WorkPointer = OldWork;
1526 return(0);
1527 }
1528 }
1529 else {
1530 (AT.WildArgTaken[i])--;
1531 numofwildarg = 0;
1532 for ( j = 0; j <= i; j++ ) {
1533 numofwildarg += AT.WildArgTaken[j];
1534 }
1535 AT.WildArgTaken[j] = AN.WildEat-numofwildarg;
1536/* ----> bug to be replaced in other source code */
1537 for ( j++; j < AN.WildArgs; j++ ) AT.WildArgTaken[j] = 0;
1538 break;
1539 }
1540 }
1541 goto topofloop;
1542NoCaseB:
1543/*
1544 Restore the old Wildcard assignments
1545*/
1546 i = nwstore;
1547 if ( i > 0 ) {
1548 m = AN.WildValue;
1549 t = OldWork + ntwa; r = AT.WildMask;
1550 do {
1551 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1552 } while ( --i > 0 );
1553 C->numrhs = *t++;
1554 C->Pointer = C->Buffer + oldcpointer;
1555 }
1556 AT.WorkPointer = OldWork;
1557 return(0); /* no match */
1558}
1559
1560/*
1561 #] MatchFunction :
1562 #[ ScanFunctions : WORD ScanFunctions(inpat,inter,par)
1563
1564 Finds in which functions to look for a match.
1565 inpat is the start of the pattern still to be matched.
1566 inter is the start of the term still to be matched.
1567 par gives information about commutativity.
1568 par = 0: nothing special
1569 par = 1: regular noncommuting function
1570 par = 2: GAMMA function
1571
1572 AN.patstop: end of the functions field in the search pattern
1573 AN.terstop: end of the functions field in the target pattern
1574 AN.terstart: address of entire term;
1575
1576 The actual matching of the functions and their arguments is done
1577 in a number of different routines. Mainly MatchFunction when there
1578 are no symmetry properties.
1579 Also: MatchE
1580 MatchCy
1581 FunMatchSy
1582 FunMatchCy
1583
1584 The main problem here is backtracking, ie continuing with wildcard
1585 possibilities when a first assignment doesn't work.
1586 Important note: this was completely forgotten in the symmetric
1587 functions till 6-jan-2009. As of the moment this still has to
1588 be fixed.
1589
1590 Functions inside functions can cause problems when antisymmetric
1591 functions are involved. The sign of the term may be at stake.
1592 At the lowest level this is no problem but in f(-fas(n2,n1)) this
1593 plays a role. Next is when we have a product of functions inside
1594 an argument. The strategy must be that we test the sign only at the
1595 last function. Hence, when inpat+inpat[1] >= AN.patstop.
1596 We might relax that to the last antisymmetric function at a later stage.
1597
1598 New scheme to be implemented for non-commuting objects:
1599 When we are matching a second (or higher) function, any match can only
1600 be directly after the last matched non-commuting function or a commuting
1601 function. This will take care of whatever happens in MatchE etc.
1602*/
1603
1604WORD ScanFunctions(PHEAD WORD *inpat, WORD *inter, WORD par)
1605{
1606 GETBIDENTITY
1607 WORD i, *m, *t, *r, sym, psym;
1608 WORD *newpat, *newter, *instart, *oinpat = 0, *ointer = 0;
1609 WORD nwstore, offset, *OldWork, SetStop = 0, oRepFunNum = AN.RepFunNum;
1610 WORD wilds, wildargs = 0, wildeat = 0, *wildargtaken;
1611 WORD *Oterfirstcomm = AN.terfirstcomm;
1612 CBUF *C = cbuf+AT.ebufnum;
1613 int ntwa = AN.NumTotWildArgs;
1614 LONG oldcpointer = C->Pointer - C->Buffer;
1615 WORD oldSignCheck = AN.SignCheck;
1616 instart = inter;
1617/*
1618 Only active for the last function in the pattern.
1619 The actual test on the sign is in MatchFunction or the symmetric functions
1620*/
1621 if ( AN.nogroundlevel ) {
1622 AN.SignCheck = ( inpat + inpat[1] >= AN.patstop ) ? 1 : 0;
1623 }
1624 else {
1625 AN.SignCheck = 0;
1626 }
1627/*
1628 Store the current Wildcard assignments
1629*/
1630 t = wildargtaken = OldWork = AT.WorkPointer;
1631 t += ntwa;
1632 m = AN.WildValue;
1633 nwstore = i = (m[-SUBEXPSIZE+1]-SUBEXPSIZE)/4;
1634 if ( i > 0 ) {
1635 r = AT.WildMask;
1636 do {
1637 *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *m++; *t++ = *r++;
1638 } while ( --i > 0 );
1639 *t++ = C->numrhs;
1640 }
1641 if ( t >= AT.WorkTop ) {
1642 MLOCK(ErrorMessageLock);
1643 MesWork();
1644 MUNLOCK(ErrorMessageLock);
1645 Terminate(-1);
1646 }
1647 AT.WorkPointer = t;
1648 do {
1649#ifndef NEWCOMMUTE
1650/*
1651 Find an eligible unsubstituted function
1652*/
1653 if ( AN.RepFunNum > 0 ) {
1654/*
1655 First try a non-commuting function, just after the last
1656 substituted non-commuting function.
1657*/
1658 if ( *inter >= FUNCTION && functions[*inter-FUNCTION].commute ) {
1659 do {
1660 offset = WORDDIF(inter,AN.terstart);
1661 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1662 if ( AN.RepFunList[i] >= offset ) break;
1663 }
1664 if ( i >= AN.RepFunNum ) break;
1665 inter += inter[1];
1666 } while ( inter < AN.terfirstcomm );
1667 if ( inter < AN.terfirstcomm ) { /* Check that it is directly after */
1668 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1669 if ( functions[AN.terstart[AN.RepFunList[i]]-FUNCTION].commute
1670 && AN.RepFunList[i]+AN.terstart[AN.RepFunList[i]+1] == offset ) break;
1671 }
1672 if ( i < AN.RepFunNum ) goto trythis;
1673 }
1674 inter = AN.terfirstcomm;
1675 }
1676/*
1677 Now try one of the commuting functions
1678*/
1679 while ( inter < AN.terstop ) {
1680 offset = WORDDIF(inter,AN.terstart);
1681 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1682 if ( AN.RepFunList[i] == offset ) break;
1683 }
1684 if ( i >= AN.RepFunNum ) break;
1685 inter += inter[1];
1686 }
1687 if ( inter >= AN.terstop ) goto Failure;
1688trythis:;
1689 }
1690 else {
1691/*
1692 The first function can be anywhere. We have no problems.
1693*/
1694 offset = WORDDIF(inter,AN.terstart);
1695 }
1696#else
1697 /* first find an unsubstituted function */
1698 do {
1699 offset = WORDDIF(inter,AN.terstart);
1700 for ( i = 0; i < AN.RepFunNum; i += 2 ) {
1701 if ( AN.RepFunList[i] == offset ) break;
1702 }
1703 if ( i >= AN.RepFunNum ) break;
1704 inter += inter[1];
1705 } while ( inter < AN.terstop );
1706 if ( inter >= AN.terstop ) goto Failure;
1707#endif
1708 wilds = 0;
1709 /* We found one */
1710 if ( *inter >= FUNCTION && *inpat >= FUNCTION ) {
1711 if ( *inpat == *inter || *inpat >= FUNCTION + WILDOFFSET ) {
1712/*
1713 if ( inter[1] == FUNHEAD ) goto rewild;
1714*/
1715 if ( functions[*inter-FUNCTION].spec >= TENSORFUNCTION
1716 && ( *inter == *inpat ||
1717 functions[*inpat-FUNCTION-WILDOFFSET].spec >= TENSORFUNCTION ) ) {
1718 sym = functions[*inter-FUNCTION].symmetric & ~REVERSEORDER;
1719 if ( *inpat == *inter ) psym = sym;
1720 else psym = functions[*inpat-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER;
1721 if ( sym == ANTISYMMETRIC || sym == SYMMETRIC
1722 || psym == SYMMETRIC || psym == ANTISYMMETRIC ) {
1723 if ( sym == ANTISYMMETRIC && psym == SYMMETRIC ) goto rewild;
1724 if ( sym == SYMMETRIC && psym == ANTISYMMETRIC ) goto rewild;
1725/*
1726 Special function call for (anti)symmetric tensors
1727*/
1728 if ( MatchE(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1729 }
1730 else if ( sym == CYCLESYMMETRIC || sym == RCYCLESYMMETRIC
1731 || psym == CYCLESYMMETRIC || psym == RCYCLESYMMETRIC ) {
1732/*
1733 Special function call for (r)cyclic tensors
1734*/
1735 if ( MatchCy(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1736 }
1737 else goto rewild;
1738 }
1739 else if ( functions[*inter-FUNCTION].spec == 0
1740 && ( *inter == *inpat ||
1741 functions[*inpat-FUNCTION-WILDOFFSET].spec == 0 ) ) {
1742 sym = functions[*inter-FUNCTION].symmetric & ~REVERSEORDER;
1743 if ( *inpat == *inter ) psym = sym;
1744 else psym = functions[*inpat-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER;
1745 if ( psym == SYMMETRIC || sym == SYMMETRIC
1746/*
1747 The next statement was commented out. Why????
1748 Werkt nog niet. Teken wordt nog niet bijgehouden.
1749 5-nov-2001
1750*/
1751 || psym == ANTISYMMETRIC || sym == ANTISYMMETRIC
1752 ) {
1753 if ( sym == ANTISYMMETRIC && psym == SYMMETRIC ) goto rewild;
1754 if ( sym == SYMMETRIC && psym == ANTISYMMETRIC ) goto rewild;
1755 if ( FunMatchSy(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1756 }
1757 else
1758 if ( sym == CYCLESYMMETRIC || sym == RCYCLESYMMETRIC
1759 || psym == CYCLESYMMETRIC || psym == RCYCLESYMMETRIC ) {
1760 if ( FunMatchCy(BHEAD inpat,inter,instart,par) ) goto OnSuccess;
1761 }
1762 else goto rewild;
1763 }
1764 else goto rewild;
1765 AN.terfirstcomm = Oterfirstcomm;
1766 }
1767 else if ( par > 0 ) { SetStop = 1; goto maybenext; }
1768 }
1769 else {
1770rewild:
1771 AN.terfirstcomm = Oterfirstcomm;
1772 if ( *inter != SUBEXPRESSION && MatchFunction(BHEAD inpat,inter,&wilds) ) {
1773 AN.terfirstcomm = Oterfirstcomm;
1774 if ( wilds ) {
1775/*
1776 Store wildcards to continue in MatchFunction if the current
1777 wildcards do not work out.
1778*/
1779 wildargs = AN.WildArgs;
1780 wildeat = AN.WildEat;
1781 for ( i = 0; i < wildargs; i++ ) wildargtaken[i] = AT.WildArgTaken[i];
1782 oinpat = inpat; ointer = inter;
1783 }
1784 if ( par && *inter == GAMMA && AN.RepFunList[AN.RepFunNum+1] ) {
1785 SetStop = 1; goto NoMat;
1786 }
1787 if ( par == 2 ) {
1788 if ( *inter < FUNCTION || functions[*inter-FUNCTION].commute ) {
1789 goto NoMat;
1790 }
1791 par = 1;
1792 }
1793 AN.RepFunList[AN.RepFunNum] = offset;
1794 AN.RepFunNum += 2;
1795 newpat = inpat + inpat[1];
1796 if ( newpat >= AN.patstop ) {
1797 if ( AN.UseFindOnly == 0 ) {
1798 if ( FindOnce(BHEAD AN.findTerm,AN.findPattern) ) {
1799 AN.UsedOtherFind = 1;
1800 goto OnSuccess;
1801 }
1802 AN.RepFunNum -= 2;
1803 goto NoMat;
1804 }
1805 goto OnSuccess;
1806 }
1807 if ( *inter < FUNCTION || functions[*inter-FUNCTION].commute ) {
1808 newter = inter + inter[1];
1809 if ( newter >= AN.terstop ) goto Failure;
1810 if ( *inter == GAMMA && inpat[1] <
1811 inter[1] - AN.RepFunList[AN.RepFunNum-1] ) {
1812 if ( ScanFunctions(BHEAD newpat,newter,2) ) goto OnSuccess;
1813 AN.terfirstcomm = Oterfirstcomm;
1814 }
1815 else if ( *newter == SUBEXPRESSION ) {}
1816 else if ( functions[*inter-FUNCTION].commute ) {
1817 if ( ScanFunctions(BHEAD newpat,newter,1) ) goto OnSuccess;
1818 AN.terfirstcomm = Oterfirstcomm;
1819 if ( ( *newpat < (FUNCTION+WILDOFFSET)
1820 && ( functions[*newpat-FUNCTION].commute == 0 ) ) ||
1821 ( *newpat >= (FUNCTION+WILDOFFSET)
1822 && ( functions[*newpat-FUNCTION-WILDOFFSET].commute == 0 ) ) ) {
1823 newter = AN.terfirstcomm;
1824 if ( newter < AN.terstop && ScanFunctions(BHEAD newpat,newter,1) ) goto OnSuccess;
1825 }
1826 }
1827 else {
1828 if ( ScanFunctions(BHEAD newpat,instart,1) ) goto OnSuccess;
1829 AN.terfirstcomm = Oterfirstcomm;
1830 }
1831 SetStop = par;
1832 }
1833 else {
1834/*
1835 Shouldn't this be newpat instead of inpat?????
1836*/
1837 if ( par && inter > instart && ( ( *newpat < (FUNCTION+WILDOFFSET)
1838 && functions[*newpat-FUNCTION].commute ) ||
1839 ( *newpat >= (FUNCTION+WILDOFFSET)
1840 && functions[*newpat-FUNCTION-WILDOFFSET].commute ) ) ) {
1841 SetStop = 1;
1842 }
1843 else {
1844 newter = instart;
1845 if ( ScanFunctions(BHEAD newpat,newter,par) ) goto OnSuccess;
1846 AN.terfirstcomm = Oterfirstcomm;
1847 }
1848 }
1849/*
1850 Restore the old Wildcard assignments
1851*/
1852NoMat:
1853 i = nwstore;
1854 if ( i > 0 ) {
1855 m = AN.WildValue;
1856 t = OldWork + ntwa; r = AT.WildMask;
1857 do {
1858 *m++ = *t++; *m++ = *t++; *m++ = *t++; *m++ = *t++; *r++ = *t++;
1859 } while ( --i > 0 );
1860 C->numrhs = *t++;
1861 C->Pointer = C->Buffer + oldcpointer;
1862 }
1863/* AN.RepFunNum -= 2; */
1864 AN.RepFunNum = oRepFunNum;
1865 if ( wilds ) {
1866 inter = ointer; inpat = oinpat;
1867 AN.WildArgs = wildargs;
1868 AN.WildEat = wildeat;
1869 for ( i = 0; i < wildargs; i++ ) AT.WildArgTaken[i] = wildargtaken[i];
1870 goto rewild;
1871 }
1872 if ( SetStop ) break;
1873 }
1874 else if ( par ) {
1875maybenext:
1876 if ( *inpat < (FUNCTION+WILDOFFSET) ) {
1877 if ( *inpat < FUNCTION ||
1878 functions[*inpat-FUNCTION].commute ) break;
1879 }
1880 else {
1881 if ( functions[*inpat-FUNCTION-WILDOFFSET].commute ) break;
1882 }
1883 }}
1884 inter += inter[1];
1885 } while ( inter < AN.terstop );
1886Failure:
1887 AN.SignCheck = oldSignCheck;
1888 AT.WorkPointer = OldWork;
1889 return(0);
1890OnSuccess:
1891 if ( AT.idallflag && AN.nogroundlevel <= 0 ) {
1892 if ( AT.idallmaxnum > 0 && AT.idallnum >= AT.idallmaxnum ) {
1893 AN.terfirstcomm = Oterfirstcomm;
1894 AN.SignCheck = oldSignCheck;
1895 AT.WorkPointer = OldWork;
1896 return(0);
1897 }
1898 SubsInAll(BHEAD0);
1899 AT.idallnum++;
1900 if ( AT.idallmaxnum == 0 || AT.idallnum < AT.idallmaxnum ) goto NoMat;
1901 }
1902 AN.terfirstcomm = Oterfirstcomm;
1903 AN.SignCheck = oldSignCheck;
1904/*
1905 Now the disorder test
1906*/
1907 if ( AN.DisOrderFlag && AN.RepFunNum >= 4 ) {
1908 WORD k, kk;
1909 for ( i = 2; i < AN.RepFunNum; i += 2 ) {
1910/*
1911------------> We still have to copy the code from Normalize wrt properorderflag
1912*/
1913 m = AN.terstart + AN.RepFunList[i-2];
1914 t = AN.terstart + AN.RepFunList[i];
1915 if ( *m != *t ) {
1916 if ( *m > *t ) continue;
1917 goto doesmatch;
1918 }
1919 if ( *m >= FUNCTION && functions[*m-FUNCTION].spec >=
1920 TENSORFUNCTION ) {
1921 k = m[1] - FUNHEAD;
1922 kk = t[1] - FUNHEAD;
1923 m += FUNHEAD;
1924 t += FUNHEAD;
1925 }
1926 else {
1927 k = m[1] - FUNHEAD;
1928 kk = t[1] - FUNHEAD;
1929 m += FUNHEAD;
1930 t += FUNHEAD;
1931 }
1932 while ( k > 0 && kk > 0 ) {
1933 if ( *m < *t ) goto NextFor;
1934 else if ( *m++ > *t++ ) goto doesmatch;
1935 k--; kk--;
1936 }
1937 if ( k > 0 ) goto doesmatch;
1938NextFor:;
1939 }
1940 SetStop = 1;
1941 goto NoMat;
1942 }
1943doesmatch:
1944 AT.WorkPointer = OldWork;
1945 return(1);
1946}
1947
1948/*
1949 #] ScanFunctions :
1950 #] Patterns :
1951*/
WORD Generator(PHEAD WORD *, WORD)
Definition proces.c:3101
WORD * Buffer
Definition structs.h:939
WORD * Pointer
Definition structs.h:941