FORM  4.2
pattern.c
Go to the documentation of this file.
1 
12 /* #[ License : */
13 /*
14  * Copyright (C) 1984-2017 J.A.M. Vermaseren
15  * When using this file you are requested to refer to the publication
16  * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
17  * This is considered a matter of courtesy as the development was paid
18  * for by FOM the Dutch physics granting agency and we would like to
19  * be able to track its scientific use to convince FOM of its value
20  * for the community.
21  *
22  * This file is part of FORM.
23  *
24  * FORM is free software: you can redistribute it and/or modify it under the
25  * terms of the GNU General Public License as published by the Free Software
26  * Foundation, either version 3 of the License, or (at your option) any later
27  * version.
28  *
29  * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
30  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
31  * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
32  * details.
33  *
34  * You should have received a copy of the GNU General Public License along
35  * with FORM. If not, see <http://www.gnu.org/licenses/>.
36  */
37 /* #] License : */
38 /*
39 !!! Notice the change in OnePV in FindAll (7-may-2008 JV).
40 
41  #[ Includes : pattern.c
42 */
43 
44 #include "form3.h"
45 
46 /*
47  #] Includes :
48  #[ Patterns :
49  #[ Rules :
50 
51  There are several rules governing the allowable replacements.
52  1: Multi with anything but symbols or dotproducts reverts
53  to many.
54  2: Each symbol can have only one (wildcard) power, so
55  x^2*x^n? is illegal.
56  3: when a single vector is used it replaces all occurences
57  of the vector. Therefore q*q(mu) or q*q(mu) cannot occur.
58  Also q*q cannot be done.
59  4: Loose vector elements are replaced with p(mu), dotproducts
60  with p?.q.
61  5: p?.q? is allowed.
62  6: x^n? can revert to n = 0 if there is no power of x.
63  7: x?^n? must match some x. There could be an ambiguity otherwise.
64 
65  #] Rules :
66  #[ TestMatch : WORD TestMatch(term,level)
67 */
68 
97 WORD TestMatch(PHEAD WORD *term, WORD *level)
98 {
99  GETBIDENTITY
100  WORD *ll, *m, *w, *llf, *OldWork, *StartWork, *ww, *mm, *t, *OldTermBuffer = 0;
101  WORD power = 0, match = 0, i, msign = 0, ll2;
102  int numdollars = 0, protosize, oldallnumrhs;
103  CBUF *C = cbuf+AM.rbufnum, *CC;
104  AT.idallflag = 0;
105  do {
106 /*
107  #[ Preliminaries :
108 */
109  ll = C->lhs[*level];
110  if ( *ll == TYPEEXPRESSION ) {
111 /*
112  Expressions are not subject to anything.
113 */
114  return(0);
115  }
116  else if ( *ll == TYPEREPEAT ) {
117  *++AN.RepPoint = 0;
118  return(0); /* Will force the next level */
119  }
120  else if ( *ll == TYPEENDREPEAT ) {
121  if ( *AN.RepPoint ) {
122  AN.RepPoint[-1] = 1; /* Mark the higher level as dirty */
123  *AN.RepPoint = 0;
124  *level = ll[2]; /* Level to jump back to */
125  }
126  else {
127  AN.RepPoint--;
128  if ( AN.RepPoint < AT.RepCount ) {
129  MLOCK(ErrorMessageLock);
130  MesPrint("Internal problems with REPEAT count");
131  MUNLOCK(ErrorMessageLock);
132  Terminate(-1);
133  }
134  }
135  return(0); /* Force the next level */
136  }
137  else if ( *ll == TYPEOPERATION ) {
138 /*
139  Operations have always their own level.
140 */
141  if ( (*(FG.OperaFind[ll[2]]))(BHEAD term,ll) ) return(-1);
142  else return(0);
143  }
144 /*
145  #] Preliminaries :
146 */
147  OldWork = AT.WorkPointer;
148  if ( AT.WorkPointer < term + *term ) AT.WorkPointer = term + *term;
149  ww = AT.WorkPointer;
150 /*
151  Here we need to make a copy of the subexpression object because we
152  will be writing the values of the wildcards in it.
153  Originally we copied it into the private version of the compiler buffer
154  that is used for scratch space (ebufnum). This caused errors in the
155  routines like ScanFunctions when the ebufnum Buffer was expanded
156  and inpat was still pointing at the old Buffer. This expansion
157  could be done in AddWild and hence cannot be fixed at > 100 places.
158  The solution is to use AN.patternbuffer (JV 16-mar-2009).
159 */
160  {
161  WORD *ta = ll, *ma;
162  int ja = ta[1];
163 /*
164  New code (16-mar-2009) JV
165 */
166  if ( ( ja + 2 ) > AN.patternbuffersize ) {
167  if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
168  AN.patternbuffersize = 2 * ja + 2;
169  AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
170  "AN.patternbuffer");
171  }
172  ma = AN.patternbuffer;
173  m = ma + IDHEAD;
174  NCOPY(ma,ta,ja);
175  *ma = 0;
176  }
177  AN.FullProto = m;
178  AN.WildValue = w = m + SUBEXPSIZE;
179  protosize = IDHEAD + m[1];
180  m += m[1];
181  AN.WildStop = m;
182  StartWork = ww;
183  ll2 = ll[2];
184 /*
185  #[ Expand dollars :
186 */
187  if ( ( ll[4] & DOLLARFLAG ) != 0 ) { /* We have at least one dollar in the pattern */
188  WORD oldRepPoint = *AN.RepPoint, olddefer = AR.DeferFlag;
189  AR.Eside = LHSIDEX;
190 /*
191  Copy into WorkSpace. This means that AN.patternbuffer will be free.
192 */
193  ww = AT.WorkPointer; i = m[0]; mm = m;
194  NCOPY(ww,mm,i);
195  *StartWork += 3;
196  *ww++ = 1; *ww++ = 1; *ww++ = 3;
197  AT.WorkPointer = ww;
198  AR.DeferFlag = 0;
199  NewSort(BHEAD0);
200  if ( Generator(BHEAD StartWork,AR.Cnumlhs) ) {
201  LowerSortLevel();
202  AT.WorkPointer = OldWork;
203  AR.DeferFlag = olddefer;
204  return(-1);
205  }
206  AT.WorkPointer = ww;
207  if ( EndSort(BHEAD ww,0) < 0 ) {}
208  AR.DeferFlag = olddefer;
209  if ( *ww == 0 || *(ww+*ww) != 0 ) {
210  if ( AP.lhdollarerror == 0 ) {
211 /*
212  If race condition we just get more error messages
213 */
214  MLOCK(ErrorMessageLock);
215  MesPrint("&LHS must be one term");
216  MUNLOCK(ErrorMessageLock);
217  AP.lhdollarerror = 1;
218  }
219  AT.WorkPointer = OldWork;
220  return(-1);
221  }
222  m = ww; ww = m + *m;
223  if ( m[*m-1] < 0 ) { msign = 1; m[*m-1] = -m[*m-1]; }
224  if ( *ww || m[*m-1] != 3 || m[*m-2] != 1 || m[*m-3] != 1 ) {
225  MLOCK(ErrorMessageLock);
226  MesPrint("Dollar variable develops into an illegal pattern in id-statement");
227  MUNLOCK(ErrorMessageLock);
228  return(-1);
229  }
230  *m -= m[*m-1];
231  if ( ( *m + 1 + protosize ) > AN.patternbuffersize ) {
232  if ( AN.patternbuffer ) M_free(AN.patternbuffer,"AN.patternbuffer");
233  AN.patternbuffersize = 2 * (*m) + 2 + protosize;
234  AN.patternbuffer = (WORD *)Malloc1(AN.patternbuffersize * sizeof(WORD),
235  "AN.patternbuffer");
236  mm = ll; ww = AN.patternbuffer; i = protosize;
237  NCOPY(ww,mm,i);
238  AN.FullProto = AN.patternbuffer + IDHEAD;
239  AN.WildValue = w = AN.FullProto + SUBEXPSIZE;
240  AN.WildStop = AN.patternbuffer + protosize;
241  }
242  mm = AN.patternbuffer + protosize;
243  i = *m;
244  NCOPY(mm,m,i);
245  m = AN.patternbuffer + protosize;
246  AR.Eside = RHSIDE;
247  *mm = 0;
248 /*
249  Test the pattern. If only wildcard powers -> SUBONCE
250 */
251  {
252  WORD *mmm = m + *m, *m1 = m+1, jm, noveto = 0;
253  while ( m1 < mmm ) {
254  if ( *m1 == SYMBOL ) {
255  for ( jm = 2; jm < m1[1]; jm+=2 ) {
256  if ( m1[jm+1] < MAXPOWER && m1[jm+1] > -MAXPOWER ) break;
257  }
258  if ( jm < m1[1] ) { noveto = 1; break; }
259  }
260  else if ( *m1 == DOTPRODUCT ) {
261  for ( jm = 2; jm < m1[1]; jm+=3 ) {
262  if ( m1[jm+2] < MAXPOWER && m1[jm+2] > -MAXPOWER ) break;
263  }
264  if ( jm < m1[1] ) { noveto = 1; break; }
265  }
266  else { noveto = 1; break; }
267  m1 += m1[1];
268  }
269  if ( noveto == 0 ) {
270  ll2 = ll2 & ~SUBMASK;
271  ll2 |= SUBONCE;
272  }
273  }
274  AT.WorkPointer = ww = StartWork;
275  *AN.RepPoint = oldRepPoint;
276  }
277 /*
278  #] Expand dollars :
279 
280  In case of id,all we have to check at this point that there are only
281  functions in the pattern.
282 */
283  if ( ( ll2 & SUBMASK ) == SUBALL ) {
284  WORD *t = AN.patternbuffer+IDHEAD, *tt;
285  WORD *tstop, *ttstop, ii;
286  t += t[1]; tstop = t + *t; t++;
287  while ( t < tstop ) {
288  if ( *t < FUNCTION ) break;
289  t += t[1];
290  }
291  if ( t < tstop ) {
292  MLOCK(ErrorMessageLock);
293  MesPrint("Error: id,all can only be used with (products of) functions and/or tensors.");
294  MUNLOCK(ErrorMessageLock);
295  return(-1);
296  }
297  OldTermBuffer = AN.termbuffer;
298  AN.termbuffer = TermMalloc("id,all");
299 /*
300  Now make sure that only regular functions and tensors can take part.
301 */
302  tt = term; ttstop = tt+*tt; ttstop -= ABS(ttstop[-1]); tt++;
303  t = AN.termbuffer+1;
304  while ( tt < ttstop ) {
305  if ( *tt >= FUNCTION && *tt != AR.PolyFun && *tt != AR.PolyFunInv ) {
306  ii = tt[1]; NCOPY(t,tt,ii);
307  }
308  else tt += tt[1];
309  }
310  *t++ = 1; *t++ = 1; *t++ = 3; AN.termbuffer[0] = t-AN.termbuffer;
311  }
312 /*
313  To be puristic, we need to check that all wildcards in the prototype
314  are actually present. If the LHS contained a replace_ this may not be
315  the case.
316 */
317  ClearWild(BHEAD0);
318  while ( w < AN.WildStop ) {
319  if ( *w == LOADDOLLAR ) numdollars++;
320  w += w[1];
321  }
322  AN.RepFunNum = 0;
323  /* rep = */ AN.RepFunList = AT.WorkPointer;
324  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
325  if ( AT.WorkPointer >= AT.WorkTop ) {
326  MLOCK(ErrorMessageLock);
327  MesWork();
328  MUNLOCK(ErrorMessageLock);
329  return(-1);
330  }
331  AN.DisOrderFlag = ll2 & SUBDISORDER;
332  AN.nogroundlevel = 0;
333  switch ( ll2 & SUBMASK ) {
334  case SUBONLY :
335  /* Must be an exact match */
336  AN.UseFindOnly = 1; AN.ForFindOnly = 0;
337  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
338  FindOnly(BHEAD term,m) ) ) {
339  power = 1;
340  if ( msign ) term[term[0]-1] = -term[term[0]-1];
341  }
342  else power = 0;
343  break;
344  case SUBMANY :
345  AN.UseFindOnly = -1;
346  if ( ( power = FindRest(BHEAD term,m) ) > 0 ) {
347  if ( ( power = FindOnce(BHEAD term,m) ) > 0 ) {
348  AN.UseFindOnly = 0;
349  do {
350  if ( msign ) term[term[0]-1] = -term[term[0]-1];
351  Substitute(BHEAD term,m,1);
352  if ( numdollars ) {
353  WildDollars(BHEAD (WORD *)0);
354  numdollars = 0;
355  }
356  if ( ww < term+term[0] ) ww = term+term[0];
357  ClearWild(BHEAD0);
358  AT.WorkPointer = ww;
359 /* if ( rep < ww ) {*/
360  AN.RepFunNum = 0;
361  /* rep = */ AN.RepFunList = ww;
362  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
363  if ( AT.WorkPointer >= AT.WorkTop ) {
364  MLOCK(ErrorMessageLock);
365  MesWork();
366  MUNLOCK(ErrorMessageLock);
367  return(-1);
368  }
369 /*
370  }
371  else {
372  AN.RepFunList = rep;
373  AN.RepFunNum = 0;
374  }
375 */
376  AN.nogroundlevel = 0;
377  } while ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
378  FindOnce(BHEAD term,m) ) );
379  match = 1;
380  }
381  else if ( power < 0 ) {
382  do {
383  if ( msign ) term[term[0]-1] = -term[term[0]-1];
384  Substitute(BHEAD term,m,1);
385  if ( numdollars ) {
386  WildDollars(BHEAD (WORD *)0);
387  numdollars = 0;
388  }
389  if ( ww < term+term[0] ) ww = term+term[0];
390  ClearWild(BHEAD0);
391  AT.WorkPointer = ww;
392 /* if ( rep < ww ) { */
393  AN.RepFunNum = 0;
394  /* rep = */ AN.RepFunList = ww;
395  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
396  if ( AT.WorkPointer >= AT.WorkTop ) {
397  MLOCK(ErrorMessageLock);
398  MesWork();
399  MUNLOCK(ErrorMessageLock);
400  return(-1);
401  }
402 /*
403  }
404  else {
405  AN.RepFunList = rep;
406  AN.RepFunNum = 0;
407  }
408 */
409  } while ( FindRest(BHEAD term,m) );
410  match = 1;
411  }
412  }
413  else if ( power < 0 ) {
414  if ( FindOnce(BHEAD term,m) ) {
415  do {
416  if ( msign ) term[term[0]-1] = -term[term[0]-1];
417  Substitute(BHEAD term,m,1);
418  if ( numdollars ) {
419  WildDollars(BHEAD (WORD *)0);
420  numdollars = 0;
421  }
422  if ( ww < term+term[0] ) ww = term+term[0];
423  ClearWild(BHEAD0);
424  AT.WorkPointer = ww;
425 /* if ( rep < ww ) { */
426  AN.RepFunNum = 0;
427  /* rep = */ AN.RepFunList = ww;
428  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer/2);
429  if ( AT.WorkPointer >= AT.WorkTop ) {
430  MLOCK(ErrorMessageLock);
431  MesWork();
432  MUNLOCK(ErrorMessageLock);
433  return(-1);
434  }
435 /*
436  }
437  else {
438  AN.RepFunList = rep;
439  AN.RepFunNum = 0;
440  }
441 */
442  } while ( FindOnce(BHEAD term,m) );
443  match = 1;
444  }
445  }
446  if ( match ) {
447  if ( ( ll2 & SUBAFTER ) != 0 ) *level = AC.Labels[ll[3]];
448  }
449  else {
450  if ( ( ll2 & SUBAFTERNOT ) != 0 ) *level = AC.Labels[ll[3]];
451  }
452  goto nextlevel;
453  case SUBONCE :
454  AN.UseFindOnly = 0;
455  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnce(BHEAD term,m) ) ) {
456  power = 1;
457  if ( msign ) term[term[0]-1] = -term[term[0]-1];
458  }
459  else power = 0;
460  break;
461  case SUBMULTI :
462  power = FindMulti(BHEAD term,m);
463  if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
464  break;
465  case SUBVECTOR :
466  while ( ( power = FindAll(BHEAD term,m,*level,(WORD *)0) ) != 0 ) {
467  if ( ( power & 1 ) != 0 && msign ) term[term[0]-1] = -term[term[0]-1];
468  match = 1;
469  }
470  break;
471  case SUBSELECT :
472  llf = ll + IDHEAD; llf += llf[1]; llf += *llf;
473  AN.UseFindOnly = 1; AN.ForFindOnly = llf;
474  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind || FindOnly(BHEAD term,m) ) ) {
475  if ( msign ) term[term[0]-1] = -term[term[0]-1];
476 /*
477  The following code needs to be hacked a bit to allow for
478  all types of sets and for occurrence anywhere in the term
479  The code at the end of FindOnly is a bit mysterious.
480 */
481  if ( llf[1] > 2 ) {
482  WORD *t1, *t2;
483  if ( *term > AN.sizeselecttermundo ) {
484  if ( AN.selecttermundo ) M_free(AN.selecttermundo,"AN.selecttermundo");
485  AN.sizeselecttermundo = *term +10;
486  AN.selecttermundo = (WORD *)Malloc1(
487  AN.sizeselecttermundo*sizeof(WORD),"AN.selecttermundo");
488  }
489  t1 = term; t2 = AN.selecttermundo; i = *term;
490  NCOPY(t2,t1,i);
491  }
492  power = 1;
493  Substitute(BHEAD term,m,power);
494  if ( llf[1] > 2 ) {
495  if ( TestSelect(term,llf) ) {
496  WORD *t1, *t2;
497  power = 0;
498  t1 = term; t2 = AN.selecttermundo; i = *t2;
499  NCOPY(t1,t2,i);
500 #if IDHEAD > 3
501  if ( ( ll2 & SUBAFTERNOT ) != 0 ) {
502  *level = AC.Labels[ll[3]];
503  }
504 #endif
505  goto nextlevel;
506  }
507  }
508  if ( numdollars ) {
509  WildDollars(BHEAD (WORD *)0);
510  numdollars = 0;
511  }
512  match = 1;
513  if ( ( ll2 & SUBAFTER ) != 0 ) {
514  *level = AC.Labels[ll[3]];
515  }
516  }
517  else {
518  if ( ( ll2 & SUBAFTERNOT ) != 0 ) {
519  *level = AC.Labels[ll[3]];
520  }
521  power = 0;
522  }
523  goto nextlevel;
524  case SUBALL:
525  AN.UseFindOnly = 0;
526  CC = cbuf+AT.allbufnum;
527  oldallnumrhs = CC->numrhs;
528  t = AddRHS(AT.allbufnum,1);
529  *t = 0;
530  AT.idallflag = 1;
531  AT.idallmaxnum = ll[5];
532  AT.idallnum = 0;
533  if ( FindRest(BHEAD AN.termbuffer,m) || AT.idallflag > 1 ) {
534  WORD *t, *tstop, *tt, first = 1, ii;
535  power = 1;
536  *CC->Pointer++ = 0;
537  if ( msign ) term[term[0]-1] = -term[term[0]-1];
538 /*
539  If we come here the matches are all already in the
540  compiler buffer. All we need to do is take out all
541  functions and replace them by a SUBEXPRESSION that
542  points to this buffer.
543  Note: the PolyFun/PolyRatFun should be excluded from this.
544  This works because each match writes incrementally to
545  the buffer using the routine SubsInAll.
546 
547  The call to WildDollars should be made in Generator.....
548 */
549  t = term; tstop = t + *t; ii = ABS(tstop[-1]); tstop -= ii;
550  tt = AT.WorkPointer+1;
551  t++;
552  while ( t < tstop ) {
553  if ( *t >= FUNCTION && *t != AR.PolyFun && *t != AR.PolyFunInv ) {
554  if ( first ) { /* SUBEXPRESSION */
555  *tt++ = SUBEXPRESSION;
556  *tt++ = SUBEXPSIZE;
557  *tt++ = CC->numrhs;
558  *tt++ = 1;
559  *tt++ = AT.allbufnum;
560  FILLSUB(tt)
561  first = 0;
562  }
563  t += t[1];
564  }
565  else {
566  i = t[1]; NCOPY(tt,t,i);
567  }
568  }
569  if ( ( ll[4] & NORMALIZEFLAG ) != 0 ) {
570 /*
571  In case of the normalization option, we have to divide
572  by AT.idallnum;
573 */
574  WORD na = t[ii-1];
575  na = REDLENG(na);
576  for ( i = 0; i < ii; i++ ) tt[i] = t[i];
577  Divvy(BHEAD (UWORD *)tt,&na,(UWORD *)(&(AT.idallnum)),1);
578  na = INCLENG(na);
579  ii = ABS(na);
580  tt[ii-1] = na;
581  tt += ii;
582  }
583  else {
584  NCOPY(tt,t,ii);
585  }
586  ii = tt-AT.WorkPointer;
587  *(AT.WorkPointer) = ii;
588  tt = AT.WorkPointer; t = term;
589  NCOPY(t,tt,ii);
590 
591  if ( ( ll2 & SUBAFTER ) != 0 ) { /* ifmatch -> */
592  *level = AC.Labels[ll[3]];
593  }
594  TermFree(AN.termbuffer,"id,all");
595  AN.termbuffer = OldTermBuffer;
596  AT.WorkPointer = AN.RepFunList;
597  AT.idallflag = 0;
598  CC->Pointer[0] = 0;
599  TransferBuffer(AT.aebufnum,AT.ebufnum,AT.allbufnum);
600  return(1);
601  }
602  AT.idallflag = 0;
603  power = 0;
604  CC->numrhs = oldallnumrhs;
605  TermFree(AN.termbuffer,"id,all");
606  AN.termbuffer = OldTermBuffer;
607  break;
608  default :
609  break;
610  }
611  if ( power ) {
612  Substitute(BHEAD term,m,power);
613  if ( numdollars ) {
614  WildDollars(BHEAD (WORD *)0);
615  numdollars = 0;
616  }
617  match = 1;
618  if ( ( ll2 & SUBAFTER ) != 0 ) { /* ifmatch -> */
619  *level = AC.Labels[ll[3]];
620  }
621  }
622  else {
623  AT.WorkPointer = AN.RepFunList;
624  if ( ( ll2 & SUBAFTERNOT ) != 0 ) { /* ifnomatch -> */
625  *level = AC.Labels[ll[3]];
626  }
627  }
628 nextlevel:;
629  } while ( (*level)++ < AR.Cnumlhs && C->lhs[*level][0] == TYPEIDOLD );
630  (*level)--;
631  AT.WorkPointer = AN.RepFunList;
632  return(match);
633 }
634 
635 /*
636  #] TestMatch :
637  #[ Substitute : VOID Substitute(term,pattern,power)
638 */
639 
640 VOID Substitute(PHEAD WORD *term, WORD *pattern, WORD power)
641 {
642  GETBIDENTITY
643  WORD *TemTerm;
644  WORD *t, *m;
645  WORD *tstop, *mstop;
646  WORD *xstop, *ystop;
647  WORD nt, *fill, nq, mt;
648  WORD *q, *subterm, *tcoef, oldval1 = 0, newval3, i = 0;
649  WORD PutExpr = 0, sign = 0;
650  TemTerm = AT.WorkPointer;
651  if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
652  MLOCK(ErrorMessageLock);
653  MesWork();
654  MUNLOCK(ErrorMessageLock);
655  Terminate(-1);
656  }
657  m = pattern;
658  mstop = m + *m;
659  m++;
660  t = term;
661  t += *term - 1;
662  tcoef = t;
663  tstop = t - ABS(*t) + 1;
664  t = term;
665  t++;
666  fill = TemTerm;
667  fill++;
668  if ( m < mstop ) { do {
669 /*
670  #[ SYMBOLS :
671 */
672  if ( *m == SYMBOL ) {
673  ystop = m + m[1];
674  m += 2;
675  while ( *t != SYMBOL && t < tstop ) {
676  nq = t[1];
677  NCOPY(fill,t,nq);
678  }
679  if ( t >= tstop ) goto SubCoef;
680  *fill++ = SYMBOL;
681  fill++;
682  subterm = fill;
683  xstop = t + t[1];
684  t += 2;
685  do {
686  if ( *m == *t && t < xstop ) {
687  nt = t[1];
688  mt = m[1];
689  if ( mt >= 2*MAXPOWER ) {
690  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
691  nt -= AN.oldvalue;
692  goto SubsL1;
693  }
694  }
695  else if ( mt <= -2*MAXPOWER ) {
696  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
697  nt += AN.oldvalue;
698  goto SubsL1;
699  }
700  }
701  else {
702  nt -= mt * power;
703 SubsL1: if ( nt ) {
704  *fill++ = *t;
705  *fill++ = nt;
706  }
707  }
708  m += 2; t+= 2;
709  }
710  else if ( *m >= 2*MAXPOWER ) {
711  while ( t < xstop ) { *fill++ = *t++; *fill++ = *t++; }
712  nq = WORDDIF(fill,subterm);
713  fill = subterm;
714  while ( nq > 0 ) {
715  if ( !CheckWild(BHEAD *m-2*MAXPOWER,SYMTOSYM,*fill,&newval3) ) {
716  mt = m[1];
717  if ( mt >= 2*MAXPOWER ) {
718  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
719  if ( fill[1] -= AN.oldvalue ) goto SubsL2;
720  }
721  }
722  else if ( mt <= -2*MAXPOWER ) {
723  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
724  if ( fill[1] += AN.oldvalue ) goto SubsL2;
725  }
726  }
727  else {
728  if ( fill[1] -= mt * power ) {
729 SubsL2: fill += nq;
730  nq = 0;
731  }
732  }
733  break;
734  }
735  nq -= 2;
736  fill += 2;
737  }
738  if ( nq ) {
739  nq -= 2;
740  q = fill + 2;
741  while ( --nq >= 0 ) *fill++ = *q++;
742  }
743  m += 2;
744  }
745  else if ( *m < *t || t >= xstop ) { m += 2; }
746  else { *fill++ = *t++; *fill++ = *t++; }
747  } while ( m < ystop );
748  while ( t < xstop ) *fill++ = *t++;
749  nq = WORDDIF(fill,subterm);
750  if ( nq > 0 ) {
751  nq += 2;
752  subterm[-1] = nq;
753  }
754  else { fill = subterm; fill -= 2; }
755  }
756 /*
757  #] SYMBOLS :
758  #[ DOTPRODUCTS :
759 */
760  else if ( *m == DOTPRODUCT ) {
761  ystop = m + m[1];
762  m += 2;
763  while ( *t > DOTPRODUCT && t < tstop ) {
764  nq = t[1];
765  NCOPY(fill,t,nq);
766  }
767  if ( t >= tstop ) goto SubCoef;
768  if ( *t != DOTPRODUCT ) {
769  m = ystop;
770  goto EndLoop;
771  }
772  *fill++ = DOTPRODUCT;
773  fill++;
774  subterm = fill;
775  xstop = t + t[1];
776  t += 2;
777  do {
778  if ( *m == *t && m[1] == t[1] && t < xstop ) {
779  nt = t[2];
780  mt = m[2];
781  if ( mt >= 2*MAXPOWER ) {
782  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
783  nt -= AN.oldvalue;
784  goto SubsL3;
785  }
786  }
787  else if ( mt <= -2*MAXPOWER ) {
788  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
789  nt += AN.oldvalue;
790  goto SubsL3;
791  }
792  }
793  else {
794  nt -= mt * power;
795 SubsL3: if ( nt ) {
796  *fill++ = *t++;
797  *fill++ = *t;
798  *fill++ = nt;
799  t += 2;
800  }
801  else t += 3;
802  }
803  m += 3;
804  }
805  else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
806  while ( t < xstop ) {
807  *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
808  }
809  oldval1 = 1;
810  goto SubsL4;
811  }
812  else if ( m[1] >= (AM.OffsetVector+WILDOFFSET) ) {
813  while ( *m >= *t && t < xstop ) {
814  *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
815  }
816  oldval1 = 0;
817 SubsL4: nq = WORDDIF(fill,subterm);
818  fill = subterm;
819  while ( nq > 0 ) {
820  if ( ( oldval1 && ( (
821  !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3)
822  && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
823  ) || (
824  !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
825  && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,fill[1],&newval3)
826  ) ) ) || ( !oldval1 && ( (
827  *m == *fill
828  && !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,fill[1],&newval3)
829  ) || (
830  !CheckWild(BHEAD m[1]-WILDOFFSET,VECTOVEC,*fill,&newval3)
831  && *m == fill[1] ) ) ) ) {
832  mt = m[2];
833  if ( mt >= 2*MAXPOWER ) {
834  if ( CheckWild(BHEAD mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
835  if ( fill[2] -= AN.oldvalue )
836  goto SubsL5;
837  }
838  }
839  else if ( mt <= -2*MAXPOWER ) {
840  if ( CheckWild(BHEAD -mt-2*MAXPOWER,SYMTONUM,-MAXPOWER,&newval3) ) {
841  if ( fill[2] += AN.oldvalue )
842  goto SubsL5;
843  }
844  }
845  else {
846  if ( fill[2] -= mt * power ) {
847 SubsL5: fill += nq;
848  nq = 0;
849  }
850  }
851  m += 3;
852  break;
853  }
854  fill += 3; nq -= 3;
855  }
856  if ( nq ) {
857  nq -= 3;
858  q = fill + 3;
859  while ( --nq >= 0 ) *fill++ = *q++;
860  }
861  }
862  else if ( t >= xstop || *m < *t || ( *m == *t && m[1] < t[1] ) )
863  { m += 3; }
864  else {
865  *fill++ = *t++; *fill++ = *t++; *fill++ = *t++;
866  }
867  } while ( m < ystop );
868  while ( t < xstop ) *fill++ = *t++;
869  nq = WORDDIF(fill,subterm);
870  if ( nq > 0 ) {
871  nq += 2;
872  subterm[-1] = nq;
873  }
874  else { fill = subterm; fill -= 2; }
875  }
876 /*
877  #] DOTPRODUCTS :
878  #[ FUNCTIONS :
879 */
880  else if ( *m >= FUNCTION ) {
881  while ( *t >= FUNCTION || *t == SUBEXPRESSION ) {
882  nt = WORDDIF(t,term);
883  for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
884  if ( nt == AN.RepFunList[mt] ) break;
885  }
886  if ( mt >= AN.RepFunNum ) {
887  nq = t[1];
888  NCOPY(fill,t,nq);
889  }
890  else {
891  WORD *oldt = 0;
892  if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
893  oldt = t;
894  if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
895  *fill++ = GAMMA;
896  *fill++ = i + FUNHEAD+1;
897  FILLFUN(fill)
898  nq = i + 1;
899  t += FUNHEAD;
900  NCOPY(fill,t,nq);
901  }
902  t = oldt;
903  }
904  else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
905  && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
906  ) sign += AN.RepFunList[mt+1];
907  else if ( *m >= FUNCTION+WILDOFFSET
908  && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
909  ) sign += AN.RepFunList[mt+1];
910  if ( !PutExpr ) {
911  xstop = t + t[1];
912  t = AN.FullProto;
913  nq = t[1];
914  t[3] = power;
915  NCOPY(fill,t,nq);
916  t = xstop;
917  PutExpr = 1;
918  }
919  else t += t[1];
920  if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
921  i = oldt[1] - m[1] - i;
922  if ( i > 0 ) {
923  *fill++ = GAMMA;
924  *fill++ = i + FUNHEAD+1;
925  FILLFUN(fill)
926  *fill++ = oldt[FUNHEAD];
927  t = t - i;
928  NCOPY(fill,t,i);
929  }
930  }
931  break;
932  }
933  }
934  m += m[1];
935  }
936 /*
937  #] FUNCTIONS :
938  #[ VECTORS :
939 */
940  else if ( *m == VECTOR ) {
941  while ( *t > VECTOR ) {
942  nq = t[1];
943  NCOPY(fill,t,nq);
944  }
945  xstop = t + t[1];
946  ystop = m + m[1];
947  t += 2;
948  m += 2;
949  *fill++ = VECTOR;
950  fill++;
951  subterm = fill;
952  do {
953  if ( *m == *t && m[1] == t[1] ) {
954  m += 2; t += 2;
955  }
956  else if ( *m >= (AM.OffsetVector+WILDOFFSET) ) {
957  while ( t < xstop ) *fill++ = *t++;
958  nq = WORDDIF(fill,subterm);
959  fill = subterm;
960  if ( m[1] < (AM.OffsetIndex+WILDOFFSET) ) {
961  do {
962  if ( m[1] == fill[1] &&
963  !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
964  break;
965  fill += 2;
966  nq -= 2;
967  } while ( nq > 0 );
968  }
969  else { /* Double wildcard */
970  do {
971  if ( !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
972  && !CheckWild(BHEAD *m-WILDOFFSET,VECTOVEC,*fill,&newval3) )
973  break;
974  if ( *fill == oldval1 && fill[1] == AN.oldvalue ) break;
975  fill += 2;
976  nq -= 2;
977  } while ( nq > 0 );
978  }
979  nq -= 2;
980  q = fill + 2;
981  if ( nq > 0 ) { NCOPY(fill,q,nq); }
982  m += 2;
983  }
984  else if ( *m <= *t &&
985  m[1] >= (AM.OffsetIndex + WILDOFFSET) ) {
986  while ( *m == *t && t < xstop )
987  { *fill++ = *t++; *fill++ = *t++; }
988  nq = WORDDIF(fill,subterm);
989  fill = subterm;
990  do {
991  if ( *m == *fill &&
992  !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3) )
993  break;
994  nq -= 2;
995  fill += 2;
996  } while ( nq > 0 );
997  nq -= 2;
998  q = fill + 2;
999  if ( nq > 0 ) { NCOPY(fill,q,nq); }
1000  m += 2;
1001  }
1002  else { *fill++ = *t++; *fill++ = *t++; }
1003  } while ( m < ystop );
1004  while ( t < xstop ) *fill++ = *t++;
1005  nq = WORDDIF(fill,subterm);
1006  if ( nq > 0 ) {
1007  nq += 2;
1008  subterm[-1] = nq;
1009  }
1010  else { fill = subterm; fill -= 2; }
1011  }
1012 /*
1013  #] VECTORS :
1014  #[ INDICES :
1015 
1016  Currently without wildcards
1017 */
1018  else if ( *m == INDEX ) {
1019  while ( *t > INDEX ) {
1020  nq = t[1];
1021  NCOPY(fill,t,nq);
1022  }
1023  xstop = t + t[1];
1024  ystop = m + m[1];
1025  t += 2;
1026  m += 2;
1027  *fill++ = INDEX;
1028  fill++;
1029  subterm = fill;
1030  do {
1031  if ( *m == *t ) {
1032  m += 1; t += 1;
1033  }
1034  else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) {
1035  while ( t < xstop ) *fill++ = *t++;
1036  nq = WORDDIF(fill, subterm);
1037  fill = subterm;
1038  do {
1039  if ( !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3) ) {
1040  break;
1041  }
1042  fill += 1;
1043  nq -= 1;
1044  } while ( nq > 0 );
1045  nq -= 1;
1046  if ( nq > 0 ) {
1047  q = fill + 1;
1048  NCOPY(fill,q,nq);
1049  }
1050  m += 1;
1051  }
1052  else {
1053  *fill++ = *t++;
1054  }
1055  } while ( m < ystop );
1056  while ( t < xstop ) *fill++ = *t++;
1057  nq = WORDDIF(fill,subterm);
1058  if ( nq > 0 ) {
1059  nq += 2;
1060  subterm[-1] = nq;
1061  }
1062  else { fill = subterm; fill -= 2; }
1063  }
1064 /*
1065  #] INDICES :
1066  #[ DELTAS :
1067 */
1068  else if ( *m == DELTA ) {
1069  while ( *t > DELTA ) {
1070  nq = t[1];
1071  NCOPY(fill,t,nq);
1072  }
1073  xstop = t + t[1];
1074  ystop = m + m[1];
1075  t += 2;
1076  m += 2;
1077  *fill++ = DELTA;
1078  fill++;
1079  subterm = fill;
1080  do {
1081  if ( *t == *m && t[1] == m[1] ) { m += 2; t += 2; }
1082  else if ( *m >= (AM.OffsetIndex+WILDOFFSET) ) { /* Two dummies */
1083  while ( t < xstop ) *fill++ = *t++;
1084 /* fill = subterm; */
1085  oldval1 = 1;
1086  goto SubsL6;
1087  }
1088  else if ( m[1] >= (AM.OffsetIndex+WILDOFFSET) ) {
1089  while ( (*m == *t || *m == t[1] ) && ( t < xstop ) ) {
1090  *fill++ = *t++; *fill++ = *t++;
1091  }
1092  oldval1 = 0;
1093 SubsL6: nq = WORDDIF(fill,subterm);
1094  fill = subterm;
1095  do {
1096  if ( ( oldval1 && ( (
1097  !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,*fill,&newval3)
1098  && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1099  ) || (
1100  !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1101  && !CheckWild(BHEAD *m-WILDOFFSET,INDTOIND,fill[1],&newval3)
1102  ) ) ) || ( !oldval1 && ( (
1103  *m == *fill
1104  && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,fill[1],&newval3)
1105  ) || (
1106  *m == fill[1]
1107  && !CheckWild(BHEAD m[1]-WILDOFFSET,INDTOIND,*fill,&newval3)
1108  ) ) ) ) break;
1109  fill += 2;
1110  nq -= 2;
1111  } while ( nq > 0 );
1112  nq -= 2;
1113  if ( nq > 0 ) {
1114  q = fill + 2;
1115  NCOPY(fill,q,nq);
1116  }
1117  m += 2;
1118  }
1119  else {
1120  *fill++ = *t++; *fill++ = *t++;
1121  }
1122  } while ( m < ystop );
1123  while ( t < xstop ) *fill++ = *t++;
1124  nq = WORDDIF(fill,subterm);
1125  if ( nq > 0 ) {
1126  nq += 2;
1127  subterm[-1] = nq;
1128  }
1129  else { fill = subterm; fill -= 2; }
1130  }
1131 /*
1132  #] DELTAS :
1133 */
1134 EndLoop:;
1135  } while ( m < mstop ); }
1136  while ( t < tstop ) *fill++ = *t++;
1137 SubCoef:
1138  if ( !PutExpr ) {
1139  t = AN.FullProto;
1140  nq = t[1];
1141  t[3] = power;
1142  NCOPY(fill,t,nq);
1143  }
1144  t = tcoef;
1145  nq = ABS(*t);
1146  t = tstop;
1147  NCOPY(fill,t,nq);
1148  nq = WORDDIF(fill,TemTerm);
1149  fill = term;
1150  t = TemTerm;
1151  *fill++ = nq--;
1152  t++;
1153  NCOPY(fill,t,nq);
1154  if ( sign ) {
1155  if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
1156  }
1157  if ( AT.WorkPointer < fill ) AT.WorkPointer = fill;
1158  AN.RepFunNum = 0;
1159 }
1160 
1161 /*
1162  #] Substitute :
1163  #[ FindSpecial : WORD FindSpecial(term)
1164 
1165  Routine to detect symplifications regarding the special functions
1166  exponent, denominator.
1167 
1168 
1169 WORD FindSpecial(WORD *term)
1170 {
1171  WORD *t;
1172  WORD *tstop;
1173  t = term; t += *t - 1; tstop = t - ABS(*t) + 1; t = term;
1174  t++;
1175  if ( t < tstop ) { do {
1176  if ( *t == EXPONENT ) {
1177  Exponents can become simpler when:
1178  a: the exponent of an expression becomes an integer.
1179  b: The expression becomes zero.
1180  }
1181  else if ( *t == DENOMINATOR ) {
1182  Denominators can become simpler when:
1183  a: The denominator is a single term without functions.
1184  b: An overall coefficient can be removed.
1185  c: An overall object can be removed.
1186  The task is here to bring the denominator in an unique form.
1187  }
1188  t += *t;
1189  } while ( t < tstop ); }
1190  return(0);
1191 }
1192 
1193  #] FindSpecial :
1194  #[ FindAll : WORD FindAll(term,pattern,level,par)
1195 */
1196 
1197 WORD FindAll(PHEAD WORD *term, WORD *pattern, WORD level, WORD *par)
1198 {
1199  GETBIDENTITY
1200  WORD *t, *m, *r, *mm, rnum;
1201  WORD *tstop, *mstop, *TwoProto, *vwhere = 0, oldv, oldvv, vv, level2;
1202  WORD v, nq, OffNum = AM.OffsetVector + WILDOFFSET, i, ii = 0, jj;
1203  WORD fromindex, *intens, notflag1 = 0, notflag2 = 0;
1204  CBUF *C;
1205  C = cbuf+AM.rbufnum;
1206  v = pattern[3]; /* The vector to be found */
1207  m = t = term;
1208  m += *m;
1209  m -= ABS(m[-1]);
1210  t++;
1211  if ( t < m ) do {
1212  tstop = t + t[1];
1213  fromindex = 2;
1214 /*
1215  #[ VECTOR :
1216 */
1217  if ( *t == VECTOR ) {
1218  r = t;
1219  r += 2;
1220 InVect:
1221  while ( r < tstop ) {
1222  oldv = *r;
1223  if ( v >= OffNum ) {
1224  vwhere = AN.FullProto + 3 + SUBEXPSIZE;
1225  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1226  WORD *afirst, *alast, j;
1227  j = vwhere[3];
1228  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1229  else { notflag1 = 0; }
1230  afirst = SetElements + Sets[j].first;
1231  alast = SetElements + Sets[j].last;
1232  ii = 1;
1233  if ( notflag1 == 0 ) {
1234  do {
1235  if ( *afirst == *r ) {
1236  if ( vwhere[1] == SETTONUM ) {
1237  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1238  AN.FullProto[11+SUBEXPSIZE] = ii;
1239  }
1240  else if ( vwhere[4] >= 0 ) {
1241  oldv = *(afirst - Sets[j].first
1242  + Sets[vwhere[4]].first);
1243  }
1244  goto DoVect;
1245  }
1246  ii++;
1247  } while ( ++afirst < alast );
1248  }
1249  else {
1250  do {
1251  if ( *afirst == *r ) break;
1252  } while ( ++afirst < alast );
1253  if ( afirst >= alast ) goto DoVect;
1254  }
1255  }
1256  else goto DoVect;
1257  }
1258  else if ( v == *r ) {
1259 DoVect: m = AT.WorkPointer;
1260  tstop = t;
1261  t = term;
1262  mstop = t + *t;
1263  do { *m++ = *t++; } while ( t < tstop );
1264  vwhere = m;
1265  t = AN.FullProto;
1266  nq = t[1];
1267  t[3] = 1;
1268  NCOPY(m,t,nq);
1269  t = tstop;
1270  if ( fromindex == 1 ) m[-1] = FUNNYVEC;
1271  else m[-1] = r[1]; /* The index is always here! */
1272  if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1273  if ( vwhere[1] > 12+SUBEXPSIZE ) {
1274  vwhere[11+SUBEXPSIZE] = ii;
1275  vwhere[8+SUBEXPSIZE] = SYMTONUM;
1276  }
1277  if ( t[1] > fromindex+2 ) {
1278  *m++ = *t++;
1279  *m++ = *t++ - fromindex;
1280  while ( t < r ) *m++ = *t++;
1281  t += fromindex;
1282  }
1283  else t += t[1];
1284  do { *m++ = *t++; } while ( t < mstop );
1285  *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1286  m = AT.WorkPointer;
1287  t = term;
1288  NCOPY(t,m,nq);
1289  AT.WorkPointer = t;
1290  return(1);
1291  }
1292  r += fromindex;
1293  }
1294  }
1295 /*
1296  #] VECTOR :
1297  #[ DOTPRODUCT :
1298 */
1299  else if ( *t == DOTPRODUCT ) {
1300  r = t;
1301  r += 2;
1302  do {
1303  if ( ( i = r[2] ) < 0 ) goto NextDot;
1304  if ( *r == r[1] ) { /* p.p */
1305  oldv = *r;
1306  if ( v == *r ) { /* v.v */
1307 TwoVec: m = AT.WorkPointer;
1308  tstop = t;
1309  t = term;
1310  mstop = t + *t;
1311  do { *m++ = *t++; } while ( t < tstop );
1312  do {
1313  vwhere = m;
1314  t = AN.FullProto;
1315  nq = t[1];
1316  t[3] = 2;
1317  NCOPY(m,t,nq);
1318  m[-1] = ++AR.CurDum;
1319  if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1320  } while ( --i > 0 );
1321 CopRest: t = tstop;
1322  if ( t[1] > 5 ) {
1323  *m++ = *t++;
1324  *m++ = *t++ - 3;
1325  while ( t < r ) *m++ = *t++;
1326  t += 3;
1327  }
1328  else t += t[1];
1329  do { *m++ = *t++; } while ( t < mstop );
1330  *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1331  m = AT.WorkPointer;
1332  t = term;
1333  NCOPY(t,m,nq);
1334  AT.WorkPointer = t;
1335  return(1);
1336  }
1337  else if ( v >= OffNum ) { /* v?.v? */
1338  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1339  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1340  WORD *afirst, *alast, j;
1341  j = vwhere[3];
1342  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1343  else { notflag1 = 0; }
1344  afirst = SetElements + Sets[j].first;
1345  alast = SetElements + Sets[j].last;
1346  ii = 1;
1347  if ( notflag1 == 0 ) {
1348  do {
1349  if ( *afirst == *r ) {
1350  if ( vwhere[1] == SETTONUM ) {
1351  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1352  AN.FullProto[11+SUBEXPSIZE] = ii;
1353  }
1354  else if ( vwhere[4] >= 0 ) {
1355  oldv = *(afirst - Sets[j].first
1356  + Sets[vwhere[4]].first);
1357  }
1358  goto TwoVec;
1359  }
1360  ii++;
1361  } while ( ++afirst < alast );
1362  }
1363  else {
1364  do {
1365  if ( *afirst == *r ) break;
1366  } while ( ++afirst < alast );
1367  if ( afirst >= alast ) goto TwoVec;
1368  }
1369  }
1370  else goto TwoVec;
1371  }
1372  }
1373  else {
1374  if ( v == r[1] ) { r[1] = *r; *r = v; }
1375  oldv = *r;
1376  oldvv = r[1];
1377  if ( v == *r ) {
1378  if ( !par ) { while ( ++level <= AR.Cnumlhs
1379  && C->lhs[level][0] == TYPEIDOLD ) {
1380  m = C->lhs[level];
1381  m += IDHEAD;
1382  if ( m[-IDHEAD+2] == SUBVECTOR ) {
1383  if ( ( vv = m[m[1]+3] ) == r[1] ) {
1384 OnePV: TwoProto = AN.FullProto;
1385 TwoPV: m = AT.WorkPointer;
1386  tstop = t;
1387  t = term;
1388  mstop = t + *t;
1389  do { *m++ = *t++; } while ( t < tstop );
1390  do {
1391  t = AN.FullProto;
1392  vwhere = m + 3 +SUBEXPSIZE;
1393  nq = t[1];
1394  t[3] = 1;
1395  NCOPY(m,t,nq);
1396  m[-1] = ++AR.CurDum;
1397  if ( v >= OffNum ) *vwhere = oldv;
1398  if ( vwhere[-2-SUBEXPSIZE] > 12+SUBEXPSIZE ) {
1399  vwhere[8] = ii;
1400  vwhere[5] = SYMTONUM;
1401  }
1402  t = TwoProto;
1403  vwhere = m + 3+SUBEXPSIZE;
1404  mm = m;
1405  nq = t[1];
1406  t[3] = 1;
1407  NCOPY(m,t,nq);
1408 /*
1409  The next two lines repair a bug. without them it takes twice
1410  the rhs of the first vector.
1411 */
1412  mm[2] = C->lhs[level][IDHEAD+2];
1413  mm[4] = C->lhs[level][IDHEAD+4];
1414  m[-1] = AR.CurDum;
1415  if ( vv >= OffNum ) *vwhere = oldvv;
1416  } while ( --i > 0 );
1417  goto CopRest;
1418  }
1419  else if ( vv > OffNum ) {
1420  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1421  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1422  WORD *afirst, *alast, j;
1423  j = vwhere[3];
1424  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1425  else { notflag1 = 0; }
1426  afirst = SetElements + Sets[j].first;
1427  alast = SetElements + Sets[j].last;
1428  if ( notflag1 == 0 ) {
1429  ii = 1;
1430  do {
1431  if ( *afirst == r[1] ) {
1432  if ( vwhere[1] == SETTONUM ) {
1433  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1434  AN.FullProto[11+SUBEXPSIZE] = ii;
1435  }
1436  else if ( vwhere[4] >= 0 ) {
1437  oldvv = *(afirst - Sets[j].first
1438  + Sets[vwhere[4]].first);
1439  }
1440  goto OnePV;
1441  }
1442  ii++;
1443  } while ( ++afirst < alast );
1444  }
1445  else {
1446  do {
1447  if ( *afirst == *r ) break;
1448  } while ( ++afirst < alast );
1449  if ( afirst >= alast ) goto OnePV;
1450  }
1451  }
1452  else goto OnePV;
1453  }
1454  }
1455  }}
1456 /*
1457  v.q with v matching and no match for the q, also
1458  not in following idold statements.
1459  Notice that a following q.p? cannot match.
1460 */
1461  rnum = r[1];
1462 OneOnly: m = AT.WorkPointer;
1463  tstop = t;
1464  t = term;
1465  mstop = t + *t;
1466  do { *m++ = *t++; } while ( t < tstop );
1467  vwhere = m;
1468  t = AN.FullProto;
1469  nq = t[1];
1470  t[3] = i;
1471  NCOPY(m,t,nq);
1472  m[-4] = INDTOIND;
1473  m[-1] = rnum;
1474  if ( v >= OffNum ) vwhere[3+SUBEXPSIZE] = oldv;
1475  goto CopRest;
1476  }
1477  else if ( v >= OffNum ) {
1478  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1479  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1480  WORD *afirst, *alast, *bfirst, *blast, j;
1481  j = vwhere[3];
1482  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1483  else { notflag1 = 0; }
1484  afirst = SetElements + Sets[j].first;
1485  alast = SetElements + Sets[j].last;
1486  ii = 1;
1487  if ( notflag1 == 0 ) {
1488  do {
1489  if ( *afirst == *r ) {
1490  if ( vwhere[1] == SETTONUM ) {
1491  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1492  AN.FullProto[11+SUBEXPSIZE] = ii;
1493  }
1494  else if ( vwhere[4] >= 0 ) {
1495  oldv = *(afirst - Sets[j].first
1496  + Sets[vwhere[4]].first);
1497  }
1498 Hitlevel1: level2 = level;
1499  do {
1500  if ( !par ) m = C->lhs[level2];
1501  else m = par;
1502  m += IDHEAD;
1503  if ( m[-IDHEAD+2] == SUBVECTOR ) {
1504  if ( ( vv = m[m[1]+3] ) == r[1] )
1505  goto OnePV;
1506  else if ( vv >= OffNum ) {
1507  if ( m[SUBEXPSIZE+4] != FROMSET &&
1508  m[SUBEXPSIZE+4] != SETTONUM ) goto OnePV;
1509  j = m[SUBEXPSIZE+6];
1510  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag2 = 1; }
1511  else { notflag2 = 0; }
1512  bfirst = SetElements + Sets[j].first;
1513  blast = SetElements + Sets[j].last;
1514  jj = 1;
1515  if ( notflag2 == 0 ) {
1516  do {
1517  if ( *bfirst == r[1] ) {
1518  if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1519  m[SUBEXPSIZE+8] = SYMTONUM;
1520  m[SUBEXPSIZE+11] = jj;
1521  }
1522  else if ( m[SUBEXPSIZE+7] >= 0 ) {
1523  oldvv = *(bfirst - Sets[j].first
1524  + Sets[m[SUBEXPSIZE+7]].first);
1525  }
1526  goto OnePV;
1527  }
1528  jj++;
1529  } while ( ++bfirst < blast );
1530  }
1531  else {
1532  do {
1533  if ( *bfirst == r[1] ) break;
1534  } while ( ++bfirst < blast );
1535  if ( bfirst >= blast ) goto OnePV;
1536  }
1537  }
1538  }
1539  } while ( ++level2 < AR.Cnumlhs &&
1540  C->lhs[level2][0] == TYPEIDOLD );
1541  rnum = r[1];
1542  goto OneOnly;
1543  }
1544  else if ( *afirst == r[1] ) {
1545  if ( vwhere[1] == SETTONUM ) {
1546  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1547  AN.FullProto[11+SUBEXPSIZE] = ii;
1548  }
1549  else if ( vwhere[4] >= 0 ) {
1550  oldv = *(afirst - Sets[j].first
1551  + Sets[vwhere[4]].first);
1552  }
1553 Hitlevel2: level2 = level;
1554  while ( ++level2 < AR.Cnumlhs &&
1555  C->lhs[level2][0] == TYPEIDOLD ) {
1556  if ( !par ) m = C->lhs[level2];
1557  else m = par;
1558  m += IDHEAD;
1559  if ( m[-IDHEAD+2] == SUBVECTOR ) {
1560  if ( ( vv = m[6] ) == *r )
1561  goto OnePV;
1562  else if ( vv >= OffNum ) {
1563  if ( m[SUBEXPSIZE+4] != FROMSET && m[SUBEXPSIZE+4]
1564  != SETTONUM ) {
1565  j = *r;
1566  *r = r[1];
1567  r[1] = j;
1568  goto OnePV;
1569  }
1570  j = m[SUBEXPSIZE+6];
1571  bfirst = SetElements + Sets[j].first;
1572  blast = SetElements + Sets[j].last;
1573  jj = 1;
1574  do {
1575  if ( *bfirst == *r ) {
1576  if ( m[SUBEXPSIZE+4] == SETTONUM ) {
1577  m[SUBEXPSIZE+8] = SYMTONUM;
1578  m[SUBEXPSIZE+11] = jj;
1579  }
1580  else if ( m[SUBEXPSIZE+7] >= 0 ) {
1581  oldvv = *(bfirst - Sets[j].first
1582  + Sets[m[SUBEXPSIZE+7]].first);
1583  }
1584  j = *r;
1585  *r = r[1];
1586  r[1] = j;
1587  j = oldv; oldv = oldvv; oldvv = j;
1588  goto OnePV;
1589  }
1590  jj++;
1591  } while ( ++bfirst < blast );
1592  }
1593  }
1594  }
1595  jj = *r; *r = r[1]; r[1] = jj;
1596  jj = oldv; oldv = oldvv; oldvv = j;
1597  rnum = r[1];
1598  goto OneOnly;
1599  }
1600  ii++;
1601  } while ( ++afirst < alast );
1602  }
1603  else {
1604  do {
1605  if ( *afirst == *r ) break;
1606  } while ( ++afirst < alast );
1607  if ( afirst >= alast ) goto Hitlevel1;
1608  do {
1609  if ( *afirst == r[1] ) break;
1610  } while ( ++afirst < alast );
1611  if ( afirst >= alast ) goto Hitlevel2;
1612  }
1613  }
1614  else { /* Matches twice */
1615  vv = v;
1616  TwoProto = AN.FullProto;
1617  goto TwoPV;
1618  }
1619  }
1620  }
1621 NextDot: r += 3;
1622  } while ( r < tstop );
1623  }
1624 /*
1625  #] DOTPRODUCT :
1626  #[ LEVICIVITA :
1627 */
1628  else if ( *t == LEVICIVITA ) {
1629  intens = 0;
1630  r = t;
1631  r += FUNHEAD;
1632 OneVect:;
1633  while ( r < tstop ) {
1634  oldv = *r;
1635  if ( v >= OffNum && *r < -10 ) {
1636  vwhere = AN.FullProto + 3+SUBEXPSIZE;
1637  if ( vwhere[1] == FROMSET || vwhere[1] == SETTONUM ) {
1638  WORD *afirst, *alast, j;
1639  j = vwhere[3];
1640  if ( j > WILDOFFSET ) { j -= 2*WILDOFFSET; notflag1 = 1; }
1641  else { notflag1 = 0; }
1642  afirst = SetElements + Sets[j].first;
1643  alast = SetElements + Sets[j].last;
1644  ii = 1;
1645  if ( notflag1 == 0 ) {
1646  do {
1647  if ( *afirst == *r ) {
1648  if ( vwhere[1] == SETTONUM ) {
1649  AN.FullProto[8+SUBEXPSIZE] = SYMTONUM;
1650  AN.FullProto[11+SUBEXPSIZE] = ii;
1651  }
1652  else if ( vwhere[4] >= 0 ) {
1653  oldv = *(afirst - Sets[j].first
1654  + Sets[vwhere[4]].first);
1655  }
1656  goto DoVect;
1657  }
1658  ii++;
1659  } while ( ++afirst < alast );
1660  }
1661  else {
1662  do {
1663  if ( *afirst == *r ) break;
1664  } while ( ++afirst < alast );
1665  if ( afirst >= alast ) goto DoVect;
1666  }
1667  }
1668  else goto LeVect;
1669  }
1670  else if ( v == *r ) {
1671 LeVect: m = AT.WorkPointer;
1672  mstop = term + *term;
1673  t = term;
1674  *r = ++AR.CurDum;
1675  if ( intens ) *intens = DIRTYSYMFLAG;
1676  do { *m++ = *t++; } while ( t < tstop );
1677  t = AN.FullProto;
1678  nq = t[1];
1679  t[3] = 1;
1680  if ( v >= OffNum ) *vwhere = oldv;
1681  NCOPY(m,t,nq);
1682  m[-1] = AR.CurDum;
1683  t = tstop;
1684  do { *m++ = *t++; } while ( t < mstop );
1685  *AT.WorkPointer = nq = WORDDIF(m,AT.WorkPointer);
1686  m = AT.WorkPointer;
1687  t = term;
1688  NCOPY(t,m,nq);
1689  AT.WorkPointer = t;
1690  return(1);
1691  }
1692  r++;
1693  }
1694  }
1695 /*
1696  #] LEVICIVITA :
1697  #[ GAMMA :
1698 */
1699  else if ( *t == GAMMA ) {
1700  intens = 0;
1701  r = t;
1702  r += FUNHEAD+1;
1703  if ( r < tstop ) goto OneVect;
1704  }
1705 /*
1706  #] GAMMA :
1707  #[ INDEX :
1708 */
1709  else if ( *t == INDEX ) { /* The 'forgotten' part */
1710  r = t;
1711  r += 2;
1712  fromindex = 1;
1713  goto InVect;
1714  }
1715 /*
1716  #] INDEX :
1717  #[ FUNCTION :
1718 */
1719  else if ( *t >= FUNCTION ) {
1720  if ( *t >= FUNCTION
1721  && functions[*t-FUNCTION].spec >= TENSORFUNCTION
1722  && t[1] > FUNHEAD ) {
1723 /*
1724  Tensors are linear in their vectors!
1725 */
1726  r = t;
1727  r += FUNHEAD;
1728  intens = t+2;
1729  goto OneVect;
1730  }
1731  }
1732 /*
1733  #] FUNCTION :
1734 */
1735  t += t[1];
1736  } while ( t < m );
1737  return(0);
1738 }
1739 
1740 /*
1741  #] FindAll :
1742  #[ TestSelect :
1743 
1744  Returns 1 if any of the objects in any of the sets in setp
1745  occur anywhere in the term
1746 */
1747 
1748 int TestSelect(WORD *term, WORD *setp)
1749 {
1750  WORD *tstop, *t, *s, *el, *elstop, *termstop, *tt, n, ns;
1751  GETSTOP(term,tstop);
1752  term += 1;
1753  while ( term < tstop ) {
1754  switch ( *term ) {
1755  case SYMBOL:
1756  n = term[1] - 2;
1757  t = term + 2;
1758  while ( n > 0 ) {
1759  ns = setp[1] - 2;
1760  s = setp + 2;
1761  while ( --ns >= 0 ) {
1762  if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1763  el = SetElements + Sets[*s].first;
1764  elstop = SetElements + Sets[*s].last;
1765  while ( el < elstop ) {
1766  if ( *el++ == *t ) return(1);
1767  }
1768  s++;
1769  }
1770  n -= 2;
1771  t += 2;
1772  }
1773  break;
1774  case VECTOR:
1775  n = term[1] - 2;
1776  t = term + 2;
1777  while ( n > 0 ) {
1778  ns = setp[1] - 2;
1779  s = setp + 2;
1780  while ( --ns >= 0 ) {
1781  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1782  el = SetElements + Sets[*s].first;
1783  elstop = SetElements + Sets[*s].last;
1784  while ( el < elstop ) {
1785  if ( *el++ == *t ) return(1);
1786  }
1787  s++;
1788  }
1789  t++;
1790  ns = setp[1] - 2;
1791  s = setp + 2;
1792  while ( --ns >= 0 ) {
1793  if ( Sets[*s].type != CINDEX
1794  && Sets[*s].type != CNUMBER ) { s++; continue; }
1795  el = SetElements + Sets[*s].first;
1796  elstop = SetElements + Sets[*s].last;
1797  while ( el < elstop ) {
1798  if ( *el++ == *t ) return(1);
1799  }
1800  s++;
1801  }
1802  n -= 2;
1803  t++;
1804  }
1805  break;
1806  case INDEX:
1807  n = term[1] - 2;
1808  t = term + 2;
1809  goto dotensor;
1810  case DOTPRODUCT:
1811  n = term[1] - 2;
1812  t = term + 2;
1813  while ( n > 0 ) {
1814  ns = setp[1] - 2;
1815  s = setp + 2;
1816  while ( --ns >= 0 ) {
1817  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1818  el = SetElements + Sets[*s].first;
1819  elstop = SetElements + Sets[*s].last;
1820  while ( el < elstop ) {
1821  if ( *el++ == *t ) return(1);
1822  }
1823  s++;
1824  }
1825  t++;
1826  ns = setp[1] - 2;
1827  s = setp + 2;
1828  while ( --ns >= 0 ) {
1829  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1830  el = SetElements + Sets[*s].first;
1831  elstop = SetElements + Sets[*s].last;
1832  while ( el < elstop ) {
1833  if ( *el++ == *t ) return(1);
1834  }
1835  s++;
1836  }
1837  n -= 3;
1838  t += 2;
1839  }
1840  break;
1841  case DELTA:
1842  n = term[1] - 2;
1843  t = term + 2;
1844  goto dotensor;
1845  default:
1846  if ( *term < FUNCTION ) break;
1847  ns = setp[1] - 2;
1848  s = setp + 2;
1849  while ( --ns >= 0 ) {
1850  if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1851  el = SetElements + Sets[*s].first;
1852  elstop = SetElements + Sets[*s].last;
1853  while ( el < elstop ) {
1854  if ( *el++ == *term ) return(1);
1855  }
1856  s++;
1857  }
1858  if ( functions[*term-FUNCTION].spec ) {
1859  n = term[1] - FUNHEAD;
1860  t = term + FUNHEAD;
1861 dotensor:
1862  while ( n > 0 ) {
1863  ns = setp[1] - 2;
1864  s = setp + 2;
1865  while ( --ns >= 0 ) {
1866  if ( *t < MINSPEC ) {
1867  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1868  }
1869  else if ( *t >= 0 ) {
1870  if ( Sets[*s].type != CINDEX
1871  && Sets[*s].type != CNUMBER ) { s++; continue; }
1872  }
1873  else { s++; continue; }
1874  el = SetElements + Sets[*s].first;
1875  elstop = SetElements + Sets[*s].last;
1876  while ( el < elstop ) {
1877  if ( *el++ == *t ) return(1);
1878  }
1879  s++;
1880  }
1881  t++;
1882  n--;
1883  }
1884  }
1885  else {
1886  termstop = term + term[1];
1887  tt = term + FUNHEAD;
1888  while ( tt < termstop ) {
1889  if ( *tt < 0 ) {
1890  if ( *tt == -SYMBOL ) {
1891  ns = setp[1] - 2;
1892  s = setp + 2;
1893  while ( --ns >= 0 ) {
1894  if ( Sets[*s].type != CSYMBOL ) { s++; continue; }
1895  el = SetElements + Sets[*s].first;
1896  elstop = SetElements + Sets[*s].last;
1897  while ( el < elstop ) {
1898  if ( *el++ == tt[1] ) return(1);
1899  }
1900  s++;
1901  }
1902  tt += 2;
1903  }
1904  else if ( *tt == -VECTOR || *tt == -MINVECTOR ) {
1905  ns = setp[1] - 2;
1906  s = setp + 2;
1907  while ( --ns >= 0 ) {
1908  if ( Sets[*s].type != CVECTOR ) { s++; continue; }
1909  el = SetElements + Sets[*s].first;
1910  elstop = SetElements + Sets[*s].last;
1911  while ( el < elstop ) {
1912  if ( *el++ == tt[1] ) return(1);
1913  }
1914  s++;
1915  }
1916  tt += 2;
1917  }
1918  else if ( *tt == -INDEX ) {
1919  ns = setp[1] - 2;
1920  s = setp + 2;
1921  while ( --ns >= 0 ) {
1922  if ( Sets[*s].type != CINDEX
1923  && Sets[*s].type != CNUMBER ) { s++; continue; }
1924  el = SetElements + Sets[*s].first;
1925  elstop = SetElements + Sets[*s].last;
1926  while ( el < elstop ) {
1927  if ( *el++ == tt[1] ) return(1);
1928  }
1929  s++;
1930  }
1931  tt += 2;
1932  }
1933  else if ( *tt <= -FUNCTION ) {
1934  ns = setp[1] - 2;
1935  s = setp + 2;
1936  while ( --ns >= 0 ) {
1937  if ( Sets[*s].type != CFUNCTION ) { s++; continue; }
1938  el = SetElements + Sets[*s].first;
1939  elstop = SetElements + Sets[*s].last;
1940  while ( el < elstop ) {
1941  if ( *el++ == -(*tt) ) return(1);
1942  }
1943  s++;
1944  }
1945  tt++;
1946  }
1947  else tt += 2;
1948  }
1949  else {
1950  t = tt + ARGHEAD;
1951  tt += *tt;
1952  while ( t < tt ) {
1953  if ( TestSelect(t,setp) ) return(1);
1954  t += *t;
1955  }
1956  }
1957  }
1958  }
1959  break;
1960  }
1961  term += term[1];
1962  }
1963  return(0);
1964 }
1965 
1966 /*
1967  #] TestSelect :
1968  #[ SubsInAll : VOID SubsInAll()
1969 
1970  This routine takes a match in id,all and stores it away in
1971  the AT.allbufnum 'compiler' buffer, after taking out the pattern.
1972  The main problem here is that id,all usually has (lots of) wildcards
1973  and their assignments are on stack and the difficult ones are in
1974  AT.ebufnum. Popping the stack while looking for more matches would
1975  loose those. Hence we have to copy them into yet another compiler
1976  buffer: AT.aebufnum. Because this may involve many matches and
1977  because the original term has only a limited number of arguments,
1978  it will pay to look for already existing ones in this buffer.
1979  (to be done later).
1980 */
1981 
1982 VOID SubsInAll(PHEAD0)
1983 {
1984  GETBIDENTITY
1985  WORD *TemTerm;
1986  WORD *t, *m, *term;
1987  WORD *tstop, *mstop, *xstop;
1988  WORD nt, *fill, nq, mt;
1989  WORD *tcoef, i = 0;
1990  WORD PutExpr = 0, sign = 0;
1991 /*
1992  We start with building the term in the WorkSpace.
1993  Afterwards we will transfer it to AT.allbufnum.
1994  We have to make sure there is room in the WorkSpace.
1995 */
1996  AT.idallflag = 2;
1997  TemTerm = AT.WorkPointer;
1998  if ( ( (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2) ) > AT.WorkTop ) {
1999  MLOCK(ErrorMessageLock);
2000  MesWork();
2001  MUNLOCK(ErrorMessageLock);
2002  Terminate(-1);
2003  }
2004  m = AN.patternbuffer + IDHEAD; m += m[1];
2005  mstop = m + *m;
2006  m++;
2007  term = AN.termbuffer;
2008  tstop = term + *term; tcoef = tstop-1; tstop -= ABS(tstop[-1]);
2009  t = term;
2010  t++;
2011  fill = TemTerm;
2012  fill++;
2013  while ( m < mstop ) {
2014  while ( t < tstop ) {
2015  nt = WORDDIF(t,term);
2016  for ( mt = 0; mt < AN.RepFunNum; mt += 2 ) {
2017  if ( nt == AN.RepFunList[mt] ) break;
2018  }
2019  if ( mt >= AN.RepFunNum ) {
2020  nq = t[1];
2021  NCOPY(fill,t,nq);
2022  }
2023  else {
2024  WORD *oldt = 0;
2025  if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
2026  oldt = t;
2027  if ( ( i = AN.RepFunList[mt+1] ) > 0 ) {
2028  *fill++ = GAMMA;
2029  *fill++ = i + FUNHEAD+1;
2030  FILLFUN(fill)
2031  nq = i + 1;
2032  t += FUNHEAD;
2033  NCOPY(fill,t,nq);
2034  }
2035  t = oldt;
2036  }
2037  else if ( ( *t == LEVICIVITA ) || ( *t >= FUNCTION
2038  && (functions[*t-FUNCTION].symmetric & ~REVERSEORDER) == ANTISYMMETRIC )
2039  ) sign += AN.RepFunList[mt+1];
2040  else if ( *m >= FUNCTION+WILDOFFSET
2041  && (functions[*m-FUNCTION-WILDOFFSET].symmetric & ~REVERSEORDER) == ANTISYMMETRIC
2042  ) sign += AN.RepFunList[mt+1];
2043  if ( !PutExpr ) {
2044  WORD *pstart = fill, *p, *w, *ww;
2045  xstop = t + t[1];
2046  t = AN.FullProto;
2047  nq = t[1];
2048  t[3] = 1;
2049  NCOPY(fill,t,nq);
2050  t = xstop;
2051  PutExpr = 1;
2052 /*
2053  Here we need provisions for keeping wildcard matches
2054  that reside in AT.ebufnum. We will move them to
2055  AT.aebufnum.
2056  Problem: the SUBEXPRESSION assumes automatically
2057  that the compiler buffer is AT.ebufnum. We have to
2058  correct that in TranferBuffer.
2059 */
2060  p = pstart + SUBEXPSIZE;
2061  while ( p < fill ) {
2062  switch ( *p ) {
2063  case SYMTOSUB:
2064  case VECTOSUB:
2065  case INDTOSUB:
2066  case ARGTOARG:
2067  case ARLTOARL:
2068  w = cbuf[AT.ebufnum].rhs[p[3]];
2069  ww = cbuf[AT.ebufnum].rhs[p[3]+1];
2070 /*
2071  Here we could search for whether this
2072  object sits in the buffer already.
2073  To be done later.
2074  By the way: ww-w fits inside a WORD.
2075 */
2076  AddRHS(AT.aebufnum,1);
2077  AddNtoC(AT.aebufnum,ww-w,w,11);
2078  p[3] = cbuf[AT.aebufnum].numrhs;
2079  cbuf[AT.aebufnum].rhs[p[3]+1] = cbuf[AT.aebufnum].Pointer;
2080  p += p[1];
2081  break;
2082  case FROMSET:
2083  case SETTONUM:
2084  case LOADDOLLAR:
2085  p += p[1];
2086  break;
2087  default:
2088  p += p[1];
2089  break;
2090  }
2091 
2092  }
2093  }
2094  else t += t[1];
2095  if ( *m == GAMMA && m[1] != FUNHEAD+1 ) {
2096  i = oldt[1] - m[1] - i;
2097  if ( i > 0 ) {
2098  *fill++ = GAMMA;
2099  *fill++ = i + FUNHEAD+1;
2100  FILLFUN(fill)
2101  *fill++ = oldt[FUNHEAD];
2102  t = t - i;
2103  NCOPY(fill,t,i);
2104  }
2105  }
2106  break;
2107  }
2108  }
2109  m += m[1];
2110  }
2111  while ( t < tstop ) *fill++ = *t++;
2112  if ( !PutExpr ) {
2113  t = AN.FullProto;
2114  nq = t[1];
2115  t[3] = 1;
2116  NCOPY(fill,t,nq);
2117  }
2118  t = tcoef;
2119  nq = ABS(*t);
2120  t = tstop;
2121  NCOPY(fill,t,nq);
2122  if ( sign ) {
2123  if ( ( sign & 1 ) != 0 ) fill[-1] = -fill[-1];
2124  }
2125  *TemTerm = fill-TemTerm;
2126 /*
2127  And now we copy this to AT.allbufnum
2128 */
2129  AddNtoC(AT.allbufnum,TemTerm[0],TemTerm,12);
2130  cbuf[AT.allbufnum].Pointer[0] = 0;
2131  AN.RepFunNum = 0;
2132 }
2133 
2134 /*
2135  #] SubsInAll :
2136  #[ TransferBuffer :
2137 
2138  Adds the whole content of a (compiler)buffer to another buffer.
2139  In spectator we have an expression in the RHS that needs the
2140  wildcard resolutions adapted by an offset.
2141 */
2142 
2143 VOID TransferBuffer(int from,int to,int spectator)
2144 {
2145  CBUF *C = cbuf + spectator;
2146  CBUF *Cf = cbuf + from;
2147  CBUF *Ct = cbuf + to;
2148  int offset = Ct->numrhs;
2149  LONG i;
2150  WORD *t, *tt, *ttt, *tstop, size;
2151  for ( i = 1; i <= Cf->numrhs; i++ ) {
2152  size = Cf->rhs[i+1]-Cf->rhs[i];
2153  AddRHS(to,1);
2154  AddNtoC(to,size,Cf->rhs[i],13);
2155  }
2156  Ct->rhs[Ct->numrhs+1] = Ct->Pointer;
2157  Cf->numrhs = 0;
2158 /*
2159  Now we have to update the 'pointers' in the spectator.
2160 */
2161  t = C->rhs[C->numrhs];
2162  while ( *t ) {
2163  tt = t+1; t += *t;
2164  tstop = t-ABS(t[-1]);
2165  while ( tt < tstop ) {
2166  if ( *tt == SUBEXPRESSION ) {
2167  ttt = tt+SUBEXPSIZE; tt += tt[1];
2168  while ( ttt < tt ) {
2169  switch ( *ttt ) {
2170  case SYMTOSUB:
2171  case VECTOSUB:
2172  case INDTOSUB:
2173  case ARGTOARG:
2174  case ARLTOARL:
2175  ttt[3] += offset;
2176  break;
2177  default:
2178  break;
2179  }
2180  ttt += 4;
2181  }
2182  }
2183  else tt += tt[1];
2184  }
2185  }
2186 }
2187 
2188 /*
2189  #] TransferBuffer :
2190  #[ TakeIDfunction :
2191 */
2192 
2193 #define PutInBuffers(pow) \
2194  AddRHS(AT.ebufnum,1); \
2195  *out++ = SUBEXPRESSION; \
2196  *out++ = SUBEXPSIZE; \
2197  *out++ = C->numrhs; \
2198  *out++ = pow; \
2199  *out++ = AT.ebufnum; \
2200  FILLSUB(out) \
2201  r = AT.pWorkSpace[rhs+i]; \
2202  if ( *r > 0 ) { \
2203  oldinr = r[*r]; r[*r] = 0; \
2204  AddNtoC(AT.ebufnum,(*r+1-ARGHEAD),(r+ARGHEAD),14); \
2205  r[*r] = oldinr; \
2206  } \
2207  else { \
2208  ToGeneral(r,buffer,1); \
2209  buffer[buffer[0]] = 0; \
2210  AddNtoC(AT.ebufnum,buffer[0]+1,buffer,15); \
2211  }
2212 
2213 int TakeIDfunction(PHEAD WORD *term)
2214 {
2215  WORD *tstop, *t, *r, *m, *f, *nextf, *funstop, *left, *l, *newterm;
2216  WORD *out, oldinr, pow;
2217  WORD buffer[20];
2218  int i, ii, j, numsub, numfound = 0, first;
2219  LONG lhs,rhs;
2220  CBUF *C;
2221  GETSTOP(term,tstop);
2222  for ( t = term+1; t < tstop; t += t[1] ) { if ( *t == IDFUNCTION ) break; }
2223  if ( t >= tstop ) return(0);
2224 /*
2225  Step 1: test validity
2226 */
2227  funstop = t + t[1]; f = t + FUNHEAD;
2228  left = term + *term;
2229  l = left+1; numsub = 0;
2230  while ( f < funstop ) {
2231  nextf = f; NEXTARG(nextf)
2232  if ( nextf >= funstop ) { return(0); } /* odd number of arguments */
2233  if ( *f == -SYMBOL ) { *l++ = SYMBOL; *l++ = 4; *l++ = f[1]; *l++ = 1; }
2234  else if ( *f < -FUNCTION ) { *l++ = *f; *l++ = FUNHEAD; FILLFUN(l) }
2235  else if ( *f > 0 ) {
2236  if ( *f != f[ARGHEAD]+ARGHEAD ) goto noaction;
2237  if ( nextf[-1] != 3 || nextf[-2] != 1 || nextf[-3] != 1 ) goto noaction;
2238  if ( f[ARGHEAD] <= 4 ) goto noaction;
2239  if ( f[ARGHEAD] != f[ARGHEAD+2]+4 ) goto noaction;
2240  if ( f[ARGHEAD] == 8 && f[ARGHEAD+1] == SYMBOL ) {
2241  for ( i = 0; i < 4; i++ ) *l++ = f[ARGHEAD+1+i];
2242  }
2243  else if ( f[ARGHEAD] == 9 && f[ARGHEAD+1] == DOTPRODUCT ) {
2244  for ( i = 0; i < 5; i++ ) *l++ = f[ARGHEAD+1+i];
2245  }
2246  else if ( f[ARGHEAD+1] >= FUNCTION ) {
2247  for ( i = 0; i < f[ARGHEAD+1]-4; i++ ) *l++ = f[ARGHEAD+1+i];
2248  }
2249  else goto noaction;
2250  }
2251  else goto noaction;
2252  numsub++;
2253  f = nextf;
2254  NEXTARG(f)
2255  }
2256  C = cbuf+AT.ebufnum;
2257  AT.WorkPointer = l;
2258  *left = l-left;
2259 /*
2260  Put the pointers to the lhs and the rhs in the pointer workspace
2261 */
2262  WantAddPointers(2*numsub);
2263  lhs = AT.pWorkPointer;
2264  rhs = lhs+numsub;
2265  AT.pWorkPointer = rhs+numsub;
2266  f = t + FUNHEAD; l = left+1;
2267  for ( i = 0; i < numsub; i++ ) {
2268  AT.pWorkSpace[lhs+i] = l; l += l[1];
2269  NEXTARG(f);
2270  AT.pWorkSpace[rhs+i] = f;
2271  NEXTARG(f);
2272  }
2273 /*
2274  Take out the patterns and replace them by SUBEXPRESSIONs pointing at
2275  the e buffer. We put the resulting term above the left sides.
2276  Note that we take out only the first id_ if there is more than one!
2277 */
2278  first = 1;
2279  t = term+1; newterm = AT.WorkPointer; out = newterm+1;
2280  while ( t < tstop ) {
2281  if ( *t == IDFUNCTION && first ) { first = 0; t += t[1]; continue; }
2282  if ( *t >= FUNCTION ) {
2283  for ( i = 0; i < numsub; i++ ) {
2284  m = AT.pWorkSpace[lhs+i];
2285  if ( *m != *t ) continue;
2286  for ( j = 1; j < t[1]; j++ ) {
2287  if ( m[j] != t[j] ) break;
2288  }
2289  if ( j != t[1] ) continue;
2290  numfound++;
2291 /*
2292  We have a match! Set up a SUBEXPRESSION subterm and put the
2293  corresponding rhs in the eBuffer.
2294 */
2295  PutInBuffers(1)
2296  t += t[1];
2297  }
2298  if ( i == numsub ) { /* no match. Just copy to output. */
2299  j = t[1]; NCOPY(out,t,j)
2300  }
2301  }
2302  else if ( *t == SYMBOL ) {
2303  for ( i = 0; i < numsub; i++ ) {
2304  m = AT.pWorkSpace[lhs+i];
2305  if ( *m != SYMBOL ) continue;
2306  for ( ii = 2; ii < t[1]; ii += 2 ) {
2307  if ( m[2] != t[ii] ) continue;
2308  pow = t[ii+1]/m[3];
2309  if ( pow <= 0 ) continue;
2310  t[ii+1] = t[ii+1]%m[3];
2311  numfound++;
2312 /*
2313  Create the proper rhs in the eBuffer and set up a
2314  SUBEXPRESSION subterm.
2315 */
2316  PutInBuffers(pow)
2317  }
2318  }
2319 /*
2320  Now we copy whatever remains of the SYMBOL subterm to the output
2321 */
2322  m = out; *out++ = t[0]; *out++ = t[1];
2323  for ( ii = 2; ii < t[1]; ii += 2 ) {
2324  if ( t[ii+1] ) { *out++ = t[ii]; *out++ = t[ii+1]; }
2325  }
2326  m[1] = out-m;
2327  if ( m[1] == 2 ) out = m;
2328  t += t[1];
2329  }
2330  else if ( *t == DOTPRODUCT ) {
2331  for ( i = 0; i < numsub; i++ ) {
2332  m = AT.pWorkSpace[lhs+i];
2333  if ( *m != DOTPRODUCT ) continue;
2334  for ( ii = 2; ii < t[1]; ii += 3 ) {
2335  if ( m[2] != t[ii] || m[3] != t[ii+1] ) continue;
2336  pow = t[ii+2]/m[4];
2337  if ( pow <= 0 ) continue;
2338  t[ii+2] = t[ii+2]%m[4];
2339  numfound++;
2340 /*
2341  Create the proper rhs in the eBuffer and set up a
2342  SUBEXPRESSION subterm.
2343 */
2344  PutInBuffers(pow)
2345  }
2346  }
2347 /*
2348  Now we copy whatever remains of the DOTPRODUCT subterm to the output
2349 */
2350  m = out; *out++ = t[0]; *out++ = t[1];
2351  for ( ii = 2; ii < t[1]; ii += 3 ) {
2352  if ( t[ii+2] ) { *out++ = t[ii]; *out++ = t[ii+1]; *out++ = t[ii+2]; }
2353  }
2354  m[1] = out-m;
2355  if ( m[1] == 2 ) out = m;
2356  t += t[1];
2357  }
2358  else {
2359  j = t[1]; NCOPY(out,t,j)
2360  }
2361  }
2362 /*
2363  Copy the coefficient and set the size.
2364 */
2365  t = tstop; r = term+*term; while ( t < r ) *out++ = *t++;
2366  *newterm = out-newterm;
2367 /*
2368  Finally we move the new term over the original term.
2369 */
2370  i = *newterm;
2371  t = term; r = newterm; NCOPY(t,r,i)
2372 /*
2373  At this point we can return and if the calling Generator jumps back to
2374  its start, TestSub can take care of the expansions of SUBEXPRESSIONs.
2375 */
2376  AT.pWorkPointer = lhs;
2377  AT.WorkPointer = t;
2378  return(numfound);
2379 noaction:
2380  return(0);
2381 }
2382 
2383 /*
2384  #] TakeIDfunction :
2385  #] Patterns :
2386 */
2387 
#define PHEAD
Definition: ftypes.h:56
WORD ** lhs
Definition: structs.h:925
Definition: structs.h:921
WORD * Pointer
Definition: structs.h:924
int AddNtoC(int bufnum, int n, WORD *array, int par)
Definition: comtool.c:317
WORD ** rhs
Definition: structs.h:926
VOID LowerSortLevel()
Definition: sort.c:4610
WORD NewSort(PHEAD0)
Definition: sort.c:589
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3034
WORD TestMatch(PHEAD WORD *term, WORD *level)
Definition: pattern.c:97
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:675
WORD * AddRHS(int num, int type)
Definition: comtool.c:214