FORM  4.1
notation.c
Go to the documentation of this file.
1 
6 /* #[ License : */
7 /*
8  * Copyright (C) 1984-2013 J.A.M. Vermaseren
9  * When using this file you are requested to refer to the publication
10  * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
11  * This is considered a matter of courtesy as the development was paid
12  * for by FOM the Dutch physics granting agency and we would like to
13  * be able to track its scientific use to convince FOM of its value
14  * for the community.
15  *
16  * This file is part of FORM.
17  *
18  * FORM is free software: you can redistribute it and/or modify it under the
19  * terms of the GNU General Public License as published by the Free Software
20  * Foundation, either version 3 of the License, or (at your option) any later
21  * version.
22  *
23  * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
24  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
25  * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
26  * details.
27  *
28  * You should have received a copy of the GNU General Public License along
29  * with FORM. If not, see <http://www.gnu.org/licenses/>.
30  */
31 /* #] License : */
32 /*
33  #[ Includes :
34 */
35 
36 #include "form3.h"
37 
38 /*
39  #] Includes :
40  #[ NormPolyTerm :
41 
42  Brings a term to normal form.
43 
44  This routine knows objects of the following types:
45  SYMBOL
46  HAAKJE
47  SNUMBER
48  LNUMBER
49  The SNUMBER and LNUMBER are worked into the coefficient.
50  One of the essences here is that everything can be done in place.
51 */
52 
53 int NormPolyTerm(PHEAD WORD *term)
54 {
55  WORD *tcoef, ncoef, *tstop, *tfill, *t, *tt;
56  int equal, i;
57  WORD *r1, *r2, *r3, *r4, *r5, *rfirst, rv;
58  WORD *lnum = AT.n_llnum+1, nnum; /* Scratch, originally for factorials */
59 /*
60  One: find the coefficient
61 */
62  tcoef = term+*term;
63  ncoef = tcoef[-1];
64  tstop = tcoef - ABS(tcoef[-1]);
65  tfill = t = term + 1;
66  rfirst = 0;
67  if ( t >= tstop ) return(*term);
68  while ( t < tstop ) {
69  switch ( *t ) {
70  case SYMBOL:
71  if ( rfirst == 0 ) {
72 /*
73  Here we only need to sort
74  1: assume no equals. Bubble.
75 */
76  rfirst = t;
77  r2 = rfirst+4; tt = r3 = t + t[1]; equal = 0;
78  while ( r2 < r3 ) {
79  r1 = r2 - 2;
80  if ( *r2 > *r1 ) { r2 += 2; continue; }
81  if ( *r2 == *r1 ) { r2 += 2; equal = 1; continue; }
82  rv = *r1; *r1 = *r2; *r2 = rv;
83  r1 -= 2; r2 -= 2; r4 = r2 + 2;
84  while ( r1 > t ) {
85  if ( *r2 >= *r1 ) { r2 = r4; break; }
86  rv = *r1; *r1 = *r2; *r2 = rv;
87  r1 -= 2; r2 -= 2;
88  }
89  }
90 /*
91  2: hunt down the equal objects
92  postpone eliminating zero powers.
93 */
94  if ( equal ) {
95  r1 = t+2; r2 = r1+2;
96  while ( r2 < r3 ) {
97  if ( *r1 == *r2 ) {
98  r1[1] += r2[1];
99  r4 = r2+2;
100  while ( r4 < r3 ) *r2++ = *r4++;
101  t[1] -= 2;
102  r2 = r1 + 2; r3 -= 2;
103  }
104  }
105  }
106  }
107  else {
108 /*
109  Here we only need to insert
110 */
111  r1 = t + 2; tt = r3 = t + t[1];
112  while ( r1 < r3 ) {
113  r2 = rfirst+2; r4 = rfirst + rfirst[1];
114  while ( r2 < r4 ) {
115  if ( *r1 == *r2 ) {
116  r2[1] += r1[1];
117  break;
118  }
119  else if ( *r2 > *r1 ) {
120  r5 = r4;
121  while ( r5 > r2 ) { r5[1] = r5[-1]; r5[0] = r5[-2]; r5 -= 2; }
122  rfirst[1] += 2;
123  *r2 = *r1; r2[1] = r1[1];
124  break;
125  }
126  r2 += 2;
127  }
128  if ( r2 == r4 ) {
129  rfirst[1] += 2;
130  *r2++ = *r1++; *r2++ = *r1++;
131  }
132  else r1 += 2;
133  }
134  }
135  t = tt;
136  break;
137  case HAAKJE: /* Here we skip brackets */
138  t += t[1];
139  break;
140  case SNUMBER:
141  if ( t[2] < 0 ) {
142  t[2] = -t[2];
143  if ( t[3] & 1 ) ncoef = -ncoef;
144  }
145  else if ( t[2] == 0 ) {
146  if ( t[3] < 0 ) goto NormInf;
147  goto NormZero;
148  }
149  lnum[0] = t[2];
150  nnum = 1;
151  if ( t[3] && RaisPow(BHEAD (UWORD *)lnum,&nnum,(UWORD)(ABS(t[3]))) ) goto FromNorm;
152  ncoef = REDLENG(ncoef);
153  if ( t[3] < 0 ) {
154  if ( Divvy(BHEAD (UWORD *)tstop,&ncoef,(UWORD *)lnum,nnum) )
155  goto FromNorm;
156  }
157  else if ( t[3] > 0 ) {
158  if ( Mully(BHEAD (UWORD *)tstop,&ncoef,(UWORD *)lnum,nnum) )
159  goto FromNorm;
160  }
161  ncoef = INCLENG(ncoef);
162  t += t[1];
163  break;
164  case LNUMBER:
165  ncoef = REDLENG(ncoef);
166  if ( Mully(BHEAD (UWORD *)tstop,&ncoef,(UWORD *)(t+3),t[2]) ) goto FromNorm;
167  ncoef = INCLENG(ncoef);
168  t += t[1];
169  break;
170  default:
171  MLOCK(ErrorMessageLock);
172  MesPrint("Illegal code in NormPolyTerm");
173  MUNLOCK(ErrorMessageLock);
174  Terminate(-1);
175  break;
176  }
177  }
178 /*
179  Now we try to eliminate objects to the power zero.
180 */
181  if ( rfirst ) {
182  r2 = rfirst+2;
183  r3 = rfirst + rfirst[1];
184  while ( r2 < r3 ) {
185  if ( r2[1] == 0 ) {
186  r1 = r2 + 2;
187  while ( r1 < r3 ) { r1[-2] = r1[0]; r1[-1] = r1[1]; r1 += 2; }
188  r3 -= 2;
189  rfirst[1] -= 2;
190  }
191  else { r2 += 2; }
192  }
193  if ( rfirst[1] < 4 ) rfirst = 0;
194  }
195 /*
196  Finally we put the term together
197 */
198  if ( rfirst ) {
199  i = rfirst[1];
200  NCOPY(tfill,rfirst,i)
201  }
202  i = ABS(ncoef)-1;
203  NCOPY(tfill,tstop,i)
204  *tfill++ = ncoef;
205  *term = tfill - term;
206  return(*term);
207 NormZero:
208  *term = 0;
209  return(0);
210 NormInf:
211  MLOCK(ErrorMessageLock);
212  MesPrint("0^0 in NormPolyTerm");
213  MUNLOCK(ErrorMessageLock);
214  Terminate(-1);
215  return(-1);
216 FromNorm:
217  MLOCK(ErrorMessageLock);
218  MesCall("NormPolyTerm");
219  MUNLOCK(ErrorMessageLock);
220  Terminate(-1);
221  return(-1);
222 }
223 
224 /*
225  #] NormPolyTerm :
226  #[ ComparePoly :
227 */
249 #ifdef WITHCOMPAREPOLY
250 
251 WORD ComparePoly(WORD *term1, WORD *term2, WORD level)
252 {
253  WORD *t1, *t2, *t3, *t4, *tstop1, *tstop2;
254  tstop1 = term1 + *term1;
255  tstop1 -= ABS(tstop1[-1]);
256  tstop2 = term2 + *term2;
257  tstop2 -= ABS(tstop2[-1]);
258  t1 = term1+1;
259  t2 = term2+1;
260  while ( t1 < tstop1 && t2 < tstop2 ) {
261  if ( *t1 == *t2 ) {
262  if ( *t1 == HAAKJE ) {
263  if ( t1[2] != t2[2] ) return(t2[2]-t1[2]);
264  t1 += t1[1]; t2 += t2[1];
265  }
266  else { /* must be type SYMBOL */
267  t3 = t1 + t1[1]; t4 = t2 + t2[1];
268  t1 += 2; t2 += 2;
269  while ( t1 < t3 && t2 < t4 ) {
270  if ( *t1 != *t2 ) return(*t2-*t1);
271  if ( t1[1] != t2[1] ) return(t2[1]-t1[1]);
272  t1 += 2; t2 += 2;
273  }
274  if ( t1 < t3 ) return(-1);
275  if ( t2 < t4 ) return(1);
276  }
277  }
278  else return(*t2-*t1);
279  }
280  if ( t1 < tstop1 ) return(-1);
281  if ( t2 < tstop2 ) return(1);
282  return(0);
283 }
284 
285 #endif
286 
287 /*
288  #] ComparePoly :
289  #[ ConvertToPoly :
290 */
303 static int FirstWarnConvertToPoly = 1;
304 
305 int ConvertToPoly(PHEAD WORD *term, WORD *outterm, WORD *comlist, WORD par)
306 {
307  WORD *tout, *tstop, ncoef, *t, *r, *tt, *ttwo = 0;
308  int i, action = 0;
309  tt = term + *term;
310  ncoef = ABS(tt[-1]);
311  tstop = tt - ncoef;
312  tout = outterm+1;
313  t = term + 1;
314  if ( comlist[2] == DOALL ) {
315  while ( t < tstop ) {
316  if ( *t == SYMBOL ) {
317  r = t+2;
318  t += t[1];
319  while ( r < t ) {
320  if ( r[1] > 0 ) {
321  *tout++ = SYMBOL;
322  *tout++ = 4;
323  *tout++ = r[0];
324  *tout++ = r[1];
325  }
326  else {
327  tout[1] = SYMBOL;
328  tout[2] = 4;
329  tout[3] = r[0];
330  tout[4] = -1;
331  i = FindSubterm(tout+1);
332  *tout++ = SYMBOL;
333  *tout++ = 4;
334  *tout++ = MAXVARIABLES-i;
335  *tout++ = -r[1];
336  action = 1;
337  }
338  r += 2;
339  }
340  }
341  else if ( *t == DOTPRODUCT ) {
342  r = t + 2;
343  t += t[1];
344  while ( r < t ) {
345  tout[1] = DOTPRODUCT;
346  tout[2] = 5;
347  tout[3] = r[0];
348  tout[4] = r[1];
349  if ( r[2] < 0 ) {
350  tout[5] = -1;
351  }
352  else {
353  tout[5] = 1;
354  }
355  i = FindSubterm(tout+1);
356  *tout++ = SYMBOL;
357  *tout++ = 4;
358  *tout++ = MAXVARIABLES-i;
359  *tout++ = ABS(r[2]);
360  r += 3;
361  action = 1;
362  }
363  }
364  else if ( *t == VECTOR ) {
365  r = t + 2;
366  t += t[1];
367  while ( r < t ) {
368  tout[1] = VECTOR;
369  tout[2] = 4;
370  tout[3] = r[0];
371  tout[4] = r[1];
372  i = FindSubterm(tout+1);
373  *tout++ = SYMBOL;
374  *tout++ = 4;
375  *tout++ = MAXVARIABLES-i;
376  *tout++ = 1;
377  r += 2;
378  action = 1;
379  }
380  }
381  else if ( *t == INDEX ) {
382  r = t + 2;
383  t += t[1];
384  while ( r < t ) {
385  tout[1] = INDEX;
386  tout[2] = 3;
387  tout[3] = r[0];
388  i = FindSubterm(tout+1);
389  *tout++ = SYMBOL;
390  *tout++ = 4;
391  *tout++ = MAXVARIABLES-i;
392  *tout++ = 1;
393  r++;
394  action = 1;
395  }
396  }
397  else if ( *t == HAAKJE) {
398  if ( par ) {
399  tout[0] = 1; tout[1] = 1; tout[2] = 3;
400  *outterm = (tout+3)-outterm;
401  if ( NormPolyTerm(BHEAD outterm) < 0 ) return(-1);
402  tout = outterm + *outterm;
403  tout -= 3;
404  i = t[1]; NCOPY(tout,t,i);
405  ttwo = tout-1;
406  }
407  else { t += t[1]; }
408  }
409  else if ( *t >= FUNCTION ) {
410  i = FindSubterm(t);
411  t += t[1];
412  *tout++ = SYMBOL;
413  *tout++ = 4;
414  *tout++ = MAXVARIABLES-i;
415  *tout++ = 1;
416  action = 1;
417  }
418  else {
419  if ( FirstWarnConvertToPoly ) {
420  MLOCK(ErrorMessageLock);
421  MesPrint("Illegal object in conversion to polynomial notation");
422  MUNLOCK(ErrorMessageLock);
423  FirstWarnConvertToPoly = 0;
424  }
425  return(-1);
426  }
427  }
428  NCOPY(tout,tstop,ncoef)
429  if ( ttwo ) {
430  WORD hh = *ttwo;
431  *ttwo = tout-ttwo;
432  if ( ( i = NormPolyTerm(BHEAD ttwo) ) >= 0 ) i = action;
433  tout = ttwo + *ttwo;
434  *ttwo = hh;
435  *outterm = tout - outterm;
436  }
437  else {
438  *outterm = tout-outterm;
439  if ( ( i = NormPolyTerm(BHEAD outterm) ) >= 0 ) i = action;
440  }
441  }
442  else if ( comlist[2] == ONLYFUNCTIONS ) {
443  while ( t < tstop ) {
444  if ( *t >= FUNCTION ) {
445  if ( comlist[1] == 3 ) {
446  i = FindSubterm(t);
447  t += t[1];
448  *tout++ = SYMBOL;
449  *tout++ = 4;
450  *tout++ = MAXVARIABLES-i;
451  *tout++ = 1;
452  action = 1;
453  }
454  else {
455  for ( i = 3; i < comlist[1]; i++ ) {
456  if ( *t == comlist[i] ) break;
457  }
458  if ( i < comlist[1] ) {
459  i = FindSubterm(t);
460  t += t[1];
461  *tout++ = SYMBOL;
462  *tout++ = 4;
463  *tout++ = MAXVARIABLES-i;
464  *tout++ = 1;
465  action = 1;
466  }
467  else {
468  i = t[1]; NCOPY(tout,t,i);
469  }
470  }
471  }
472  else {
473  i = t[1]; NCOPY(tout,t,i);
474  }
475  }
476  NCOPY(tout,tstop,ncoef)
477  *outterm = tout-outterm;
478  Normalize(BHEAD outterm);
479  i = action;
480  }
481  else {
482  MLOCK(ErrorMessageLock);
483  MesPrint("Illegal internal code in conversion to polynomial notation");
484  MUNLOCK(ErrorMessageLock);
485  i = -1;
486  }
487  return(i);
488 }
489 
490 /*
491  #] ConvertToPoly :
492  #[ LocalConvertToPoly :
493 */
508 int LocalConvertToPoly(PHEAD WORD *term, WORD *outterm, WORD startebuf, WORD par)
509 {
510  WORD *tout, *tstop, ncoef, *t, *r, *tt, *ttwo = 0;
511  int i, action = 0;
512  tt = term + *term;
513  ncoef = ABS(tt[-1]);
514  tstop = tt - ncoef;
515  tout = outterm+1;
516  t = term + 1;
517  while ( t < tstop ) {
518  if ( *t == SYMBOL ) {
519  r = t+2;
520  t += t[1];
521  while ( r < t ) {
522  if ( r[1] > 0 ) {
523  *tout++ = SYMBOL;
524  *tout++ = 4;
525  *tout++ = r[0];
526  *tout++ = r[1];
527  }
528  else {
529  tout[1] = SYMBOL;
530  tout[2] = 4;
531  tout[3] = r[0];
532  tout[4] = -1;
533  i = FindLocalSubterm(BHEAD tout+1,startebuf);
534  *tout++ = SYMBOL;
535  *tout++ = 4;
536  *tout++ = MAXVARIABLES-i;
537  *tout++ = -r[1];
538  action = 1;
539  }
540  r += 2;
541  }
542  }
543  else if ( *t == DOTPRODUCT ) {
544  r = t + 2;
545  t += t[1];
546  while ( r < t ) {
547  tout[1] = DOTPRODUCT;
548  tout[2] = 5;
549  tout[3] = r[0];
550  tout[4] = r[1];
551  if ( r[2] < 0 ) {
552  tout[5] = -1;
553  }
554  else {
555  tout[5] = 1;
556  }
557  i = FindLocalSubterm(BHEAD tout+1,startebuf);
558  *tout++ = SYMBOL;
559  *tout++ = 4;
560  *tout++ = MAXVARIABLES-i;
561  *tout++ = ABS(r[2]);
562  r += 3;
563  action = 1;
564  }
565  }
566  else if ( *t == VECTOR ) {
567  r = t + 2;
568  t += t[1];
569  while ( r < t ) {
570  tout[1] = VECTOR;
571  tout[2] = 4;
572  tout[3] = r[0];
573  tout[4] = r[1];
574  i = FindLocalSubterm(BHEAD tout+1,startebuf);
575  *tout++ = SYMBOL;
576  *tout++ = 4;
577  *tout++ = MAXVARIABLES-i;
578  *tout++ = 1;
579  r += 2;
580  action = 1;
581  }
582  }
583  else if ( *t == INDEX ) {
584  r = t + 2;
585  t += t[1];
586  while ( r < t ) {
587  tout[1] = INDEX;
588  tout[2] = 3;
589  tout[3] = r[0];
590  i = FindLocalSubterm(BHEAD tout+1,startebuf);
591  *tout++ = SYMBOL;
592  *tout++ = 4;
593  *tout++ = MAXVARIABLES-i;
594  *tout++ = 1;
595  r++;
596  action = 1;
597  }
598  }
599  else if ( *t == HAAKJE) {
600  if ( par ) {
601  tout[0] = 1; tout[1] = 1; tout[2] = 3;
602  *outterm = (tout+3)-outterm;
603  if ( NormPolyTerm(BHEAD outterm) < 0 ) return(-1);
604  tout = outterm + *outterm;
605  tout -= 3;
606  i = t[1]; NCOPY(tout,t,i);
607  ttwo = tout-1;
608  }
609  else { t += t[1]; }
610  }
611  else if ( *t >= FUNCTION ) {
612  i = FindLocalSubterm(BHEAD t,startebuf);
613  t += t[1];
614  *tout++ = SYMBOL;
615  *tout++ = 4;
616  *tout++ = MAXVARIABLES-i;
617  *tout++ = 1;
618  action = 1;
619  }
620  else {
621  if ( FirstWarnConvertToPoly ) {
622  MLOCK(ErrorMessageLock);
623  MesPrint("Illegal object in conversion to polynomial notation");
624  MUNLOCK(ErrorMessageLock);
625  FirstWarnConvertToPoly = 0;
626  }
627  return(-1);
628  }
629  }
630  NCOPY(tout,tstop,ncoef)
631  if ( ttwo ) {
632  WORD hh = *ttwo;
633  *ttwo = tout-ttwo;
634  if ( ( i = NormPolyTerm(BHEAD ttwo) ) >= 0 ) i = action;
635  tout = ttwo + *ttwo;
636  *ttwo = hh;
637  *outterm = tout - outterm;
638  }
639  else {
640  *outterm = tout-outterm;
641  if ( ( i = NormPolyTerm(BHEAD outterm) ) >= 0 ) i = action;
642  }
643  return(i);
644 }
645 
646 /*
647  #] LocalConvertToPoly :
648  #[ ConvertFromPoly :
649 
650  Converts a generic term from polynomial notation to the original
651  in which the extra symbols have been replaced by their values.
652  The output is in outterm.
653  We only deal with the extra symbols in the range from < i <= to
654  The output has to be sent to TestSub because it may contain
655  subexpressions when extra symbols have been replaced.
656 */
657 
658 int ConvertFromPoly(PHEAD WORD *term, WORD *outterm, WORD from, WORD to, WORD offset, WORD par)
659 {
660  WORD *tout, *tstop, *tstop1, ncoef, *t, *r, *tt;
661  int i;
662 /* first = 1; */
663  tt = term + *term;
664  tout = outterm+1;
665  ncoef = ABS(tt[-1]);
666  tstop = tt - ncoef;
667 /*
668  r = t = term + 1;
669  while ( t < tstop ) {
670  if ( *t == SYMBOL ) {
671  tstop1 = t + t[1];
672  tt = t + 2;
673  while ( tt < tstop1 ) {
674  if ( ( *tt < MAXVARIABLES - to )
675  || ( *tt >= MAXVARIABLES - from ) ) {
676  tt += 2;
677  }
678  else break;
679  }
680  if ( tt >= tstop1 ) { t = tstop1; continue; }
681  while ( r < t ) *tout++ = *r++;
682  t += 2;
683  first = 0;
684  while ( t < tstop1 ) {
685  if ( ( *t < MAXVARIABLES - to )
686  || ( *t >= MAXVARIABLES - from ) ) {
687  *tout++ = SYMBOL;
688  *tout++ = 4;
689  *tout++ = *t++;
690  *tout++ = *t++;
691  }
692  else {
693  *tout++ = SUBEXPRESSION;
694  *tout++ = SUBEXPSIZE;
695  *tout++ = MAXVARIABLES - *t++ + offset;
696  *tout++ = *t++;
697  if ( par ) *tout++ = AT.ebufnum;
698  else *tout++ = AM.sbufnum;
699  FILLSUB(tout)
700  }
701  }
702  r = t;
703  }
704  else {
705  t += t[1];
706  }
707  }
708  if ( first ) {
709  i = *term; t = term;
710  NCOPY(outterm,t,i);
711  return(*term);
712  }
713  while ( r < t ) *tout++ = *r++;
714  NCOPY(tout,tstop,ncoef)
715  *outterm = tout-outterm;
716 */
717  t = term + 1;
718  while ( t < tstop ) {
719  if ( *t == SYMBOL ) {
720  tstop1 = t + t[1];
721  tt = t + 2;
722  while ( tt < tstop1 ) {
723  if ( ( *tt < MAXVARIABLES - to )
724  || ( *tt >= MAXVARIABLES - from ) ) {
725  tt += 2;
726  }
727  else {
728  *tout++ = SUBEXPRESSION;
729  *tout++ = SUBEXPSIZE;
730  *tout++ = MAXVARIABLES - *tt++ + offset;
731  *tout++ = *tt++;
732  if ( par ) *tout++ = AT.ebufnum;
733  else *tout++ = AM.sbufnum;
734  FILLSUB(tout)
735  }
736  }
737  r = tout; t += 2;
738  *tout++ = SYMBOL; *tout++ = 0;
739  while ( t < tstop1 ) {
740  if ( ( *t < MAXVARIABLES - to )
741  || ( *t >= MAXVARIABLES - from ) ) {
742  *tout++ = *t++;
743  *tout++ = *t++;
744  }
745  else { t += 2; }
746  }
747  r[1] = tout - r;
748  if ( r[1] <= 2 ) tout = r;
749  }
750  else {
751  i = t[1]; NCOPY(tout,t,i)
752  }
753  }
754  NCOPY(tout,tstop,ncoef)
755  *outterm = tout-outterm;
756  return(*outterm);
757 }
758 
759 /*
760  #] ConvertFromPoly :
761  #[ FindSubterm :
762 
763  In this routine we look up a variable.
764  If we don't find it we will enter it in the subterm compiler buffer
765  Searching is by tree structure.
766  Adding changes the tree.
767 
768  Notice that in TFORM we should be in sequential mode.
769 */
770 
771 WORD FindSubterm(WORD *subterm)
772 {
773  WORD old[5], *ss, *term, number;
774  CBUF *C = cbuf + AM.sbufnum;
775  LONG oldCpointer;
776  term = subterm-1;
777  ss = subterm+subterm[1];
778 /*
779  Convert to proper term
780 */
781  old[0] = *term; old[1] = ss[0]; old[2] = ss[1]; old[3] = ss[2]; old[4] = ss[3];
782  ss[0] = 1; ss[1] = 1; ss[2] = 3; ss[3] = 0; *term = subterm[1]+4;
783 /*
784  We may have to add the term to the compiler
785  buffer and then to the tree. This cannot be done in parallel and
786  hence we have to set a lock.
787 */
788  LOCK(AM.sbuflock);
789 
790  oldCpointer = C->Pointer-C->Buffer; /* Offset of course !!!!!*/
791  AddRHS(AM.sbufnum,1);
792  AddNtoC(AM.sbufnum,*term,term);
793  AddToCB(C,0)
794 /*
795  See whether we have this one already. If not, insert it in the tree.
796 */
797  number = InsTree(AM.sbufnum,C->numrhs);
798 /*
799  Restore old values and return what is needed.
800 */
801  if ( number < (C->numrhs) ) { /* It existed already */
802  C->Pointer = oldCpointer + C->Buffer;
803  C->numrhs--;
804  }
805  else {
806  GETIDENTITY
807  WORD dim = DimensionSubterm(subterm);
808 
809  if ( dim == -MAXPOSITIVE ) { /* Give error message but continue */
810  WORD *old = AN.currentTerm;
811  AN.currentTerm = term;
812  MLOCK(ErrorMessageLock);
813  MesPrint("Dimension out of range in %t");
814  MUNLOCK(ErrorMessageLock);
815  AN.currentTerm = old;
816  }
817 /*
818  Store the dimension
819 */
820  C->dimension[number] = dim;
821  }
822  UNLOCK(AM.sbuflock);
823 
824  *term = old[0]; ss[0] = old[1]; ss[1] = old[2]; ss[2] = old[3]; ss[3] = old[4];
825  return(number);
826 }
827 
828 /*
829  #] FindSubterm :
830  #[ FindLocalSubterm :
831 
832  In this routine we look up a variable.
833  If we don't find it we will enter it in the subterm compiler buffer
834  Searching is by tree structure.
835  Adding changes the tree.
836 
837  Notice that in TFORM we should be in sequential mode.
838 */
839 
840 WORD FindLocalSubterm(PHEAD WORD *subterm, WORD startebuf)
841 {
842  WORD old[5], *ss, *term, number, i, j, *t1, *t2;
843  CBUF *C = cbuf + AT.ebufnum;
844  term = subterm-1;
845  ss = subterm+subterm[1];
846 /*
847  Convert to proper term
848 */
849  old[0] = *term; old[1] = ss[0]; old[2] = ss[1]; old[3] = ss[2]; old[4] = ss[3];
850  ss[0] = 1; ss[1] = 1; ss[2] = 3; ss[3] = 0; *term = subterm[1]+4;
851 /*
852  First see whether we have this one already in the global buffer.
853 */
854  number = FindTree(AM.sbufnum,term);
855  if ( number > 0 ) goto wearehappy;
856 /*
857  Now look whether it is in the ebufnum between startebuf and numrhs
858  Note however that we need an offset of (numxsymbol-startebuf)
859 */
860  for ( i = startebuf+1; i <= C->numrhs; i++ ) {
861  t1 = C->rhs[i]; t2 = term;
862  if ( *t1 == *t2 ) {
863  j = *t1;
864  while ( *t1 == *t2 && j > 0 ) { t1++; t2++; j--; }
865  if ( j <= 0 ) {
866  number = i-startebuf+numxsymbol;
867  goto wearehappy;
868  }
869  }
870  }
871 /*
872  Now we have to add it to cbuf[AT.ebufnum]
873 */
874  AddRHS(AT.ebufnum,1);
875  AddNtoC(AT.ebufnum,*term,term);
876  AddToCB(C,0)
877  number = C->numrhs-startebuf+numxsymbol;
878 wearehappy:
879  *term = old[0]; ss[0] = old[1]; ss[1] = old[2]; ss[2] = old[3]; ss[3] = old[4];
880  return(number);
881 }
882 
883 /*
884  #] FindLocalSubterm :
885  #[ PrintSubtermList :
886 
887  Prints all the expressions in the subterm compiler buffer.
888  The format is such that they give definitions of the temporary
889  variables of which the contents are stored in this buffer.
890  These variables have the names Z_123 etc.
891 */
892 
893 void PrintSubtermList(int from,int to)
894 {
895  UBYTE buffer[80], *out, outbuffer[300];
896  int first, i, ii, inc = 1;
897  WORD *term;
898  CBUF *C = cbuf + AM.sbufnum;
899 /*
900  if ( to < from ) inc = -1;
901  if ( to == from ) inc = 0;
902 */
903  if ( from <= to ) {
904  inc = 1; to += inc;
905  }
906  else {
907  inc = -1; to += inc;
908  }
909  AO.OutFill = AO.OutputLine = outbuffer;
910  AO.OutStop = AO.OutputLine+AC.LineLength;
911  AO.IsBracket = 0;
912  AO.OutSkip = 3;
913 
914  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {
915  TokenToLine((UBYTE *)" ");
916  AO.OutSkip = 7;
917  }
918  else if ( ( AO.Optimize.debugflags & 1 ) == 1 ) {}
919  else if ( AO.OutSkip > 0 ) {
920  for ( i = 0; i < AO.OutSkip; i++ ) TokenToLine((UBYTE *)" ");
921  }
922  i = from;
923  do {
924  if ( ( AO.Optimize.debugflags & 1 ) == 1 ) {
925  TokenToLine((UBYTE *)"id ");
926  for ( ii = 3; ii < AO.OutSkip; ii++ ) TokenToLine((UBYTE *)" ");
927  }
928 /*
929  if ( AC.OutputMode == NORMALFORMAT ) {
930  TokenToLine((UBYTE *)"id ");
931  }
932 */
933  else if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {}
934  else { TokenToLine((UBYTE *)" "); }
935 
936  out = StrCopy((UBYTE *)AC.extrasym,buffer);
937  if ( AC.extrasymbols == 0 ) {
938  out = NumCopy(i,out);
939  out = StrCopy((UBYTE *)"_",out);
940  }
941  else if ( AC.extrasymbols == 1 ) {
942  out = AddArrayIndex(i,out);
943  }
944  out = StrCopy((UBYTE *)"=",out);
945  TokenToLine(buffer);
946  term = C->rhs[i];
947  first = 1;
948  if ( *term == 0 ) {
949  out = StrCopy((UBYTE *)"0",buffer);
950  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE ) {
951  out = StrCopy((UBYTE *)";",out);
952  }
953  TokenToLine(buffer);
954  }
955  else {
956  while ( *term ) {
957  if ( WriteInnerTerm(term,first) ) Terminate(-1);
958  term += *term;
959  first = 0;
960  }
961  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE ) {
962  out = StrCopy((UBYTE *)";",buffer);
963  TokenToLine(buffer);
964  }
965  }
966 /*
967  There is a problem with FiniLine because it prepares for a
968  continuation line in fortran mode.
969  But the next statement should start on a blank line.
970 */
971 /*
972  FiniLine();
973  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {
974  AO.OutFill = AO.OutputLine;
975  TokenToLine((UBYTE *)" ");
976  AO.OutSkip = 7;
977  }
978 */
979  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {
980  AO.OutSkip = 6;
981  FiniLine();
982  AO.OutSkip = 7;
983  }
984  else {
985  FiniLine();
986  }
987  i += inc;
988  } while ( i != to );
989 }
990 
991 /*
992  #] PrintSubtermList :
993  #[ PrintExtraSymbol :
994 
995  Prints the definition of extra symbol num as the contents
996  of the expression in terms.
997  The parameter par has three options:
998  EXTRASYMBOL num is interpreted as the number of an extra symbol
999  REGULARSYMBOL num is interpreted as the number of a symbol.
1000  It could still be an extra symbol.
1001  EXPRESSIONNUMBER num is the number of an expression.
1002  terms contains the rhs expression.
1003 */
1004 
1005 void PrintExtraSymbol(int num, WORD *terms,int par)
1006 {
1007  UBYTE buffer[80], *out, outbuffer[300];
1008  int first, i;
1009  WORD *term;
1010 
1011  AO.OutFill = AO.OutputLine = outbuffer;
1012  AO.OutStop = AO.OutputLine+AC.LineLength;
1013  AO.IsBracket = 0;
1014 
1015  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {
1016  TokenToLine((UBYTE *)" ");
1017  AO.OutSkip = 7;
1018  }
1019  else if ( ( AO.Optimize.debugflags & 1 ) == 1 ) {
1020  TokenToLine((UBYTE *)"id ");
1021  for ( i = 3; i < AO.OutSkip; i++ ) TokenToLine((UBYTE *)" ");
1022  }
1023  else if ( AO.OutSkip > 0 ) {
1024  for ( i = 0; i < AO.OutSkip; i++ ) TokenToLine((UBYTE *)" ");
1025  }
1026  out = buffer;
1027  switch ( par ) {
1028  case REGULARSYMBOL:
1029  if ( num >= MAXVARIABLES-cbuf[AM.sbufnum].numrhs ) {
1030  num = MAXVARIABLES-num;
1031  }
1032  else {
1033  out = StrCopy(VARNAME(symbols,num),out);
1034  break;
1035  }
1036  case EXTRASYMBOL:
1037  out = StrCopy((UBYTE *)AC.extrasym,out);
1038  if ( AC.extrasymbols == 0 ) {
1039  out = NumCopy(num,out);
1040  out = StrCopy((UBYTE *)"_",out);
1041  }
1042  else if ( AC.extrasymbols == 1 ) {
1043  out = AddArrayIndex(num,out);
1044  }
1045  break;
1046  case EXPRESSIONNUMBER:
1047  out = StrCopy(EXPRNAME(num),out);
1048  break;
1049  default:
1050  MesPrint("Illegal option in PrintExtraSymbol");
1051  Terminate(-1);
1052  }
1053  out = StrCopy((UBYTE *)"=",out);
1054  TokenToLine(buffer);
1055  term = terms;
1056  first = 1;
1057  if ( *term == 0 ) {
1058  out = StrCopy((UBYTE *)"0",buffer);
1059  TokenToLine(buffer);
1060  }
1061  else {
1062  while ( *term ) {
1063  if ( WriteInnerTerm(term,first) ) Terminate(-1);
1064  term += *term;
1065  first = 0;
1066  }
1067  }
1068  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE ) {
1069  out = StrCopy((UBYTE *)";",buffer);
1070  TokenToLine(buffer);
1071  }
1072  FiniLine();
1073 }
1074 
1075 /*
1076  #] PrintExtraSymbol :
1077  #[ FindSubexpression :
1078 
1079  In this routine we look up a subexpression.
1080  If we don't find it we will enter it in the subterm compiler buffer
1081  Searching is by tree structure.
1082  Adding changes the tree.
1083 
1084  Notice that in TFORM we should be in sequential mode.
1085 */
1086 
1087 WORD FindSubexpression(WORD *subexpr)
1088 {
1089  WORD *term, number;
1090  CBUF *C = cbuf + AM.sbufnum;
1091  LONG oldCpointer = C->Pointer-C->Buffer; /* Offset of course !!!!!*/
1092 /*
1093  We may have to add the subexpression to the tree.
1094  This requires a lock.
1095 */
1096  LOCK(AM.sbuflock);
1097 
1098  AddRHS(AM.sbufnum,1);
1099  term = subexpr;
1100  while ( *term ) term += *term;
1101  number = term - subexpr;
1102 /*
1103  Add the terms to the compiler buffer. Paste on a zero.
1104 */
1105  AddNtoC(AM.sbufnum,number,subexpr);
1106  AddToCB(C,0)
1107 /*
1108  See whether we have this one already. If not, insert it in the tree.
1109 */
1110  number = InsTree(AM.sbufnum,C->numrhs);
1111 /*
1112  Restore old values and return what is needed.
1113 */
1114  if ( number < (C->numrhs) ) { /* It existed already */
1115  C->Pointer = oldCpointer + C->Buffer;
1116  C->numrhs--;
1117  }
1118  else {
1119  GETIDENTITY
1120  WORD dim = DimensionExpression(BHEAD subexpr);
1121 /*
1122  Store the dimension
1123 */
1124  C->dimension[number] = dim;
1125  }
1126 
1127  UNLOCK(AM.sbuflock);
1128 
1129  return(number);
1130 }
1131 
1132 /*
1133  #] FindSubexpression :
1134  #[ ExtraSymFun :
1135 */
1136 
1137 int ExtraSymFun(PHEAD WORD *term,WORD level)
1138 {
1139  WORD *oldworkpointer = AT.WorkPointer;
1140  WORD *termout, *t1, *t2, *t3, *tstop, *tend, i;
1141  int retval = 0;
1142  tend = termout = term + *term;
1143  tstop = tend - ABS(tend[-1]);
1144  t3 = t1 = term+1; t2 = termout+1;
1145 /*
1146  First refind the function(s). There is at least one.
1147 */
1148  while ( t1 < tstop ) {
1149  if ( *t1 == EXTRASYMFUN && t1[1] == FUNHEAD+2 ) {
1150  if ( t1[FUNHEAD] == -SNUMBER && t1[FUNHEAD+1] <= numxsymbol
1151  && t1[FUNHEAD+1] > 0 ) {
1152  i = t1[FUNHEAD+1];
1153  }
1154  else if ( t1[FUNHEAD] == -SYMBOL && t1[FUNHEAD+1] < MAXVARIABLES
1155  && t1[FUNHEAD+1] >= MAXVARIABLES-numxsymbol ) {
1156  i = MAXVARIABLES - t1[FUNHEAD+1];
1157  }
1158  else goto nocase;
1159  while ( t3 < t1 ) *t2++ = *t3++;
1160 /*
1161  Now inset the rhs pointer
1162 */
1163  *t2++ = SUBEXPRESSION;
1164  *t2++ = SUBEXPSIZE;
1165  *t2++ = i;
1166  *t2++ = 1;
1167  *t2++ = AM.sbufnum;
1168  FILLSUB(t2)
1169  t3 = t1 = t1 + t1[1];
1170  }
1171  else if ( *t1 == EXTRASYMFUN && t1[1] == FUNHEAD ) {
1172  while ( t3 < t1 ) *t2++ = *t3++;
1173  t3 = t1 = t1 + t1[1];
1174  }
1175  else {
1176 nocase:;
1177  t1 = t1 + t1[1];
1178  }
1179  }
1180  while ( t3 < tend ) *t2++ = *t3++;
1181  *termout = t2 - termout;
1182  AT.WorkPointer = t2;
1183  if ( AT.WorkPointer >= AT.WorkTop ) {
1184  MLOCK(ErrorMessageLock);
1185  MesWork();
1186  MUNLOCK(ErrorMessageLock);
1187  AT.WorkPointer = oldworkpointer;
1188  return(-1);
1189  }
1190  retval = Generator(BHEAD termout,level);
1191  AT.WorkPointer = oldworkpointer;
1192  if ( retval < 0 ) {
1193  MLOCK(ErrorMessageLock);
1194  MesCall("ExtraSymFun");
1195  MUNLOCK(ErrorMessageLock);
1196  }
1197  return(retval);
1198 }
1199 
1200 /*
1201  #] ExtraSymFun :
1202 */
#define PHEAD
Definition: ftypes.h:56
Definition: structs.h:908
WORD * Pointer
Definition: structs.h:911
WORD * dimension
Definition: structs.h:917
int LocalConvertToPoly(PHEAD WORD *term, WORD *outterm, WORD startebuf, WORD par)
Definition: notation.c:508
WORD ** rhs
Definition: structs.h:913
WORD * Buffer
Definition: structs.h:909
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:2865