FORM  4.3
if.c
Go to the documentation of this file.
1 
5 /* #[ License : */
6 /*
7  * Copyright (C) 1984-2022 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  /* fall through */
551  case DOLINDEX:
552  if ( d->index == 0 ) {
553  ncoef2 = coef2[0] = 0; coef2[1] = 1;
554  }
555  else if ( d->index > 0 && d->index < AM.OffsetIndex ) {
556  ncoef2 = 1; coef2[0] = d->index; coef2[1] = 1;
557  }
558  else if ( AC.UnsureDollarMode == 0 ) {
559 #ifdef WITHPTHREADS
560  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
561 #endif
562  MLOCK(ErrorMessageLock);
563  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
564  MUNLOCK(ErrorMessageLock);
565  Terminate(-1);
566  }
567  ncoef2 = coef2[0] = 0; coef2[1] = 1;
568  break;
569  case DOLWILDARGS:
570  if ( d->where[0] <= -FUNCTION ||
571  ( d->where[0] < 0 && d->where[2] != 0 )
572  || ( d->where[0] > 0 && d->where[d->where[0]] != 0 )
573  ) {
574  if ( AC.UnsureDollarMode == 0 ) {
575 #ifdef WITHPTHREADS
576  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
577 #endif
578  MLOCK(ErrorMessageLock);
579  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
580  MUNLOCK(ErrorMessageLock);
581  Terminate(-1);
582  }
583  ncoef2 = coef2[0] = 0; coef2[1] = 1;
584  break;
585  }
586  /* fall through */
587  case DOLARGUMENT:
588  if ( d->where[0] == -SNUMBER ) {
589  if ( d->where[1] == 0 ) {
590  ncoef2 = coef2[0] = 0;
591  }
592  else if ( d->where[1] < 0 ) {
593  ncoef2 = -1;
594  coef2[0] = -d->where[1];
595  }
596  else {
597  ncoef2 = 1;
598  coef2[0] = d->where[1];
599  }
600  coef2[1] = 1;
601  }
602  else if ( d->where[0] == -INDEX
603  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
604  if ( d->where[1] == 0 ) {
605  ncoef2 = coef2[0] = 0; coef2[1] = 1;
606  }
607  else {
608  ncoef2 = 1; coef2[0] = d->where[1];
609  coef2[1] = 1;
610  }
611  }
612  else if ( d->where[0] > 0
613  && d->where[ARGHEAD] == (d->where[0]-ARGHEAD)
614  && ABS(d->where[d->where[0]-1]) ==
615  (d->where[0] - ARGHEAD-1) ) {
616  i = d->where[d->where[0]-1];
617  ncoef2 = (ABS(i)-1)/2;
618  if ( i < 0 ) { ncoef2 = -ncoef2; i = -i; }
619  i--; cc = coef2; r = d->where + ARGHEAD+1;
620  while ( --i >= 0 ) *cc++ = (UWORD)(*r++);
621  }
622  else {
623  if ( AC.UnsureDollarMode == 0 ) {
624 #ifdef WITHPTHREADS
625  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
626 #endif
627  MLOCK(ErrorMessageLock);
628  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
629  MUNLOCK(ErrorMessageLock);
630  Terminate(-1);
631  }
632  ncoef2 = 0; coef2[0] = 0; coef2[1] = 1;
633  }
634  break;
635  case DOLNUMBER:
636  case DOLTERMS:
637  if ( d->where[d->where[0]] == 0 ) {
638  r = d->where + d->where[0]-1;
639  i = ABS(*r);
640  if ( i == ( d->where[0]-1 ) ) {
641  ncoef2 = (i-1)/2;
642  if ( *r < 0 ) ncoef2 = -ncoef2;
643  i--; cc = coef2; r = d->where + 1;
644  while ( --i >= 0 ) *cc++ = (UWORD)(*r++);
645  break;
646  }
647  }
648 generic:;
649  if ( AC.UnsureDollarMode == 0 ) {
650 #ifdef WITHPTHREADS
651  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
652 #endif
653  MLOCK(ErrorMessageLock);
654  MesPrint("$%s is of wrong type",AC.dollarnames->namebuffer+d->name);
655  MUNLOCK(ErrorMessageLock);
656  Terminate(-1);
657  }
658  ncoef2 = 0; coef2[0] = 0; coef2[1] = 1;
659  break;
660  }
661  }
662 #ifdef WITHPTHREADS
663  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
664 #endif
665  }
666  break;
667  case IFEXPRESSION:
668  r = ifp+2; j = ifp[1] - 2; ncoef2 = 0;
669  while ( --j >= 0 ) {
670  if ( *r == AR.CurExpr ) { ncoef2 = 1; break; }
671  r++;
672  }
673  coef2[0] = ncoef2;
674  coef2[1] = 1;
675  break;
676  case IFISFACTORIZED:
677  r = ifp+2; j = ifp[1] - 2;
678  if ( j == 0 ) {
679  ncoef2 = 0;
680  if ( ( Expressions[AR.CurExpr].vflags & ISFACTORIZED ) != 0 ) {
681  ncoef2 = 1;
682  }
683  }
684  else {
685  ncoef2 = 1;
686  while ( --j >= 0 ) {
687  if ( ( Expressions[*r].vflags & ISFACTORIZED ) == 0 ) {
688  ncoef2 = 0;
689  break;
690  }
691  r++;
692  }
693  }
694  coef2[0] = ncoef2;
695  coef2[1] = 1;
696  break;
697  case IFOCCURS:
698  {
699  WORD *OccStop = ifp + ifp[1], *ifpp = ifp+2;
700  ncoef2 = 0;
701  while ( ifpp < OccStop ) {
702  if ( FindVar(ifpp,term) == 1 ) {
703  ncoef2 = 1; break;
704  }
705  if ( *ifpp == DOTPRODUCT ) ifp += 3;
706  else ifpp += 2;
707  }
708  coef2[0] = ncoef2;
709  coef2[1] = 1;
710  }
711  break;
712  default:
713  break;
714  }
715  if ( !first ) {
716  if ( ifp[-2] != ORCOND && ifp[-2] != ANDCOND ) {
717  if ( ( ifp[-2] == EQUAL || ifp[-2] == NOTEQUAL ) &&
718  ( ismul2 || ismul1 ) ) {
719  if ( ismul1 && ismul2 ) {
720  if ( coef1[0] == coef2[0] ) i = 1;
721  else i = 0;
722  }
723  else {
724  if ( ismul1 ) {
725  if ( ncoef2 )
726  Divvy(BHEAD coef2,&ncoef2,coef1,ncoef1);
727  cc = coef2; ncoef3 = ncoef2;
728  }
729  else {
730  if ( ncoef1 )
731  Divvy(BHEAD coef1,&ncoef1,coef2,ncoef2);
732  cc = coef1; ncoef3 = ncoef1;
733  }
734  if ( ncoef3 < 0 ) ncoef3 = -ncoef3;
735  if ( ncoef3 == 0 ) {
736  if ( ifp[-2] == EQUAL ) i = 1;
737  else i = 0;
738  }
739  else if ( cc[ncoef3] != 1 ) {
740  if ( ifp[-2] == EQUAL ) i = 0;
741  else i = 1;
742  }
743  else {
744  for ( j = 1; j < ncoef3; j++ ) {
745  if ( cc[ncoef3+j] != 0 ) break;
746  }
747  if ( j < ncoef3 ) {
748  if ( ifp[-2] == EQUAL ) i = 0;
749  else i = 1;
750  }
751  else if ( ifp[-2] == EQUAL ) i = 1;
752  else i = 0;
753  }
754  }
755  goto donemul;
756  }
757  else if ( AddRat(BHEAD coef1,ncoef1,coef2,-ncoef2,coef3,&ncoef3) ) {
758  NumberFree(coef3,"DoIfStatement"); NumberFree(Spac1,"DoIfStatement"); TermFree(Spac2,"DoIfStatement");
759  MesCall("DoIfStatement"); return(-1);
760  }
761  switch ( ifp[-2] ) {
762  case GREATER:
763  if ( ncoef3 > 0 ) i = 1;
764  else i = 0;
765  break;
766  case GREATEREQUAL:
767  if ( ncoef3 >= 0 ) i = 1;
768  else i = 0;
769  break;
770  case LESS:
771  if ( ncoef3 < 0 ) i = 1;
772  else i = 0;
773  break;
774  case LESSEQUAL:
775  if ( ncoef3 <= 0 ) i = 1;
776  else i = 0;
777  break;
778  case EQUAL:
779  if ( ncoef3 == 0 ) i = 1;
780  else i = 0;
781  break;
782  case NOTEQUAL:
783  if ( ncoef3 != 0 ) i = 1;
784  else i = 0;
785  break;
786  }
787 donemul: if ( i ) { ncoef2 = 1; coef2 = Spac2; coef2[0] = coef2[1] = 1; }
788  else ncoef2 = 0;
789  ismul1 = ismul2 = 0;
790  }
791  }
792  else {
793  first = 0;
794  }
795  coef1 = Spac1;
796  i = 2*ABS(ncoef2);
797  for ( j = 0; j < i; j++ ) coef1[j] = coef2[j];
798  ncoef1 = ncoef2;
799 SkipCond:
800  ifp += ifp[1];
801  } while ( ifp < ifstop );
802 
803  NumberFree(coef3,"DoIfStatement"); NumberFree(Spac1,"DoIfStatement"); TermFree(Spac2,"DoIfStatement");
804  if ( ncoef1 ) return(1);
805  else return(0);
806 }
807 
808 /*
809  #] DoIfStatement :
810  #[ HowMany : WORD HowMany(ifcode,term)
811 
812  Returns the number of times that the pattern in ifcode
813  can be taken out from term. There is a subkey in ifcode[2];
814  The notation is identical to the lhs of an id statement.
815  Most of the code comes from TestMatch.
816 */
817 
818 WORD HowMany(PHEAD WORD *ifcode, WORD *term)
819 {
820  GETBIDENTITY
821  WORD *m, *t, *r, *w, power, RetVal, i, topje, *newterm;
822  WORD *OldWork, *ww, *mm;
823  int *RepSto, RepVal;
824  int numdollars = 0;
825  m = ifcode + IDHEAD;
826  AN.FullProto = m;
827  AN.WildValue = w = m + SUBEXPSIZE;
828  m += m[1];
829  AN.WildStop = m;
830  OldWork = AT.WorkPointer;
831  if ( ( ifcode[4] & 1 ) != 0 ) { /* We have at least one dollar in the pattern */
832  AR.Eside = LHSIDEX;
833  ww = AT.WorkPointer; i = m[0]; mm = m;
834  NCOPY(ww,mm,i);
835  *OldWork += 3;
836  *ww++ = 1; *ww++ = 1; *ww++ = 3;
837  AT.WorkPointer = ww;
838  RepSto = AN.RepPoint;
839  RepVal = *RepSto;
840  NewSort(BHEAD0);
841  if ( Generator(BHEAD OldWork,AR.Cnumlhs) ) {
842  LowerSortLevel();
843  *RepSto = RepVal;
844  AN.RepPoint = RepSto;
845  AT.WorkPointer = OldWork;
846  return(-1);
847  }
848  AT.WorkPointer = ww;
849  if ( EndSort(BHEAD ww,0) < 0 ) {}
850  *RepSto = RepVal;
851  AN.RepPoint = RepSto;
852  if ( *ww == 0 || *(ww+*ww) != 0 ) {
853  if ( AP.lhdollarerror == 0 ) {
854  MLOCK(ErrorMessageLock);
855  MesPrint("&LHS must be one term");
856  MUNLOCK(ErrorMessageLock);
857  AP.lhdollarerror = 1;
858  }
859  AT.WorkPointer = OldWork;
860  return(-1);
861  }
862  m = ww; AT.WorkPointer = ww = m + *m;
863  if ( m[*m-1] < 0 ) { m[*m-1] = -m[*m-1]; }
864  *m -= m[*m-1];
865  AR.Eside = RHSIDE;
866  }
867  else {
868  ww = term + *term;
869  if ( AT.WorkPointer < ww ) AT.WorkPointer = ww;
870  }
871  ClearWild(BHEAD0);
872  while ( w < AN.WildStop ) {
873  if ( *w == LOADDOLLAR ) numdollars++;
874  w += w[1];
875  }
876  AN.RepFunNum = 0;
877  AN.RepFunList = AT.WorkPointer;
878  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
879  topje = cbuf[AT.ebufnum].numrhs;
880  if ( AT.WorkPointer >= AT.WorkTop ) {
881  MLOCK(ErrorMessageLock);
882  MesWork();
883  MUNLOCK(ErrorMessageLock);
884  return(-1);
885  }
886  AN.DisOrderFlag = ifcode[2] & SUBDISORDER;
887  switch ( ifcode[2] & (~SUBDISORDER) ) {
888  case SUBONLY :
889  /* Must be an exact match */
890  AN.UseFindOnly = 1; AN.ForFindOnly = 0;
891 /*
892  Copy the term first to scratchterm. This is needed
893  because of the Substitute.
894 */
895  i = *term;
896  t = term; newterm = r = AT.WorkPointer;
897  NCOPY(r,t,i); AT.WorkPointer = r;
898  RetVal = 0;
899  if ( FindRest(BHEAD newterm,m) && ( AN.UsedOtherFind ||
900  FindOnly(BHEAD newterm,m) ) ) {
901  Substitute(BHEAD newterm,m,1);
902  if ( numdollars ) {
903  WildDollars(BHEAD (WORD *)0);
904  numdollars = 0;
905  }
906  ClearWild(BHEAD0);
907  RetVal = 1;
908  }
909  else RetVal = 0;
910  break;
911  case SUBMANY :
912 /*
913  Copy the term first to scratchterm. This is needed
914  because of the Substitute.
915 */
916  i = *term;
917  t = term; newterm = r = AT.WorkPointer;
918  NCOPY(r,t,i); AT.WorkPointer = r;
919  RetVal = 0;
920  AN.UseFindOnly = 0;
921  if ( ( power = FindRest(BHEAD newterm,m) ) > 0 ) {
922  if ( ( power = FindOnce(BHEAD newterm,m) ) > 0 ) {
923  AN.UseFindOnly = 0;
924  do {
925  Substitute(BHEAD newterm,m,1);
926  if ( numdollars ) {
927  WildDollars(BHEAD (WORD *)0);
928  numdollars = 0;
929  }
930  ClearWild(BHEAD0);
931  RetVal++;
932  } while ( FindRest(BHEAD newterm,m) && (
933  AN.UsedOtherFind || FindOnce(BHEAD newterm,m) ) );
934  }
935  else if ( power < 0 ) {
936  do {
937  Substitute(BHEAD newterm,m,1);
938  if ( numdollars ) {
939  WildDollars(BHEAD (WORD *)0);
940  numdollars = 0;
941  }
942  ClearWild(BHEAD0);
943  RetVal++;
944  } while ( FindRest(BHEAD newterm,m) );
945  }
946  }
947  else if ( power < 0 ) {
948  if ( FindOnce(BHEAD newterm,m) ) {
949  do {
950  Substitute(BHEAD newterm,m,1);
951  if ( numdollars ) {
952  WildDollars(BHEAD (WORD *)0);
953  numdollars = 0;
954  }
955  ClearWild(BHEAD0);
956  } while ( FindOnce(BHEAD newterm,m) );
957  RetVal = 1;
958  }
959  }
960  break;
961  case SUBONCE :
962 /*
963  Copy the term first to scratchterm. This is needed
964  because of the Substitute.
965 */
966  i = *term;
967  t = term; newterm = r = AT.WorkPointer;
968  NCOPY(r,t,i); AT.WorkPointer = r;
969  RetVal = 0;
970  AN.UseFindOnly = 0;
971  if ( FindRest(BHEAD newterm,m) && ( AN.UsedOtherFind || FindOnce(BHEAD newterm,m) ) ) {
972  Substitute(BHEAD newterm,m,1);
973  if ( numdollars ) {
974  WildDollars(BHEAD (WORD *)0);
975  numdollars = 0;
976  }
977  ClearWild(BHEAD0);
978  RetVal = 1;
979  }
980  else RetVal = 0;
981  break;
982  case SUBMULTI :
983  RetVal = FindMulti(BHEAD term,m);
984  break;
985  case SUBVECTOR :
986  RetVal = 0;
987  for ( i = 0; i < *term; i++ ) ww[i] = term[i];
988  while ( ( power = FindAll(BHEAD ww,m,AR.Cnumlhs,ifcode) ) != 0 ) { RetVal += power; }
989  break;
990  case SUBSELECT :
991  ifcode += IDHEAD; ifcode += ifcode[1]; ifcode += *ifcode;
992  AN.UseFindOnly = 1; AN.ForFindOnly = ifcode;
993  if ( FindRest(BHEAD term,m) && ( AN.UsedOtherFind ||
994  FindOnly(BHEAD term,m) ) ) RetVal = 1;
995  else RetVal = 0;
996  break;
997  default :
998  RetVal = 0;
999  break;
1000  }
1001  AT.WorkPointer = AN.RepFunList;
1002  cbuf[AT.ebufnum].numrhs = topje;
1003  return(RetVal);
1004 }
1005 
1006 /*
1007  #] HowMany :
1008  #[ DoubleIfBuffers :
1009 */
1010 
1011 VOID DoubleIfBuffers()
1012 {
1013  int newmax, i;
1014  WORD *newsumcheck;
1015  LONG *newheap, *newifcount;
1016  if ( AC.MaxIf == 0 ) newmax = 10;
1017  else newmax = 2*AC.MaxIf;
1018  newheap = (LONG *)Malloc1(sizeof(LONG)*(newmax+1),"IfHeap");
1019  newsumcheck = (WORD *)Malloc1(sizeof(WORD)*(newmax+1),"IfSumCheck");
1020  newifcount = (LONG *)Malloc1(sizeof(LONG)*(newmax+1),"IfCount");
1021  if ( AC.MaxIf ) {
1022  for ( i = 0; i < AC.MaxIf; i++ ) {
1023  newheap[i] = AC.IfHeap[i];
1024  newsumcheck[i] = AC.IfSumCheck[i];
1025  newifcount[i] = AC.IfCount[i];
1026  }
1027  AC.IfStack = (AC.IfStack-AC.IfHeap) + newheap;
1028  M_free(AC.IfHeap,"AC.IfHeap");
1029  M_free(AC.IfCount,"AC.IfCount");
1030  M_free(AC.IfSumCheck,"AC.IfSumCheck");
1031  }
1032  else {
1033  AC.IfStack = newheap;
1034  }
1035  AC.IfHeap = newheap;
1036  AC.IfSumCheck = newsumcheck;
1037  AC.IfCount = newifcount;
1038  AC.MaxIf = newmax;
1039 }
1040 
1041 /*
1042  #] DoubleIfBuffers :
1043  #] If statement :
1044  #[ Switch statement :
1045  #[ DoSwitch :
1046 */
1047 
1048 int DoSwitch(PHEAD WORD *term, WORD *lhs)
1049 {
1050 /*
1051  For the moment we ignore the compiler buffer problems.
1052 */
1053  WORD numdollar = lhs[2];
1054  WORD ncase = DolToNumber(BHEAD numdollar);
1055  SWITCHTABLE *swtab = FindCase(lhs[3],ncase);
1056  return(Generator(BHEAD term,swtab->value));
1057 }
1058 
1059 /*
1060  #] DoSwitch :
1061  #[ DoEndSwitch :
1062 */
1063 
1064 int DoEndSwitch(PHEAD WORD *term, WORD *lhs)
1065 {
1066  SWITCH *sw = AC.SwitchArray+lhs[2];
1067  return(Generator(BHEAD term,sw->endswitch.value+1));
1068 }
1069 
1070 /*
1071  #] DoEndSwitch :
1072  #[ FindCase :
1073 */
1074 
1075 SWITCHTABLE *FindCase(WORD nswitch, WORD ncase)
1076 {
1077 /*
1078  First find the switch table and determine how we have to search.
1079 */
1080  SWITCH *sw = AC.SwitchArray+nswitch;
1081  WORD hi, lo, med;
1082  if ( sw->typetable == DENSETABLE ) {
1083  med = ncase - sw->caseoffset;
1084  if ( med >= sw->numcases || med < 0 ) return(&sw->defaultcase);
1085  }
1086  else {
1087 /*
1088  We need a binary search in the table.
1089 */
1090  if ( ncase > sw->maxcase || ncase < sw->mincase ) return(&sw->defaultcase);
1091  hi = sw->numcases-1; lo = 0;
1092  for(;;) {
1093  med = (hi+lo)/2;
1094  if ( ncase == sw->table[med].ncase ) break;
1095  else if ( ncase > sw->table[med].ncase ) {
1096  lo = med+1;
1097  if ( lo > hi ) return(&sw->defaultcase);
1098  }
1099  else {
1100  hi = med-1;
1101  if ( hi < lo ) return(&sw->defaultcase);
1102  }
1103  }
1104  }
1105  return(&sw->table[med]);
1106 }
1107 
1108 /*
1109  #] FindCase :
1110  #[ DoubleSwitchBuffers :
1111 */
1112 
1113 int DoubleSwitchBuffers()
1114 {
1115  int newmax, i;
1116  SWITCH *newarray;
1117  WORD *newheap;
1118  if ( AC.MaxSwitch == 0 ) newmax = 10;
1119  else newmax = 2*AC.MaxSwitch;
1120  newarray = (SWITCH *)Malloc1(sizeof(SWITCH)*(newmax+1),"SwitchArray");
1121  newheap = (WORD *)Malloc1(sizeof(WORD)*(newmax+1),"SwitchHeap");
1122  if ( AC.MaxSwitch ) {
1123  for ( i = 0; i < AC.MaxSwitch; i++ ) {
1124  newarray[i] = AC.SwitchArray[i];
1125  newheap[i] = AC.SwitchHeap[i];
1126  }
1127  M_free(AC.SwitchHeap,"AC.SwitchHeap");
1128  M_free(AC.SwitchArray,"AC.SwitchArray");
1129  }
1130  for ( i = AC.MaxSwitch; i <= newmax; i++ ) {
1131  newarray[i].table = 0;
1132  newarray[i].tablesize = 0;
1133  newarray[i].defaultcase.ncase = 0;
1134  newarray[i].defaultcase.value = 0;
1135  newarray[i].defaultcase.compbuffer = 0;
1136  newarray[i].endswitch.ncase = 0;
1137  newarray[i].endswitch.value = 0;
1138  newarray[i].endswitch.compbuffer = 0;
1139  newarray[i].typetable = 0;
1140  newarray[i].mincase = 0;
1141  newarray[i].maxcase = 0;
1142  newarray[i].numcases = 0;
1143  newarray[i].caseoffset = 0;
1144  newarray[i].iflevel = 0;
1145  newarray[i].whilelevel = 0;
1146  newarray[i].nestingsum = 0;
1147  newheap[i] = 0;
1148  }
1149  AC.SwitchArray = newarray;
1150  AC.SwitchHeap = newheap;
1151  AC.MaxSwitch = newmax;
1152  return(0);
1153 }
1154 
1155 /*
1156  #] DoubleSwitchBuffers :
1157  #[ SwitchSplitMerge :
1158 
1159  Sorts an array of WORDs. No adding of equal objects.
1160 */
1161 
1162 VOID SwitchSplitMergeRec(SWITCHTABLE *array,WORD num,SWITCHTABLE *auxarray)
1163 {
1164  WORD n1,n2,i,j,k;
1165  SWITCHTABLE *t1,*t2, t;
1166  if ( num < 2 ) return;
1167  if ( num == 2 ) {
1168  if ( array[0].ncase > array[1].ncase ) {
1169  t = array[0]; array[0] = array[1]; array[1] = t;
1170  }
1171  return;
1172  }
1173  n1 = num/2;
1174  n2 = num - n1;
1175  SwitchSplitMergeRec(array,n1,auxarray);
1176  SwitchSplitMergeRec(array+n1,n2,auxarray);
1177  if ( array[n1-1].ncase <= array[n1].ncase ) return;
1178 
1179  t1 = array; t2 = auxarray; i = n1; NCOPY(t2,t1,i);
1180  i = 0; j = n1; k = 0;
1181  while ( i < n1 && j < num ) {
1182  if ( auxarray[i].ncase <= array[j].ncase ) { array[k++] = auxarray[i++]; }
1183  else { array[k++] = array[j++]; }
1184  }
1185  while ( i < n1 ) array[k++] = auxarray[i++];
1186 /*
1187  Remember: remnants of j are still in place!
1188 */
1189 }
1190 
1191 VOID SwitchSplitMerge(SWITCHTABLE *array,WORD num)
1192 {
1193  SWITCHTABLE *auxarray = (SWITCHTABLE *)Malloc1(sizeof(SWITCHTABLE)*num/2,"SwitchSplitMerge");
1194  SwitchSplitMergeRec(array,num,auxarray);
1195  M_free(auxarray,"SwitchSplitMerge");
1196 }
1197 
1198 /*
1199  #] SwitchSplitMerge :
1200  #] Switch statement :
1201 */
VOID LowerSortLevel()
Definition: sort.c:4727
WORD NewSort(PHEAD0)
Definition: sort.c:592
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3101
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:682