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 
51 WORD 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 
97 void 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 
139 void 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 
174 void 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 
213 WORD 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;
279 recycle:
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 
373 WORD 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 
473 int 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 
518 WORD 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++;
570 NextGroup:;
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  }
596 NextFun:
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 
633 WORD 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  }
676 NextFun:
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 
691 int 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 
739 int 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 
817 WORD 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 ) {
938 WithGamma: 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  }
955 FullOK: 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 {
981 NoGamma:
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;
1028 toploop:
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 
1091 endloop:;
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  }
1105 enloop:;
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;
1162 topofloop:
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 ) {
1204 ArgAll: 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;
1218 SymAll:
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 ) {
1224 IndAll: 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 {
1435 nomatch:
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 
1501 endofloop:;
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 
1516 endoloop:;
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;
1542 NoCaseB:
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 
1604 WORD 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;
1688 trythis:;
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 {
1770 rewild:
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 */
1852 NoMat:
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 ) {
1875 maybenext:
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 );
1886 Failure:
1887  AN.SignCheck = oldSignCheck;
1888  AT.WorkPointer = OldWork;
1889  return(0);
1890 OnSuccess:
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;
1938 NextFor:;
1939  }
1940  SetStop = 1;
1941  goto NoMat;
1942  }
1943 doesmatch:
1944  AT.WorkPointer = OldWork;
1945  return(1);
1946 }
1947 
1948 /*
1949  #] ScanFunctions :
1950  #] Patterns :
1951 */
Definition: structs.h:938
WORD * Pointer
Definition: structs.h:941
WORD * Buffer
Definition: structs.h:939
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3101