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