FORM  4.2.1
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 /*
2120  if SETTONUM: x?j[n2]
2121  if FROMSET: x?j?n2 or x?j and n2 = -WOLDOFFSET.
2122 */
2123  if ( j > WILDOFFSET ) {
2124  j -= 2*WILDOFFSET;
2125  notflag = 1;
2126 /*
2127  ???????
2128 */
2129  AN.oldtype = -1;
2130  AN.oldvalue = -1;
2131  }
2132  if ( j < AM.NumFixedSets ) { /* special set */
2133  retblock = 1;
2134  switch ( j ) {
2135  case POS_:
2136  if ( type != SYMTONUM ||
2137  newnumber <= 0 ) goto NoMnot;
2138  break;
2139  case POS0_:
2140  if ( type != SYMTONUM ||
2141  newnumber < 0 ) goto NoMnot;
2142  break;
2143  case NEG_:
2144  if ( type != SYMTONUM ||
2145  newnumber >= 0 ) goto NoMnot;
2146  break;
2147  case NEG0_:
2148  if ( type != SYMTONUM ||
2149  newnumber > 0 ) goto NoMnot;
2150  break;
2151  case EVEN_:
2152  if ( type != SYMTONUM ||
2153  ( newnumber & 1 ) != 0 ) goto NoMnot;
2154  break;
2155  case ODD_:
2156  if ( type != SYMTONUM ||
2157  ( newnumber & 1 ) == 0 ) goto NoMnot;
2158  break;
2159  case Z_:
2160  if ( type != SYMTONUM ) goto NoMnot;
2161  break;
2162  case SYMBOL_:
2163  if ( type != SYMTOSYM ) goto NoMnot;
2164  break;
2165  case FIXED_:
2166  if ( type != INDTOIND ||
2167  newnumber >= AM.OffsetIndex ||
2168  newnumber < 0 ) goto NoMnot;
2169  break;
2170  case INDEX_:
2171  if ( type != INDTOIND ||
2172  newnumber < 0 ) goto NoMnot;
2173  break;
2174  case Q_:
2175  if ( type == SYMTONUM ) break;
2176  if ( type == SYMTOSUB ) {
2177  WORD *ss, *sstop;
2178  ss = newval;
2179  sstop = ss + *ss;
2180  ss += ARGHEAD;
2181  if ( ss >= sstop ) break;
2182  if ( ss + *ss < sstop ) goto NoMnot;
2183  if ( ABS(sstop[-1]) == ss[0]-1 ) break;
2184  }
2185  goto NoMnot;
2186  case DUMMYINDEX_:
2187  if ( type != INDTOIND ||
2188  newnumber < AM.IndDum || newnumber >= AM.IndDum+MAXDUMMIES ) goto NoMnot;
2189  break;
2190  case VECTOR_:
2191  if ( type != VECTOVEC ) goto NoMnot;
2192  break;
2193  default:
2194  goto NoMnot;
2195  }
2196 Mnot:
2197  if ( notflag ) goto NoM;
2198  return(0);
2199 NoMnot:
2200  if ( !notflag ) goto NoM;
2201  return(0);
2202  }
2203  else if ( Sets[j].type == CRANGE ) {
2204  if ( ( type == SYMTONUM )
2205  || ( type == INDTOIND && ( newnumber > 0
2206  && newnumber <= AM.OffsetIndex ) ) ) {
2207  if ( Sets[j].first < MAXPOWER ) {
2208  if ( newnumber >= Sets[j].first ) goto NoMnot;
2209  }
2210  else if ( Sets[j].first < 3*MAXPOWER ) {
2211  if ( newnumber+2*MAXPOWER > Sets[j].first ) goto NoMnot;
2212  }
2213  if ( Sets[j].last > -MAXPOWER ) {
2214  if ( newnumber <= Sets[j].last ) goto NoMnot;
2215  }
2216  else if ( Sets[j].last > -3*MAXPOWER ) {
2217  if ( newnumber-2*MAXPOWER < Sets[j].last ) goto NoMnot;
2218  }
2219  goto Mnot;
2220  }
2221  goto NoMnot;
2222  }
2223 /*
2224  Now we have to determine which set element
2225 */
2226  w = SetElements + Sets[j].first;
2227  m = SetElements + Sets[j].last;
2228  if ( ( Sets[j].flags & ORDEREDSET ) == ORDEREDSET ) {
2229 /*
2230  We search first and ask questions later
2231 */
2232  i = BinarySearch(w,Sets[j].last-Sets[j].first,newnumber);
2233  if ( i < 0 ) { /* no matter what, it is not in the set. */
2234  goto NoMnot;
2235  }
2236  else {
2237 /*
2238  We can set the proper parameters now to make only the
2239  checks for the given set element.
2240  After that we jump into the appropriate loop.
2241 */
2242  w = m = SetElements + i;
2243  i++;
2244  if ( Sets[j].type == -1 || Sets[j].type == CNUMBER ) {
2245  goto insideloop1;
2246  }
2247  else {
2248  goto insideloop2;
2249  }
2250  }
2251  }
2252  i = 1;
2253  if ( Sets[j].type == -1 || Sets[j].type == CNUMBER ) {
2254  do {
2255  insideloop1:
2256  if ( notflag ) {
2257  switch ( type ) {
2258  case SYMTOSYM:
2259  if ( Sets[j].type == CNUMBER ) {}
2260  else {
2261  if ( *w == newnumber ) goto NoMatch;
2262  }
2263  break;
2264  case SYMTONUM:
2265  case INDTOIND:
2266  if ( *w == newnumber ) goto NoMatch;
2267  break;
2268  default:
2269  break;
2270  }
2271  }
2272  else if ( type != SYMTONUM && type != INDTOIND
2273  && type != SYMTOSYM ) goto NoMatch;
2274  else if ( type == SYMTOSYM && Sets[j].type == CNUMBER ) goto NoMatch;
2275  else if ( *w == newnumber ) {
2276  if ( *s == SETTONUM ) {
2277  if ( n2 == oldnumber && type
2278  <= SYMTOSUB ) goto NoMatch;
2279  m = AT.WildMask;
2280  w = AN.WildValue;
2281  n = AN.NumWild;
2282  while ( --n >= 0 ) {
2283  if ( w[2] == n2 && *w <= SYMTOSUB ) {
2284  if ( !*m ) {
2285  *w = SYMTONUM;
2286  w[3] = i;
2287  AN.WildReserve = 1;
2288  return(0);
2289  }
2290  if ( *w != SYMTONUM )
2291  goto NoMatch;
2292  if ( w[3] == i ) return(0);
2293  i = w[3];
2294  j = (SetElements + Sets[j].first)[i];
2295  if ( j == n2 ) return(0);
2296  goto NoMatch;
2297  }
2298  m++; w += w[1];
2299  }
2300  }
2301  else if ( n2 >= 0 ) {
2302  *newval = *(w - Sets[j].first + Sets[n2].first);
2303  if ( *newval > MAXPOWER ) *newval -= 2*MAXPOWER;
2304  if ( dirty && *newval != oldval ) {
2305  *newval = oldval; goto NoMatch;
2306  }
2307  }
2308  return(0);
2309  }
2310  i++;
2311  } while ( ++w < m );
2312  }
2313  else {
2314  do {
2315  insideloop2:
2316  inset = *w;
2317  if ( notflag ) {
2318  switch ( type ) {
2319  case SYMTONUM:
2320  case SYMTOSYM:
2321  if ( ( type == SYMTOSYM && *w == newnumber )
2322  || ( type == SYMTONUM && *w-2*MAXPOWER == newnumber ) ) {
2323  goto NoMatch;
2324  }
2325  /* fall through */
2326  case SYMTOSUB:
2327  if ( *w < 0 ) {
2328  WORD *mm = AT.WildMask, *mmm, *part;
2329  WORD *ww = AN.WildValue;
2330  WORD nn = AN.NumWild;
2331  k = -*w;
2332  while ( --nn >= 0 ) {
2333  if ( *mm && ww[2] == k && ww[0] == type ) {
2334  if ( type != SYMTOSUB ) {
2335  if ( ww[3] == newnumber ) goto NoMatch;
2336  }
2337  else {
2338  mmm = C->rhs[ww[3]];
2339  nn = *newval-2;
2340  part = newval+2;
2341  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2342  while ( --nn >= 0 ) {
2343  if ( *mmm != *part ) {
2344  mmm++; part++; break;
2345  }
2346  mmm++; part++;
2347  }
2348  if ( nn < 0 ) goto NoMatch;
2349  }
2350  }
2351  break;
2352  }
2353  mm++; ww += ww[1];
2354  }
2355  }
2356  break;
2357  case VECTOMIN:
2358  if ( type == VECTOMIN ) {
2359  if ( inset >= AM.OffsetVector ) { i++; continue; }
2360  inset += WILDMASK;
2361  }
2362  /* fall through */
2363  case VECTOVEC:
2364  if ( inset == newnumber ) goto NoMatch;
2365  /* fall through */
2366  case VECTOSUB:
2367  if ( inset - WILDOFFSET >= AM.OffsetVector ) {
2368  WORD *mm = AT.WildMask, *mmm, *part;
2369  WORD *ww = AN.WildValue;
2370  WORD nn = AN.NumWild;
2371  k = inset - WILDOFFSET;
2372  while ( --nn >= 0 ) {
2373  if ( *mm && ww[2] == k && ww[0] == type ) {
2374  if ( type == VECTOVEC ) {
2375  if ( ww[3] == newnumber ) goto NoMatch;
2376  }
2377  else {
2378  mmm = C->rhs[ww[3]];
2379  nn = *newval-2;
2380  part = newval+2;
2381  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2382  while ( --nn >= 0 ) {
2383  if ( *mmm != *part ) {
2384  mmm++; part++; break;
2385  }
2386  mmm++; part++;
2387  }
2388  if ( nn < 0 ) goto NoMatch;
2389  }
2390  }
2391  break;
2392  }
2393  mm++; ww += ww[1];
2394  }
2395  }
2396  break;
2397  case INDTOIND:
2398  if ( *w == newnumber ) goto NoMatch;
2399  /* fall through */
2400  case INDTOSUB:
2401  if ( *w - (WORD)WILDMASK >= AM.OffsetIndex ) {
2402  WORD *mm = AT.WildMask, *mmm, *part;
2403  WORD *ww = AN.WildValue;
2404  WORD nn = AN.NumWild;
2405  k = *w - WILDMASK;
2406  while ( --nn >= 0 ) {
2407  if ( *mm && ww[2] == k && ww[0] == type ) {
2408  if ( type == INDTOIND ) {
2409  if ( ww[3] == newnumber ) goto NoMatch;
2410  }
2411  else {
2412  mmm = C->rhs[ww[3]];
2413  nn = *newval-2;
2414  part = newval+2;
2415  if ( (C->rhs[ww[3]+1]-mmm-1) == nn ) {
2416  while ( --nn >= 0 ) {
2417  if ( *mmm != *part ) {
2418  mmm++; part++; break;
2419  }
2420  mmm++; part++;
2421  }
2422  if ( nn < 0 ) goto NoMatch;
2423  }
2424  }
2425  break;
2426  }
2427  mm++; ww += ww[1];
2428  }
2429  }
2430  break;
2431  case FUNTOFUN:
2432  if ( *w == newnumber ) goto NoMatch;
2433  if ( ( type == FUNTOFUN &&
2434  ( k = *w - WILDMASK ) > FUNCTION ) ) {
2435  WORD *mm = AT.WildMask;
2436  WORD *ww = AN.WildValue;
2437  WORD nn = AN.NumWild;
2438  while ( --nn >= 0 ) {
2439  if ( *mm && ww[2] == k && ww[0] == type ) {
2440  if ( ww[3] == newnumber ) goto NoMatch;
2441  break;
2442  }
2443  mm++; ww += ww[1];
2444  }
2445  }
2446  default:
2447  break;
2448  }
2449  }
2450  else {
2451  if ( type == VECTOMIN ) {
2452  if ( inset >= AM.OffsetVector ) { i++; continue; }
2453  inset += WILDMASK;
2454  }
2455  if ( ( inset == newnumber && type != SYMTONUM ) ||
2456  ( type == SYMTONUM && inset-2*MAXPOWER == newnumber ) ) {
2457  if ( *s == SETTONUM ) {
2458  if ( n2 == oldnumber && type
2459  <= SYMTOSUB ) goto NoMatch;
2460  m = AT.WildMask;
2461  w = AN.WildValue;
2462  n = AN.NumWild;
2463  while ( --n >= 0 ) {
2464  if ( w[2] == n2 && *w <= SYMTOSUB ) {
2465  if ( !*m ) {
2466  *w = SYMTONUM;
2467  w[3] = i;
2468  AN.WildReserve = 1;
2469  return(0);
2470  }
2471  if ( *w != SYMTONUM )
2472  goto NoMatch;
2473  if ( w[3] == i ) return(0);
2474  i = w[3];
2475  j = (SetElements + Sets[j].first)[i];
2476  if ( j == n2 ) return(0);
2477  goto NoMatch;
2478  }
2479  m++; w += w[1];
2480  }
2481  }
2482  else if ( n2 >= 0 ) {
2483  *newval = *(w - Sets[j].first + Sets[n2].first);
2484  if ( *newval > MAXPOWER ) *newval -= 2*MAXPOWER;
2485  if ( dirty && *newval != oldval ) {
2486  *newval = oldval; goto NoMatch;
2487  }
2488  }
2489  return(0);
2490  }
2491  }
2492  i++;
2493  } while ( ++w < m );
2494  }
2495  if ( notflag ) return(0);
2496  AN.oldtype = old2; AN.oldvalue = oldval; goto NoMatch;
2497  }
2498  else { return(0); }
2499 
2500 NoM:
2501  AN.oldtype = old2; AN.oldvalue = w[3]; goto NoMatch;
2502 }
2503 
2504 /*
2505  #] CheckWild :
2506  #] Wildcards :
2507  #[ DenToFunction :
2508 
2509  Renames the denominator function into a function with the given number.
2510  For the syntax see Denominators,function;
2511 */
2512 
2513 int DenToFunction(WORD *term, WORD numfun)
2514 {
2515  int action = 0;
2516  WORD *t, *tstop, *tnext, *arg, *argstop, *targ;
2517  t = term+1;
2518  tstop = term + *term; tstop -= ABS(tstop[-1]);
2519  while ( t < tstop ) {
2520  if ( *t == DENOMINATOR ) {
2521  *t = numfun; t[2] |= DIRTYFLAG; action = 1;
2522  }
2523  tnext = t + t[1];
2524  if ( *t >= FUNCTION && functions[*t-FUNCTION].spec == 0 ) {
2525  arg = t + FUNHEAD;
2526  while ( arg < tnext ) {
2527  if ( *arg > 0 ) {
2528  targ = arg + ARGHEAD; argstop = arg + *arg;
2529  while ( targ < argstop ) {
2530  if ( DenToFunction(targ,numfun) ) {
2531  arg[1] |= DIRTYFLAG; t[2] |= DIRTYFLAG; action = 1;
2532  }
2533  targ += *targ;
2534  }
2535  arg = argstop;
2536  }
2537  else if ( *arg <= -FUNCTION ) arg++;
2538  else arg += 2;
2539  }
2540  }
2541  t = tnext;
2542  }
2543  return(action);
2544 }
2545 
2546 /*
2547  #] DenToFunction :
2548 */
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition: comtool.c:143
Definition: structs.h:938
WORD * Pointer
Definition: structs.h:941
WORD ** rhs
Definition: structs.h:943
WORD * Top
Definition: structs.h:940
WORD * AddRHS(int num, int type)
Definition: comtool.c:214