FORM  4.1
comtool.c
Go to the documentation of this file.
1 
5 /* #[ License : */
6 /*
7  * Copyright (C) 1984-2013 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 :
33 */
34 
35 #include "form3.h"
36 
37 /*
38  #] Includes :
39  #[ inicbufs :
40 */
41 
42 int inicbufs()
43 {
44  int i, num = AC.cbufList.num;
45  CBUF *C = cbuf;
46  for ( i = 0; i < num; i++, C++ ) {
47  if ( C->Buffer == 0 ) break;
48  }
49  if ( i >= num ) C = (CBUF *)FromList(&AC.cbufList);
50  else num = i;
51  C->BufferSize = 2000;
52  C->Buffer = (WORD *)Malloc1(C->BufferSize*sizeof(WORD),"compiler buffer");
53  C->Pointer = C->Buffer;
54  C->Top = C->Buffer + C->BufferSize;
55  C->maxlhs = 10;
56  C->lhs = (WORD **)Malloc1(C->maxlhs*sizeof(WORD *),"compiler buffer");
57  C->numlhs = 0;
58  C->mnumlhs = 0;
59  C->maxrhs = 25;
60  C->rhs = (WORD **)Malloc1(C->maxrhs*(sizeof(WORD *)+2*sizeof(LONG)+2*sizeof(WORD)),"compiler buffer");
61  C->CanCommu = (LONG *)(C->rhs+C->maxrhs);
62  C->NumTerms = C->CanCommu+C->maxrhs;
63  C->numdum = (WORD *)(C->NumTerms+C->maxrhs);
64  C->dimension = C->numdum + C->maxrhs;
65  C->numrhs = 0;
66  C->mnumrhs = 0;
67  C->rhs[0] = C->rhs[1] = C->Pointer;
68  C->boomlijst = 0;
69  RedoTree(C,C->maxrhs);
70  ClearTree(num);
71  return(num);
72 }
73 
74 /*
75  #] inicbufs :
76  #[ finishcbuf :
77 */
78 
79 void finishcbuf(WORD num)
80 {
81  CBUF *C = cbuf+num;
82  if ( C->Buffer ) M_free(C->Buffer,"compiler buffer");
83  if ( C->rhs ) M_free(C->rhs,"compiler buffer");
84  if ( C->lhs ) M_free(C->lhs,"compiler buffer");
85  if ( C->boomlijst ) M_free(C->boomlijst,"boomlijst");
86  C->Top = C->Pointer = C->Buffer = 0;
87  C->rhs = C->lhs = 0;
88  C->CanCommu = 0;
89  C->NumTerms = 0;
90  C->BufferSize = 0;
91  C->boomlijst = 0;
92  C->numlhs = C->numrhs = C->maxlhs = C->maxrhs = C->mnumlhs =
93  C->mnumrhs = C->numtree = C->rootnum = C->MaxTreeSize = 0;
94 }
95 
96 /*
97  #] finishcbuf :
98  #[ clearcbuf :
99 */
100 
101 void clearcbuf(WORD num)
102 {
103  CBUF *C = cbuf+num;
104  if ( C->boomlijst ) M_free(C->boomlijst,"boomlijst");
105  C->Pointer = C->Buffer;
106  C->numrhs = C->numlhs = 0;
107  C->mnumlhs = 0;
108  C->boomlijst = 0;
109  C->mnumrhs = 0;
110  C->rhs[0] = C->rhs[1] = C->Pointer;
111  C->numtree = C->rootnum = C->MaxTreeSize = 0;
112  RedoTree(C,C->maxrhs);
113  ClearTree(num);
114 }
115 
116 /*
117  #] clearcbuf :
118  #[ DoubleCbuffer :
119 */
120 
121 WORD *DoubleCbuffer(int num, WORD *w)
122 {
123  CBUF *C = cbuf + num;
124  LONG newsize = C->BufferSize*2;
125  WORD *newbuffer = (WORD *)Malloc1(newsize*sizeof(WORD),"compiler buffer");
126  WORD *w1, *w2;
127  LONG offset, j, i;
128  w1 = C->Buffer; w2 = newbuffer;
129  i = w - w1;
130  j = i & 7;
131  while ( --j >= 0 ) *w2++ = *w1++;
132  i >>= 3;
133  while ( --i >= 0 ) {
134  *w2++ = *w1++; *w2++ = *w1++; *w2++ = *w1++; *w2++ = *w1++;
135  *w2++ = *w1++; *w2++ = *w1++; *w2++ = *w1++; *w2++ = *w1++;
136  }
137  offset = newbuffer - C->Buffer;
138  for ( i = 0; i <= C->numlhs; i++ ) C->lhs[i] += offset;
139  for ( i = 1; i <= C->numrhs; i++ ) C->rhs[i] += offset;
140  w1 = C->Buffer;
141  C->Pointer += offset;
142  C->Top = newbuffer + newsize;
143  C->BufferSize = newsize;
144  C->Buffer = newbuffer;
145  M_free(w1,"DoubleCbuffer");
146  return(w2);
147 }
148 
149 /*
150  #] DoubleCbuffer :
151  #[ AddLHS :
152 */
153 
154 WORD *AddLHS(int num)
155 {
156  CBUF *C = cbuf + num;
157  C->numlhs++;
158  if ( C->numlhs >= (C->maxlhs-2) ) {
159  WORD ***ppp = &(C->lhs); /* to avoid compiler warning */
160  if ( DoubleList((VOID ***)ppp,&(C->maxlhs),sizeof(WORD *),
161  "statement lists") ) Terminate(-1);
162  }
163  C->lhs[C->numlhs] = C->Pointer;
164  C->lhs[C->numlhs+1] = 0;
165  return(C->Pointer);
166 }
167 
168 /*
169  #] AddLHS :
170  #[ AddRHS :
171 */
172 
173 WORD *AddRHS(int num, int type)
174 {
175  LONG fullsize, *lold, newsize;
176  int i;
177  WORD **old, *wold;
178  CBUF *C;
179 restart:;
180  C = cbuf + num;
181  if ( C->numrhs >= (C->maxrhs-2) ) {
182  if ( C->maxrhs == 0 ) newsize = 100;
183  else newsize = C->maxrhs * 2;
184  if ( newsize > MAXCOMBUFRHS ) newsize = MAXCOMBUFRHS;
185  if ( newsize == C->maxrhs ) {
186  if ( AC.tablefilling ) {
187  TABLES T = functions[AC.tablefilling].tabl;
188 /*
189  We add a compiler buffer, change a few settings and continue.
190 */
191  if ( T->buffersfill >= T->bufferssize ) {
192  int new1 = 2*T->bufferssize;
193  WORD *nbufs = (WORD *)Malloc1(new1*sizeof(WORD),"Table compile buffers");
194  for ( i = 0; i < T->buffersfill; i++ )
195  nbufs[i] = T->buffers[i];
196  for ( ; i < new1; i++ ) nbufs[i] = 0;
197  M_free(T->buffers,"Table compile buffers");
198  T->buffers = nbufs;
199  T->bufferssize = new1;
200  }
201  T->buffers[T->buffersfill++] = T->bufnum = inicbufs();
202  AC.cbufnum = num = T->bufnum;
203  goto restart;
204  }
205  else {
206  MesPrint("@Compiler buffer overflow. Try to make modules smaller");
207  Terminate(-1);
208  }
209  }
210  old = C->rhs;
211  fullsize = newsize * (sizeof(WORD *) + 2*sizeof(LONG) + 2*sizeof(WORD));
212  C->rhs = (WORD **)Malloc1(fullsize,"subexpression lists");
213  for ( i = 0; i < C->maxrhs; i++ ) C->rhs[i] = old[i];
214  lold = C->CanCommu; C->CanCommu = (LONG *)(C->rhs+newsize);
215  for ( i = 0; i < C->maxrhs; i++ ) C->CanCommu[i] = lold[i];
216  lold = C->NumTerms; C->NumTerms = (LONG *)(C->rhs+2*newsize);
217  for ( i = 0; i < C->maxrhs; i++ ) C->NumTerms[i] = lold[i];
218  wold = C->numdum; C->numdum = (WORD *)(C->NumTerms+newsize);
219  for ( i = 0; i < C->maxrhs; i++ ) C->numdum[i] = wold[i];
220  wold = C->dimension; C->dimension = (WORD *)(C->numdum+newsize);
221  for ( i = 0; i < C->maxrhs; i++ ) C->dimension[i] = wold[i];
222  if ( old ) M_free(old,"subexpression lists");
223  C->maxrhs = newsize;
224  if ( type == 0 ) RedoTree(C,C->maxrhs);
225  }
226  C->numrhs++;
227  C->CanCommu[C->numrhs] = 0;
228  C->NumTerms[C->numrhs] = 0;
229  C->numdum[C->numrhs] = 0;
230  C->dimension[C->numrhs] = 0;
231  C->rhs[C->numrhs] = C->Pointer;
232  return(C->Pointer);
233 }
234 
235 /*
236  #] AddRHS :
237  #[ AddNtoL :
238 */
239 
240 int AddNtoL(int n, WORD *array)
241 {
242  int i;
243  CBUF *C = cbuf+AC.cbufnum;
244 #ifdef COMPBUFDEBUG
245  MesPrint("LH: %a",n,array);
246 #endif
247  AddLHS(AC.cbufnum);
248  while ( C->Pointer+n >= C->Top ) DoubleCbuffer(AC.cbufnum,C->Pointer);
249  for ( i = 0; i < n; i++ ) *(C->Pointer)++ = *array++;
250  return(0);
251 }
252 
253 /*
254  #] AddNtoL :
255  #[ AddNtoC :
256 
257  Commentary: added the bufnum on 14-sep-2010 to make the whole a bit
258  more flexible (JV). Still to do with AddNtoL.
259 */
260 
261 int AddNtoC(int bufnum, int n, WORD *array)
262 {
263  int i;
264  WORD *w;
265  CBUF *C = cbuf+bufnum;
266 #ifdef COMPBUFDEBUG
267  MesPrint("RH: %a",n,array);
268 #endif
269  while ( C->Pointer+n+1 >= C->Top ) DoubleCbuffer(bufnum,C->Pointer);
270  w = C->Pointer;
271  for ( i = 0; i < n; i++ ) *w++ = *array++;
272  C->Pointer = w;
273  return(0);
274 }
275 
276 /*
277  #] AddNtoC :
278  #[ InsTree :
279 
280  Routines for balanced tree searching and insertion.
281  Compared to Knuth we have a parent link. This minimizes the
282  number of compares. That is better for anything that is more
283  complicated than just single numbers.
284  There are no provisions for removing elements from the tree.
285  The routines are:
286  void RedoTree(size) Re-allocates the tree space. There will
287  be MaxTreeSize = size elements.
288  void ClearTree() Prunes the tree down to the root element.
289  int InsTree(int,int)Searches for the requested element. If not found it
290  will allocate a new element, balance the tree if
291  necessary and return the called number.
292  If it was in the tree, it returns the tree 'value'.
293 
294  Commentary: added the bufnum on 14-sep-2010 to make the whole a bit
295  more flexible (JV).
296 */
297 static COMPTREE comptreezero = {0,0,0,0,0,0};
298 
299 int InsTree(int bufnum, int h)
300 {
301  CBUF *C = cbuf + bufnum;
302  COMPTREE *boomlijst = C->boomlijst, *q = boomlijst + C->rootnum, *p, *s;
303  WORD *v1, *v2, *v3;
304  int ip, iq, is;
305 
306  if ( C->numtree + 1 >= C->MaxTreeSize ) {
307  if ( C->MaxTreeSize == 0 ) {
308  COMPTREE *root;
309  C->MaxTreeSize = 125;
310  C->boomlijst = (COMPTREE *)Malloc1((C->MaxTreeSize+1)*sizeof(COMPTREE),
311  "ClearInsTree");
312  root = C->boomlijst;
313  C->numtree = 0;
314  C->rootnum = 0;
315  root->left = -1;
316  root->right = -1;
317  root->parent = -1;
318  root->blnce = 0;
319  root->value = -1;
320  root->usage = 0;
321  for ( ip = 1; ip < C->MaxTreeSize; ip++ ) { C->boomlijst[ip] = comptreezero; }
322  }
323  else {
324  is = C->MaxTreeSize * 2;
325  s = (COMPTREE *)Malloc1((is+1)*sizeof(COMPTREE),"InsTree");
326  for ( ip = 0; ip < C->MaxTreeSize; ip++ ) { s[ip] = C->boomlijst[ip]; }
327  for ( ip = C->MaxTreeSize; ip <= is; ip++ ) { s[ip] = comptreezero; }
328  if ( C->boomlijst ) M_free(C->boomlijst,"InsTree");
329  C->boomlijst = s;
330  C->MaxTreeSize = is;
331  }
332  boomlijst = C->boomlijst;
333  q = boomlijst + C->rootnum;
334  }
335 
336  if ( q->right == -1 ) { /* First element */
337  C->numtree++;
338  s = boomlijst+C->numtree;
339  q->right = C->numtree;
340  s->parent = C->rootnum;
341  s->left = s->right = -1;
342  s->blnce = 0;
343  s->value = h;
344  s->usage = 1;
345  return(h);
346  }
347  ip = q->right;
348  while ( ip >= 0 ) {
349  p = boomlijst + ip;
350  v1 = C->rhs[p->value]; v2 = v3 = C->rhs[h];
351  while ( *v3 ) v3 += *v3; /* find the 0 that indicates end-of-expr */
352  while ( *v1 == *v2 && v2 < v3 ) { v1++; v2++; }
353  if ( *v1 > *v2 ) {
354  iq = p->right;
355  if ( iq >= 0 ) { ip = iq; }
356  else {
357  C->numtree++;
358  is = C->numtree;
359  p->right = is;
360  s = boomlijst + is;
361  s->parent = ip; s->left = s->right = -1;
362  s->blnce = 0; s->value = h; s->usage = 1;
363  p->blnce++;
364  if ( p->blnce == 0 ) return(h);
365  goto balance;
366  }
367  }
368  else if ( *v1 < *v2 ) {
369  iq = p->left;
370  if ( iq >= 0 ) { ip = iq; }
371  else {
372  C->numtree++;
373  is = C->numtree;
374  s = boomlijst+is;
375  p->left = is;
376  s->parent = ip; s->left = s->right = -1;
377  s->blnce = 0; s->value = h; s->usage = 1;
378  p->blnce--;
379  if ( p->blnce == 0 ) return(h);
380  goto balance;
381  }
382  }
383  else {
384  p->usage++;
385  return(p->value);
386  }
387  }
388  MesPrint("We vallen uit de boom!");
389  Terminate(-1);
390  return(h);
391 balance:;
392  for (;;) {
393  p = boomlijst + ip;
394  iq = p->parent;
395  if ( iq == C->rootnum ) break;
396  q = boomlijst + iq;
397  if ( ip == q->left ) q->blnce--;
398  else q->blnce++;
399  if ( q->blnce == 0 ) break;
400  if ( q->blnce == -2 ) {
401  if ( p->blnce == -1 ) { /* single rotation */
402  q->left = p->right;
403  p->right = iq;
404  p->parent = q->parent;
405  q->parent = ip;
406  if ( boomlijst[p->parent].left == iq ) boomlijst[p->parent].left = ip;
407  else boomlijst[p->parent].right = ip;
408  if ( q->left >= 0 ) boomlijst[q->left].parent = iq;
409  q->blnce = p->blnce = 0;
410  }
411  else { /* double rotation */
412  s = boomlijst + is;
413  q->left = s->right;
414  p->right = s->left;
415  s->right = iq;
416  s->left = ip;
417  if ( p->right >= 0 ) boomlijst[p->right].parent = ip;
418  if ( q->left >= 0 ) boomlijst[q->left].parent = iq;
419  s->parent = q->parent;
420  q->parent = is;
421  p->parent = is;
422  if ( boomlijst[s->parent].left == iq )
423  boomlijst[s->parent].left = is;
424  else boomlijst[s->parent].right = is;
425  if ( s->blnce > 0 ) { q->blnce = s->blnce = 0; p->blnce = -1; }
426  else if ( s->blnce < 0 ) { p->blnce = s->blnce = 0; q->blnce = 1; }
427  else { p->blnce = s->blnce = q->blnce = 0; }
428  }
429  break;
430  }
431  else if ( q->blnce == 2 ) {
432  if ( p->blnce == 1 ) { /* single rotation */
433  q->right = p->left;
434  p->left = iq;
435  p->parent = q->parent;
436  q->parent = ip;
437  if ( boomlijst[p->parent].left == iq ) boomlijst[p->parent].left = ip;
438  else boomlijst[p->parent].right = ip;
439  if ( q->right >= 0 ) boomlijst[q->right].parent = iq;
440  q->blnce = p->blnce = 0;
441  }
442  else { /* double rotation */
443  s = boomlijst + is;
444  q->right = s->left;
445  p->left = s->right;
446  s->left = iq;
447  s->right = ip;
448  if ( p->left >= 0 ) boomlijst[p->left].parent = ip;
449  if ( q->right >= 0 ) boomlijst[q->right].parent = iq;
450  s->parent = q->parent;
451  q->parent = is;
452  p->parent = is;
453  if ( boomlijst[s->parent].left == iq ) boomlijst[s->parent].left = is;
454  else boomlijst[s->parent].right = is;
455  if ( s->blnce < 0 ) { q->blnce = s->blnce = 0; p->blnce = 1; }
456  else if ( s->blnce > 0 ) { p->blnce = s->blnce = 0; q->blnce = -1; }
457  else { p->blnce = s->blnce = q->blnce = 0; }
458  }
459  break;
460  }
461  is = ip; ip = iq;
462  }
463  return(h);
464 }
465 
466 /*
467  #] InsTree :
468  #[ FindTree :
469 
470  Routines for balanced tree searching.
471  Is like InsTree but without the insertions.
472  Returns -1 if the element is not in the tree.
473  The advantage of this routine over InsTree is that this routine
474  can be run in parallel.
475 */
476 
477 int FindTree(int bufnum, WORD *subexpr)
478 {
479  CBUF *C = cbuf + bufnum;
480  COMPTREE *boomlijst = C->boomlijst, *q = boomlijst + C->rootnum, *p;
481  WORD *v1, *v2, *v3;
482  int ip, iq;
483 
484  ip = q->right;
485  while ( ip >= 0 ) {
486  p = boomlijst + ip;
487  v1 = C->rhs[p->value]; v2 = v3 = subexpr;
488  while ( *v3 ) v3 += *v3; /* find the 0 that indicates end-of-expr */
489  while ( *v1 == *v2 && v2 < v3 ) { v1++; v2++; }
490  if ( *v1 > *v2 ) {
491  iq = p->right;
492  if ( iq >= 0 ) { ip = iq; }
493  else { return(-1); }
494  }
495  else if ( *v1 < *v2 ) {
496  iq = p->left;
497  if ( iq >= 0 ) { ip = iq; }
498  else { return(-1); }
499  }
500  else {
501  p->usage++;
502  return(p->value);
503  }
504  }
505  return(-1);
506 }
507 
508 /*
509  #] FindTree :
510  #[ RedoTree :
511 */
512 
513 void RedoTree(CBUF *C, int size)
514 {
515  COMPTREE *newboomlijst;
516  int i;
517  newboomlijst = (COMPTREE *)Malloc1((size+1)*sizeof(COMPTREE),"newboomlijst");
518  if ( C->boomlijst ) {
519  if ( C->MaxTreeSize > size ) C->MaxTreeSize = size;
520  for ( i = 0; i < C->MaxTreeSize; i++ ) newboomlijst[i] = C->boomlijst[i];
521  M_free(C->boomlijst,"boomlijst");
522  }
523  C->boomlijst = newboomlijst;
524  C->MaxTreeSize = size;
525 }
526 
527 /*
528  #] RedoTree :
529  #[ ClearTree :
530 */
531 
532 void ClearTree(int i)
533 {
534  CBUF *C = cbuf + i;
535  COMPTREE *root = C->boomlijst;
536  if ( root ) {
537  C->numtree = 0;
538  C->rootnum = 0;
539  root->left = -1;
540  root->right = -1;
541  root->parent = -1;
542  root->blnce = 0;
543  root->value = -1;
544  root->usage = 0;
545  }
546 }
547 
548 /*
549  #] ClearTree :
550  #[ IniFbuffer :
551 */
558 int IniFbuffer(WORD bufnum)
559 {
560  CBUF *C = cbuf + bufnum;
561  COMPTREE *root;
562  int i;
563  LONG fullsize;
564  C->maxrhs = AM.fbuffersize;
565  C->MaxTreeSize = AM.fbuffersize;
566 
567  /*
568  * Note that bufnum is a return value of inicbufs(). So C has been already
569  * initialized. (TU 20 Dec 2011)
570  */
571  if ( C->boomlijst ) M_free(C->boomlijst, "IniFbuffer-tree");
572  if ( C->rhs ) M_free(C->rhs, "IniFbuffer-rhs");
573 
574  C->boomlijst = (COMPTREE *)Malloc1((C->MaxTreeSize+1)*sizeof(COMPTREE),"IniFbuffer-tree");
575  root = C->boomlijst;
576  C->numtree = 0;
577  C->rootnum = 0;
578  root->left = -1;
579  root->right = -1;
580  root->parent = -1;
581  root->blnce = 0;
582  root->value = -1;
583  root->usage = 0;
584  for ( i = 1; i < C->MaxTreeSize; i++ ) { C->boomlijst[i] = comptreezero; }
585 
586  fullsize = (C->maxrhs+1) * (sizeof(WORD *) + 2*sizeof(LONG) + 2*sizeof(WORD));
587  C->rhs = (WORD **)Malloc1(fullsize,"IniFbuffer-rhs");
588  C->CanCommu = (LONG *)(C->rhs+C->maxrhs);
589  C->NumTerms = (LONG *)(C->rhs+2*C->maxrhs);
590  C->numdum = (WORD *)(C->NumTerms+C->maxrhs);
591  C->dimension = (WORD *)(C->numdum+C->maxrhs);
592 
593  return(0);
594 }
595 
596 /*
597  #] IniFbuffer :
598  #[ numcommute :
599 
600  Returns the number of non-commuting terms in the expression
601 */
602 
603 LONG numcommute(WORD *terms, LONG *numterms)
604 {
605  LONG num = 0;
606  WORD *t, *m;
607  *numterms = 0;
608  while ( *terms ) {
609  *numterms += 1;
610  t = terms + 1;
611  GETSTOP(terms,m);
612  while ( t < m ) {
613  if ( *t >= FUNCTION ) {
614  if ( functions[*t-FUNCTION].commute ) { num++; break; }
615  }
616  t += t[1];
617  }
618  terms = terms + *terms;
619  }
620  return(num);
621 }
622 
623 /*
624  #] numcommute :
625 */
626 
WORD bufferssize
Definition: structs.h:366
LONG * NumTerms
Definition: structs.h:915
WORD * buffers
Definition: structs.h:352
int value
Definition: structs.h:285
int parent
Definition: structs.h:282
int right
Definition: structs.h:284
int left
Definition: structs.h:283
WORD ** lhs
Definition: structs.h:912
Definition: structs.h:908
Definition: structs.h:281
WORD * Pointer
Definition: structs.h:911
WORD * dimension
Definition: structs.h:917
int usage
Definition: structs.h:287
int blnce
Definition: structs.h:286
WORD ** rhs
Definition: structs.h:913
WORD bufnum
Definition: structs.h:365
WORD buffersfill
Definition: structs.h:367
WORD * numdum
Definition: structs.h:916
COMPTREE * boomlijst
Definition: structs.h:918
WORD * Buffer
Definition: structs.h:909
LONG BufferSize
Definition: structs.h:919
WORD * Top
Definition: structs.h:910
struct tree COMPTREE
int IniFbuffer(WORD bufnum)
Definition: comtool.c:558
LONG * CanCommu
Definition: structs.h:914