FORM  4.2
wildcard.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  #[ Includes : wildcard.c
40 */
41 
42 #include "form3.h"
43 
44 #define DEBUG(x)
45 
46 /*
47 #define DEBUG(x) x
48 
49  #] Includes :
50  #[ Wildcards :
51  #[ WildFill : WORD WildFill(to,from,sub)
52 
53  Takes the term in from and puts it into to while
54  making wildcard substitutions.
55  The return value is the number of words put in to.
56  The length as the first word of from is not copied.
57 
58  There are two possible algorithms:
59  1: For each element in `from': scan sub.
60  2: For each wildcard in sub replace elements in term.
61  The original algorithm used 1:
62 
63 */
64 
65 WORD WildFill(PHEAD WORD *to, WORD *from, WORD *sub)
66 {
67  GETBIDENTITY
68  WORD i, j, *s, *t, *m, len, dflag, odirt, adirt;
69  WORD *r, *u, *v, *w, *z, *zst, *zz, *subs, *accu, na, dirty = 0, *tstop;
70  WORD *temp = 0, *uu, *oldcpointer, sgn;
71  WORD subcount, setflag, *setlist = 0, si;
72  accu = oldcpointer = AR.CompressPointer;
73  t = sub;
74  t += sub[1];
75  s = sub + SUBEXPSIZE;
76  i = 0;
77  while ( s < t && *s != FROMBRAC ) {
78  i++; s += s[1];
79  }
80  if ( !i ) { /* No wildcards -> done quickly */
81  j = i = *from;
82  NCOPY(to,from,i);
83  if ( dirty ) AN.WildDirt = dirty;
84  return(j);
85  }
86  sgn = 0;
87  subs = sub + SUBEXPSIZE;
88  t = from;
89  GETSTOP(t,r);
90  t++;
91  m = to + 1;
92  if ( t < r ) do {
93  uu = u = t + t[1];
94  setflag = 0;
95 ReSwitch:
96  switch ( *t ) {
97  case SYMBOL:
98 /*
99  #[ SYMBOLS :
100 */
101  z = accu;
102  *m++ = *t++;
103  *m++ = *t++;
104  v = m;
105  while ( t < u ) {
106  *m = *t;
107  for ( si = 0; si < setflag; si += 2 ) {
108  if ( t == temp + setlist[si] ) goto sspow;
109  }
110  s = subs;
111  for ( j = 0; j < i; j++ ) {
112  if ( *t == s[2] ) {
113  if ( *s == SYMTOSYM ) {
114  *m = s[3]; dirty = 1;
115  break;
116  }
117  else if ( *s == SYMTONUM ) {
118  dirty = 1;
119  zst = z;
120  *z++ = SNUMBER;
121  *z++ = 4;
122  *z++ = s[3];
123  w = z;
124  *z++ = *++t;
125  if ( ABS(*t) >= 2*MAXPOWER) {
126 DoPow: s = subs;
127  for ( j = 0; j < i; j++ ) {
128  if ( ( *s == SYMTONUM ) &&
129  ( ABS(*t) - 2*MAXPOWER ) == s[2] ) {
130  dirty = 1;
131  *w = s[3];
132  if ( *t < 0 ) *w = -*w;
133  break;
134  }
135  if ( ( *s == SYMTOSYM ) &&
136  ( ABS(*t) - 2*MAXPOWER ) == s[2] ) {
137  dirty = 1;
138  zz = z;
139  while ( --zz >= zst ) {
140  zz[1+FUNHEAD+ARGHEAD] = *zz;
141  }
142  w += 1+FUNHEAD+ARGHEAD;
143  *zst = EXPONENT;
144  zst[2] = DIRTYFLAG;
145  zst[FUNHEAD+ARGHEAD] = WORDDIF(z,zst)+4;
146  zst[1+FUNHEAD] = 1;
147  zst[FUNHEAD] = WORDDIF(z,zst)+4+ARGHEAD;
148  z += FUNHEAD+ARGHEAD+1;
149  *w = 1; /* exponent -> 1 */
150  *z++ = 1;
151  *z++ = 1;
152  *z++ = 3;
153  if ( *t > 0 ) {
154  *z++ = -SYMBOL;
155  *z++ = s[3];
156  }
157  else {
158  *z++ = ARGHEAD+8;
159  *z++ = 1;
160  *z++ = 8;
161  *z++ = SYMBOL;
162  *z++ = 4;
163  *z++ = s[3];
164  *z++ = 1;
165  *z++ = 1;
166  *z++ = 1;
167  *z++ = -3;
168  }
169  zst[1] = WORDDIF(z,zst);
170  break;
171  }
172  if ( *s == SYMTOSUB &&
173  ( ABS(*t) - 2*MAXPOWER ) == s[2] ) {
174 MakeExp: dirty = 1;
175  zz = z;
176  while ( --zz >= zst ) {
177  zz[1+FUNHEAD+ARGHEAD] = *zz;
178  }
179  w += 1+FUNHEAD+ARGHEAD;
180  *zst = EXPONENT;
181  zst[2] = DIRTYFLAG;
182  zst[FUNHEAD+ARGHEAD] = WORDDIF(z,zst)+4;
183  zst[1+FUNHEAD] = 1;
184  zst[FUNHEAD] = WORDDIF(z,zst)+4+ARGHEAD;
185  z += FUNHEAD+ARGHEAD+1;
186  *w = 1; /* exponent -> 1 */
187  *z++ = 1;
188  *z++ = 1;
189  *z++ = 3;
190  *z++ = 4+SUBEXPSIZE+ARGHEAD;
191  *z++ = 1;
192  *z++ = 4+SUBEXPSIZE;
193  *z++ = SUBEXPRESSION;
194  *z++ = SUBEXPSIZE;
195  *z++ = s[3];
196  *z++ = 1;
197  *z++ = AT.ebufnum;
198  FILLSUB(z)
199  *z++ = 1;
200  *z++ = 1;
201  *z++ = *t > 0 ? 3: -3;
202  zst[1] = WORDDIF(z,zst);
203  break;
204  }
205  s += s[1];
206  }
207  }
208  if ( !*w ) z = w - 3;
209  t++;
210  goto Seven;
211  }
212  else if ( *s == SYMTOSUB ) {
213  dirty = 1;
214  zst = z;
215  *z++ = SUBEXPRESSION;
216  *z++ = SUBEXPSIZE;
217  *z++ = s[3];
218  w = z;
219  *z++ = *++t;
220  *z++ = AT.ebufnum;
221  FILLSUB(z)
222  goto DoPow;
223  }
224  }
225  s += s[1];
226  }
227 sspow:
228  s = subs;
229  *++m = *++t;
230  for ( si = 0; si < setflag; si += 2 ) {
231  if ( t == temp + setlist[si] ) {
232  t++; m++;
233  goto Seven;
234  }
235  }
236  for ( j = 0; j < i; j++ ) {
237  if ( ( ABS(*t) - 2*MAXPOWER ) == s[2] ) {
238  if ( *s == SYMTONUM ) {
239  dirty = 1;
240  *m = s[3];
241  if ( *t < 0 ) *m = -*m;
242  break;
243  }
244  else if ( *s == SYMTOSYM ) {
245  dirty = 1;
246  *z++ = EXPONENT;
247  if ( *t < 0 ) *z++ = FUNHEAD+ARGHEAD+10;
248  else *z++ = 4+FUNHEAD;
249  *z++ = 0;
250  FILLFUN3(z)
251  *z++ = -SYMBOL;
252  *z++ = m[-1];
253  if ( *t < 0 ) {
254  *z++ = ARGHEAD+8;
255  *z++ = 0;
256  *z++ = 8;
257  *z++ = SYMBOL;
258  *z++ = 4;
259  *z++ = s[3];
260  *z++ = 1;
261  *z++ = 1;
262  *z++ = 1;
263  *z = -3;
264  }
265  else {
266  *z++ = -SYMBOL;
267  *z++ = s[3];
268  }
269  m -= 2;
270  break;
271  }
272  else if ( *s == SYMTOSUB ) {
273  zst = z;
274  *z++ = SYMBOL;
275  *z++ = 4;
276  *z++ = *--m;
277  w = z;
278  *z++ = *t;
279  goto MakeExp;
280  }
281  }
282  s += s[1];
283  }
284  t++;
285  if ( *m ) m++;
286  else m--;
287 Seven:;
288  }
289  j = WORDDIF(m,v);
290  if ( !j ) m -= 2;
291  else v[-1] = j + 2;
292  s = accu;
293  while ( s < z ) *m++ = *s++;
294  break;
295 /*
296  #] SYMBOLS :
297 */
298  case DOTPRODUCT:
299 /*
300  #[ DOTPRODUCTS :
301 */
302  *m++ = *t++;
303  *m++ = *t++;
304  v = m;
305  z = accu;
306  while ( t < u ) {
307  *m = *t;
308  subcount = 0;
309  for ( si = 0; si < setflag; si += 2 ) {
310  if ( t == temp + setlist[si] ) goto ss2;
311  }
312  s = subs;
313  for ( j = 0; j < i; j++ ) {
314  if ( *t == s[2] ) {
315  if ( *s == VECTOVEC ) {
316  *m = s[3]; dirty = 1; break;
317  }
318  if ( *s == VECTOMIN ) {
319  *m = s[3]; dirty = 1; sgn += t[2]; break;
320  }
321  if ( *s == VECTOSUB ) {
322  *m = s[3]; dirty = 1; subcount = 1; break;
323  }
324  }
325  s += s[1];
326  }
327 ss2:
328  *++m = *++t;
329  s = subs;
330  for ( si = 0; si < setflag; si += 2 ) {
331  if ( t == temp + setlist[si] ) goto ss3;
332  }
333  for ( j = 0; j < i; j++ ) {
334  if ( *t == s[2] ) {
335  if ( *s == VECTOVEC ) {
336  *m = s[3]; dirty = 1; break;
337  }
338  if ( *s == VECTOMIN ) {
339  *m = s[3]; dirty = 1; sgn += t[1]; break;
340  }
341  if ( *s == VECTOSUB ) {
342  *m = s[3]; dirty = 1; subcount += 2; break;
343  }
344  }
345  s += s[1];
346  }
347 ss3: *++m = *++t;
348  if ( ( ABS(*t) - 2*MAXPOWER ) < 0 ) goto RegPow;
349  s = subs;
350  for ( j = 0; j < i; j++ ) {
351  if ( ( ABS(*t) - 2*MAXPOWER ) == s[2] ) {
352  if ( *s == SYMTONUM ) {
353  *m = s[3];
354  if ( *t < 0 ) *m = -*m;
355  dirty = 1;
356  break;
357  }
358  if ( *s <= SYMTOSUB ) {
359 /*
360  Here we put together a power function with the proper
361  arguments. Note that a p?.q? resolves to a single power.
362 */
363  m -= 2;
364  *z++ = EXPONENT;
365  w = z;
366  if ( subcount == 0 ) {
367  *z++ = 17+FUNHEAD+2*ARGHEAD;
368  *z++ = DIRTYFLAG;
369  FILLFUN3(z)
370  *z++ = 9+ARGHEAD;
371  *z++ = 0;
372  FILLARG(z)
373  *z++ = 9;
374  *z++ = DOTPRODUCT;
375  *z++ = 5;
376  *z++ = *m;
377  *z++ = m[1];
378  *z++ = 1;
379  *z++ = 1;
380  *z++ = 1;
381  *z++ = 3;
382  if ( *s == SYMTOSYM ) {
383  *z++ = 8+ARGHEAD;
384  *z++ = 0;
385  FILLARG(z)
386  *z++ = 8;
387  *z++ = SYMBOL;
388  *z++ = 4;
389  *z++ = s[3];
390  *z++ = 1;
391  }
392  else {
393  *z++ = 4+SUBEXPSIZE+ARGHEAD;
394  *z++ = 1;
395  FILLARG(z)
396  *z++ = 4+SUBEXPSIZE;
397  *z++ = SUBEXPRESSION;
398  *z++ = SUBEXPSIZE;
399  *z++ = s[3];
400  *z++ = 1;
401  *z++ = AT.ebufnum;
402  FILLSUB(z)
403  }
404  *z++ = 1; *z++ = 1;
405  *z++ = ( s[2] > 0 ) ? 3: -3;
406  }
407  else if ( subcount == 3 ) {
408  *z++ = 20+2*SUBEXPSIZE+FUNHEAD+2*ARGHEAD;
409  *z++ = DIRTYFLAG;
410  FILLFUN3(z)
411  *z++ = 12+2*SUBEXPSIZE+ARGHEAD;
412  *z++ = 1;
413  *z++ = 12+2*SUBEXPSIZE;
414  *z++ = SUBEXPRESSION;
415  *z++ = 4+SUBEXPSIZE;
416  *z++ = *m + 1;
417  *z++ = 1;
418  *z++ = AT.ebufnum;
419  FILLSUB(z)
420  *z++ = INDTOIND;
421  *z++ = 4;
422  *z++ = FUNNYVEC;
423  *z++ = ++AR.CurDum;
424 
425  *z++ = SUBEXPRESSION;
426  *z++ = 4+SUBEXPSIZE;
427  *z++ = m[1] + 1;
428  *z++ = 1;
429  *z++ = AT.ebufnum;
430  FILLSUB(z)
431  *z++ = INDTOIND;
432  *z++ = 4;
433  *z++ = FUNNYVEC;
434  *z++ = AR.CurDum;
435  *z++ = 1; *z++ = 1; *z++ = 3;
436  }
437  else {
438  if ( subcount == 2 ) {
439  j = *m; *m = m[1]; m[1] = j;
440  }
441  *z++ = 16+SUBEXPSIZE+FUNHEAD+2*ARGHEAD;
442  *z++ = DIRTYFLAG;
443  FILLFUN3(z)
444  *z++ = 8+SUBEXPSIZE+ARGHEAD;
445  *z++ = 1;
446  *z++ = 8+SUBEXPSIZE;
447  *z++ = SUBEXPRESSION;
448  *z++ = 4+SUBEXPSIZE;
449  *z++ = *m + 1;
450  *z++ = 1;
451  *z++ = AT.ebufnum;
452  FILLSUB(z)
453  *z++ = INDTOIND;
454  *z++ = 4;
455  *z++ = FUNNYVEC;
456  *z++ = m[1];
457  *z++ = 1; *z++ = 1; *z++ = 3;
458  }
459  if ( *s == SYMTOSYM ) {
460  if ( s[2] > 0 ) {
461  *z++ = -SYMBOL;
462  *z++ = s[3];
463  t++;
464  *w = z-w+1;
465  goto NextDot;
466  }
467  *z++ = 8+ARGHEAD;
468  *z++ = 0;
469  *z++ = 8;
470  *z++ = SYMBOL;
471  *z++ = 4;
472  *z++ = s[3];
473  *z++ = 1;
474  }
475  else {
476  *z++ = 4+SUBEXPSIZE+ARGHEAD;
477  *z++ = 1;
478  *z++ = 4+SUBEXPSIZE;
479  *z++ = SUBEXPRESSION;
480  *z++ = SUBEXPSIZE;
481  *z++ = s[3];
482  *z++ = 1;
483  *z++ = AT.ebufnum;
484  FILLSUB(z)
485  }
486  *z++ = 1; *z++ = 1;
487  *z++ = ( s[2] > 0 ) ? 3: -3;
488  t++;
489  *w = z-w+1;
490  goto NextDot;
491  }
492  }
493  s += s[1];
494  }
495 RegPow: if ( *m ) m++;
496  else { m -= 2; subcount = 0; }
497  t++;
498  if ( subcount ) {
499  m -= 3;
500  if ( subcount == 3 ) {
501  if ( m[2] < 0 ) {
502  j = (-m[2]) * (2*SUBEXPSIZE+8);
503  *z++ = DENOMINATOR;
504  *z++ = j + 8 + FUNHEAD + ARGHEAD;
505  *z++ = DIRTYFLAG;
506  FILLFUN3(z)
507  *z++ = j + 8 + ARGHEAD;
508  *z++ = 1;
509  *z++ = j + 8;
510  while ( m[2] < 0 ) {
511  (m[2])++;
512  *z++ = SUBEXPRESSION;
513  *z++ = 4+SUBEXPSIZE;
514  *z++ = *m + 1;
515  *z++ = 1;
516  *z++ = AT.ebufnum;
517  FILLSUB(z)
518  *z++ = INDTOIND;
519  *z++ = 4;
520  *z++ = FUNNYVEC;
521  *z++ = ++AR.CurDum;
522  *z++ = SUBEXPRESSION;
523  *z++ = 8+SUBEXPSIZE;
524  *z++ = m[1] + 1;
525  *z++ = 1;
526  *z++ = AT.ebufnum;
527  FILLSUB(z)
528  *z++ = INDTOIND;
529  *z++ = 4;
530  *z++ = FUNNYVEC;
531  *z++ = AR.CurDum;
532  *z++ = SYMTOSYM; /* Needed to avoid */
533  *z++ = 4; /* problems with */
534  *z++ = 1000; /* conversion to */
535  *z++ = 1000; /* square of subexp*/
536  }
537  *z++ = 1; *z++ = 1; *z++ = 3;
538  }
539  else {
540  while ( m[2] > 0 ) {
541  (m[2])--;
542  *z++ = SUBEXPRESSION;
543  *z++ = 4+SUBEXPSIZE;
544  *z++ = *m + 1;
545  *z++ = 1;
546  *z++ = AT.ebufnum;
547  FILLSUB(z)
548  *z++ = INDTOIND;
549  *z++ = 4;
550  *z++ = FUNNYVEC;
551  *z++ = ++AR.CurDum;
552  *z++ = SUBEXPRESSION;
553  *z++ = 4+SUBEXPSIZE;
554  *z++ = m[1] + 1;
555  *z++ = 1;
556  *z++ = AT.ebufnum;
557  FILLSUB(z)
558  *z++ = INDTOIND;
559  *z++ = 4;
560  *z++ = FUNNYVEC;
561  *z++ = AR.CurDum;
562  }
563  }
564  }
565  else {
566  if ( subcount == 2 ) {
567  j = *m; *m = m[1]; m[1] = j;
568  }
569  if ( m[2] < 0 ) {
570  *z++ = DENOMINATOR;
571  *z++ = 8+SUBEXPSIZE+FUNHEAD+ARGHEAD;
572  *z++ = DIRTYFLAG;
573  FILLFUN3(z)
574  *z++ = 8+SUBEXPSIZE+ARGHEAD;
575  *z++ = 1;
576  *z++ = 8+SUBEXPSIZE;
577  }
578  *z++ = SUBEXPRESSION;
579  *z++ = 4+SUBEXPSIZE;
580  *z++ = *m + 1;
581  *z++ = ABS(m[2]);
582  *z++ = AT.ebufnum;
583  FILLSUB(z)
584  *z++ = INDTOIND;
585  *z++ = 4;
586  *z++ = FUNNYVEC;
587  *z++ = m[1];
588  if ( m[2] < 0 ) {
589  *z++ = 1; *z++ = 1; *z++ = 3;
590  }
591  }
592  }
593 NextDot:;
594  }
595  if ( m <= v ) m = v - 2;
596  else v[-1] = WORDDIF(m,v) + 2;
597  if ( z > accu ) {
598  j = WORDDIF(z,accu);
599  z = accu;
600  NCOPY(m,z,j);
601  }
602  break;
603 /*
604  #] DOTPRODUCTS :
605 */
606  case SETSET:
607 /*
608  #[ SETS :
609 */
610  temp = accu + (((AR.ComprTop - accu)>>1)&(-2));
611  if ( ResolveSet(BHEAD t,temp,sub) ) {
612  Terminate(-1);
613  }
614  setlist = t + 2 + t[3];
615  setflag = t[1] - 2 - t[3]; /* Number of elements * 2 */
616  t = temp; u = t + t[1];
617  goto ReSwitch;
618 /*
619  #] SETS :
620 */
621  case VECTOR:
622 /*
623  #[ VECTORS :
624 */
625  *m++ = *t++;
626  *m++ = *t++;
627  v = m;
628  z = accu;
629  while ( t < u ) {
630  *m = *t;
631  for ( si = 0; si < setflag; si += 2 ) {
632  if ( t == temp + setlist[si] ) goto ss4;
633  }
634  s = subs;
635  for ( j = 0; j < i; j++ ) {
636  if ( *t == s[2] ) {
637  if ( *s == INDTOIND || *s == VECTOVEC ) {
638  *m = s[3]; dirty = 1; break;
639  }
640  if ( *s == VECTOMIN ) {
641  *m = s[3]; dirty = 1; sgn++; break;
642  }
643  else if ( *s == VECTOSUB ) {
644  *z++ = SUBEXPRESSION;
645  *z++ = 4+SUBEXPSIZE;
646  *z++ = s[3]+1;
647  *z++ = 1;
648  *z++ = AT.ebufnum;
649  FILLSUB(z)
650  *z++ = VECTOVEC;
651  *z++ = 4;
652  *z++ = FUNNYVEC;
653  *z++ = *++t;
654  m--;
655  s = subs;
656  for ( j = 0; j < i; j++ ) {
657  if ( z[-1] == s[2] ) {
658  if ( *s == INDTOIND || *s == VECTOVEC ) {
659  z[-1] = s[3];
660  break;
661  }
662  if ( *s == INDTOSUB || *s == VECTOSUB ) {
663  z[-1] = ++AR.CurDum;
664  *z++ = SUBEXPRESSION;
665  *z++ = 4+SUBEXPSIZE;
666  *z++ = s[3]+1;
667  *z++ = 1;
668  *z++ = AT.ebufnum;
669  FILLSUB(z)
670  if ( *s == INDTOSUB ) *z++ = INDTOIND;
671  else *z++ = VECTOSUB;
672  *z++ = 4;
673  *z++ = FUNNYVEC;
674  *z++ = AR.CurDum;
675  break;
676  }
677  }
678  s += s[1];
679  }
680  dirty = 1;
681  break;
682  }
683  else if ( *s == INDTOSUB ) {
684  *z++ = SUBEXPRESSION;
685  *z++ = 4+SUBEXPSIZE;
686  *z++ = s[3]+1;
687  *z++ = 1;
688  *z++ = AT.ebufnum;
689  FILLSUB(z)
690  *z++ = INDTOIND;
691  *z++ = 4;
692  *z++ = FUNNYVEC;
693  m -= 2;
694  *z++ = m[1];
695  dirty = 1;
696  t++;
697  break;
698  }
699  }
700  s += s[1];
701  }
702 ss4: m++; t++;
703  }
704  if ( m <= v ) m = v-2;
705  else v[-1] = WORDDIF(m,v)+2;
706  if ( z > accu ) {
707  j = WORDDIF(z,accu); z = accu;
708  NCOPY(m,z,j);
709  }
710  break;
711 /*
712  #] VECTORS :
713 */
714  case INDEX:
715 /*
716  #[ INDEX :
717 */
718  *m++ = *t++;
719  *m++ = *t++;
720  v = m;
721  z = accu;
722  while ( t < u ) {
723  *m = *t;
724  for ( si = 0; si < setflag; si += 2 ) {
725  if ( t == temp + setlist[si] ) goto ss5;
726  }
727  s = subs;
728  for ( j = 0; j < i; j++ ) {
729  if ( *t == s[2] ) {
730  if ( *s == INDTOIND || *s == VECTOVEC )
731  { *m = s[3]; dirty = 1; break; }
732  if ( *s == VECTOMIN )
733  { *m = s[3]; dirty = 1; sgn++; break; }
734  else if ( *s == VECTOSUB || *s == INDTOSUB ) {
735  *z++ = SUBEXPRESSION;
736  *z++ = SUBEXPSIZE;
737  *z++ = s[3];
738  *z++ = 1;
739  *z++ = AT.ebufnum;
740  FILLSUB(z)
741  m--;
742  dirty = 1;
743  break;
744  }
745  }
746  s += s[1];
747  }
748 ss5: m++; t++;
749  }
750  if ( m <= v ) m = v-2;
751  else v[-1] = WORDDIF(m,v)+2;
752  if ( z > accu ) {
753  j = WORDDIF(z,accu); z = accu;
754  NCOPY(m,z,j);
755  }
756  break;
757 /*
758  #] INDEX :
759 */
760  case DELTA:
761  case LEVICIVITA:
762  case GAMMA:
763 /*
764  #[ SPECIALS :
765 */
766  v = m;
767  *m++ = *t++;
768  *m++ = *t++;
769 #if FUNHEAD > 2
770  if ( t[-2] != DELTA ) *m++ = *t++;
771 #endif
772 Tensors:
773  COPYFUN3(m,t)
774  z = accu;
775  while ( t < u ) {
776  *m = *t;
777  for ( si = 0; si < setflag; si += 2 ) {
778  if ( t == temp + setlist[si] ) goto ss6;
779  }
780  s = subs;
781  if ( *m == FUNNYWILD ) {
782  CBUF *C = cbuf+AT.ebufnum;
783  t++;
784  for ( j = 0; j < i; j++ ) {
785  if ( *s == ARGTOARG && *t == s[2] ) {
786  v[2] |= DIRTYFLAG;
787  if ( s[3] < 0 ) { /* empty */
788  t++; break;
789  }
790  w = C->rhs[s[3]];
791 DEBUG(MesPrint("Thread %w(a): s[3] = %d, w=(%d,%d,%d,%d)",s[3],w[0],w[1],w[2],w[3]);)
792  j = *w++;
793  if ( j > 0 ) {
794  NCOPY(m,w,j);
795  }
796  else {
797  while ( *w ) {
798  if ( *w == -INDEX || *w == -VECTOR
799  || *w == -MINVECTOR
800  || ( *w == -SNUMBER && w[1] >= 0
801  && w[1] < AM.OffsetIndex ) ) {
802  if ( *w == -MINVECTOR ) sgn++;
803  w++;
804  *m++ = *w++;
805  }
806  else {
807  MLOCK(ErrorMessageLock);
808 DEBUG(MesPrint("Thread %w(aa): *w = %d",*w);)
809  MesPrint("Illegal substitution of argument field in tensor");
810  MUNLOCK(ErrorMessageLock);
811  SETERROR(-1)
812  }
813  }
814  }
815  t++;
816  break;
817  }
818  s += s[1];
819  }
820  }
821  else {
822  for ( j = 0; j < i; j++ ) {
823  if ( *t == s[2] ) {
824  if ( *s == INDTOIND || *s == VECTOVEC )
825  { *m = s[3]; dirty = 1; break; }
826  if ( *s == VECTOMIN )
827  { *m = s[3]; dirty = 1; sgn++; break; }
828  else if ( *s == VECTOSUB || *s == INDTOSUB ) {
829  *m = ++AR.CurDum;
830  *z++ = SUBEXPRESSION;
831  *z++ = 4+SUBEXPSIZE;
832  *z++ = s[3]+1;
833  *z++ = 1;
834  *z++ = AT.ebufnum;
835  FILLSUB(z)
836  *z++ = INDTOIND;
837  *z++ = 4;
838  *z++ = FUNNYVEC;
839  *z++ = AR.CurDum;
840  dirty = 1;
841  break;
842  }
843  }
844  s += s[1];
845  }
846  if ( j < i && *v != DELTA ) v[2] |= DIRTYFLAG;
847 ss6: m++; t++;
848  }
849  }
850  v[1] = WORDDIF(m,v);
851  if ( z > accu ) {
852  j = WORDDIF(z,accu); z = accu;
853  NCOPY(m,z,j);
854  }
855  break;
856 /*
857  #] SPECIALS :
858 */
859  case SUBEXPRESSION:
860 /*
861  #[ SUBEXPRESSION :
862 */
863  dirty = 1;
864  tstop = t + t[1];
865  *m++ = *t++;
866  *m++ = *t++;
867  *m++ = *t++;
868  *m++ = *t++;
869  if ( t[-1] >= 2*MAXPOWER || t[-1] <= -2*MAXPOWER ) {
870  s = subs;
871  for ( j = 0; j < i; j++ ) {
872  if ( *s == SYMTONUM &&
873  ( ABS(t[-1]) - 2*MAXPOWER ) == s[2] ) {
874  m[-1] = s[3];
875  if ( t[-1] < 0 ) m[-1] = -m[-1];
876  break;
877  }
878  s += s[1];
879  }
880  }
881  *m++ = *t++;
882  COPYSUB(m,t)
883  while ( t < tstop ) {
884  for ( si = 0; si < setflag; si += 2 ) {
885  if ( t == temp + setlist[si] - 2 ) goto ss7;
886  }
887  s = subs;
888  for ( j = 0; j < i; j++ ) {
889  if ( s[2] == t[2] ) {
890  if ( ( *s <= SYMTOSUB && *t <= SYMTOSUB )
891  || ( *s == *t && *s < FROMBRAC )
892  || ( *s == VECTOVEC && ( *t == VECTOSUB || *t == VECTOMIN ) )
893  || ( *s == VECTOSUB && ( *t == VECTOVEC || *t == VECTOMIN ) )
894  || ( *s == VECTOMIN && ( *t == VECTOSUB || *t == VECTOVEC ) )
895  || ( *s == INDTOIND && *t == INDTOSUB )
896  || ( *s == INDTOSUB && *t == INDTOIND ) ) {
897  WORD *vv = m;
898 /* *t = *s; Wrong!!! Overwrites compiler buffer */
899  j = t[1];
900  NCOPY(m,t,j);
901  vv[0] = s[0];
902  vv[3] = s[3];
903  goto sr7;
904  }
905  }
906  s += s[1];
907  }
908 ss7: j = t[1];
909  NCOPY(m,t,j);
910 sr7:;
911  }
912  break;
913 /*
914  #] SUBEXPRESSION :
915 */
916  case EXPRESSION:
917 /*
918  #[ EXPRESSION :
919 */
920  dirty = 1;
921  tstop = t + t[1];
922  v = m;
923  *m++ = *t++;
924  *m++ = *t++;
925  *m++ = *t++;
926  *m++ = *t++;
927  s = subs;
928  for ( j = 0; j < i; j++ ) {
929  if ( ( ABS(t[-1]) - 2*MAXPOWER ) == s[2] ) {
930  if ( *s == SYMTONUM ) {
931  m[-1] = s[3];
932  if ( t[-1] < 0 ) m[-1] = -m[-1];
933  break;
934  }
935  else if ( *s <= SYMTOSUB ) {
936  MLOCK(ErrorMessageLock);
937  MesPrint("Wildcard power of expression should be a number");
938  MUNLOCK(ErrorMessageLock);
939  SETERROR(-1)
940  }
941  }
942  s += s[1];
943  }
944  *m++ = *t++;
945  COPYSUB(m,t)
946  while ( t < tstop && *t != WILDCARDS ) {
947  j = t[1];
948  NCOPY(m,t,j);
949  }
950  if ( t < tstop && *t == WILDCARDS ) {
951  *m++ = *t;
952  s = sub;
953  j = s[1];
954  *m++ = j+2;
955  NCOPY(m,s,j);
956  t += t[1];
957  }
958  if ( t < tstop && *t == FROMBRAC ) {
959  w = m;
960  *m++ = *t;
961  *m++ = t[1];
962  if ( WildFill(BHEAD m,t+2,sub) < 0 ) {
963  MLOCK(ErrorMessageLock);
964  MesCall("WildFill");
965  MUNLOCK(ErrorMessageLock);
966  SETERROR(-1)
967  }
968  m += *m;
969  w[1] = m - w;
970  t += t[1];
971  }
972  while ( t < tstop ) {
973  j = t[1];
974  NCOPY(m,t,j);
975  }
976  v[1] = m-v;
977  break;
978 /*
979  #] EXPRESSION :
980 */
981  default:
982 /*
983  #[ FUNCTIONS :
984 */
985  if ( *t >= FUNCTION ) {
986  dflag = 0;
987  na = 0;
988  *m = *t;
989  for ( si = 0; si < setflag; si += 2 ) {
990  if ( t == temp + setlist[si] ) {
991  dflag = DIRTYFLAG; goto ss8;
992  }
993  }
994  s = subs;
995  for ( j = 0; j < i; j++ ) {
996  if ( *s == FUNTOFUN && *t == s[2] )
997  { *m = s[3]; dirty = 1; dflag = DIRTYFLAG; break; }
998  s += s[1];
999  }
1000 ss8: v = m;
1001  if ( *t >= FUNCTION && functions[*t-FUNCTION].spec
1002  >= TENSORFUNCTION ) {
1003  if ( *m < FUNCTION || functions[*m-FUNCTION].spec
1004  < TENSORFUNCTION ) {
1005  MLOCK(ErrorMessageLock);
1006  MesPrint("Illegal wildcarding of regular function to tensorfunction");
1007  MUNLOCK(ErrorMessageLock);
1008  SETERROR(-1)
1009  }
1010  m++; t++;
1011  *m++ = *t++;
1012  *m++ = *t++ | dflag;
1013  goto Tensors;
1014  }
1015  m++; t++;
1016  *m++ = *t++;
1017  *m++ = *t++ | dflag;
1018  COPYFUN3(m,t)
1019  z = accu;
1020  while ( t < u ) { /* do an argument */
1021  if ( *t < 0 ) {
1022 /*
1023  #[ Simple arguments :
1024 */
1025  CBUF *C = cbuf+AT.ebufnum;
1026  for ( si = 0; si < setflag; si += 2 ) {
1027  if ( *t <= -FUNCTION ) {
1028  if ( t == temp + setlist[si] ) {
1029  v[2] |= DIRTYFLAG; goto ss10; }
1030  }
1031  else {
1032  if ( t == temp + setlist[si]-1 ) {
1033  v[2] |= DIRTYFLAG; goto ss9; }
1034  }
1035  }
1036  if ( *t == -ARGWILD ) {
1037  s = subs;
1038  for ( j = 0; j < i; j++ ) {
1039  if ( *s == ARGTOARG && s[2] == t[1] ) break;
1040  s += s[1];
1041  }
1042  v[2] |= DIRTYFLAG;
1043  w = C->rhs[s[3]];
1044 DEBUG(MesPrint("Thread %w(b): s[3] = %d, w=(%d,%d,%d,%d)",s[3],w[0],w[1],w[2],w[3]);)
1045  if ( *w == 0 ) {
1046  w++;
1047  while ( *w ) {
1048  if ( *w > 0 ) j = *w;
1049  else if ( *w <= -FUNCTION ) j = 1;
1050  else j = 2;
1051  NCOPY(m,w,j);
1052  }
1053  }
1054  else {
1055  j = *w++;
1056  while ( --j >= 0 ) {
1057  if ( *w < MINSPEC ) *m++ = -VECTOR;
1058  else if ( *w >= 0 && *w < AM.OffsetIndex )
1059  *m++ = -SNUMBER;
1060  else *m++ = -INDEX;
1061  *m++ = *w++;
1062  }
1063  }
1064  t += 2;
1065  dirty = 1;
1066  if ( ( *v == NUMARGSFUN || *v == NUMTERMSFUN )
1067  && t >= u && m == v + FUNHEAD ) {
1068  m = v;
1069  *m++ = SNUMBER; *m++ = 3; *m++ = 0;
1070  break;
1071  }
1072  }
1073  else if ( *t <= -FUNCTION ) {
1074  *m = *t;
1075  s = subs;
1076  for ( j = 0; j < i; j++ ) {
1077  if ( -*t == s[2] ) {
1078  if ( *s == FUNTOFUN )
1079  { *m = -s[3]; dirty = 1; v[2] |= DIRTYFLAG; break; }
1080  }
1081  s += s[1];
1082  }
1083  m++; t++;
1084  }
1085  else if ( *t == -SYMBOL ) {
1086  *m++ = *t++;
1087  *m = *t;
1088  s = subs;
1089  for ( j = 0; j < i; j++ ) {
1090  if ( *t == s[2] && *s <= SYMTOSUB ) {
1091  dirty = 1; v[2] |= DIRTYFLAG;
1092  if ( AR.PolyFunType == 2 && v[0] == AR.PolyFun )
1093  v[2] |= MUSTCLEANPRF;
1094  if ( *s == SYMTOSYM ) *m = s[3];
1095  else if ( *s == SYMTONUM ) {
1096  m[-1] = -SNUMBER;
1097  *m = s[3];
1098  }
1099  else if ( *s == SYMTOSUB ) {
1100 ToSub: m--;
1101  w = C->rhs[s[3]];
1102 DEBUG(MesPrint("Thread %w(c): s[3] = %d, w=(%d,%d,%d,%d)",s[3],w[0],w[1],w[2],w[3]);)
1103  s = m;
1104  m += 2;
1105  while ( *w ) {
1106  j = *w;
1107  NCOPY(m,w,j);
1108  }
1109  *s = WORDDIF(m,s);
1110  s[1] = 0;
1111  *m = 0;
1112  if ( t[-1] == -MINVECTOR ) {
1113  w = s+2;
1114  while ( *w ) {
1115  w += *w;
1116  w[-1] = -w[-1];
1117  }
1118  }
1119  if ( ToFast(s,s) ) {
1120  if ( *s <= -FUNCTION ) m = s;
1121  else m = s + 1;
1122  }
1123  else m--;
1124  }
1125  break;
1126  }
1127  s += s[1];
1128  }
1129  m++; t++;
1130  }
1131  else if ( *t == -INDEX ) {
1132  *m++ = *t++;
1133  *m = *t;
1134  s = subs;
1135  for ( j = 0; j < i; j++ ) {
1136  if ( *t == s[2] ) {
1137  if ( *s == INDTOIND || *s == VECTOVEC ) {
1138  *m = s[3];
1139  if ( *m < MINSPEC ) m[-1] = -VECTOR;
1140  else if ( *m >= 0 && *m < AM.OffsetIndex )
1141  m[-1] = -SNUMBER;
1142  else m[-1] = -INDEX;
1143  }
1144  else if ( *s == VECTOSUB || *s == INDTOSUB ) {
1145  m[-1] = -INDEX;
1146  *m = ++AR.CurDum;
1147  *z++ = SUBEXPRESSION;
1148  *z++ = 4+SUBEXPSIZE;
1149  *z++ = s[3]+1;
1150  *z++ = 1;
1151  *z++ = AT.ebufnum;
1152  FILLSUB(z)
1153  *z++ = INDTOIND;
1154  *z++ = 4;
1155  *z++ = FUNNYVEC;
1156  *z++ = AR.CurDum;
1157  }
1158  v[2] |= DIRTYFLAG; dirty = 1;
1159  break;
1160  }
1161  s += s[1];
1162  }
1163  m++; t++;
1164  }
1165  else if ( *t == -VECTOR || *t == -MINVECTOR ) {
1166  *m++ = *t++;
1167  *m = *t;
1168  s = subs;
1169  for ( j = 0; j < i; j++ ) {
1170  if ( *t == s[2] ) {
1171  if ( *s == VECTOVEC ) *m = s[3];
1172  else if ( *s == VECTOMIN ) {
1173  *m = s[3];
1174  if ( t[-1] == -VECTOR )
1175  m[-1] = -MINVECTOR;
1176  else
1177  m[-1] = -VECTOR;
1178  }
1179  else if ( *s == VECTOSUB ) goto ToSub;
1180  dirty = 1; v[2] |= DIRTYFLAG;
1181  break;
1182  }
1183  s += s[1];
1184  }
1185  m++; t++;
1186  }
1187  else if ( *t == -SNUMBER ) {
1188  *m++ = *t++;
1189  *m = *t;
1190  s = subs;
1191  for ( j = 0; j < i; j++ ) {
1192  if ( *t == s[2] && *s >= NUMTONUM && *s <= NUMTOSUB ) {
1193  dirty = 1; v[2] |= DIRTYFLAG;
1194  if ( *s == NUMTONUM ) *m = s[3];
1195  else if ( *s == NUMTOSYM ) {
1196  m[-1] = -SYMBOL;
1197  *m = s[3];
1198  }
1199  else if ( *s == NUMTOIND ) {
1200  m[-1] = -INDEX;
1201  *m = s[3];
1202  }
1203  else if ( *s == NUMTOSUB ) goto ToSub;
1204  break;
1205  }
1206  s += s[1];
1207  }
1208  m++; t++;
1209  }
1210  else {
1211 ss9: *m++ = *t++;
1212 ss10: *m++ = *t++;
1213  }
1214  na = WORDDIF(z,accu);
1215 /*
1216  #] Simple arguments :
1217 */
1218  }
1219  else {
1220  w = m;
1221  zz = t;
1222  NEXTARG(zz)
1223  odirt = AN.WildDirt; AN.WildDirt = 0;
1224  AR.CompressPointer = accu + na;
1225  for ( j = 0; j < ARGHEAD; j++ ) *m++ = *t++;
1226  j = 0;
1227  adirt = 0;
1228  while ( t < zz ) { /* do a term */
1229  if ( ( len = WildFill(BHEAD m,t,sub) ) < 0 ) {
1230  MLOCK(ErrorMessageLock);
1231  MesCall("WildFill");
1232  MUNLOCK(ErrorMessageLock);
1233  SETERROR(-1)
1234  }
1235  if ( AN.WildDirt ) {
1236  adirt = AN.WildDirt;
1237  AN.WildDirt = 0;
1238  }
1239  m += len;
1240  t += *t;
1241  }
1242  *w = WORDDIF(m,w); /* Fill parameter length */
1243  if ( adirt ) {
1244  dirty = w[1] = 1; v[2] |= DIRTYFLAG;
1245  if ( AR.PolyFunType == 2 && v[0] == AR.PolyFun )
1246  v[2] |= MUSTCLEANPRF;
1247  AN.WildDirt = adirt;
1248  }
1249  else {
1250  AN.WildDirt = odirt;
1251  }
1252  if ( ToFast(w,w) ) {
1253  if ( *w <= -FUNCTION ) {
1254  if ( *w == NUMARGSFUN || *w == NUMTERMSFUN ) {
1255  *w = -SNUMBER; w[1] = 0; m = w + 2;
1256  }
1257  else m = w+1;
1258  }
1259  else m = w+2;
1260  }
1261  AR.CompressPointer = oldcpointer;
1262  }
1263  }
1264  v[1] = WORDDIF(m,v); /* Fill function length */
1265  s = accu;
1266  NCOPY(m,s,na);
1267 /*
1268  Now some code to speed up a few special cases
1269 */
1270  if ( v[0] == EXPONENT ) {
1271  if ( v[1] == FUNHEAD+4 && v[FUNHEAD] == -SYMBOL &&
1272  v[FUNHEAD+2] == -SNUMBER && v[FUNHEAD+3] < MAXPOWER
1273  && v[FUNHEAD+3] > -MAXPOWER ) {
1274  v[0] = SYMBOL;
1275  v[1] = 4;
1276  v[2] = v[FUNHEAD+1];
1277  v[3] = v[FUNHEAD+3];
1278  m = v+4;
1279  }
1280  else if ( v[1] == FUNHEAD+ARGHEAD+11
1281  && v[FUNHEAD] == ARGHEAD+9
1282  && v[FUNHEAD+ARGHEAD] == 9
1283  && v[FUNHEAD+ARGHEAD+1] == DOTPRODUCT
1284  && v[FUNHEAD+ARGHEAD+8] == 3
1285  && v[FUNHEAD+ARGHEAD+7] == 1
1286  && v[FUNHEAD+ARGHEAD+6] == 1
1287  && v[FUNHEAD+ARGHEAD+5] == 1
1288  && v[FUNHEAD+ARGHEAD+9] == -SNUMBER
1289  && v[FUNHEAD+ARGHEAD+10] < MAXPOWER
1290  && v[FUNHEAD+ARGHEAD+10] > -MAXPOWER ) {
1291  v[0] = DOTPRODUCT;
1292  v[1] = 5;
1293  v[2] = v[FUNHEAD+ARGHEAD+3];
1294  v[3] = v[FUNHEAD+ARGHEAD+4];
1295  v[4] = v[FUNHEAD+ARGHEAD+10];
1296  m = v+5;
1297  }
1298  }
1299  }
1300  else { while ( t < u ) *m++ = *t++; }
1301 /*
1302  #] FUNCTIONS :
1303 */
1304  }
1305  t = uu;
1306  } while ( t < r );
1307  t = from; /* Copy coefficient */
1308  t += *t;
1309  if ( r < t ) do { *m++ = *r++; } while ( r < t );
1310  if ( ( sgn & 1 ) != 0 ) m[-1] = -m[-1];
1311  *to = WORDDIF(m,to);
1312  if ( dirty ) AN.WildDirt = dirty;
1313  return(*to);
1314 }
1315 
1316 /*
1317  #] WildFill :
1318  #[ ResolveSet : WORD ResolveSet(from,to,subs)
1319 
1320  The set syntax is:
1321  SET,length,subterm,where,whichmember[,where,whichmember]
1322 
1323  setlength is 2*n+1 with n the number of set substitutions.
1324  length = setlength + subtermlength + 2
1325 
1326  At `where' is the number of the set and `whichmember' is the
1327  number of the element. This is still a symbol/dollar and we
1328  have to find the substitution in the wildcards.
1329  The output is the subterm in which the setelements have been
1330  substituted. This is ready for further wildcard substitutions.
1331 */
1332 
1333 WORD ResolveSet(PHEAD WORD *from, WORD *to, WORD *subs)
1334 {
1335  GETBIDENTITY
1336  WORD *m, *s, *w, j, i, ii, i3, flag, num;
1337  DOLLARS d = 0;
1338 #ifdef WITHPTHREADS
1339  int nummodopt, dtype = -1;
1340 #endif
1341  m = to; /* pointer in output */
1342  s = from + 2;
1343  w = s + s[1];
1344  while ( s < w ) *m++ = *s++;
1345  j = (from[1] - WORDDIF(w,from) ) >> 1;
1346  m = subs + subs[1];
1347  subs += SUBEXPSIZE;
1348  s = subs;
1349  i = 0;
1350  while ( s < m ) { i++; s += s[1]; }
1351  m = to;
1352  if ( *m >= FUNCTION && functions[*m-FUNCTION].spec
1353  >= TENSORFUNCTION ) flag = 0;
1354  else flag = 1;
1355  while ( --j >= 0 ) {
1356  if ( w[1] >= 0 ) {
1357  s = subs;
1358  for ( ii = 0; ii < i; ii++ ) {
1359  if ( *s == SYMTONUM && s[2] == w[1] ) { num = s[3]; goto GotOne; }
1360  s += s[1];
1361  }
1362  MLOCK(ErrorMessageLock);
1363  MesPrint(" Unresolved setelement during substitution");
1364  MUNLOCK(ErrorMessageLock);
1365  return(-1);
1366  }
1367  else { /* Dollar ! */
1368  d = Dollars - w[1];
1369 #ifdef WITHPTHREADS
1370  if ( AS.MultiThreaded ) {
1371  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1372  if ( -w[1] == ModOptdollars[nummodopt].number ) break;
1373  }
1374  if ( nummodopt < NumModOptdollars ) {
1375  dtype = ModOptdollars[nummodopt].type;
1376  if ( dtype == MODLOCAL ) {
1377  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1378  }
1379  else {
1380  LOCK(d->pthreadslockread);
1381  }
1382  }
1383  }
1384 #endif
1385  if ( d->type == DOLNUMBER || d->type == DOLTERMS ) {
1386  if ( d->where[0] == 4 && d->where[3] == 3 && d->where[2] == 1
1387  && d->where[1] > 0 && d->where[4] == 0 ) {
1388  num = d->where[1]; goto GotOne;
1389  }
1390  }
1391  else if ( d->type == DOLINDEX ) {
1392  if ( d->index > 0 && d->index < AM.OffsetIndex ) {
1393  num = d->index; goto GotOne;
1394  }
1395  }
1396  else if ( d->type == DOLARGUMENT ) {
1397  if ( d->where[0] == -SNUMBER && d->where[1] > 0 ) {
1398  num = d->where[1]; goto GotOne;
1399  }
1400  }
1401  else if ( d->type == DOLWILDARGS ) {
1402  if ( d->where[0] == 1 &&
1403  d->where[1] > 0 && d->where[1] < AM.OffsetIndex ) {
1404  num = d->where[1]; goto GotOne;
1405  }
1406  if ( d->where[0] == 0 && d->where[1] < 0 && d->where[3] == 0 ) {
1407  if ( ( d->where[1] == -SNUMBER && d->where[2] > 0 )
1408  || ( d->where[1] == -INDEX && d->where[2] > 0
1409  && d->where[2] < AM.OffsetIndex ) ) {
1410  num = d->where[2]; goto GotOne;
1411  }
1412  }
1413  }
1414 #ifdef WITHPTHREADS
1415  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1416 #endif
1417  MLOCK(ErrorMessageLock);
1418  MesPrint("Unusable type of variable $%s in set substitution",
1419  AC.dollarnames->namebuffer+d->name);
1420  MUNLOCK(ErrorMessageLock);
1421  return(-1);
1422  }
1423 GotOne:;
1424 #ifdef WITHPTHREADS
1425  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1426 #endif
1427  ii = m[*w];
1428  if ( ii >= 2*MAXPOWER ) i3 = ii - 2*MAXPOWER;
1429  else if ( ii <= -2*MAXPOWER ) i3 = -ii - 2*MAXPOWER;
1430  else i3 = ( ii >= 0 ) ? ii: -ii - 1;
1431 
1432  if ( num > ( Sets[i3].last - Sets[i3].first ) || num <= 0 ) {
1433  MLOCK(ErrorMessageLock);
1434  MesPrint("Array bound check during set substitution");
1435  MesPrint(" value is %d",num);
1436  MUNLOCK(ErrorMessageLock);
1437  return(-1);
1438  }
1439  m[*w] = (SetElements+Sets[i3].first)[num-1];
1440  if ( Sets[i3].type == CSYMBOL && m[*w] > MAXPOWER ) {
1441  if ( ii >= 2*MAXPOWER ) m[*w] -= 2*MAXPOWER;
1442  else if ( ii <= -2*MAXPOWER ) m[*w] = -(m[*w] - 2*MAXPOWER);
1443  else {
1444  m[*w] -= MAXPOWER;
1445  if ( m[*w] < MAXPOWER ) m[*w] -= 2*MAXPOWER;
1446  if ( flag ) MakeDirty(m,m+*w,1);
1447  }
1448  }
1449  else if ( Sets[i3].type == CSYMBOL ) {
1450  if ( ii >= 2*MAXPOWER ) m[*w] += 2*MAXPOWER;
1451  else if ( ii <= -2*MAXPOWER ) m[*w] = -m[*w] - 2*MAXPOWER;
1452  else if ( ii < 0 ) m[*w] = - m[*w];
1453  }
1454  else if ( ii < 0 ) m[*w] = - m[*w];
1455  w += 2;
1456  }
1457  m = to;
1458  if ( *m >= FUNCTION && functions[*m-FUNCTION].spec
1459  >= TENSORFUNCTION ) {
1460  w = from + 2 + from[3];
1461  if ( *w == 0 ) { /* We had function -> tensor */
1462  m = from + 2 + FUNHEAD; s = to + FUNHEAD;
1463  while ( m < w ) {
1464  if ( *m == -INDEX || *m == -VECTOR ) {}
1465  else if ( *m == -ARGWILD ) { *s++ = FUNNYWILD; }
1466  else {
1467  MLOCK(ErrorMessageLock);
1468  MesPrint("Illegal argument in tensor after set substitution");
1469  MUNLOCK(ErrorMessageLock);
1470  SETERROR(-1)
1471  }
1472  *s++ = m[1];
1473  m += 2;
1474  }
1475  to[1] = WORDDIF(s,to);
1476  }
1477  }
1478  return(0);
1479 }
1480 
1481 /*
1482  #] ResolveSet :
1483  #[ ClearWild : VOID ClearWild()
1484 
1485  Clears the current wildcard settings and makes them ready for
1486  CheckWild and AddWild.
1487 
1488 */
1489 
1490 VOID ClearWild(PHEAD0)
1491 {
1492  GETBIDENTITY
1493  WORD n, nn, *w;
1494  n = (AN.WildValue[-SUBEXPSIZE+1]-SUBEXPSIZE)/4; /* Number of wildcards */
1495  AN.NumWild = nn = n;
1496  if ( n > 0 ) {
1497  w = AT.WildMask;
1498  do { *w++ = 0; } while ( --n > 0 );
1499  w = AN.WildValue;
1500  do {
1501  if ( *w == SYMTONUM ) *w = SYMTOSYM;
1502  w += w[1];
1503  } while ( --nn > 0 );
1504  }
1505 }
1506 
1507 /*
1508  #] ClearWild :
1509  #[ AddWild : WORD AddWild(oldnumber,type,newnumber)
1510 
1511  Adds a wildcard assignment.
1512  Extra parameter in AN.argaddress;
1513 
1514 */
1515 
1516 WORD AddWild(PHEAD WORD oldnumber, WORD type, WORD newnumber)
1517 {
1518  GETBIDENTITY
1519  WORD *w, *m, n, k, i = -1;
1520  CBUF *C = cbuf+AT.ebufnum;
1521 DEBUG(WORD *mm;)
1522  AN.WildReserve = 0;
1523  m = AT.WildMask;
1524  w = AN.WildValue;
1525  n = AN.NumWild;
1526  if ( n <= 0 ) { return(-1); }
1527  if ( type <= SYMTOSUB ) {
1528  do {
1529  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1530  if ( n > 1 && w[4] == SETTONUM ) i = w[7];
1531  *w = type;
1532  if ( *m != 2 ) *m = 1;
1533  if ( type != SYMTOSUB ) {
1534  if ( type == SYMTONUM ) AN.MaskPointer = m;
1535  w[3] = newnumber;
1536  goto FlipOn;
1537  }
1538  m = AddRHS(AT.ebufnum,1);
1539  w[3] = C->numrhs;
1540  w = AN.argaddress;
1541 DEBUG(mm = m;)
1542  n = *w - ARGHEAD;
1543  w += ARGHEAD;
1544  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,4);
1545  while ( --n >= 0 ) *m++ = *w++;
1546  *m++ = 0;
1547  C->rhs[C->numrhs+1] = m;
1548 DEBUG(MesPrint("Thread %w(d): m=(%d,%d,%d,%d)(%d)",mm[0],mm[1],mm[2],mm[3],C->numrhs);)
1549  C->Pointer = m;
1550  goto FlipOn;
1551  }
1552  m++; w += w[1];
1553  } while ( --n > 0 );
1554  }
1555  else if ( type == ARGTOARG ) {
1556  do {
1557  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1558  *m = 1;
1559  m = AddRHS(AT.ebufnum,1);
1560  w[3] = C->numrhs;
1561  w = AN.argaddress;
1562 DEBUG(mm=m;)
1563  if ( ( newnumber & EATTENSOR ) != 0 ) {
1564  n = newnumber & ~EATTENSOR;
1565  *m++ = n;
1566  w = AN.argaddress;
1567  }
1568  else {
1569  while ( --newnumber >= 0 ) { NEXTARG(w) }
1570  n = WORDDIF(w,AN.argaddress);
1571  w = AN.argaddress;
1572  *m++ = 0;
1573  }
1574  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,5);
1575 DEBUG(if ( mm != m-1 ) MesPrint("Thread %w(e): Alarm!"); mm = m-1;)
1576  while ( --n >= 0 ) *m++ = *w++;
1577  *m++ = 0;
1578  C->rhs[C->numrhs+1] = m;
1579  C->Pointer = m;
1580 DEBUG(MesPrint("Thread %w(e): w=(%d,%d,%d,%d)(%d)",mm[0],mm[1],mm[2],mm[3],C->numrhs);)
1581  return(0);
1582  }
1583  m++; w += w[1];
1584  } while ( --n > 0 );
1585  }
1586  else if ( type == ARLTOARL ) {
1587  do {
1588  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1589  WORD **a;
1590  *m = 1;
1591  m = AddRHS(AT.ebufnum,1);
1592  w[3] = C->numrhs;
1593 DEBUG(mm=m;)
1594  a = (WORD **)(AN.argaddress); n = 0; k = newnumber;
1595  while ( --newnumber >= 0 ) {
1596  w = *a++;
1597  if ( *w > 0 ) n += *w;
1598  else if ( *w <= -FUNCTION ) n++;
1599  else n += 2;
1600  }
1601  *m++ = 0;
1602  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,6);
1603 DEBUG(if ( mm != m-1 ) MesPrint("Thread %w(f): Alarm!"); mm = m-1;)
1604  a = (WORD **)(AN.argaddress);
1605  while ( --k >= 0 ) {
1606  w = *a++;
1607  if ( *w > 0 ) { n = *w; NCOPY(m,w,n); }
1608  else if ( *w <= -FUNCTION ) *m++ = *w++;
1609  else { *m++ = *w++; *m++ = *w++; }
1610  }
1611  *m++ = 0;
1612  C->rhs[C->numrhs+1] = m;
1613 DEBUG(MesPrint("Thread %w(f): w=(%d,%d,%d,%d)(%d)",mm[0],mm[1],mm[2],mm[3],C->numrhs);)
1614  C->Pointer = m;
1615  return(0);
1616  }
1617  m++; w += w[1];
1618  } while ( --n > 0 );
1619  }
1620  else if ( type == VECTOSUB || type == INDTOSUB ) {
1621  WORD *ss, *sstop, *tt, *ttstop, j, *v1, *v2 = 0;
1622  do {
1623  if ( w[2] == oldnumber && ( *w == type ||
1624  ( type == VECTOSUB && ( *w == VECTOVEC || *w == VECTOMIN ) )
1625  || ( type == INDTOSUB && *w == INDTOIND ) ) ) {
1626  if ( n > 1 && w[4] == SETTONUM ) i = w[7];
1627  *w = type;
1628  *m = 1;
1629  m = AddRHS(AT.ebufnum,1);
1630  w[3] = C->numrhs;
1631  w = AN.argaddress;
1632  n = *w - ARGHEAD;
1633  w += ARGHEAD;
1634  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,7);
1635  while ( --n >= 0 ) *m++ = *w++;
1636  *m++ = 0;
1637  C->rhs[C->numrhs+1] = m;
1638  C->Pointer = m;
1639  m = AddRHS(AT.ebufnum,1);
1640  w = AN.argaddress;
1641  n = *w - ARGHEAD;
1642  w += ARGHEAD;
1643  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,8);
1644  sstop = w + n;
1645  while ( w < sstop ) { /* Run over terms */
1646  tt = w + *w; ttstop = tt - ABS(tt[-1]);
1647  ss = m; m++; w++;
1648  while ( w < ttstop ) { /* Subterms */
1649  if ( *w != INDEX ) {
1650  j = w[1];
1651  NCOPY(m,w,j);
1652  }
1653  else {
1654  v1 = m;
1655  *m++ = *w++;
1656  *m++ = j = *w++;
1657  j -= 2;
1658  while ( --j >= 0 ) {
1659  if ( *w >= MINSPEC ) *m++ = *w++;
1660  else v2 = w++;
1661  }
1662  j = WORDDIF(m,v1);
1663  if ( j != v1[1] ) {
1664  if ( j <= 2 ) m -= 2;
1665  else v1[1] = j;
1666  *m++ = VECTOR;
1667  *m++ = 4;
1668  *m++ = *v2;
1669  *m++ = FUNNYVEC;
1670  }
1671  }
1672  }
1673  while ( w < tt ) *m++ = *w++;
1674  *ss = WORDDIF(m,ss);
1675  }
1676  *m++ = 0;
1677  C->rhs[C->numrhs+1] = m;
1678  C->Pointer = m;
1679  if ( m > C->Top ) {
1680  MLOCK(ErrorMessageLock);
1681  MesPrint("Internal problems with extra compiler buffer");
1682  MUNLOCK(ErrorMessageLock);
1683  Terminate(-1);
1684  }
1685  goto FlipOn;
1686  }
1687  m++; w += w[1];
1688  } while ( --n > 0 );
1689  }
1690  else {
1691  do {
1692  if ( w[2] == oldnumber && ( *w == type || ( type == VECTOVEC
1693  && ( *w == VECTOMIN || *w == VECTOSUB ) ) || ( type == VECTOMIN
1694  && ( *w == VECTOVEC || *w == VECTOSUB ) )
1695  || ( type == INDTOIND && *w == INDTOSUB ) ) ) {
1696  if ( n > 1 && w[4] == SETTONUM ) i = w[7];
1697  *w = type;
1698  w[3] = newnumber;
1699  *m = 1;
1700  goto FlipOn;
1701  }
1702  m++; w += w[1];
1703  } while ( --n > 0 );
1704  }
1705  MLOCK(ErrorMessageLock);
1706  MesPrint("Bug in AddWild.");
1707  MUNLOCK(ErrorMessageLock);
1708  return(-1);
1709 FlipOn:
1710  if ( i >= 0 ) {
1711  m = AT.WildMask;
1712  w = AN.WildValue;
1713  n = AN.NumWild;
1714  while ( --n >= 0 ) {
1715  if ( w[2] == i && *w == SYMTONUM ) {
1716  *m = 2;
1717  return(0);
1718  }
1719  m++; w += w[1];
1720  }
1721  MLOCK(ErrorMessageLock);
1722  MesPrint(" Bug in AddWild with passing set[i]");
1723  MUNLOCK(ErrorMessageLock);
1724 /*
1725  For the moment we want to crash here. That is easier with debugging.
1726 */
1727 #ifdef WITHPTHREADS
1728  { WORD *s = 0;
1729  *s++ = 1;
1730  }
1731 #endif
1732  Terminate(-1);
1733  }
1734  return(0);
1735 }
1736 
1737 /*
1738  #] AddWild :
1739  #[ CheckWild : WORD CheckWild(oldnumber,type,newnumber,newval)
1740 
1741  Tests whether a wildcard assignment is allowed.
1742  A return value of zero means that it is allowed (nihil obstat).
1743  If the variable has been assigned already its existing
1744  assignment is returned in AN.oldvalue and AN.oldtype, which are
1745  global variables.
1746 
1747  Note the special problem with name?set[i]. Here we have to pass
1748  an extra assignment. This cannot be done via globals as we
1749  call CheckWild sometimes twice before calling AddWild.
1750  Trick: Check the assignment of the number and if OK put it
1751  in place, but don't alter the used flag (if needed).
1752  Then AddWild can alter the used flag but the value is there.
1753  As long as this trick is `hanging' we turn on the flag:
1754  `AN.WildReserve' which is either turned off by AddWild or by
1755  a failing call to CheckWild.
1756 
1757  With ARGTOARG the tensors give the number of arguments
1758  or-ed with EATTENSOR which is at least 8192.
1759 */
1760 
1761 WORD CheckWild(PHEAD WORD oldnumber, WORD type, WORD newnumber, WORD *newval)
1762 {
1763  GETBIDENTITY
1764  WORD *w, *m, *s, n, old2, inset;
1765  WORD n2, oldval, dirty, i, j, notflag = 0, retblock = 0;
1766  CBUF *C = cbuf+AT.ebufnum;
1767  m = AT.WildMask;
1768  w = AN.WildValue;
1769  n = AN.NumWild;
1770  if ( n <= 0 ) { AN.oldtype = -1; AN.WildReserve = 0; return(-1); }
1771  switch ( type ) {
1772  case SYMTONUM :
1773  *newval = newnumber;
1774  do {
1775  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1776  old2 = *w;
1777  if ( !*m ) goto TestSet;
1778  AN.MaskPointer = m;
1779  if ( *w == SYMTONUM && w[3] == newnumber ) {
1780  return(0);
1781  }
1782  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
1783  }
1784  m++; w += w[1];
1785  } while ( --n > 0 );
1786  break;
1787  case SYMTOSYM :
1788  *newval = newnumber;
1789  do {
1790  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1791  old2 = *w;
1792  if ( *w == SYMTOSYM ) {
1793  if ( !*m ) goto TestSet;
1794  if ( newnumber >= 0 && (w+4) < AN.WildStop
1795  && ( w[4] == FROMSET || w[4] == SETTONUM )
1796  && w[7] >= 0 ) goto TestSet;
1797  if ( w[3] == newnumber ) return(0);
1798  }
1799  else {
1800  if ( !*m ) goto TestSet;
1801  }
1802  goto NoM;
1803  }
1804  m++; w += w[1];
1805  } while ( --n > 0 );
1806  break;
1807  case SYMTOSUB :
1808 /*
1809  Now newval contains the pointer to the argument.
1810 */
1811  {
1812 /*
1813  Search for vector or index nature. If so: reject.
1814 */
1815  WORD *ss, *sstop, *tt, *ttstop;
1816  ss = newval;
1817  sstop = ss + *ss;
1818  ss += ARGHEAD;
1819  while ( ss < sstop ) {
1820  tt = ss + *ss;
1821  ttstop = tt - ABS(tt[-1]);
1822  ss++;
1823  while ( ss < ttstop ) {
1824  if ( *ss == INDEX ) goto NoMatch;
1825  ss += ss[1];
1826  }
1827  ss = tt;
1828  }
1829  }
1830  do {
1831  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1832  old2 = *w;
1833  if ( *w == SYMTONUM || *w == SYMTOSYM ) {
1834  if ( !*m ) {
1835  s = w + w[1];
1836  if ( s >= AN.WildStop || *s != SETTONUM )
1837  goto TestSet;
1838  }
1839  }
1840  else if ( *w == SYMTOSUB ) {
1841  if ( !*m ) {
1842  s = w + w[1];
1843  if ( s >= AN.WildStop || *s != SETTONUM )
1844  goto TestSet;
1845  }
1846  n = *newval - 2;
1847  newval += 2;
1848  m = C->rhs[w[3]];
1849  if ( (C->rhs[w[3]+1] - m - 1) == n ) {
1850  while ( n > 0 ) {
1851  if ( *m != *newval ) {
1852  m++; newval++; break;
1853  }
1854  m++; newval++;
1855  n--;
1856  }
1857  if ( n <= 0 ) return(0);
1858  }
1859  }
1860  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
1861  }
1862  m++; w += w[1];
1863  } while ( --n > 0 );
1864  break;
1865  case ARGTOARG :
1866  do {
1867  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1868  if ( !*m ) return(0); /* nihil obstat */
1869  m = C->rhs[w[3]];
1870  if ( ( newnumber & EATTENSOR ) != 0 ) {
1871  n = newnumber & ~EATTENSOR;
1872  if ( *m != 0 ) {
1873  if ( n == *m ) {
1874  m++;
1875  while ( --n >= 0 ) {
1876  if ( *m != *newval ) {
1877  m++; newval++; break;
1878  }
1879  m++; newval++;
1880  }
1881  if ( n < 0 ) return(0);
1882  }
1883  }
1884  else {
1885  m++;
1886  while ( --n >= 0 ) {
1887  if ( *newval != m[1] || ( *m != -INDEX
1888  && *m != -VECTOR && *m != -SNUMBER ) ) break;
1889  m += 2;
1890  newval++;
1891  }
1892  if ( n < 0 && *m == 0 ) return(0);
1893  }
1894  }
1895  else {
1896  i = newnumber;
1897  if ( *m != 0 ) { /* Tensor field */
1898  if ( *m == i ) {
1899  m++;
1900  while ( --i >= 0 ) {
1901  if ( *m != newval[1]
1902  || ( *newval != -VECTOR
1903  && *newval != -INDEX
1904  && *newval != -SNUMBER ) ) break;
1905  newval += 2;
1906  m++;
1907  }
1908  if ( i < 0 ) return(0);
1909  }
1910  }
1911  else {
1912  m++;
1913  s = newval;
1914  while ( --i >= 0 ) { NEXTARG(s) }
1915  n = WORDDIF(s,newval);
1916  while ( --n >= 0 ) {
1917  if ( *m != *newval ) {
1918  m++; newval++; break;
1919  }
1920  m++; newval++;
1921  }
1922  if ( n < 0 && *m == 0 ) return(0);
1923  }
1924  }
1925  AN.oldtype = *w; AN.oldvalue = w[3]; goto NoMatch;
1926  }
1927  m++; w += w[1];
1928  } while ( --n > 0 );
1929  break;
1930  case ARLTOARL :
1931  do {
1932  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1933  WORD **a;
1934  if ( !*m ) return(0); /* nihil obstat */
1935  m = C->rhs[w[3]];
1936  i = newnumber;
1937  a = (WORD **)newval;
1938  if ( *m != 0 ) { /* Tensor field */
1939  if ( *m == i ) {
1940  m++;
1941  while ( --i >= 0 ) {
1942  s = *a++;
1943  if ( *m != s[1]
1944  || ( *s != -VECTOR
1945  && *s != -INDEX
1946  && *s != -SNUMBER ) ) break;
1947  m++;
1948  }
1949  if ( i < 0 ) return(0);
1950  }
1951  }
1952  else {
1953  m++;
1954  while ( --i >= 0 ) {
1955  s = *a++;
1956  if ( *s > 0 ) {
1957  n = *s;
1958  while ( --n >= 0 ) {
1959  if ( *s != *m ) {
1960  s++; m++; break;
1961  }
1962  s++; m++;
1963  }
1964  if ( n >= 0 ) break;
1965  }
1966  else if ( *s <= -FUNCTION ) {
1967  if ( *s != *m ) {
1968  s++; m++; break;
1969  }
1970  s++; m++;
1971  }
1972  else {
1973  if ( *s != *m ) {
1974  s++; m++; break;
1975  }
1976  s++; m++;
1977  if ( *s != *m ) {
1978  s++; m++; break;
1979  }
1980  s++; m++;
1981  }
1982  }
1983  if ( i < 0 && *m == 0 ) return(0);
1984  }
1985  AN.oldtype = *w; AN.oldvalue = w[3]; goto NoMatch;
1986  }
1987  m++; w += w[1];
1988  } while ( --n > 0 );
1989  break;
1990  case VECTOSUB :
1991  case INDTOSUB :
1992 /*
1993  Now newval contains the pointer to the argument(s).
1994 */
1995  {
1996 /*
1997  Search for vector or index nature. If not so: reject.
1998 */
1999  WORD *ss, *sstop, *tt, *ttstop, count, jt;
2000  ss = newval;
2001  sstop = ss + *ss;
2002  ss += ARGHEAD;
2003  while ( ss < sstop ) {
2004  tt = ss + *ss;
2005  ttstop = tt - ABS(tt[-1]);
2006  ss++;
2007  count = 0;
2008  while ( ss < ttstop ) {
2009  if ( *ss == INDEX ) {
2010  jt = ss[1] - 2; ss += 2;
2011  while ( --jt >= 0 ) {
2012  if ( *ss < MINSPEC ) count++;
2013  ss++;
2014  }
2015  }
2016  else ss += ss[1];
2017  }
2018  if ( count != 1 ) goto NoMatch;
2019  ss = tt;
2020  }
2021  }
2022  do {
2023  if ( w[2] == oldnumber ) {
2024  old2 = *w;
2025  if ( ( type == VECTOSUB && ( *w == VECTOVEC || *w == VECTOMIN ) )
2026  || ( type == INDTOSUB && *w == INDTOIND ) ) {
2027  if ( !*m ) goto TestSet;
2028  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2029  }
2030  else if ( *w == type ) {
2031  if ( !*m ) goto TestSet;
2032  if ( type != INDTOIND && type != INDTOSUB ) { /* Prevent double index */
2033  n = *newval - 2;
2034  newval += 2;
2035  m = C->rhs[w[3]];
2036  if ( (C->rhs[w[3]+1] - m - 1) == n ) {
2037  while ( n > 0 ) {
2038  if ( *m != *newval ) {
2039  m++; newval++; break;
2040  }
2041  m++; newval++;
2042  n--;
2043  }
2044  if ( n <= 0 ) return(0);
2045  }
2046  }
2047  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2048  }
2049  }
2050  m++; w += w[1];
2051  } while ( --n > 0 );
2052  break;
2053  default :
2054  *newval = newnumber;
2055  do {
2056  if ( w[2] == oldnumber ) {
2057  if ( *w == type ) {
2058  old2 = *w;
2059  if ( !*m ) goto TestSet;
2060  if ( newnumber >= 0 && (w+4) < AN.WildStop &&
2061  ( w[4] == FROMSET || w[4] == SETTONUM )
2062  && w[7] >= 0 ) goto TestSet;
2063  if ( newnumber < 0 && *w == VECTOVEC
2064  && (w+4) < AN.WildStop && ( w[4] == FROMSET
2065  || w[4] == SETTONUM ) && w[7] >= 0 ) goto TestSet;
2066 /*
2067  The next statement kills multiple indices -> vector
2068 */
2069  if ( *w == INDTOIND && w[3] < 0 ) goto NoMatch;
2070  if ( w[3] == newnumber ) {
2071  if ( *w != FUNTOFUN || newnumber < FUNCTION
2072  || functions[newnumber-FUNCTION].spec ==
2073  functions[oldnumber-FUNCTION].spec )
2074  return(0);
2075  }
2076  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2077  }
2078  else if ( ( type == VECTOVEC &&
2079  ( *w == VECTOSUB || *w == VECTOMIN ) )
2080  || ( type == INDTOIND && *w == INDTOSUB ) ) {
2081  if ( *m ) goto NoMatch;
2082  old2 = *w;
2083  goto TestSet;
2084  }
2085  else if ( type == VECTOMIN &&
2086  ( *w == VECTOSUB || *w == VECTOVEC ) ) {
2087  if ( *m ) goto NoMatch;
2088  old2 = *w;
2089  goto TestSet;
2090  }
2091  }
2092  m++; w += w[1];
2093  if ( n > 1 && ( *w == FROMSET
2094  || *w == SETTONUM ) ) { n--; m++; w += w[1]; }
2095  } while ( --n > 0 );
2096  break;
2097  }
2098  AN.oldtype = -1;
2099  AN.oldvalue = -1;
2100  AN.WildReserve = 0;
2101  MLOCK(ErrorMessageLock);
2102  MesPrint("Inconsistency in Wildcard prototype.");
2103  MUNLOCK(ErrorMessageLock);
2104  return(-1);
2105 NoMatch:
2106  AN.WildReserve = 0;
2107  return(1+retblock);
2108 /*
2109  Here we test the compatibility with a set specification.
2110 */
2111 TestSet:
2112  dirty = *m;
2113  oldval = w[3];
2114  w += w[1];
2115  if ( w < AN.WildStop && ( *w == FROMSET || *w == SETTONUM ) ) {
2116  WORD k;
2117  s = w;
2118  j = w[2]; n2 = w[3];
2119  if ( j > WILDOFFSET ) {
2120  j -= 2*WILDOFFSET;
2121  notflag = 1;
2122 /*
2123  ???????
2124 */
2125  AN.oldtype = -1;
2126  AN.oldvalue = -1;
2127  }
2128  if ( j < AM.NumFixedSets ) { /* special set */
2129  retblock = 1;
2130  switch ( j ) {
2131  case POS_:
2132  if ( type != SYMTONUM ||
2133  newnumber <= 0 ) goto NoMnot;
2134  break;
2135  case POS0_:
2136  if ( type != SYMTONUM ||
2137  newnumber < 0 ) goto NoMnot;
2138  break;
2139  case NEG_:
2140  if ( type != SYMTONUM ||
2141  newnumber >= 0 ) goto NoMnot;
2142  break;
2143  case NEG0_:
2144  if ( type != SYMTONUM ||
2145  newnumber > 0 ) goto NoMnot;
2146  break;
2147  case EVEN_:
2148  if ( type != SYMTONUM ||
2149  ( newnumber & 1 ) != 0 ) goto NoMnot;
2150  break;
2151  case ODD_:
2152  if ( type != SYMTONUM ||
2153  ( newnumber & 1 ) == 0 ) goto NoMnot;
2154  break;
2155  case Z_:
2156  if ( type != SYMTONUM ) goto NoMnot;
2157  break;
2158  case SYMBOL_:
2159  if ( type != SYMTOSYM ) goto NoMnot;
2160  break;
2161  case FIXED_:
2162  if ( type != INDTOIND ||
2163  newnumber >= AM.OffsetIndex ||
2164  newnumber < 0 ) goto NoMnot;
2165  break;
2166  case INDEX_:
2167  if ( type != INDTOIND ||
2168  newnumber < 0 ) goto NoMnot;
2169  break;
2170  case Q_:
2171  if ( type == SYMTONUM ) break;
2172  if ( type == SYMTOSUB ) {
2173  WORD *ss, *sstop;
2174  ss = newval;
2175  sstop = ss + *ss;
2176  ss += ARGHEAD;
2177  if ( ss >= sstop ) break;
2178  if ( ss + *ss < sstop ) goto NoMnot;
2179  if ( ABS(sstop[-1]) == ss[0]-1 ) break;
2180  }
2181  goto NoMnot;
2182  case DUMMYINDEX_:
2183  if ( type != INDTOIND ||
2184  newnumber < AM.IndDum || newnumber >= AM.IndDum+MAXDUMMIES ) goto NoMnot;
2185  break;
2186  case VECTOR_:
2187  if ( type != VECTOVEC ) goto NoMnot;
2188  break;
2189  default:
2190  goto NoMnot;
2191  }
2192 Mnot:
2193  if ( notflag ) goto NoM;
2194  return(0);
2195 NoMnot:
2196  if ( !notflag ) goto NoM;
2197  return(0);
2198  }
2199  else if ( Sets[j].type == CRANGE ) {
2200  if ( ( type == SYMTONUM )
2201  || ( type == INDTOIND && ( newnumber > 0
2202  && newnumber <= AM.OffsetIndex ) ) ) {
2203  if ( Sets[j].first < MAXPOWER ) {
2204  if ( newnumber >= Sets[j].first ) goto NoMnot;
2205  }
2206  else if ( Sets[j].first < 3*MAXPOWER ) {
2207  if ( newnumber+2*MAXPOWER > Sets[j].first ) goto NoMnot;
2208  }
2209  if ( Sets[j].last > -MAXPOWER ) {
2210  if ( newnumber <= Sets[j].last ) goto NoMnot;
2211  }
2212  else if ( Sets[j].last > -3*MAXPOWER ) {
2213  if ( newnumber-2*MAXPOWER < Sets[j].last ) goto NoMnot;
2214  }
2215  goto Mnot;
2216  }
2217  goto NoMnot;
2218  }
2219  w = SetElements + Sets[j].first;
2220  m = SetElements + Sets[j].last;
2221  i = 1;
2222  if ( Sets[j].type == -1 || Sets[j].type == CNUMBER ) { do {
2223  if ( notflag ) {
2224  switch ( type ) {
2225  case SYMTOSYM:
2226  if ( Sets[j].type == CNUMBER ) {}
2227  else {
2228  if ( *w == newnumber ) goto NoMatch;
2229  }
2230  break;
2231  case SYMTONUM:
2232  case INDTOIND:
2233  if ( *w == newnumber ) goto NoMatch;
2234  break;
2235  default:
2236  break;
2237  }
2238  }
2239  else if ( type != SYMTONUM && type != INDTOIND
2240  && type != SYMTOSYM ) goto NoMatch;
2241  else if ( type == SYMTOSYM && Sets[j].type == CNUMBER ) goto NoMatch;
2242  else if ( *w == newnumber ) {
2243  if ( *s == SETTONUM ) {
2244  if ( n2 == oldnumber && type
2245  <= SYMTOSUB ) goto NoMatch;
2246  m = AT.WildMask;
2247  w = AN.WildValue;
2248  n = AN.NumWild;
2249  while ( --n >= 0 ) {
2250  if ( w[2] == n2 && *w <= SYMTOSUB ) {
2251  if ( !*m ) {
2252  *w = SYMTONUM;
2253  w[3] = i;
2254  AN.WildReserve = 1;
2255  return(0);
2256  }
2257  if ( *w != SYMTONUM )
2258  goto NoMatch;
2259  if ( w[3] == i ) return(0);
2260  i = w[3];
2261  j = (SetElements + Sets[j].first)[i];
2262  if ( j == n2 ) return(0);
2263  goto NoMatch;
2264  }
2265  m++; w += w[1];
2266  }
2267  }
2268  else if ( n2 >= 0 ) {
2269  *newval = *(w - Sets[j].first + Sets[n2].first);
2270  if ( *newval > MAXPOWER ) *newval -= 2*MAXPOWER;
2271  if ( dirty && *newval != oldval ) {
2272  *newval = oldval; goto NoMatch;
2273  }
2274  }
2275  return(0);
2276  }
2277  i++;
2278  } while ( ++w < m ); }
2279  else { do {
2280  inset = *w;
2281  if ( notflag ) {
2282  switch ( type ) {
2283  case SYMTONUM:
2284  case SYMTOSYM:
2285  if ( ( type == SYMTOSYM && *w == newnumber )
2286  || ( type == SYMTONUM && *w-2*MAXPOWER == newnumber ) ) {
2287  goto NoMatch;
2288  }
2289  case SYMTOSUB:
2290  if ( *w < 0 ) {
2291  WORD *mm = AT.WildMask, *mmm, *part;
2292  WORD *ww = AN.WildValue;
2293  WORD nn = AN.NumWild;
2294  k = -*w;
2295  while ( --nn >= 0 ) {
2296  if ( *mm && ww[2] == k && ww[0] == type ) {
2297  if ( type != SYMTOSUB ) {
2298  if ( ww[3] == newnumber ) goto NoMatch;
2299  }
2300  else {
2301  mmm = C->rhs[ww[3]];
2302  nn = *newval-2;
2303  part = newval+2;
2304  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2305  while ( --nn >= 0 ) {
2306  if ( *mmm != *part ) {
2307  mmm++; part++; break;
2308  }
2309  mmm++; part++;
2310  }
2311  if ( nn < 0 ) goto NoMatch;
2312  }
2313  }
2314  break;
2315  }
2316  mm++; ww += ww[1];
2317  }
2318  }
2319  break;
2320  case VECTOMIN:
2321  if ( type == VECTOMIN ) {
2322  if ( inset >= AM.OffsetVector ) { i++; continue; }
2323  inset += WILDMASK;
2324  }
2325  case VECTOVEC:
2326  if ( inset == newnumber ) goto NoMatch;
2327  case VECTOSUB:
2328  if ( inset - WILDOFFSET >= AM.OffsetVector ) {
2329  WORD *mm = AT.WildMask, *mmm, *part;
2330  WORD *ww = AN.WildValue;
2331  WORD nn = AN.NumWild;
2332  k = inset - WILDOFFSET;
2333  while ( --nn >= 0 ) {
2334  if ( *mm && ww[2] == k && ww[0] == type ) {
2335  if ( type == VECTOVEC ) {
2336  if ( ww[3] == newnumber ) goto NoMatch;
2337  }
2338  else {
2339  mmm = C->rhs[ww[3]];
2340  nn = *newval-2;
2341  part = newval+2;
2342  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2343  while ( --nn >= 0 ) {
2344  if ( *mmm != *part ) {
2345  mmm++; part++; break;
2346  }
2347  mmm++; part++;
2348  }
2349  if ( nn < 0 ) goto NoMatch;
2350  }
2351  }
2352  break;
2353  }
2354  mm++; ww += ww[1];
2355  }
2356  }
2357  break;
2358  case INDTOIND:
2359  if ( *w == newnumber ) goto NoMatch;
2360  case INDTOSUB:
2361  if ( *w - (WORD)WILDMASK >= AM.OffsetIndex ) {
2362  WORD *mm = AT.WildMask, *mmm, *part;
2363  WORD *ww = AN.WildValue;
2364  WORD nn = AN.NumWild;
2365  k = *w - WILDMASK;
2366  while ( --nn >= 0 ) {
2367  if ( *mm && ww[2] == k && ww[0] == type ) {
2368  if ( type == INDTOIND ) {
2369  if ( ww[3] == newnumber ) goto NoMatch;
2370  }
2371  else {
2372  mmm = C->rhs[ww[3]];
2373  nn = *newval-2;
2374  part = newval+2;
2375  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2376  while ( --nn >= 0 ) {
2377  if ( *mmm != *part ) {
2378  mmm++; part++; break;
2379  }
2380  mmm++; part++;
2381  }
2382  if ( nn < 0 ) goto NoMatch;
2383  }
2384  }
2385  break;
2386  }
2387  mm++; ww += ww[1];
2388  }
2389  }
2390  break;
2391  case FUNTOFUN:
2392  if ( *w == newnumber ) goto NoMatch;
2393  if ( ( type == FUNTOFUN &&
2394  ( k = *w - WILDMASK ) > FUNCTION ) ) {
2395  WORD *mm = AT.WildMask;
2396  WORD *ww = AN.WildValue;
2397  WORD nn = AN.NumWild;
2398  while ( --nn >= 0 ) {
2399  if ( *mm && ww[2] == k && ww[0] == type ) {
2400  if ( ww[3] == newnumber ) goto NoMatch;
2401  break;
2402  }
2403  mm++; ww += ww[1];
2404  }
2405  }
2406  default:
2407  break;
2408  }
2409  }
2410  else {
2411  if ( type == VECTOMIN ) {
2412  if ( inset >= AM.OffsetVector ) { i++; continue; }
2413  inset += WILDMASK;
2414  }
2415  if ( ( inset == newnumber && type != SYMTONUM ) ||
2416  ( type == SYMTONUM && inset-2*MAXPOWER == newnumber ) ) {
2417  if ( *s == SETTONUM ) {
2418  if ( n2 == oldnumber && type
2419  <= SYMTOSUB ) goto NoMatch;
2420  m = AT.WildMask;
2421  w = AN.WildValue;
2422  n = AN.NumWild;
2423  while ( --n >= 0 ) {
2424  if ( w[2] == n2 && *w <= SYMTOSUB ) {
2425  if ( !*m ) {
2426  *w = SYMTONUM;
2427  w[3] = i;
2428  AN.WildReserve = 1;
2429  return(0);
2430  }
2431  if ( *w != SYMTONUM )
2432  goto NoMatch;
2433  if ( w[3] == i ) return(0);
2434  i = w[3];
2435  j = (SetElements + Sets[j].first)[i];
2436  if ( j == n2 ) return(0);
2437  goto NoMatch;
2438  }
2439  m++; w += w[1];
2440  }
2441  }
2442  else if ( n2 >= 0 ) {
2443  *newval = *(w - Sets[j].first + Sets[n2].first);
2444  if ( *newval > MAXPOWER ) *newval -= 2*MAXPOWER;
2445  if ( dirty && *newval != oldval ) {
2446  *newval = oldval; goto NoMatch;
2447  }
2448  }
2449  return(0);
2450  }
2451  }
2452  i++;
2453  } while ( ++w < m ); }
2454  if ( notflag ) return(0);
2455  AN.oldtype = old2; AN.oldvalue = oldval; goto NoMatch;
2456  }
2457  else { return(0); }
2458 
2459 NoM:
2460  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2461 }
2462 
2463 /*
2464  #] CheckWild :
2465  #] Wildcards :
2466  #[ DenToFunction :
2467 
2468  Renames the denominator function into a function with the given number.
2469  For the syntax see Denominators,function;
2470 */
2471 
2472 int DenToFunction(WORD *term, WORD numfun)
2473 {
2474  int action = 0;
2475  WORD *t, *tstop, *tnext, *arg, *argstop, *targ;
2476  t = term+1;
2477  tstop = term + *term; tstop -= ABS(tstop[-1]);
2478  while ( t < tstop ) {
2479  if ( *t == DENOMINATOR ) {
2480  *t = numfun; t[2] |= DIRTYFLAG; action = 1;
2481  }
2482  tnext = t + t[1];
2483  if ( *t >= FUNCTION && functions[*t-FUNCTION].spec == 0 ) {
2484  arg = t + FUNHEAD;
2485  while ( arg < tnext ) {
2486  if ( *arg > 0 ) {
2487  targ = arg + ARGHEAD; argstop = arg + *arg;
2488  while ( targ < argstop ) {
2489  if ( DenToFunction(targ,numfun) ) {
2490  arg[1] |= DIRTYFLAG; t[2] |= DIRTYFLAG; action = 1;
2491  }
2492  targ += *targ;
2493  }
2494  arg = argstop;
2495  }
2496  else if ( *arg <= -FUNCTION ) arg++;
2497  else arg += 2;
2498  }
2499  }
2500  t = tnext;
2501  }
2502  return(action);
2503 }
2504 
2505 /*
2506  #] DenToFunction :
2507 */
#define PHEAD
Definition: ftypes.h:56
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition: comtool.c:143
Definition: structs.h:921
WORD * Pointer
Definition: structs.h:924
WORD ** rhs
Definition: structs.h:926
WORD * Top
Definition: structs.h:923
WORD * AddRHS(int num, int type)
Definition: comtool.c:214