FORM  4.2
if.c
Go to the documentation of this file.
1 
5 /* #[ License : */
6 /*
7  * Copyright (C) 1984-2017 J.A.M. Vermaseren
8  * When using this file you are requested to refer to the publication
9  * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
10  * This is considered a matter of courtesy as the development was paid
11  * for by FOM the Dutch physics granting agency and we would like to
12  * be able to track its scientific use to convince FOM of its value
13  * for the community.
14  *
15  * This file is part of FORM.
16  *
17  * FORM is free software: you can redistribute it and/or modify it under the
18  * terms of the GNU General Public License as published by the Free Software
19  * Foundation, either version 3 of the License, or (at your option) any later
20  * version.
21  *
22  * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
23  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
24  * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
25  * details.
26  *
27  * You should have received a copy of the GNU General Public License along
28  * with FORM. If not, see <http://www.gnu.org/licenses/>.
29  */
30 /* #] License : */
31 /*
32  #[ Includes : if.c
33 */
34 
35 #include "form3.h"
36 
37 /*
38  #] Includes :
39  #[ If statement :
40  #[ Syntax :
41 
42  The `if' is a conglomerate of statements: if,else,endif
43 
44  The if consists in principle of:
45 
46  if ( number );
47  statements
48  else;
49  statements
50  endif;
51 
52  The first set is taken when number != 0.
53  The else is not mandatory.
54  TRUE = 1 and FALSE = 0
55 
56  The number can be built up via a logical expression:
57 
58  expr1 condition expr2
59 
60  each expression can be a subexpression again. It has to be
61  enclosed in parentheses in that case.
62  Conditions are:
63  >, >=, <, <=, ==, !=, ||, &&
64 
65  When Expressions are chained evaluation is from left to right,
66  independent of whether this indicates nonsense.
67  if ( a || b || c || d ); is a perfectly normal statement.
68  if ( a >= b || c == d ); would be messed up. This should be:
69  if ( ( a >= b ) || ( c == d ) );
70 
71  The building blocks of the Expressions are:
72 
73  Match(option,pattern) The number of times pattern fits in term_
74  Count(....) The count value of term_
75  Coeff[icient] The coefficient of term_
76  FindLoop(options) Are there loops (as in ReplaceLoop).
77 
78  Implementation for internal notation:
79 
80  TYPEIF,length,gotolevel(if fail),EXPRTYPE,length,......
81 
82  EXPRTYPE can be:
83  SHORTNUMBER ->,4,sign,size
84  LONGNUMBER ->,|ncoef+2|,ncoef,numer,denom
85  MATCH ->,patternsiz+3,keyword,pattern
86  MULTIPLEOF ->,3,thenumber
87  COUNT ->,countsiz+2,countinfo
88  TYPEFINDLOOP ->,7 (findloop info)
89  COEFFICIENT ->,2
90  IFDOLLAR ->,3,dollarnumber
91  SUBEXPR ->,size,dummy,size1,EXPRTYPE,length,...
92  ,2,condition1,size2,...
93  This is like functions.
94 
95  Note that there must be a restriction to the number of nestings
96  of parentheses in an if statement. It has been set to 10.
97 
98  The syntax of match corresponds to the syntax of the left side
99  of an id statement. The only difference is the keyword
100  MATCH vs TYPEIDNEW.
101 
102  #] Syntax :
103  #[ GetIfDollarNum :
104 */
105 
106 WORD GetIfDollarNum(WORD *ifp, WORD *ifstop)
107 {
108  DOLLARS d;
109  WORD num, *w;
110  if ( ifp[2] < 0 ) { return(-ifp[2]-1); }
111  d = Dollars+ifp[2];
112  if ( ifp+3 < ifstop && ifp[3] == IFDOLLAREXTRA ) {
113  if ( d->nfactors == 0 ) {
114  MLOCK(ErrorMessageLock);
115  MesPrint("Attempt to use a factor of an unfactored $-variable");
116  MUNLOCK(ErrorMessageLock);
117  Terminate(-1);
118  }
119  num = GetIfDollarNum(ifp+3,ifstop);
120  if ( num > d->nfactors ) {
121  MLOCK(ErrorMessageLock);
122  MesPrint("Dollar factor number %s out of range",num);
123  MUNLOCK(ErrorMessageLock);
124  Terminate(-1);
125  }
126  if ( num == 0 ) {
127  return(d->nfactors);
128  }
129  w = d->factors[num-1].where;
130  if ( w == 0 ) return(d->factors[num].value);
131 getnumber:;
132  if ( *w == 0 ) return(0);
133  if ( *w == 4 && w[3] == 3 && w[2] == 1 && w[1] < MAXPOSITIVE && w[4] == 0 ) {
134  return(w[1]);
135  }
136  if ( ( w[w[0]] != 0 ) || ( ABS(w[w[0]-1]) != w[0]-1 ) ) {
137  MLOCK(ErrorMessageLock);
138  MesPrint("Dollar factor number expected but found expression");
139  MUNLOCK(ErrorMessageLock);
140  Terminate(-1);
141  }
142  else {
143  MLOCK(ErrorMessageLock);
144  MesPrint("Dollar factor number out of range");
145  MUNLOCK(ErrorMessageLock);
146  Terminate(-1);
147  }
148  return(0);
149  }
150 /*
151  Now we have just a dollar and should evaluate that into a short number
152 */
153  if ( d->type == DOLZERO ) {
154  return(0);
155  }
156  else if ( d->type == DOLNUMBER || d->type == DOLTERMS ) {
157  w = d->where; goto getnumber;
158  }
159  else {
160  MLOCK(ErrorMessageLock);
161  MesPrint("Dollar factor number is wrong type");
162  MUNLOCK(ErrorMessageLock);
163  Terminate(-1);
164  return(0);
165  }
166 }
167 
168 /*
169  #] GetIfDollarNum :
170  #[ FindVar :
171 */
172 
173 int FindVar(WORD *v, WORD *term)
174 {
175  WORD *t, *tstop, *m, *mstop, *f, *fstop, *a, *astop;
176  GETSTOP(term,tstop);
177  t = term+1;
178  while ( t < tstop ) {
179  if ( *v == *t && *v < FUNCTION ) { /* VECTOR, INDEX, SYMBOL, DOTPRODUCT */
180  switch ( *v ) {
181  case SYMBOL:
182  m = t+2; mstop = t+t[1];
183  while ( m < mstop ) {
184  if ( *m == v[1] ) return(1);
185  m += 2;
186  }
187  break;
188  case INDEX:
189  case VECTOR:
190 InVe:
191  m = t+2; mstop = t+t[1];
192  while ( m < mstop ) {
193  if ( *m == v[1] ) return(1);
194  m++;
195  }
196  break;
197  case DOTPRODUCT:
198  m = t+2; mstop = t+t[1];
199  while ( m < mstop ) {
200  if ( *m == v[1] && m[1] == v[2] ) return(1);
201  if ( *m == v[2] && m[1] == v[1] ) return(1);
202  m += 3;
203  }
204  break;
205  }
206  }
207  else if ( *v == VECTOR && *t == INDEX ) goto InVe;
208  else if ( *v == INDEX && *t == VECTOR ) goto InVe;
209  else if ( ( *v == VECTOR || *v == INDEX ) && *t == DOTPRODUCT ) {
210  m = t+2; mstop = t+t[1];
211  while ( m < mstop ) {
212  if ( v[1] == m[0] || v[1] == m[1] ) return(1);
213  m += 3;
214  }
215  }
216  else if ( *t >= FUNCTION ) {
217  if ( *v == FUNCTION && v[1] == *t ) return(1);
218  if ( functions[*t-FUNCTION].spec > 0 ) {
219  if ( *v == VECTOR || *v == INDEX ) { /* we need to check arguments */
220  int i;
221  for ( i = FUNHEAD; i < t[1]; i++ ) {
222  if ( v[1] == t[i] ) return(1);
223  }
224  }
225  }
226  else {
227  fstop = t + t[1]; f = t + FUNHEAD;
228  while ( f < fstop ) { /* Do the arguments one by one */
229  if ( *f <= 0 ) {
230  switch ( *f ) {
231  case -SYMBOL:
232  if ( *v == SYMBOL && v[1] == f[1] ) return(1);
233  f += 2;
234  break;
235  case -VECTOR:
236  case -MINVECTOR:
237  case -INDEX:
238  if ( ( *v == VECTOR || *v == INDEX )
239  && ( v[1] == f[1] ) ) return(1);
240  f += 2;
241  break;
242  case -SNUMBER:
243  f += 2;
244  break;
245  default:
246  if ( *v == FUNCTION && v[1] == -*f && *f <= -FUNCTION ) return(1);
247  if ( *f <= -FUNCTION ) f++;
248  else f += 2;
249  break;
250  }
251  }
252  else {
253  a = f + ARGHEAD; astop = f + *f;
254  while ( a < astop ) {
255  if ( FindVar(v,a) == 1 ) return(1);
256  a += *a;
257  }
258  f = astop;
259  }
260  }
261  }
262  }
263  t += t[1];
264  }
265  return(0);
266 }
267 
268 /*
269  #] FindVar :
270  #[ DoIfStatement : WORD DoIfStatement(PHEAD ifcode,term)
271 
272  The execution time part of the if-statement.
273  The arguments are a pointer to the TYPEIF and a pointer to the term.
274  The answer is either 1 (success) or 0 (fail).
275  The calling routine can figure out where to go in case of failure
276  by picking up gotolevel.
277  Note that the whole setup asks for recursions.
278 */
279 
280 WORD DoIfStatement(PHEAD WORD *ifcode, WORD *term)
281 {
282  GETBIDENTITY
283  WORD *ifstop, *ifp;
284  UWORD *coef1 = 0, *coef2, *coef3, *cc;
285  WORD ncoef1, ncoef2, ncoef3, i = 0, first, *r, acoef, ismul1, ismul2, j;
286  UWORD *Spac1, *Spac2;
287  ifstop = ifcode + ifcode[1];
288  ifp = ifcode + 3;
289  if ( ifp >= ifstop ) return(1);
290  if ( ( ifp + ifp[1] ) >= ifstop ) {
291  switch ( *ifp ) {
292  case LONGNUMBER:
293  if ( ifp[2] ) return(1);
294  else return(0);
295  case MATCH:
296  case TYPEIF:
297  if ( HowMany(BHEAD ifp,term) ) return(1);
298  else return(0);
299  case TYPEFINDLOOP:
300  if ( Lus(term,ifp[3],ifp[4],ifp[5],ifp[6],ifp[2]) ) return(1);
301  else return(0);
302  case TYPECOUNT:
303  if ( CountDo(term,ifp) ) return(1);
304  else return(0);
305  case COEFFI:
306  case MULTIPLEOF:
307  return(1);
308  case IFDOLLAR:
309  {
310  DOLLARS d = Dollars + ifp[2];
311 #ifdef WITHPTHREADS
312  int nummodopt, dtype = -1;
313  if ( AS.MultiThreaded ) {
314  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
315  if ( ifp[2] == ModOptdollars[nummodopt].number ) break;
316  }
317  if ( nummodopt < NumModOptdollars ) {
318  dtype = ModOptdollars[nummodopt].type;
319  if ( dtype == MODLOCAL ) {
320  d = ModOptdollars[nummodopt].dstruct+AT.identity;
321  }
322  }
323  }
324  dtype = d->type;
325 #else
326  int dtype = d->type; /* We use dtype to make the operation atomic */
327 #endif
328  if ( dtype == DOLZERO ) return(0);
329  if ( dtype == DOLUNDEFINED ) {
330  if ( AC.UnsureDollarMode == 0 ) {
331  MesPrint("$%s is undefined",AC.dollarnames->namebuffer+d->name);
332  Terminate(-1);
333  }
334  }
335  }
336  return(1);
337  case IFEXPRESSION:
338  r = ifp+2; j = ifp[1] - 2;
339  while ( --j >= 0 ) {
340  if ( *r == AR.CurExpr ) return(1);
341  r++;
342  }
343  return(0);
344  case IFISFACTORIZED:
345  r = ifp+2; j = ifp[1] - 2;
346  if ( j == 0 ) {
347  if ( ( Expressions[AR.CurExpr].vflags & ISFACTORIZED ) != 0 )
348  return(1);
349  else
350  return(0);
351  }
352  while ( --j >= 0 ) {
353  if ( ( Expressions[*r].vflags & ISFACTORIZED ) == 0 ) return(0);
354  r++;
355  }
356  return(1);
357  case IFOCCURS:
358  {
359  WORD *OccStop = ifp + ifp[1];
360  ifp += 2;
361  while ( ifp < OccStop ) {
362  if ( FindVar(ifp,term) == 1 ) return(1);
363  if ( *ifp == DOTPRODUCT ) ifp += 3;
364  else ifp += 2;
365  }
366  }
367  return(0);
368  default:
369 /*
370  Now we have a subexpression. Test first for one with a single item.
371 */
372  if ( ifp[3] == ( ifp[1] + 3 ) ) return(DoIfStatement(BHEAD ifp,term));
373  ifstop = ifp + ifp[1];
374  ifp += 3;
375  break;
376  }
377  }
378 /*
379  Here is the composite condition.
380 */
381  coef3 = NumberMalloc("DoIfStatement");
382  Spac1 = NumberMalloc("DoIfStatement");
383  Spac2 = (UWORD *)(TermMalloc("DoIfStatement"));
384  ncoef1 = 0; first = 1; ismul1 = 0;
385  do {
386  if ( !first ) {
387  ifp += 2;
388  if ( ifp[-2] == ORCOND && ncoef1 ) {
389  coef1 = Spac1;
390  ncoef1 = 1; coef1[0] = coef1[1] = 1;
391  goto SkipCond;
392  }
393  if ( ifp[-2] == ANDCOND && !ncoef1 ) goto SkipCond;
394  }
395  coef2 = Spac2;
396  ncoef2 = 1;
397  ismul2 = 0;
398  switch ( *ifp ) {
399  case LONGNUMBER:
400  ncoef2 = ifp[2];
401  j = 2*(ABS(ncoef2));
402  cc = (UWORD *)(ifp + 3);
403  for ( i = 0; i < j; i++ ) coef2[i] = cc[i];
404  break;
405  case MATCH:
406  case TYPEIF:
407  coef2[0] = HowMany(BHEAD ifp,term);
408  coef2[1] = 1;
409  if ( coef2[0] == 0 ) ncoef2 = 0;
410  break;
411  case TYPECOUNT:
412  acoef = CountDo(term,ifp);
413  coef2[0] = ABS(acoef);
414  coef2[1] = 1;
415  if ( acoef == 0 ) ncoef2 = 0;
416  else if ( acoef < 0 ) ncoef2 = -1;
417  break;
418  case TYPEFINDLOOP:
419  acoef = Lus(term,ifp[3],ifp[4],ifp[5],ifp[6],ifp[2]);
420  coef2[0] = ABS(acoef);
421  coef2[1] = 1;
422  if ( acoef == 0 ) ncoef2 = 0;
423  else if ( acoef < 0 ) ncoef2 = -1;
424  break;
425  case COEFFI:
426  r = term + *term;
427  ncoef2 = r[-1];
428  i = ABS(ncoef2);
429  cc = (UWORD *)(r - i);
430  if ( ncoef2 < 0 ) ncoef2 = (ncoef2+1)>>1;
431  else ncoef2 = (ncoef2-1)>>1;
432  i--; for ( j = 0; j < i; j++ ) coef2[j] = cc[j];
433  break;
434  case SUBEXPR:
435  ncoef2 = coef2[0] = DoIfStatement(BHEAD ifp,term);
436  coef2[1] = 1;
437  break;
438  case MULTIPLEOF:
439  ncoef2 = 1;
440  coef2[0] = ifp[2];
441  coef2[1] = 1;
442  ismul2 = 1;
443  break;
444  case IFDOLLAREXTRA:
445  break;
446  case IFDOLLAR:
447  {
448 /*
449  We need to abstract a long rational in coef2
450  with length ncoef2. What if that cannot be done?
451 */
452  DOLLARS d = Dollars + ifp[2];
453 #ifdef WITHPTHREADS
454  int nummodopt, dtype = -1;
455  if ( AS.MultiThreaded ) {
456  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
457  if ( ifp[2] == ModOptdollars[nummodopt].number ) break;
458  }
459  if ( nummodopt < NumModOptdollars ) {
460  dtype = ModOptdollars[nummodopt].type;
461  if ( dtype == MODLOCAL ) {
462  d = ModOptdollars[nummodopt].dstruct+AT.identity;
463  }
464  else {
465  LOCK(d->pthreadslockread);
466  }
467  }
468  }
469 #endif
470 /*
471  We have to pick up the IFDOLLAREXTRA pieces for [1], [$y] etc.
472 */
473  if ( ifp+3 < ifstop && ifp[3] == IFDOLLAREXTRA ) {
474  if ( d->nfactors == 0 ) {
475  MLOCK(ErrorMessageLock);
476  MesPrint("Attempt to use a factor of an unfactored $-variable");
477  MUNLOCK(ErrorMessageLock);
478  Terminate(-1);
479  } {
480  WORD num = GetIfDollarNum(ifp+3,ifstop);
481  WORD *w;
482  while ( ifp+3 < ifstop && ifp[3] == IFDOLLAREXTRA ) ifp += 3;
483  if ( num > d->nfactors ) {
484  MLOCK(ErrorMessageLock);
485  MesPrint("Dollar factor number %s out of range",num);
486  MUNLOCK(ErrorMessageLock);
487  Terminate(-1);
488  }
489  if ( num == 0 ) {
490  ncoef2 = 1; coef2[0] = d->nfactors; coef2[1] = 1;
491  break;
492  }
493  w = d->factors[num-1].where;
494  if ( w == 0 ) {
495  if ( d->factors[num-1].value < 0 ) {
496  ncoef2 = -1; coef2[0] = -d->factors[num-1].value; coef2[1] = 1;
497  }
498  else {
499  ncoef2 = 1; coef2[0] = d->factors[num-1].value; coef2[1] = 1;
500  }
501  break;
502  }
503  if ( w[*w] == 0 ) {
504  r = w + *w - 1;
505  i = ABS(*r);
506  if ( i == ( *w-1 ) ) {
507  ncoef2 = (i-1)/2;
508  if ( *r < 0 ) ncoef2 = -ncoef2;
509  i--; cc = coef2; r = w + 1;
510  while ( --i >= 0 ) *cc++ = (UWORD)(*r++);
511  break;
512  }
513  }
514  goto generic;
515  }
516  }
517  else {
518  switch ( d->type ) {
519  case DOLUNDEFINED:
520  if ( AC.UnsureDollarMode == 0 ) {
521 #ifdef WITHPTHREADS
522  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
523 #endif
524  MLOCK(ErrorMessageLock);
525  MesPrint("$%s is undefined",AC.dollarnames->namebuffer+d->name);
526  MUNLOCK(ErrorMessageLock);
527  Terminate(-1);
528  }
529  ncoef2 = 0; coef2[0] = 0; coef2[1] = 1;
530  break;
531  case DOLZERO:
532  ncoef2 = coef2[0] = 0; coef2[1] = 1;
533  break;
534  case DOLSUBTERM:
535  if ( d->where[0] != INDEX || d->where[1] != 3
536  || d->where[2] < 0 || d->where[2] >= AM.OffsetIndex ) {
537  if ( AC.UnsureDollarMode == 0 ) {
538 #ifdef WITHPTHREADS
539  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
540 #endif
541  MLOCK(ErrorMessageLock);
542  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
543  MUNLOCK(ErrorMessageLock);
544  Terminate(-1);
545  }
546  ncoef2 = 0; coef2[0] = 0; coef2[1] = 1;
547  break;
548  }
549  d->index = d->where[2];
550  case DOLINDEX:
551  if ( d->index == 0 ) {
552  ncoef2 = coef2[0] = 0; coef2[1] = 1;
553  }
554  else if ( d->index > 0 && d->index < AM.OffsetIndex ) {
555  ncoef2 = 1; coef2[0] = d->index; coef2[1] = 1;
556  }
557  else if ( AC.UnsureDollarMode == 0 ) {
558 #ifdef WITHPTHREADS
559  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
560 #endif
561  MLOCK(ErrorMessageLock);
562  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
563  MUNLOCK(ErrorMessageLock);
564  Terminate(-1);
565  }
566  ncoef2 = coef2[0] = 0; coef2[1] = 1;
567  break;
568  case DOLWILDARGS:
569  if ( d->where[0] <= -FUNCTION ||
570  ( d->where[0] < 0 && d->where[2] != 0 )
571  || ( d->where[0] > 0 && d->where[d->where[0]] != 0 )
572  ) {
573  if ( AC.UnsureDollarMode == 0 ) {
574 #ifdef WITHPTHREADS
575  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
576 #endif
577  MLOCK(ErrorMessageLock);
578  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
579  MUNLOCK(ErrorMessageLock);
580  Terminate(-1);
581  }
582  ncoef2 = coef2[0] = 0; coef2[1] = 1;
583  break;
584  }
585  case DOLARGUMENT:
586  if ( d->where[0] == -SNUMBER ) {
587  if ( d->where[1] == 0 ) {
588  ncoef2 = coef2[0] = 0;
589  }
590  else if ( d->where[1] < 0 ) {
591  ncoef2 = -1;
592  coef2[0] = -d->where[1];
593  }
594  else {
595  ncoef2 = 1;
596  coef2[0] = d->where[1];
597  }
598  coef2[1] = 1;
599  }
600  else if ( d->where[0] == -INDEX
601  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
602  if ( d->where[1] == 0 ) {
603  ncoef2 = coef2[0] = 0; coef2[1] = 1;
604  }
605  else {
606  ncoef2 = 1; coef2[0] = d->where[1];
607  coef2[1] = 1;
608  }
609  }
610  else if ( d->where[0] > 0
611  && d->where[ARGHEAD] == (d->where[0]-ARGHEAD)
612  && ABS(d->where[d->where[0]-1]) ==
613  (d->where[0] - ARGHEAD-1) ) {
614  i = d->where[d->where[0]-1];
615  ncoef2 = (ABS(i)-1)/2;
616  if ( i < 0 ) { ncoef2 = -ncoef2; i = -i; }
617  i--; cc = coef2; r = d->where + ARGHEAD+1;
618  while ( --i >= 0 ) *cc++ = (UWORD)(*r++);
619  }
620  else {
621  if ( AC.UnsureDollarMode == 0 ) {
622 #ifdef WITHPTHREADS
623  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
624 #endif
625  MLOCK(ErrorMessageLock);
626  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
627  MUNLOCK(ErrorMessageLock);
628  Terminate(-1);
629  }
630  ncoef2 = 0; coef2[0] = 0; coef2[1] = 1;
631  }
632  break;
633  case DOLNUMBER:
634  case DOLTERMS:
635  if ( d->where[d->where[0]] == 0 ) {
636  r = d->where + d->where[0]-1;
637  i = ABS(*r);
638  if ( i == ( d->where[0]-1 ) ) {
639  ncoef2 = (i-1)/2;
640  if ( *r < 0 ) ncoef2 = -ncoef2;
641  i--; cc = coef2; r = d->where + 1;
642  while ( --i >= 0 ) *cc++ = (UWORD)(*r++);
643  break;
644  }
645  }
646 generic:;
647  if ( AC.UnsureDollarMode == 0 ) {
648 #ifdef WITHPTHREADS
649  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
650 #endif
651  MLOCK(ErrorMessageLock);
652  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
653  MUNLOCK(ErrorMessageLock);
654  Terminate(-1);
655  }
656  ncoef2 = 0; coef2[0] = 0; coef2[1] = 1;
657  break;
658  }
659  }
660 #ifdef WITHPTHREADS
661  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
662 #endif
663  }
664  break;
665  case IFEXPRESSION:
666  r = ifp+2; j = ifp[1] - 2; ncoef2 = 0;
667  while ( --j >= 0 ) {
668  if ( *r == AR.CurExpr ) { ncoef2 = 1; break; }
669  r++;
670  }
671  coef2[0] = ncoef2;
672  coef2[1] = 1;
673  break;
674  case IFISFACTORIZED:
675  r = ifp+2; j = ifp[1] - 2;
676  if ( j == 0 ) {
677  ncoef2 = 0;
678  if ( ( Expressions[AR.CurExpr].vflags & ISFACTORIZED ) != 0 ) {
679  ncoef2 = 1;
680  }
681  }
682  else {
683  ncoef2 = 1;
684  while ( --j >= 0 ) {
685  if ( ( Expressions[*r].vflags & ISFACTORIZED ) == 0 ) {
686  ncoef2 = 0;
687  break;
688  }
689  r++;
690  }
691  }
692  coef2[0] = ncoef2;
693  coef2[1] = 1;
694  break;
695  case IFOCCURS:
696  {
697  WORD *OccStop = ifp + ifp[1], *ifpp = ifp+2;
698  ncoef2 = 0;
699  while ( ifpp < OccStop ) {
700  if ( FindVar(ifpp,term) == 1 ) {
701  ncoef2 = 1; break;
702  }
703  if ( *ifpp == DOTPRODUCT ) ifp += 3;
704  else ifpp += 2;
705  }
706  coef2[0] = ncoef2;
707  coef2[1] = 1;
708  }
709  break;
710  default:
711  break;
712  }
713  if ( !first ) {
714  if ( ifp[-2] != ORCOND && ifp[-2] != ANDCOND ) {
715  if ( ( ifp[-2] == EQUAL || ifp[-2] == NOTEQUAL ) &&
716  ( ismul2 || ismul1 ) ) {
717  if ( ismul1 && ismul2 ) {
718  if ( coef1[0] == coef2[0] ) i = 1;
719  else i = 0;
720  }
721  else {
722  if ( ismul1 ) {
723  if ( ncoef2 )
724  Divvy(BHEAD coef2,&ncoef2,coef1,ncoef1);
725  cc = coef2; ncoef3 = ncoef2;
726  }
727  else {
728  if ( ncoef1 )
729  Divvy(BHEAD coef1,&ncoef1,coef2,ncoef2);
730  cc = coef1; ncoef3 = ncoef1;
731  }
732  if ( ncoef3 < 0 ) ncoef3 = -ncoef3;
733  if ( ncoef3 == 0 ) {
734  if ( ifp[-2] == EQUAL ) i = 1;
735  else i = 0;
736  }
737  else if ( cc[ncoef3] != 1 ) {
738  if ( ifp[-2] == EQUAL ) i = 0;
739  else i = 1;
740  }
741  else {
742  for ( j = 1; j < ncoef3; j++ ) {
743  if ( cc[ncoef3+j] != 0 ) break;
744  }
745  if ( j < ncoef3 ) {
746  if ( ifp[-2] == EQUAL ) i = 0;
747  else i = 1;
748  }
749  else if ( ifp[-2] == EQUAL ) i = 1;
750  else i = 0;
751  }
752  }
753  goto donemul;
754  }
755  else if ( AddRat(BHEAD coef1,ncoef1,coef2,-ncoef2,coef3,&ncoef3) ) {
756  NumberFree(coef3,"DoIfStatement"); NumberFree(Spac1,"DoIfStatement"); TermFree(Spac2,"DoIfStatement");
757  MesCall("DoIfStatement"); return(-1);
758  }
759  switch ( ifp[-2] ) {
760  case GREATER:
761  if ( ncoef3 > 0 ) i = 1;
762  else i = 0;
763  break;
764  case GREATEREQUAL:
765  if ( ncoef3 >= 0 ) i = 1;
766  else i = 0;
767  break;
768  case LESS:
769  if ( ncoef3 < 0 ) i = 1;
770  else i = 0;
771  break;
772  case LESSEQUAL:
773  if ( ncoef3 <= 0 ) i = 1;
774  else i = 0;
775  break;
776  case EQUAL:
777  if ( ncoef3 == 0 ) i = 1;
778  else i = 0;
779  break;
780  case NOTEQUAL:
781  if ( ncoef3 != 0 ) i = 1;
782  else i = 0;
783  break;
784  }
785 donemul: if ( i ) { ncoef2 = 1; coef2 = Spac2; coef2[0] = coef2[1] = 1; }
786  else ncoef2 = 0;
787  ismul1 = ismul2 = 0;
788  }
789  }
790  else {
791  first = 0;
792  }
793  coef1 = Spac1;
794  i = 2*ABS(ncoef2);
795  for ( j = 0; j < i; j++ ) coef1[j] = coef2[j];
796  ncoef1 = ncoef2;
797 SkipCond:
798  ifp += ifp[1];
799  } while ( ifp < ifstop );
800 
801  NumberFree(coef3,"DoIfStatement"); NumberFree(Spac1,"DoIfStatement"); TermFree(Spac2,"DoIfStatement");
802  if ( ncoef1 ) return(1);
803  else return(0);
804 }
805 
806 /*
807  #] DoIfStatement :
808  #[ HowMany : WORD HowMany(ifcode,term)
809 
810  Returns the number of times that the pattern in ifcode
811  can be taken out from term. There is a subkey in ifcode[2];
812  The notation is identical to the lhs of an id statement.
813  Most of the code comes from TestMatch.
814 */
815 
816 WORD HowMany(PHEAD WORD *ifcode, WORD *term)
817 {
818  GETBIDENTITY
819  WORD *m, *t, *r, *w, power, RetVal, i, topje, *newterm;
820  WORD *OldWork, *ww, *mm;
821  int *RepSto, RepVal;
822  int numdollars = 0;
823  m = ifcode + IDHEAD;
824  AN.FullProto = m;
825  AN.WildValue = w = m + SUBEXPSIZE;
826  m += m[1];
827  AN.WildStop = m;
828  OldWork = AT.WorkPointer;
829  if ( ( ifcode[4] & 1 ) != 0 ) { /* We have at least one dollar in the pattern */
830  AR.Eside = LHSIDEX;
831  ww = AT.WorkPointer; i = m[0]; mm = m;
832  NCOPY(ww,mm,i);
833  *OldWork += 3;
834  *ww++ = 1; *ww++ = 1; *ww++ = 3;
835  AT.WorkPointer = ww;
836  RepSto = AN.RepPoint;
837  RepVal = *RepSto;
838  NewSort(BHEAD0);
839  if ( Generator(BHEAD OldWork,AR.Cnumlhs) ) {
840  LowerSortLevel();
841  *RepSto = RepVal;
842  AN.RepPoint = RepSto;
843  AT.WorkPointer = OldWork;
844  return(-1);
845  }
846  AT.WorkPointer = ww;
847  if ( EndSort(BHEAD ww,0) < 0 ) {}
848  *RepSto = RepVal;
849  AN.RepPoint = RepSto;
850  if ( *ww == 0 || *(ww+*ww) != 0 ) {
851  if ( AP.lhdollarerror == 0 ) {
852  MLOCK(ErrorMessageLock);
853  MesPrint("&LHS must be one term");
854  MUNLOCK(ErrorMessageLock);
855  AP.lhdollarerror = 1;
856  }
857  AT.WorkPointer = OldWork;
858  return(-1);
859  }
860  m = ww; AT.WorkPointer = ww = m + *m;
861  if ( m[*m-1] < 0 ) { m[*m-1] = -m[*m-1]; }
862  *m -= m[*m-1];
863  AR.Eside = RHSIDE;
864  }
865  else {
866  ww = term + *term;
867  if ( AT.WorkPointer < ww ) AT.WorkPointer = ww;
868  }
869  ClearWild(BHEAD0);
870  while ( w < AN.WildStop ) {
871  if ( *w == LOADDOLLAR ) numdollars++;
872  w += w[1];
873  }
874  AN.RepFunNum = 0;
875  AN.RepFunList = AT.WorkPointer;
876  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
877  topje = cbuf[AT.ebufnum].numrhs;
878  if ( AT.WorkPointer >= AT.WorkTop ) {
879  MLOCK(ErrorMessageLock);
880  MesWork();
881  MUNLOCK(ErrorMessageLock);
882  return(-1);
883  }
884  AN.DisOrderFlag = ifcode[2] & SUBDISORDER;
885  switch ( ifcode[2] & (~SUBDISORDER) ) {
886  case SUBONLY :
887  /* Must be an exact match */
888  AN.UseFindOnly = 1; AN.ForFindOnly = 0;
889 /*
890  Copy the term first to scratchterm. This is needed
891  because of the Substitute.
892 */
893  i = *term;
894  t = term; newterm = r = AT.WorkPointer;
895  NCOPY(r,t,i); AT.WorkPointer = r;
896  RetVal = 0;
897  if ( FindRest(BHEAD newterm,m) && ( AN.UsedOtherFind ||
898  FindOnly(BHEAD newterm,m) ) ) {
899  Substitute(BHEAD newterm,m,1);
900  if ( numdollars ) {
901  WildDollars(BHEAD (WORD *)0);
902  numdollars = 0;
903  }
904  ClearWild(BHEAD0);
905  RetVal = 1;
906  }
907  else RetVal = 0;
908  break;
909  case SUBMANY :
910 /*
911  Copy the term first to scratchterm. This is needed
912  because of the Substitute.
913 */
914  i = *term;
915  t = term; newterm = r = AT.WorkPointer;
916  NCOPY(r,t,i); AT.WorkPointer = r;
917  RetVal = 0;
918  AN.UseFindOnly = 0;
919  if ( ( power = FindRest(BHEAD newterm,m) ) > 0 ) {
920  if ( ( power = FindOnce(BHEAD newterm,m) ) > 0 ) {
921  AN.UseFindOnly = 0;
922  do {
923  Substitute(BHEAD newterm,m,1);
924  if ( numdollars ) {
925  WildDollars(BHEAD (WORD *)0);
926  numdollars = 0;
927  }
928  ClearWild(BHEAD0);
929  RetVal++;
930  } while ( FindRest(BHEAD newterm,m) && (
931  AN.UsedOtherFind || FindOnce(BHEAD newterm,m) ) );
932  }
933  else if ( power < 0 ) {
934  do {
935  Substitute(BHEAD newterm,m,1);
936  if ( numdollars ) {
937  WildDollars(BHEAD (WORD *)0);
938  numdollars = 0;
939  }
940  ClearWild(BHEAD0);
941  RetVal++;
942  } while ( FindRest(BHEAD newterm,m) );
943  }
944  }
945  else if ( power < 0 ) {
946  if ( FindOnce(BHEAD newterm,m) ) {
947  do {
948  Substitute(BHEAD newterm,m,1);
949  if ( numdollars ) {
950  WildDollars(BHEAD (WORD *)0);
951  numdollars = 0;
952  }
953  ClearWild(BHEAD0);
954  } while ( FindOnce(BHEAD newterm,m) );
955  RetVal = 1;
956  }
957  }
958  break;
959  case SUBONCE :
960 /*
961  Copy the term first to scratchterm. This is needed
962  because of the Substitute.
963 */
964  i = *term;
965  t = term; newterm = r = AT.WorkPointer;
966  NCOPY(r,t,i); AT.WorkPointer = r;
967  RetVal = 0;
968  AN.UseFindOnly = 0;
969  if ( FindRest(BHEAD newterm,m) && ( AN.UsedOtherFind || FindOnce(BHEAD newterm,m) ) ) {
970  Substitute(BHEAD newterm,m,1);
971  if ( numdollars ) {
972  WildDollars(BHEAD (WORD *)0);
973  numdollars = 0;
974  }
975  ClearWild(BHEAD0);
976  RetVal = 1;
977  }
978  else RetVal = 0;
979  break;
980  case SUBMULTI :
981  RetVal = FindMulti(BHEAD term,m);
982  break;
983  case SUBVECTOR :
984  RetVal = 0;
985  for ( i = 0; i < *term; i++ ) ww[i] = term[i];
986  while ( ( power = FindAll(BHEAD ww,m,AR.Cnumlhs,ifcode) ) != 0 ) { RetVal += power; }
987  break;
988  case SUBSELECT :
989  ifcode += IDHEAD; ifcode += ifcode[1]; ifcode += *ifcode;
990  AN.UseFindOnly = 1; AN.ForFindOnly = ifcode;
991  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
992  FindOnly(BHEAD term,m) ) ) RetVal = 1;
993  else RetVal = 0;
994  break;
995  default :
996  RetVal = 0;
997  break;
998  }
999  AT.WorkPointer = AN.RepFunList;
1000  cbuf[AT.ebufnum].numrhs = topje;
1001  return(RetVal);
1002 }
1003 
1004 /*
1005  #] HowMany :
1006  #[ DoubleIfBuffers :
1007 */
1008 
1009 VOID DoubleIfBuffers()
1010 {
1011  int newmax, i;
1012  WORD *newsumcheck;
1013  LONG *newheap, *newifcount;
1014  if ( AC.MaxIf == 0 ) newmax = 10;
1015  else newmax = 2*AC.MaxIf;
1016  newheap = (LONG *)Malloc1(sizeof(LONG)*(newmax+1),"IfHeap");
1017  newsumcheck = (WORD *)Malloc1(sizeof(WORD)*(newmax+1),"IfSumCheck");
1018  newifcount = (LONG *)Malloc1(sizeof(LONG)*(newmax+1),"IfCount");
1019  if ( AC.MaxIf ) {
1020  for ( i = 0; i < AC.MaxIf; i++ ) {
1021  newheap[i] = AC.IfHeap[i];
1022  newsumcheck[i] = AC.IfSumCheck[i];
1023  newifcount[i] = AC.IfCount[i];
1024  }
1025  AC.IfStack = (AC.IfStack-AC.IfHeap) + newheap;
1026  M_free(AC.IfHeap,"AC.IfHeap");
1027  M_free(AC.IfCount,"AC.IfCount");
1028  M_free(AC.IfSumCheck,"AC.IfSumCheck");
1029  }
1030  else {
1031  AC.IfStack = newheap;
1032  }
1033  AC.IfHeap = newheap;
1034  AC.IfSumCheck = newsumcheck;
1035  AC.IfCount = newifcount;
1036  AC.MaxIf = newmax;
1037 }
1038 
1039 /*
1040  #] DoubleIfBuffers :
1041  #] If statement :
1042 */
#define PHEAD
Definition: ftypes.h:56
VOID LowerSortLevel()
Definition: sort.c:4610
WORD NewSort(PHEAD0)
Definition: sort.c:589
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3034
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:675