FORM 4.3
wildcard.c
Go to the documentation of this file.
1
12/* #[ License : */
13/*
14 * Copyright (C) 1984-2022 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
65WORD 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;
95ReSwitch:
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) {
126DoPow: 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] ) {
174MakeExp: 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 }
227sspow:
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--;
287Seven:;
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 }
327ss2:
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 }
347ss3: *++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 }
495RegPow: 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 }
593NextDot:;
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 }
702ss4: 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 }
748ss5: 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
772Tensors:
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]];
791DEBUG(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);
808DEBUG(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;
847ss6: 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 }
908ss7: j = t[1];
909 NCOPY(m,t,j);
910sr7:;
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 }
1000ss8: 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]];
1044DEBUG(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 ) {
1100ToSub: m--;
1101 w = C->rhs[s[3]];
1102DEBUG(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 {
1211ss9: *m++ = *t++;
1212ss10: *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
1333WORD 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 }
1423GotOne:;
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
1490VOID 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
1516WORD 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;
1521DEBUG(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;
1541DEBUG(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;
1548DEBUG(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;
1562DEBUG(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);
1575DEBUG(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;
1580DEBUG(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;
1593DEBUG(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);
1603DEBUG(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;
1613DEBUG(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);
1709FlipOn:
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
1761WORD 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);
2105NoMatch:
2106 AN.WildReserve = 0;
2107 return(1+retblock);
2108/*
2109 Here we test the compatibility with a set specification.
2110*/
2111TestSet:
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 }
2196Mnot:
2197 if ( notflag ) goto NoM;
2198 return(0);
2199NoMnot:
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
2500NoM:
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
2513int 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 * AddRHS(int num, int type)
Definition: comtool.c:214
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition: comtool.c:143
Definition: structs.h:938
WORD * Top
Definition: structs.h:940
WORD ** rhs
Definition: structs.h:943
WORD * Pointer
Definition: structs.h:941