FORM  4.1
wildcard.c
Go to the documentation of this file.
1 
12 /* #[ License : */
13 /*
14  * Copyright (C) 1984-2013 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 ( *s == SYMTOSYM ) *m = s[3];
1093  else if ( *s == SYMTONUM ) {
1094  m[-1] = -SNUMBER;
1095  *m = s[3];
1096  }
1097  else if ( *s == SYMTOSUB ) {
1098 ToSub: m--;
1099  w = C->rhs[s[3]];
1100 DEBUG(MesPrint("Thread %w(c): s[3] = %d, w=(%d,%d,%d,%d)",s[3],w[0],w[1],w[2],w[3]);)
1101  s = m;
1102  m += 2;
1103  while ( *w ) {
1104  j = *w;
1105  NCOPY(m,w,j);
1106  }
1107  *s = WORDDIF(m,s);
1108  s[1] = 0;
1109  *m = 0;
1110  if ( t[-1] == -MINVECTOR ) {
1111  w = s+2;
1112  while ( *w ) {
1113  w += *w;
1114  w[-1] = -w[-1];
1115  }
1116  }
1117  if ( ToFast(s,s) ) {
1118  if ( *s <= -FUNCTION ) m = s;
1119  else m = s + 1;
1120  }
1121  else m--;
1122  }
1123  break;
1124  }
1125  s += s[1];
1126  }
1127  m++; t++;
1128  }
1129  else if ( *t == -INDEX ) {
1130  *m++ = *t++;
1131  *m = *t;
1132  s = subs;
1133  for ( j = 0; j < i; j++ ) {
1134  if ( *t == s[2] ) {
1135  if ( *s == INDTOIND || *s == VECTOVEC ) {
1136  *m = s[3];
1137  if ( *m < MINSPEC ) m[-1] = -VECTOR;
1138  else if ( *m >= 0 && *m < AM.OffsetIndex )
1139  m[-1] = -SNUMBER;
1140  else m[-1] = -INDEX;
1141  }
1142  else if ( *s == VECTOSUB || *s == INDTOSUB ) {
1143  m[-1] = -INDEX;
1144  *m = ++AR.CurDum;
1145  *z++ = SUBEXPRESSION;
1146  *z++ = 4+SUBEXPSIZE;
1147  *z++ = s[3]+1;
1148  *z++ = 1;
1149  *z++ = AT.ebufnum;
1150  FILLSUB(z)
1151  *z++ = INDTOIND;
1152  *z++ = 4;
1153  *z++ = FUNNYVEC;
1154  *z++ = AR.CurDum;
1155  }
1156  v[2] |= DIRTYFLAG; dirty = 1;
1157  break;
1158  }
1159  s += s[1];
1160  }
1161  m++; t++;
1162  }
1163  else if ( *t == -VECTOR || *t == -MINVECTOR ) {
1164  *m++ = *t++;
1165  *m = *t;
1166  s = subs;
1167  for ( j = 0; j < i; j++ ) {
1168  if ( *t == s[2] ) {
1169  if ( *s == VECTOVEC ) *m = s[3];
1170  else if ( *s == VECTOMIN ) {
1171  *m = s[3];
1172  if ( t[-1] == -VECTOR )
1173  m[-1] = -MINVECTOR;
1174  else
1175  m[-1] = -VECTOR;
1176  }
1177  else if ( *s == VECTOSUB ) goto ToSub;
1178  dirty = 1; v[2] |= DIRTYFLAG;
1179  break;
1180  }
1181  s += s[1];
1182  }
1183  m++; t++;
1184  }
1185  else if ( *t == -SNUMBER ) {
1186  *m++ = *t++;
1187  *m = *t;
1188  s = subs;
1189  for ( j = 0; j < i; j++ ) {
1190  if ( *t == s[2] && *s >= NUMTONUM && *s <= NUMTOSUB ) {
1191  dirty = 1; v[2] |= DIRTYFLAG;
1192  if ( *s == NUMTONUM ) *m = s[3];
1193  else if ( *s == NUMTOSYM ) {
1194  m[-1] = -SYMBOL;
1195  *m = s[3];
1196  }
1197  else if ( *s == NUMTOIND ) {
1198  m[-1] = -INDEX;
1199  *m = s[3];
1200  }
1201  else if ( *s == NUMTOSUB ) goto ToSub;
1202  break;
1203  }
1204  s += s[1];
1205  }
1206  m++; t++;
1207  }
1208  else {
1209 ss9: *m++ = *t++;
1210 ss10: *m++ = *t++;
1211  }
1212  na = WORDDIF(z,accu);
1213 /*
1214  #] Simple arguments :
1215 */
1216  }
1217  else {
1218  w = m;
1219  zz = t;
1220  NEXTARG(zz)
1221  odirt = AN.WildDirt; AN.WildDirt = 0;
1222  AR.CompressPointer = accu + na;
1223  for ( j = 0; j < ARGHEAD; j++ ) *m++ = *t++;
1224  j = 0;
1225  adirt = 0;
1226  while ( t < zz ) { /* do a term */
1227  if ( ( len = WildFill(BHEAD m,t,sub) ) < 0 ) {
1228  MLOCK(ErrorMessageLock);
1229  MesCall("WildFill");
1230  MUNLOCK(ErrorMessageLock);
1231  SETERROR(-1)
1232  }
1233  if ( AN.WildDirt ) {
1234  adirt = AN.WildDirt;
1235  AN.WildDirt = 0;
1236  }
1237  m += len;
1238  t += *t;
1239  }
1240  *w = WORDDIF(m,w); /* Fill parameter length */
1241  if ( adirt ) {
1242  dirty = w[1] = 1; v[2] |= DIRTYFLAG;
1243  AN.WildDirt = adirt;
1244  }
1245  else {
1246  AN.WildDirt = odirt;
1247  }
1248  if ( ToFast(w,w) ) {
1249  if ( *w <= -FUNCTION ) {
1250  if ( *w == NUMARGSFUN || *w == NUMTERMSFUN ) {
1251  *w = -SNUMBER; w[1] = 0; m = w + 2;
1252  }
1253  else m = w+1;
1254  }
1255  else m = w+2;
1256  }
1257  AR.CompressPointer = oldcpointer;
1258  }
1259  }
1260  v[1] = WORDDIF(m,v); /* Fill function length */
1261  s = accu;
1262  NCOPY(m,s,na);
1263 /*
1264  Now some code to speed up a few special cases
1265 */
1266  if ( v[0] == EXPONENT ) {
1267  if ( v[1] == FUNHEAD+4 && v[FUNHEAD] == -SYMBOL &&
1268  v[FUNHEAD+2] == -SNUMBER && v[FUNHEAD+3] < MAXPOWER
1269  && v[FUNHEAD+3] > -MAXPOWER ) {
1270  v[0] = SYMBOL;
1271  v[1] = 4;
1272  v[2] = v[FUNHEAD+1];
1273  v[3] = v[FUNHEAD+3];
1274  m = v+4;
1275  }
1276  else if ( v[1] == FUNHEAD+ARGHEAD+11
1277  && v[FUNHEAD] == ARGHEAD+9
1278  && v[FUNHEAD+ARGHEAD] == 9
1279  && v[FUNHEAD+ARGHEAD+1] == DOTPRODUCT
1280  && v[FUNHEAD+ARGHEAD+8] == 3
1281  && v[FUNHEAD+ARGHEAD+7] == 1
1282  && v[FUNHEAD+ARGHEAD+6] == 1
1283  && v[FUNHEAD+ARGHEAD+5] == 1
1284  && v[FUNHEAD+ARGHEAD+9] == -SNUMBER
1285  && v[FUNHEAD+ARGHEAD+10] < MAXPOWER
1286  && v[FUNHEAD+ARGHEAD+10] > -MAXPOWER ) {
1287  v[0] = DOTPRODUCT;
1288  v[1] = 5;
1289  v[2] = v[FUNHEAD+ARGHEAD+3];
1290  v[3] = v[FUNHEAD+ARGHEAD+4];
1291  v[4] = v[FUNHEAD+ARGHEAD+10];
1292  m = v+5;
1293  }
1294  }
1295  }
1296  else { while ( t < u ) *m++ = *t++; }
1297 /*
1298  #] FUNCTIONS :
1299 */
1300  }
1301  t = uu;
1302  } while ( t < r );
1303  t = from; /* Copy coefficient */
1304  t += *t;
1305  if ( r < t ) do { *m++ = *r++; } while ( r < t );
1306  if ( ( sgn & 1 ) != 0 ) m[-1] = -m[-1];
1307  *to = WORDDIF(m,to);
1308  if ( dirty ) AN.WildDirt = dirty;
1309  return(*to);
1310 }
1311 
1312 /*
1313  #] WildFill :
1314  #[ ResolveSet : WORD ResolveSet(from,to,subs)
1315 
1316  The set syntax is:
1317  SET,length,subterm,where,whichmember[,where,whichmember]
1318 
1319  setlength is 2*n+1 with n the number of set substitutions.
1320  length = setlength + subtermlength + 2
1321 
1322  At `where' is the number of the set and `whichmember' is the
1323  number of the element. This is still a symbol/dollar and we
1324  have to find the substitution in the wildcards.
1325  The output is the subterm in which the setelements have been
1326  substituted. This is ready for further wildcard substitutions.
1327 */
1328 
1329 WORD ResolveSet(PHEAD WORD *from, WORD *to, WORD *subs)
1330 {
1331  GETBIDENTITY
1332  WORD *m, *s, *w, j, i, ii, i3, flag, num;
1333  DOLLARS d = 0;
1334 #ifdef WITHPTHREADS
1335  int nummodopt, dtype = -1;
1336 #endif
1337  m = to; /* pointer in output */
1338  s = from + 2;
1339  w = s + s[1];
1340  while ( s < w ) *m++ = *s++;
1341  j = (from[1] - WORDDIF(w,from) ) >> 1;
1342  m = subs + subs[1];
1343  subs += SUBEXPSIZE;
1344  s = subs;
1345  i = 0;
1346  while ( s < m ) { i++; s += s[1]; }
1347  m = to;
1348  if ( *m >= FUNCTION && functions[*m-FUNCTION].spec
1349  >= TENSORFUNCTION ) flag = 0;
1350  else flag = 1;
1351  while ( --j >= 0 ) {
1352  if ( w[1] >= 0 ) {
1353  s = subs;
1354  for ( ii = 0; ii < i; ii++ ) {
1355  if ( *s == SYMTONUM && s[2] == w[1] ) { num = s[3]; goto GotOne; }
1356  s += s[1];
1357  }
1358  MLOCK(ErrorMessageLock);
1359  MesPrint(" Unresolved setelement during substitution");
1360  MUNLOCK(ErrorMessageLock);
1361  return(-1);
1362  }
1363  else { /* Dollar ! */
1364  d = Dollars - w[1];
1365 #ifdef WITHPTHREADS
1366  if ( AS.MultiThreaded ) {
1367  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1368  if ( -w[1] == ModOptdollars[nummodopt].number ) break;
1369  }
1370  if ( nummodopt < NumModOptdollars ) {
1371  dtype = ModOptdollars[nummodopt].type;
1372  if ( dtype == MODLOCAL ) {
1373  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1374  }
1375  else {
1376  LOCK(d->pthreadslockread);
1377  }
1378  }
1379  }
1380 #endif
1381  if ( d->type == DOLNUMBER || d->type == DOLTERMS ) {
1382  if ( d->where[0] == 4 && d->where[3] == 3 && d->where[2] == 1
1383  && d->where[1] > 0 && d->where[4] == 0 ) {
1384  num = d->where[1]; goto GotOne;
1385  }
1386  }
1387  else if ( d->type == DOLINDEX ) {
1388  if ( d->index > 0 && d->index < AM.OffsetIndex ) {
1389  num = d->index; goto GotOne;
1390  }
1391  }
1392  else if ( d->type == DOLARGUMENT ) {
1393  if ( d->where[0] == -SNUMBER && d->where[1] > 0 ) {
1394  num = d->where[1]; goto GotOne;
1395  }
1396  }
1397  else if ( d->type == DOLWILDARGS ) {
1398  if ( d->where[0] == 1 &&
1399  d->where[1] > 0 && d->where[1] < AM.OffsetIndex ) {
1400  num = d->where[1]; goto GotOne;
1401  }
1402  if ( d->where[0] == 0 && d->where[1] < 0 && d->where[3] == 0 ) {
1403  if ( ( d->where[1] == -SNUMBER && d->where[2] > 0 )
1404  || ( d->where[1] == -INDEX && d->where[2] > 0
1405  && d->where[2] < AM.OffsetIndex ) ) {
1406  num = d->where[2]; goto GotOne;
1407  }
1408  }
1409  }
1410 #ifdef WITHPTHREADS
1411  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1412 #endif
1413  MLOCK(ErrorMessageLock);
1414  MesPrint("Unusable type of variable $%s in set substitution",
1415  AC.dollarnames->namebuffer+d->name);
1416  MUNLOCK(ErrorMessageLock);
1417  return(-1);
1418  }
1419 GotOne:;
1420 #ifdef WITHPTHREADS
1421  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1422 #endif
1423  ii = m[*w];
1424  if ( ii >= 2*MAXPOWER ) i3 = ii - 2*MAXPOWER;
1425  else if ( ii <= -2*MAXPOWER ) i3 = -ii - 2*MAXPOWER;
1426  else i3 = ( ii >= 0 ) ? ii: -ii - 1;
1427 
1428  if ( num > ( Sets[i3].last - Sets[i3].first ) || num <= 0 ) {
1429  MLOCK(ErrorMessageLock);
1430  MesPrint("Array bound check during set substitution");
1431  MesPrint(" value is %d",num);
1432  MUNLOCK(ErrorMessageLock);
1433  return(-1);
1434  }
1435  m[*w] = (SetElements+Sets[i3].first)[num-1];
1436  if ( Sets[i3].type == CSYMBOL && m[*w] > MAXPOWER ) {
1437  if ( ii >= 2*MAXPOWER ) m[*w] -= 2*MAXPOWER;
1438  else if ( ii <= -2*MAXPOWER ) m[*w] = -(m[*w] - 2*MAXPOWER);
1439  else {
1440  m[*w] -= MAXPOWER;
1441  if ( m[*w] < MAXPOWER ) m[*w] -= 2*MAXPOWER;
1442  if ( flag ) MakeDirty(m,m+*w,1);
1443  }
1444  }
1445  else if ( Sets[i3].type == CSYMBOL ) {
1446  if ( ii >= 2*MAXPOWER ) m[*w] += 2*MAXPOWER;
1447  else if ( ii <= -2*MAXPOWER ) m[*w] = -m[*w] - 2*MAXPOWER;
1448  else if ( ii < 0 ) m[*w] = - m[*w];
1449  }
1450  else if ( ii < 0 ) m[*w] = - m[*w];
1451  w += 2;
1452  }
1453  m = to;
1454  if ( *m >= FUNCTION && functions[*m-FUNCTION].spec
1455  >= TENSORFUNCTION ) {
1456  w = from + 2 + from[3];
1457  if ( *w == 0 ) { /* We had function -> tensor */
1458  m = from + 2 + FUNHEAD; s = to + FUNHEAD;
1459  while ( m < w ) {
1460  if ( *m == -INDEX || *m == -VECTOR ) {}
1461  else if ( *m == -ARGWILD ) { *s++ = FUNNYWILD; }
1462  else {
1463  MLOCK(ErrorMessageLock);
1464  MesPrint("Illegal argument in tensor after set substitution");
1465  MUNLOCK(ErrorMessageLock);
1466  SETERROR(-1)
1467  }
1468  *s++ = m[1];
1469  m += 2;
1470  }
1471  to[1] = WORDDIF(s,to);
1472  }
1473  }
1474  return(0);
1475 }
1476 
1477 /*
1478  #] ResolveSet :
1479  #[ ClearWild : VOID ClearWild()
1480 
1481  Clears the current wildcard settings and makes them ready for
1482  CheckWild and AddWild.
1483 
1484 */
1485 
1486 VOID ClearWild(PHEAD0)
1487 {
1488  GETBIDENTITY
1489  WORD n, nn, *w;
1490  n = (AN.WildValue[-SUBEXPSIZE+1]-SUBEXPSIZE)/4; /* Number of wildcards */
1491  AN.NumWild = nn = n;
1492  if ( n > 0 ) {
1493  w = AT.WildMask;
1494  do { *w++ = 0; } while ( --n > 0 );
1495  w = AN.WildValue;
1496  do {
1497  if ( *w == SYMTONUM ) *w = SYMTOSYM;
1498  w += w[1];
1499  } while ( --nn > 0 );
1500  }
1501 }
1502 
1503 /*
1504  #] ClearWild :
1505  #[ AddWild : WORD AddWild(oldnumber,type,newnumber)
1506 
1507  Adds a wildcard assignment.
1508  Extra parameter in AN.argaddress;
1509 
1510 */
1511 
1512 WORD AddWild(PHEAD WORD oldnumber, WORD type, WORD newnumber)
1513 {
1514  GETBIDENTITY
1515  WORD *w, *m, n, k, i = -1;
1516  CBUF *C = cbuf+AT.ebufnum;
1517 DEBUG(WORD *mm;)
1518  AN.WildReserve = 0;
1519  m = AT.WildMask;
1520  w = AN.WildValue;
1521  n = AN.NumWild;
1522  if ( n <= 0 ) { return(-1); }
1523  if ( type <= SYMTOSUB ) {
1524  do {
1525  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1526  if ( n > 1 && w[4] == SETTONUM ) i = w[7];
1527  *w = type;
1528  if ( *m != 2 ) *m = 1;
1529  if ( type != SYMTOSUB ) {
1530  if ( type == SYMTONUM ) AN.MaskPointer = m;
1531  w[3] = newnumber;
1532  goto FlipOn;
1533  }
1534  m = AddRHS(AT.ebufnum,1);
1535  w[3] = C->numrhs;
1536  w = AN.argaddress;
1537 DEBUG(mm = m;)
1538  n = *w - ARGHEAD;
1539  w += ARGHEAD;
1540  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m);
1541  while ( --n >= 0 ) *m++ = *w++;
1542  *m++ = 0;
1543  C->rhs[C->numrhs+1] = m;
1544 DEBUG(MesPrint("Thread %w(d): m=(%d,%d,%d,%d)(%d)",mm[0],mm[1],mm[2],mm[3],C->numrhs);)
1545  C->Pointer = m;
1546  goto FlipOn;
1547  }
1548  m++; w += w[1];
1549  } while ( --n > 0 );
1550  }
1551  else if ( type == ARGTOARG ) {
1552  do {
1553  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1554  *m = 1;
1555  m = AddRHS(AT.ebufnum,1);
1556  w[3] = C->numrhs;
1557  w = AN.argaddress;
1558 DEBUG(mm=m;)
1559  if ( ( newnumber & EATTENSOR ) != 0 ) {
1560  n = newnumber & ~EATTENSOR;
1561  *m++ = n;
1562  w = AN.argaddress;
1563  }
1564  else {
1565  while ( --newnumber >= 0 ) { NEXTARG(w) }
1566  n = WORDDIF(w,AN.argaddress);
1567  w = AN.argaddress;
1568  *m++ = 0;
1569  }
1570  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m);
1571 DEBUG(if ( mm != m-1 ) MesPrint("Thread %w(e): Alarm!"); mm = m-1;)
1572  while ( --n >= 0 ) *m++ = *w++;
1573  *m++ = 0;
1574  C->rhs[C->numrhs+1] = m;
1575  C->Pointer = m;
1576 DEBUG(MesPrint("Thread %w(e): w=(%d,%d,%d,%d)(%d)",mm[0],mm[1],mm[2],mm[3],C->numrhs);)
1577  return(0);
1578  }
1579  m++; w += w[1];
1580  } while ( --n > 0 );
1581  }
1582  else if ( type == ARLTOARL ) {
1583  do {
1584  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1585  WORD **a;
1586  *m = 1;
1587  m = AddRHS(AT.ebufnum,1);
1588  w[3] = C->numrhs;
1589 DEBUG(mm=m;)
1590  a = (WORD **)(AN.argaddress); n = 0; k = newnumber;
1591  while ( --newnumber >= 0 ) {
1592  w = *a++;
1593  if ( *w > 0 ) n += *w;
1594  else if ( *w <= -FUNCTION ) n++;
1595  else n += 2;
1596  }
1597  *m++ = 0;
1598  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m);
1599 DEBUG(if ( mm != m-1 ) MesPrint("Thread %w(f): Alarm!"); mm = m-1;)
1600  a = (WORD **)(AN.argaddress);
1601  while ( --k >= 0 ) {
1602  w = *a++;
1603  if ( *w > 0 ) { n = *w; NCOPY(m,w,n); }
1604  else if ( *w <= -FUNCTION ) *m++ = *w++;
1605  else { *m++ = *w++; *m++ = *w++; }
1606  }
1607  *m++ = 0;
1608  C->rhs[C->numrhs+1] = m;
1609 DEBUG(MesPrint("Thread %w(f): w=(%d,%d,%d,%d)(%d)",mm[0],mm[1],mm[2],mm[3],C->numrhs);)
1610  C->Pointer = m;
1611  return(0);
1612  }
1613  m++; w += w[1];
1614  } while ( --n > 0 );
1615  }
1616  else if ( type == VECTOSUB || type == INDTOSUB ) {
1617  WORD *ss, *sstop, *tt, *ttstop, j, *v1, *v2 = 0;
1618  do {
1619  if ( w[2] == oldnumber && ( *w == type ||
1620  ( type == VECTOSUB && ( *w == VECTOVEC || *w == VECTOMIN ) )
1621  || ( type == INDTOSUB && *w == INDTOIND ) ) ) {
1622  if ( n > 1 && w[4] == SETTONUM ) i = w[7];
1623  *w = type;
1624  *m = 1;
1625  m = AddRHS(AT.ebufnum,1);
1626  w[3] = C->numrhs;
1627  w = AN.argaddress;
1628  n = *w - ARGHEAD;
1629  w += ARGHEAD;
1630  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m);
1631  while ( --n >= 0 ) *m++ = *w++;
1632  *m++ = 0;
1633  C->rhs[C->numrhs+1] = m;
1634  C->Pointer = m;
1635  m = AddRHS(AT.ebufnum,1);
1636  w = AN.argaddress;
1637  n = *w - ARGHEAD;
1638  w += ARGHEAD;
1639  while ( (m + n + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m);
1640  sstop = w + n;
1641  while ( w < sstop ) { /* Run over terms */
1642  tt = w + *w; ttstop = tt - ABS(tt[-1]);
1643  ss = m; m++; w++;
1644  while ( w < ttstop ) { /* Subterms */
1645  if ( *w != INDEX ) {
1646  j = w[1];
1647  NCOPY(m,w,j);
1648  }
1649  else {
1650  v1 = m;
1651  *m++ = *w++;
1652  *m++ = j = *w++;
1653  j -= 2;
1654  while ( --j >= 0 ) {
1655  if ( *w >= MINSPEC ) *m++ = *w++;
1656  else v2 = w++;
1657  }
1658  j = WORDDIF(m,v1);
1659  if ( j != v1[1] ) {
1660  if ( j <= 2 ) m -= 2;
1661  else v1[1] = j;
1662  *m++ = VECTOR;
1663  *m++ = 4;
1664  *m++ = *v2;
1665  *m++ = FUNNYVEC;
1666  }
1667  }
1668  }
1669  while ( w < tt ) *m++ = *w++;
1670  *ss = WORDDIF(m,ss);
1671  }
1672  *m++ = 0;
1673  C->rhs[C->numrhs+1] = m;
1674  C->Pointer = m;
1675  if ( m > C->Top ) {
1676  MLOCK(ErrorMessageLock);
1677  MesPrint("Internal problems with extra compiler buffer");
1678  MUNLOCK(ErrorMessageLock);
1679  Terminate(-1);
1680  }
1681  goto FlipOn;
1682  }
1683  m++; w += w[1];
1684  } while ( --n > 0 );
1685  }
1686  else {
1687  do {
1688  if ( w[2] == oldnumber && ( *w == type || ( type == VECTOVEC
1689  && ( *w == VECTOMIN || *w == VECTOSUB ) )
1690  || ( type == INDTOIND && *w == INDTOSUB ) ) ) {
1691  if ( n > 1 && w[4] == SETTONUM ) i = w[7];
1692  *w = type;
1693  w[3] = newnumber;
1694  *m = 1;
1695  goto FlipOn;
1696  }
1697  m++; w += w[1];
1698  } while ( --n > 0 );
1699  }
1700  MLOCK(ErrorMessageLock);
1701  MesPrint("Bug in AddWild.");
1702  MUNLOCK(ErrorMessageLock);
1703  return(-1);
1704 FlipOn:
1705  if ( i >= 0 ) {
1706  m = AT.WildMask;
1707  w = AN.WildValue;
1708  n = AN.NumWild;
1709  while ( --n >= 0 ) {
1710  if ( w[2] == i && *w == SYMTONUM ) {
1711  *m = 2;
1712  return(0);
1713  }
1714  m++; w += w[1];
1715  }
1716  MLOCK(ErrorMessageLock);
1717  MesPrint(" Bug in AddWild with passing set[i]");
1718  MUNLOCK(ErrorMessageLock);
1719 /*
1720  For the moment we want to crash here. That is easier with debugging.
1721 */
1722 #ifdef WITHPTHREADS
1723  { WORD *s = 0;
1724  *s++ = 1;
1725  }
1726 #endif
1727  Terminate(-1);
1728  }
1729  return(0);
1730 }
1731 
1732 /*
1733  #] AddWild :
1734  #[ CheckWild : WORD CheckWild(oldnumber,type,newnumber,newval)
1735 
1736  Tests whether a wildcard assignment is allowed.
1737  A return value of zero means that it is allowed (nihil obstat).
1738  If the variable has been assigned already its existing
1739  assignment is returned in AN.oldvalue and AN.oldtype, which are
1740  global variables.
1741 
1742  Note the special problem with name?set[i]. Here we have to pass
1743  an extra assignment. This cannot be done via globals as we
1744  call CheckWild sometimes twice before calling AddWild.
1745  Trick: Check the assignment of the number and if OK put it
1746  in place, but don't alter the used flag (if needed).
1747  Then AddWild can alter the used flag but the value is there.
1748  As long as this trick is `hanging' we turn on the flag:
1749  `AN.WildReserve' which is either turned off by AddWild or by
1750  a failing call to CheckWild.
1751 
1752  With ARGTOARG the tensors give the number of arguments
1753  or-ed with EATTENSOR which is at least 8192.
1754 */
1755 
1756 WORD CheckWild(PHEAD WORD oldnumber, WORD type, WORD newnumber, WORD *newval)
1757 {
1758  GETBIDENTITY
1759  WORD *w, *m, *s, n, old2;
1760  WORD n2, oldval, dirty, i, j, notflag = 0, retblock = 0;
1761  CBUF *C = cbuf+AT.ebufnum;
1762  m = AT.WildMask;
1763  w = AN.WildValue;
1764  n = AN.NumWild;
1765  if ( n <= 0 ) { AN.oldtype = -1; AN.WildReserve = 0; return(-1); }
1766  switch ( type ) {
1767  case SYMTONUM :
1768  *newval = newnumber;
1769  do {
1770  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1771  old2 = *w;
1772  if ( !*m ) goto TestSet;
1773  AN.MaskPointer = m;
1774  if ( *w == SYMTONUM && w[3] == newnumber ) {
1775  return(0);
1776  }
1777  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
1778  }
1779  m++; w += w[1];
1780  } while ( --n > 0 );
1781  break;
1782  case SYMTOSYM :
1783  *newval = newnumber;
1784  do {
1785  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1786  old2 = *w;
1787  if ( *w == SYMTOSYM ) {
1788  if ( !*m ) goto TestSet;
1789  if ( newnumber >= 0 && (w+4) < AN.WildStop
1790  && ( w[4] == FROMSET || w[4] == SETTONUM )
1791  && w[7] >= 0 ) goto TestSet;
1792  if ( w[3] == newnumber ) return(0);
1793  }
1794  else {
1795  if ( !*m ) goto TestSet;
1796  }
1797  goto NoM;
1798  }
1799  m++; w += w[1];
1800  } while ( --n > 0 );
1801  break;
1802  case SYMTOSUB :
1803 /*
1804  Now newval contains the pointer to the argument.
1805 */
1806  {
1807 /*
1808  Search for vector or index nature. If so: reject.
1809 */
1810  WORD *ss, *sstop, *tt, *ttstop;
1811  ss = newval;
1812  sstop = ss + *ss;
1813  ss += ARGHEAD;
1814  while ( ss < sstop ) {
1815  tt = ss + *ss;
1816  ttstop = tt - ABS(tt[-1]);
1817  ss++;
1818  while ( ss < ttstop ) {
1819  if ( *ss == INDEX ) goto NoMatch;
1820  ss += ss[1];
1821  }
1822  ss = tt;
1823  }
1824  }
1825  do {
1826  if ( w[2] == oldnumber && *w <= SYMTOSUB ) {
1827  old2 = *w;
1828  if ( *w == SYMTONUM || *w == SYMTOSYM ) {
1829  if ( !*m ) {
1830  s = w + w[1];
1831  if ( s >= AN.WildStop || *s != SETTONUM )
1832  goto TestSet;
1833  }
1834  }
1835  else if ( *w == SYMTOSUB ) {
1836  if ( !*m ) {
1837  s = w + w[1];
1838  if ( s >= AN.WildStop || *s != SETTONUM )
1839  goto TestSet;
1840  }
1841  n = *newval - 2;
1842  newval += 2;
1843  m = C->rhs[w[3]];
1844  if ( (C->rhs[w[3]+1] - m - 1) == n ) {
1845  while ( n > 0 ) {
1846  if ( *m != *newval ) {
1847  m++; newval++; break;
1848  }
1849  m++; newval++;
1850  n--;
1851  }
1852  if ( n <= 0 ) return(0);
1853  }
1854  }
1855  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
1856  }
1857  m++; w += w[1];
1858  } while ( --n > 0 );
1859  break;
1860  case ARGTOARG :
1861  do {
1862  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1863  if ( !*m ) return(0); /* nihil obstat */
1864  m = C->rhs[w[3]];
1865  if ( ( newnumber & EATTENSOR ) != 0 ) {
1866  n = newnumber & ~EATTENSOR;
1867  if ( *m != 0 ) {
1868  if ( n == *m ) {
1869  m++;
1870  while ( --n >= 0 ) {
1871  if ( *m != *newval ) {
1872  m++; newval++; break;
1873  }
1874  m++; newval++;
1875  }
1876  if ( n < 0 ) return(0);
1877  }
1878  }
1879  else {
1880  m++;
1881  while ( --n >= 0 ) {
1882  if ( *newval != m[1] || ( *m != -INDEX
1883  && *m != -VECTOR && *m != -SNUMBER ) ) break;
1884  m += 2;
1885  newval++;
1886  }
1887  if ( n < 0 && *m == 0 ) return(0);
1888  }
1889  }
1890  else {
1891  i = newnumber;
1892  if ( *m != 0 ) { /* Tensor field */
1893  if ( *m == i ) {
1894  m++;
1895  while ( --i >= 0 ) {
1896  if ( *m != newval[1]
1897  || ( *newval != -VECTOR
1898  && *newval != -INDEX
1899  && *newval != -SNUMBER ) ) break;
1900  newval += 2;
1901  m++;
1902  }
1903  if ( i < 0 ) return(0);
1904  }
1905  }
1906  else {
1907  m++;
1908  s = newval;
1909  while ( --i >= 0 ) { NEXTARG(s) }
1910  n = WORDDIF(s,newval);
1911  while ( --n >= 0 ) {
1912  if ( *m != *newval ) {
1913  m++; newval++; break;
1914  }
1915  m++; newval++;
1916  }
1917  if ( n < 0 && *m == 0 ) return(0);
1918  }
1919  }
1920  AN.oldtype = *w; AN.oldvalue = w[3]; goto NoMatch;
1921  }
1922  m++; w += w[1];
1923  } while ( --n > 0 );
1924  break;
1925  case ARLTOARL :
1926  do {
1927  if ( w[2] == oldnumber && *w == ARGTOARG ) {
1928  WORD **a;
1929  if ( !*m ) return(0); /* nihil obstat */
1930  m = C->rhs[w[3]];
1931  i = newnumber;
1932  a = (WORD **)newval;
1933  if ( *m != 0 ) { /* Tensor field */
1934  if ( *m == i ) {
1935  m++;
1936  while ( --i >= 0 ) {
1937  s = *a++;
1938  if ( *m != s[1]
1939  || ( *s != -VECTOR
1940  && *s != -INDEX
1941  && *s != -SNUMBER ) ) break;
1942  m++;
1943  }
1944  if ( i < 0 ) return(0);
1945  }
1946  }
1947  else {
1948  m++;
1949  while ( --i >= 0 ) {
1950  s = *a++;
1951  if ( *s > 0 ) {
1952  n = *s;
1953  while ( --n >= 0 ) {
1954  if ( *s != *m ) {
1955  s++; m++; break;
1956  }
1957  s++; m++;
1958  }
1959  if ( n >= 0 ) break;
1960  }
1961  else if ( *s <= -FUNCTION ) {
1962  if ( *s != *m ) {
1963  s++; m++; break;
1964  }
1965  s++; m++;
1966  }
1967  else {
1968  if ( *s != *m ) {
1969  s++; m++; break;
1970  }
1971  s++; m++;
1972  if ( *s != *m ) {
1973  s++; m++; break;
1974  }
1975  s++; m++;
1976  }
1977  }
1978  if ( i < 0 && *m == 0 ) return(0);
1979  }
1980  AN.oldtype = *w; AN.oldvalue = w[3]; goto NoMatch;
1981  }
1982  m++; w += w[1];
1983  } while ( --n > 0 );
1984  break;
1985  case VECTOSUB :
1986  case INDTOSUB :
1987 /*
1988  Now newval contains the pointer to the argument(s).
1989 */
1990  {
1991 /*
1992  Search for vector or index nature. If not so: reject.
1993 */
1994  WORD *ss, *sstop, *tt, *ttstop, count, jt;
1995  ss = newval;
1996  sstop = ss + *ss;
1997  ss += ARGHEAD;
1998  while ( ss < sstop ) {
1999  tt = ss + *ss;
2000  ttstop = tt - ABS(tt[-1]);
2001  ss++;
2002  count = 0;
2003  while ( ss < ttstop ) {
2004  if ( *ss == INDEX ) {
2005  jt = ss[1] - 2; ss += 2;
2006  while ( --jt >= 0 ) {
2007  if ( *ss < MINSPEC ) count++;
2008  ss++;
2009  }
2010  }
2011  else ss += ss[1];
2012  }
2013  if ( count != 1 ) goto NoMatch;
2014  ss = tt;
2015  }
2016  }
2017  do {
2018  if ( w[2] == oldnumber ) {
2019  old2 = *w;
2020  if ( ( type == VECTOSUB && ( *w == VECTOVEC || *w == VECTOMIN ) )
2021  || ( type == INDTOSUB && *w == INDTOIND ) ) {
2022  if ( !*m ) goto TestSet;
2023  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2024  }
2025  else if ( *w == type ) {
2026  if ( !*m ) goto TestSet;
2027  if ( type != INDTOIND && type != INDTOSUB ) { /* Prevent double index */
2028  n = *newval - 2;
2029  newval += 2;
2030  m = C->rhs[w[3]];
2031  if ( (C->rhs[w[3]+1] - m - 1) == n ) {
2032  while ( n > 0 ) {
2033  if ( *m != *newval ) {
2034  m++; newval++; break;
2035  }
2036  m++; newval++;
2037  n--;
2038  }
2039  if ( n <= 0 ) return(0);
2040  }
2041  }
2042  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2043  }
2044  }
2045  m++; w += w[1];
2046  } while ( --n > 0 );
2047  break;
2048  default :
2049  *newval = newnumber;
2050  do {
2051  if ( w[2] == oldnumber ) {
2052  if ( *w == type ) {
2053  old2 = *w;
2054  if ( !*m ) goto TestSet;
2055  if ( newnumber >= 0 && (w+4) < AN.WildStop &&
2056  ( w[4] == FROMSET || w[4] == SETTONUM )
2057  && w[7] >= 0 ) goto TestSet;
2058  if ( newnumber < 0 && *w == VECTOVEC
2059  && (w+4) < AN.WildStop && ( w[4] == FROMSET
2060  || w[4] == SETTONUM ) && w[7] >= 0 ) goto TestSet;
2061 /*
2062  The next statement kills multiple indices -> vector
2063 */
2064  if ( *w == INDTOIND && w[3] < 0 ) goto NoMatch;
2065  if ( w[3] == newnumber ) {
2066  if ( *w != FUNTOFUN || newnumber < FUNCTION
2067  || functions[newnumber-FUNCTION].spec ==
2068  functions[oldnumber-FUNCTION].spec )
2069  return(0);
2070  }
2071  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2072  }
2073  else if ( ( type == VECTOVEC &&
2074  ( *w == VECTOSUB || *w == VECTOMIN ) )
2075  || ( type == INDTOIND && *w == INDTOSUB ) ) {
2076  if ( *m ) goto NoMatch;
2077  old2 = *w;
2078  goto TestSet;
2079  }
2080  }
2081  m++; w += w[1];
2082  if ( n > 1 && ( *w == FROMSET
2083  || *w == SETTONUM ) ) { n--; m++; w += w[1]; }
2084  } while ( --n > 0 );
2085  break;
2086  }
2087  AN.oldtype = -1;
2088  AN.oldvalue = -1;
2089  AN.WildReserve = 0;
2090  MLOCK(ErrorMessageLock);
2091  MesPrint("Inconsistency in Wildcard prototype.");
2092  MUNLOCK(ErrorMessageLock);
2093  return(-1);
2094 NoMatch:
2095  AN.WildReserve = 0;
2096  return(1+retblock);
2097 /*
2098  Here we test the compatibility with a set specification.
2099 */
2100 TestSet:
2101  dirty = *m;
2102  oldval = w[3];
2103  w += w[1];
2104  if ( w < AN.WildStop && ( *w == FROMSET || *w == SETTONUM ) ) {
2105  WORD k;
2106  s = w;
2107  j = w[2]; n2 = w[3];
2108  if ( j > WILDOFFSET ) {
2109  j -= 2*WILDOFFSET;
2110  notflag = 1;
2111 /*
2112  ???????
2113 */
2114  AN.oldtype = -1;
2115  AN.oldvalue = -1;
2116  }
2117  if ( j < AM.NumFixedSets ) { /* special set */
2118  retblock = 1;
2119  switch ( j ) {
2120  case POS_:
2121  if ( type != SYMTONUM ||
2122  newnumber <= 0 ) goto NoMnot;
2123  break;
2124  case POS0_:
2125  if ( type != SYMTONUM ||
2126  newnumber < 0 ) goto NoMnot;
2127  break;
2128  case NEG_:
2129  if ( type != SYMTONUM ||
2130  newnumber >= 0 ) goto NoMnot;
2131  break;
2132  case NEG0_:
2133  if ( type != SYMTONUM ||
2134  newnumber > 0 ) goto NoMnot;
2135  break;
2136  case EVEN_:
2137  if ( type != SYMTONUM ||
2138  ( newnumber & 1 ) != 0 ) goto NoMnot;
2139  break;
2140  case ODD_:
2141  if ( type != SYMTONUM ||
2142  ( newnumber & 1 ) == 0 ) goto NoMnot;
2143  break;
2144  case Z_:
2145  if ( type != SYMTONUM ) goto NoMnot;
2146  break;
2147  case SYMBOL_:
2148  if ( type != SYMTOSYM ) goto NoMnot;
2149  break;
2150  case FIXED_:
2151  if ( type != INDTOIND ||
2152  newnumber >= AM.OffsetIndex ||
2153  newnumber < 0 ) goto NoMnot;
2154  break;
2155  case INDEX_:
2156  if ( type != INDTOIND ||
2157  newnumber < 0 ) goto NoMnot;
2158  break;
2159  case Q_:
2160  if ( type == SYMTONUM ) break;
2161  if ( type == SYMTOSUB ) {
2162  WORD *ss, *sstop;
2163  ss = newval;
2164  sstop = ss + *ss;
2165  ss += ARGHEAD;
2166  if ( ss >= sstop ) break;
2167  if ( ss + *ss < sstop ) goto NoMnot;
2168  if ( ABS(sstop[-1]) == ss[0]-1 ) break;
2169  }
2170  goto NoMnot;
2171  case DUMMYINDEX_:
2172  if ( type != INDTOIND ||
2173  newnumber < AM.IndDum || newnumber >= AM.IndDum+MAXDUMMIES ) goto NoMnot;
2174  break;
2175  default:
2176  goto NoMnot;
2177  }
2178 Mnot:
2179  if ( notflag ) goto NoM;
2180  return(0);
2181 NoMnot:
2182  if ( !notflag ) goto NoM;
2183  return(0);
2184  }
2185  else if ( Sets[j].type == CRANGE ) {
2186  if ( ( type == SYMTONUM )
2187  || ( type == INDTOIND && ( newnumber > 0
2188  && newnumber <= AM.OffsetIndex ) ) ) {
2189  if ( Sets[j].first < MAXPOWER ) {
2190  if ( newnumber >= Sets[j].first ) goto NoMnot;
2191  }
2192  else if ( Sets[j].first < 3*MAXPOWER ) {
2193  if ( newnumber+2*MAXPOWER > Sets[j].first ) goto NoMnot;
2194  }
2195  if ( Sets[j].last > -MAXPOWER ) {
2196  if ( newnumber <= Sets[j].last ) goto NoMnot;
2197  }
2198  else if ( Sets[j].last > -3*MAXPOWER ) {
2199  if ( newnumber-2*MAXPOWER < Sets[j].last ) goto NoMnot;
2200  }
2201  goto Mnot;
2202  }
2203  goto NoMnot;
2204  }
2205  w = SetElements + Sets[j].first;
2206  m = SetElements + Sets[j].last;
2207  i = 1;
2208  if ( Sets[j].type == -1 || Sets[j].type == CNUMBER ) { do {
2209  if ( notflag ) {
2210  switch ( type ) {
2211  case SYMTOSYM:
2212  if ( Sets[j].type == CNUMBER ) {}
2213  else {
2214  if ( *w == newnumber ) goto NoMatch;
2215  }
2216  break;
2217  case SYMTONUM:
2218  case INDTOIND:
2219  if ( *w == newnumber ) goto NoMatch;
2220  break;
2221  default:
2222  break;
2223  }
2224  }
2225  else if ( type != SYMTONUM && type != INDTOIND
2226  && type != SYMTOSYM ) goto NoMatch;
2227  else if ( type == SYMTOSYM && Sets[j].type == CNUMBER ) goto NoMatch;
2228  else if ( *w == newnumber ) {
2229  if ( *s == SETTONUM ) {
2230  if ( n2 == oldnumber && type
2231  <= SYMTOSUB ) goto NoMatch;
2232  m = AT.WildMask;
2233  w = AN.WildValue;
2234  n = AN.NumWild;
2235  while ( --n >= 0 ) {
2236  if ( w[2] == n2 && *w <= SYMTOSUB ) {
2237  if ( !*m ) {
2238  *w = SYMTONUM;
2239  w[3] = i;
2240  AN.WildReserve = 1;
2241  return(0);
2242  }
2243  if ( *w != SYMTONUM )
2244  goto NoMatch;
2245  if ( w[3] == i ) return(0);
2246  i = w[3];
2247  j = (SetElements + Sets[j].first)[i];
2248  if ( j == n2 ) return(0);
2249  goto NoMatch;
2250  }
2251  m++; w += w[1];
2252  }
2253  }
2254  else if ( n2 >= 0 ) {
2255  *newval = *(w - Sets[j].first + Sets[n2].first);
2256  if ( *newval > MAXPOWER ) *newval -= 2*MAXPOWER;
2257  if ( dirty && *newval != oldval ) {
2258  *newval = oldval; goto NoMatch;
2259  }
2260  }
2261  return(0);
2262  }
2263  i++;
2264  } while ( ++w < m ); }
2265  else { do {
2266  if ( notflag ) {
2267  switch ( type ) {
2268  case SYMTONUM:
2269  case SYMTOSYM:
2270  if ( ( type == SYMTOSYM && *w == newnumber )
2271  || ( type == SYMTONUM && *w-2*MAXPOWER == newnumber ) ) {
2272  goto NoMatch;
2273  }
2274  case SYMTOSUB:
2275  if ( *w < 0 ) {
2276  WORD *mm = AT.WildMask, *mmm, *part;
2277  WORD *ww = AN.WildValue;
2278  WORD nn = AN.NumWild;
2279  k = -*w;
2280  while ( --nn >= 0 ) {
2281  if ( *mm && ww[2] == k && ww[0] == type ) {
2282  if ( type != SYMTOSUB ) {
2283  if ( ww[3] == newnumber ) goto NoMatch;
2284  }
2285  else {
2286  mmm = C->rhs[ww[3]];
2287  nn = *newval-2;
2288  part = newval+2;
2289  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2290  while ( --nn >= 0 ) {
2291  if ( *mmm != *part ) {
2292  mmm++; part++; break;
2293  }
2294  mmm++; part++;
2295  }
2296  if ( nn < 0 ) goto NoMatch;
2297  }
2298  }
2299  break;
2300  }
2301  mm++; ww += ww[1];
2302  }
2303  }
2304  break;
2305  case VECTOVEC:
2306  if ( *w == newnumber ) goto NoMatch;
2307  case VECTOSUB:
2308  if ( *w - WILDOFFSET >= AM.OffsetVector ) {
2309  WORD *mm = AT.WildMask, *mmm, *part;
2310  WORD *ww = AN.WildValue;
2311  WORD nn = AN.NumWild;
2312  k = *w - WILDOFFSET;
2313  while ( --nn >= 0 ) {
2314  if ( *mm && ww[2] == k && ww[0] == type ) {
2315  if ( type == VECTOVEC ) {
2316  if ( ww[3] == newnumber ) goto NoMatch;
2317  }
2318  else {
2319  mmm = C->rhs[ww[3]];
2320  nn = *newval-2;
2321  part = newval+2;
2322  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2323  while ( --nn >= 0 ) {
2324  if ( *mmm != *part ) {
2325  mmm++; part++; break;
2326  }
2327  mmm++; part++;
2328  }
2329  if ( nn < 0 ) goto NoMatch;
2330  }
2331  }
2332  break;
2333  }
2334  mm++; ww += ww[1];
2335  }
2336  }
2337  break;
2338  case INDTOIND:
2339  if ( *w == newnumber ) goto NoMatch;
2340  case INDTOSUB:
2341  if ( *w - (WORD)WILDMASK >= AM.OffsetIndex ) {
2342  WORD *mm = AT.WildMask, *mmm, *part;
2343  WORD *ww = AN.WildValue;
2344  WORD nn = AN.NumWild;
2345  k = *w - WILDMASK;
2346  while ( --nn >= 0 ) {
2347  if ( *mm && ww[2] == k && ww[0] == type ) {
2348  if ( type == INDTOIND ) {
2349  if ( ww[3] == newnumber ) goto NoMatch;
2350  }
2351  else {
2352  mmm = C->rhs[ww[3]];
2353  nn = *newval-2;
2354  part = newval+2;
2355  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2356  while ( --nn >= 0 ) {
2357  if ( *mmm != *part ) {
2358  mmm++; part++; break;
2359  }
2360  mmm++; part++;
2361  }
2362  if ( nn < 0 ) goto NoMatch;
2363  }
2364  }
2365  break;
2366  }
2367  mm++; ww += ww[1];
2368  }
2369  }
2370  break;
2371  case FUNTOFUN:
2372  if ( *w == newnumber ) goto NoMatch;
2373  if ( ( type == FUNTOFUN &&
2374  ( k = *w - WILDMASK ) > FUNCTION ) ) {
2375  WORD *mm = AT.WildMask;
2376  WORD *ww = AN.WildValue;
2377  WORD nn = AN.NumWild;
2378  while ( --nn >= 0 ) {
2379  if ( *mm && ww[2] == k && ww[0] == type ) {
2380  if ( ww[3] == newnumber ) goto NoMatch;
2381  break;
2382  }
2383  mm++; ww += ww[1];
2384  }
2385  }
2386  default:
2387  break;
2388  }
2389  }
2390  else if ( ( *w == newnumber && type != SYMTONUM ) ||
2391  ( type == SYMTONUM && *w-2*MAXPOWER == newnumber ) ) {
2392  if ( *s == SETTONUM ) {
2393  if ( n2 == oldnumber && type
2394  <= SYMTOSUB ) goto NoMatch;
2395  m = AT.WildMask;
2396  w = AN.WildValue;
2397  n = AN.NumWild;
2398  while ( --n >= 0 ) {
2399  if ( w[2] == n2 && *w <= SYMTOSUB ) {
2400  if ( !*m ) {
2401  *w = SYMTONUM;
2402  w[3] = i;
2403  AN.WildReserve = 1;
2404  return(0);
2405  }
2406  if ( *w != SYMTONUM )
2407  goto NoMatch;
2408  if ( w[3] == i ) return(0);
2409  i = w[3];
2410  j = (SetElements + Sets[j].first)[i];
2411  if ( j == n2 ) return(0);
2412  goto NoMatch;
2413  }
2414  m++; w += w[1];
2415  }
2416  }
2417  else if ( n2 >= 0 ) {
2418  *newval = *(w - Sets[j].first + Sets[n2].first);
2419  if ( *newval > MAXPOWER ) *newval -= 2*MAXPOWER;
2420  if ( dirty && *newval != oldval ) {
2421  *newval = oldval; goto NoMatch;
2422  }
2423  }
2424  return(0);
2425  }
2426  i++;
2427  } while ( ++w < m ); }
2428  if ( notflag ) return(0);
2429  AN.oldtype = old2; AN.oldvalue = oldval; goto NoMatch;
2430  }
2431  else { return(0); }
2432 
2433 NoM:
2434  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2435 }
2436 
2437 /*
2438  #] CheckWild :
2439  #] Wildcards :
2440  #[ DenToFunction :
2441 
2442  Renames the denominator function into a function with the given number.
2443  For the syntax see Denominators,function;
2444 */
2445 
2446 int DenToFunction(WORD *term, WORD numfun)
2447 {
2448  int action = 0;
2449  WORD *t, *tstop, *tnext, *arg, *argstop, *targ;
2450  t = term+1;
2451  tstop = term + *term; tstop -= ABS(tstop[-1]);
2452  while ( t < tstop ) {
2453  if ( *t == DENOMINATOR ) {
2454  *t = numfun; t[2] |= DIRTYFLAG; action = 1;
2455  }
2456  tnext = t + t[1];
2457  if ( *t >= FUNCTION && functions[*t-FUNCTION].spec == 0 ) {
2458  arg = t + FUNHEAD;
2459  while ( arg < tnext ) {
2460  if ( *arg > 0 ) {
2461  targ = arg + ARGHEAD; argstop = arg + *arg;
2462  while ( targ < argstop ) {
2463  if ( DenToFunction(targ,numfun) ) {
2464  arg[1] |= DIRTYFLAG; t[2] |= DIRTYFLAG; action = 1;
2465  }
2466  targ += *targ;
2467  }
2468  arg = argstop;
2469  }
2470  else if ( *arg <= -FUNCTION ) arg++;
2471  else arg += 2;
2472  }
2473  }
2474  t = tnext;
2475  }
2476  return(action);
2477 }
2478 
2479 /*
2480  #] DenToFunction :
2481 */
2482 
#define PHEAD
Definition: ftypes.h:56
Definition: structs.h:908
WORD * Pointer
Definition: structs.h:911
WORD ** rhs
Definition: structs.h:913
WORD * Top
Definition: structs.h:910