FORM  4.2.1
dollar.c
Go to the documentation of this file.
1 
6 /* #[ License : */
7 /*
8  * Copyright (C) 1984-2017 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 /* EXTERNLOCK(dummylock) */
39 
40 static UBYTE underscore[2] = {'_',0};
41 
42 /*
43  #] Includes :
44  #[ CatchDollar :
45 
46  Works out a dollar expression during compile type.
47  Steals it from the buffer and puts it in an assignment.
48  At the moment we should keep this inside the small buffer.
49  Later with more sort buffers we can do this better.
50  Par == 0 : regular assignment
51  par == -1: after error. Just make zero for now.
52 */
53 
54 int CatchDollar(int par)
55 {
56  GETIDENTITY
57  CBUF *C = cbuf + AC.cbufnum;
58  int error = 0, numterms = 0, numdollar, resetmods = 0;
59  LONG newsize, retval;
60  WORD *w, *t, n, nsize, *oldwork = AT.WorkPointer, *dbuffer;
61  WORD oldncmod = AN.ncmod;
62  DOLLARS d;
63  if ( AN.ncmod && ( ( AC.modmode & ALSODOLLARS ) == 0 ) ) AN.ncmod = 0;
64  if ( AN.ncmod && AN.cmod == 0 ) { SetMods(); resetmods = 1; }
65 
66  numdollar = C->lhs[C->numlhs][2];
67 
68  d = Dollars+numdollar;
69  if ( par == -1 ) {
70  d->type = DOLUNDEFINED;
71  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
72  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
73  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"$-buffer old");
74  d->size = 0; d->where = &(AM.dollarzero);
75  cbuf[AM.dbufnum].rhs[numdollar] = d->where;
76  AN.ncmod = oldncmod;
77  if ( resetmods ) UnSetMods();
78  return(0);
79  }
80 #ifdef WITHMPI
81  /*
82  * The problem here is that only the master can make an assignment
83  * like #$a=g; where g is an expression: only the master has an access to
84  * the expression. So, in cases where the RHS contains expression names,
85  * only the master invokes Generator() and then broadcasts the result to
86  * the all slaves.
87  * Broadcasting must be performed immediately; one cannot postpone it
88  * to the end of the module because the dollar variable is visible
89  * in the current module. For the same reason, this should be done
90  * regardless of on/off parallel status.
91  * If the RHS does not contain any expression names, it can be processed
92  * in each slave.
93  */
94  if ( PF.me == MASTER || !AC.RhsExprInModuleFlag ) {
95 #endif
96 
97  EXCHINOUT
98 
99  if ( NewSort(BHEAD0) ) { if ( !error ) error = 1; goto onerror; }
100  if ( NewSort(BHEAD0) ) {
101  LowerSortLevel();
102  if ( !error ) error = 1;
103  goto onerror;
104  }
105  AN.RepPoint = AT.RepCount + 1;
106  w = C->rhs[C->lhs[C->numlhs][5]];
107  while ( *w ) {
108  n = *w; t = oldwork;
109  NCOPY(t,w,n)
110  AT.WorkPointer = t;
111  AR.Cnumlhs = C->numlhs;
112  if ( Generator(BHEAD oldwork,C->numlhs) ) { error = 1; break; }
113  }
114  AT.WorkPointer = oldwork;
115  AN.tryterm = 0; /* for now */
116  dbuffer = 0;
117  if ( ( retval = EndSort(BHEAD (WORD *)((VOID *)(&dbuffer)),2) ) < 0 ) { error = 1; }
118  LowerSortLevel();
119  if ( retval <= 1 || dbuffer == 0 ) {
120  d->type = DOLZERO;
121  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"$-buffer old");
122  d->size = 0; d->where = &(AM.dollarzero);
123  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
124  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
125  goto docopy2;
126  }
127  w = dbuffer;
128  if ( error == 0 )
129  while ( *w ) { w += *w; numterms++; }
130  else
131  goto onerror;
132  newsize = (w-dbuffer)+1;
133 #ifdef WITHMPI
134  }
135  if ( AC.RhsExprInModuleFlag )
136  /* PF_BroadcastPreDollar allocates dbuffer for slaves! */
137  if ( (error = PF_BroadcastPreDollar(&dbuffer, &newsize, &numterms)) != 0 )
138  goto onerror;
139 #endif
140  if ( newsize < MINALLOC ) newsize = MINALLOC;
141  newsize = ((newsize+7)/8)*8;
142  if ( numterms == 0 ) {
143  d->type = DOLZERO;
144  goto docopy;
145  }
146  else if ( numterms == 1 ) {
147  t = dbuffer;
148  n = *t;
149  nsize = t[n-1];
150  if ( nsize < 0 ) { nsize = -nsize; }
151  if ( nsize == (n-1) ) { /* numerical */
152  nsize = (nsize-1)/2;
153  w = t + 1 + nsize;
154  if ( *w != 1 ) goto doterms;
155  w++; while ( w < ( t + n - 1 ) ) { if ( *w ) break; w++; }
156  if ( w < ( t + n - 1 ) ) goto doterms;
157  d->type = DOLNUMBER;
158  goto docopy;
159  }
160  else if ( n == 7 && t[6] == 3 && t[5] == 1 && t[4] == 1
161  && t[1] == INDEX && t[2] == 3 ) {
162  d->type = DOLINDEX;
163  d->index = t[3];
164  goto docopy;
165  }
166  else goto doterms;
167  }
168  else {
169 doterms:;
170  d->type = DOLTERMS;
171  cbuf[AM.dbufnum].CanCommu[numdollar] = numcommute(dbuffer,
172  &(cbuf[AM.dbufnum].NumTerms[numdollar]));
173 docopy:;
174  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"$-buffer old");
175  d->size = newsize; d->where = dbuffer;
176 docopy2:;
177  cbuf[AM.dbufnum].rhs[numdollar] = d->where;
178  }
179  if ( C->Pointer > C->rhs[C->numrhs] ) C->Pointer = C->rhs[C->numrhs];
180  C->numlhs--; C->numrhs--;
181 onerror:
182 #ifdef WITHMPI
183  if ( PF.me == MASTER || !AC.RhsExprInModuleFlag )
184 #endif
185  BACKINOUT
186  AN.ncmod = oldncmod;
187  if ( resetmods ) UnSetMods();
188  return(error);
189 }
190 
191 /*
192  #] CatchDollar :
193  #[ AssignDollar :
194 
195  To be called from Generator. Assigns an expression to a $ variable.
196  This one is slightly different from CatchDollar.
197  We have no easy buffer this time.
198  We will have to hack our way using what we normally use for functions.
199 
200  Note that in the threaded case we trust the user. That means that
201  we are not going to recheck whether there is a maximum, minimum or sum.
202  If the user says it is like that, we treat it like that.
203  We only check that in this centralized version MODLOCAL isn't used.
204 
205  In a later stage dtype could be used for actually checking MODMAX
206  and MODMIN cases.
207 */
208 
209 int AssignDollar(PHEAD WORD *term, WORD level)
210 {
211  GETBIDENTITY
212  CBUF *C = cbuf+AM.rbufnum;
213  int numterms = 0, numdollar = C->lhs[level][2];
214  LONG newsize;
215  DOLLARS d = Dollars + numdollar;
216  WORD *w, *t, n, nsize, *rh = cbuf[C->lhs[level][7]].rhs[C->lhs[level][5]];
217  WORD *ss, *ww;
218  WORD olddefer, oldcompress, oldncmod = AN.ncmod;
219 #ifdef WITHPTHREADS
220  int nummodopt, dtype = -1, dw;
221  WORD numvalue;
222  if ( AN.ncmod && ( ( AC.modmode & ALSODOLLARS ) == 0 ) ) AN.ncmod = 0;
223  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
224 /*
225  Here we come only when the module runs with more than one thread.
226  This must be a variable with a special module option.
227  For the multi-threaded version we only allow MODSUM, MODMAX and MODMIN.
228 */
229  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
230  if ( numdollar == ModOptdollars[nummodopt].number ) break;
231  }
232  if ( nummodopt >= NumModOptdollars ) {
233  MLOCK(ErrorMessageLock);
234  MesPrint("Illegal attempt to change $-variable in multi-threaded module %l",AC.CModule);
235  MUNLOCK(ErrorMessageLock);
236  Terminate(-1);
237  }
238  dtype = ModOptdollars[nummodopt].type;
239  if ( dtype == MODLOCAL ) {
240  d = ModOptdollars[nummodopt].dstruct+AT.identity;
241  }
242  }
243 #endif
244  DUMMYUSE(term);
245  w = rh;
246 /*
247  First some shortcuts
248 */
249  if ( *w == 0 ) {
250 /*
251  #[ Thread version : Zero case
252 */
253 #ifdef WITHPTHREADS
254  if ( dtype > 0 ) {
255 /* LOCK(d->pthreadslockwrite); */
256  LOCK(d->pthreadslockread);
257 NewValIsZero:;
258  switch ( d->type ) {
259  case DOLZERO: goto NoChangeZero;
260  case DOLNUMBER:
261  case DOLTERMS:
262  if ( ( dw = d->where[0] ) > 0 && d->where[dw] != 0 ) {
263  break; /* was not a single number. Trust the user */
264  }
265  if ( dtype == MODMAX && d->where[dw-1] >= 0 ) goto NoChangeZero;
266  if ( dtype == MODMIN && d->where[dw-1] <= 0 ) goto NoChangeZero;
267  break;
268  default:
269  numvalue = DolToNumber(BHEAD numdollar);
270  if ( AN.ErrorInDollar != 0 ) break;
271  if ( dtype == MODMAX && numvalue >= 0 ) goto NoChangeZero;
272  if ( dtype == MODMIN && numvalue <= 0 ) goto NoChangeZero;
273  break;
274  }
275  d->type = DOLZERO;
276  d->where[0] = 0;
277  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
278  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
279 NoChangeZero:;
280  CleanDollarFactors(d);
281 /* UNLOCK(d->pthreadslockwrite); */
282  UNLOCK(d->pthreadslockread);
283  AN.ncmod = oldncmod;
284  return(0);
285  }
286 #endif
287 /*
288  #] Thread version :
289 */
290  d->type = DOLZERO;
291  d->where[0] = 0;
292  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
293  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
294  CleanDollarFactors(d);
295  AN.ncmod = oldncmod;
296  return(0);
297  }
298  else if ( *w == 4 && w[4] == 0 && w[2] == 1 ) {
299 /*
300  #[ Thread version : New value is 'single precision'
301 */
302 #ifdef WITHPTHREADS
303  if ( dtype > 0 ) {
304 /* LOCK(d->pthreadslockwrite); */
305  LOCK(d->pthreadslockread);
306  if ( d->size < MINALLOC ) {
307  WORD oldsize, *oldwhere, i;
308  oldsize = d->size; oldwhere = d->where;
309  d->size = MINALLOC;
310  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
311  cbuf[AM.dbufnum].rhs[numdollar] = d->where;
312  if ( oldsize > 0 ) {
313  for ( i = 0; i < oldsize; i++ ) d->where[i] = oldwhere[i];
314  }
315  else d->where[0] = 0;
316  if ( oldwhere && oldwhere != &(AM.dollarzero) ) M_free(oldwhere,"dollar contents");
317  }
318  switch ( d->type ) {
319  case DOLZERO:
320 HandleDolZero:;
321  if ( dtype == MODMAX && w[3] <= 0 ) goto NoChangeOne;
322  if ( dtype == MODMIN && w[3] >= 0 ) goto NoChangeOne;
323  break;
324  case DOLNUMBER:
325  case DOLTERMS:
326  if ( ( dw = d->where[0] ) > 0 && d->where[dw] != 0 ) {
327  break; /* was not a single number. Trust the user */
328  }
329  if ( dtype == MODMAX && CompCoef(d->where,w) >= 0 ) goto NoChangeOne;
330  if ( dtype == MODMIN && CompCoef(d->where,w) <= 0 ) goto NoChangeOne;
331  break;
332  default:
333  {
334 /*
335  Note that we convert the type for the next time around.
336 */
337  WORD extraterm[4];
338  numvalue = DolToNumber(BHEAD numdollar);
339  if ( AN.ErrorInDollar != 0 ) break;
340  if ( numvalue == 0 ) {
341  d->type = DOLZERO;
342  d->where[0] = 0;
343  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
344  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
345  goto HandleDolZero;
346  }
347  d->where[0] = extraterm[0] = 4;
348  d->where[1] = extraterm[1] = ABS(numvalue);
349  d->where[2] = extraterm[2] = 1;
350  d->where[3] = extraterm[3] = numvalue > 0 ? 3 : -3;
351  d->where[4] = 0;
352  d->type = DOLNUMBER;
353  if ( dtype == MODMAX && CompCoef(extraterm,w) >= 0 ) goto NoChangeOne;
354  if ( dtype == MODMIN && CompCoef(extraterm,w) <= 0 ) goto NoChangeOne;
355  break;
356  }
357  }
358  d->where[0] = w[0];
359  d->where[1] = w[1];
360  d->where[2] = w[2];
361  d->where[3] = w[3];
362  d->where[4] = 0;
363  d->type = DOLNUMBER;
364  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
365  cbuf[AM.dbufnum].NumTerms[numdollar] = 1;
366 NoChangeOne:;
367  CleanDollarFactors(d);
368 /* UNLOCK(d->pthreadslockwrite); */
369  UNLOCK(d->pthreadslockread);
370  AN.ncmod = oldncmod;
371  return(0);
372  }
373 #endif
374 /*
375  #] Thread version :
376 */
377  if ( d->size < MINALLOC ) {
378  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
379  d->size = MINALLOC;
380  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
381  cbuf[AM.dbufnum].rhs[numdollar] = d->where;
382  }
383  d->where[0] = w[0];
384  d->where[1] = w[1];
385  d->where[2] = w[2];
386  d->where[3] = w[3];
387  d->where[4] = 0;
388  d->type = DOLNUMBER;
389  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
390  cbuf[AM.dbufnum].NumTerms[numdollar] = 1;
391  CleanDollarFactors(d);
392  AN.ncmod = oldncmod;
393  return(0);
394  }
395 /*
396  Now the real evaluation.
397  In the case of threads and MODSUM this requires an immediate lock.
398  Otherwise the lock could be placed later.
399 */
400 #ifdef WITHPTHREADS
401  if ( dtype == MODSUM ) {
402 /* LOCK(d->pthreadslockwrite); */
403  LOCK(d->pthreadslockread);
404  }
405 #endif
406  CleanDollarFactors(d);
407 /*
408  The following case cannot occur. We treated it already
409 
410  if ( *w == 0 ) {
411  ss = 0; numterms = 0; newsize = 0;
412  olddefer = AR.DeferFlag; AR.DeferFlag = 0;
413  oldcompress = AR.NoCompress; AR.NoCompress = 1;
414  }
415  else
416 */
417  {
418 /*
419  New value is an expression that has to be evaluated first
420  This is all generic. It won't foliate due to the sort level
421 */
422  if ( NewSort(BHEAD0) ) {
423  AN.ncmod = oldncmod;
424  return(1);
425  }
426  olddefer = AR.DeferFlag; AR.DeferFlag = 0;
427  oldcompress = AR.NoCompress; AR.NoCompress = 1;
428  while ( *w ) {
429  n = *w; t = ww = AT.WorkPointer;
430  NCOPY(t,w,n);
431  AT.WorkPointer = t;
432  if ( Generator(BHEAD ww,AR.Cnumlhs) ) {
433  AT.WorkPointer = ww;
434  LowerSortLevel();
435  AR.DeferFlag = olddefer;
436  AN.ncmod = oldncmod;
437  return(1);
438  }
439  AT.WorkPointer = ww;
440  }
441  AN.tryterm = 0; /* for now */
442  if ( ( newsize = EndSort(BHEAD (WORD *)((VOID *)(&ss)),2) ) < 0 ) {
443  AN.ncmod = oldncmod;
444  return(1);
445  }
446  numterms = 0; t = ss; while ( *t ) { numterms++; t += *t; }
447  }
448 #ifdef WITHPTHREADS
449  if ( dtype != MODSUM ) {
450 /* LOCK(d->pthreadslockwrite); */
451  LOCK(d->pthreadslockread);
452  }
453 #endif
454  if ( numterms == 0 ) {
455 /*
456  the new value evaluates to zero
457 */
458 #ifdef WITHPTHREADS
459  if ( dtype == MODMAX || dtype == MODMIN ) {
460  if ( ss ) { M_free(ss,"Sort of $"); ss = 0; }
461  AR.DeferFlag = olddefer; AR.NoCompress = oldcompress;
462  goto NewValIsZero;
463  }
464  else
465 #endif
466  {
467  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
468  d->where = &(AM.dollarzero);
469  d->size = 0;
470  cbuf[AM.dbufnum].rhs[numdollar] = 0;
471  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
472  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
473  d->type = DOLZERO;
474  }
475  if ( ss ) { M_free(ss,"Sort of $"); ss = 0; }
476  }
477  else {
478 /*
479  #[ Thread version :
480 */
481 #ifdef WITHPTHREADS
482  if ( dtype == MODMAX || dtype == MODMIN ) {
483  if ( numterms == 1 && ( *ss-1 == ABS(ss[*ss-1]) ) ) { /* is number */
484  switch ( d->type ) {
485  case DOLZERO:
486 HandleDolZero1:;
487  if ( dtype == MODMAX && ss[*ss-1] > 0 ) break;
488  if ( dtype == MODMIN && ss[*ss-1] < 0 ) break;
489  if ( ss ) { M_free(ss,"Sort of $"); ss = 0; }
490  AR.DeferFlag = olddefer; AR.NoCompress = oldcompress;
491  goto NoChange;
492  case DOLTERMS:
493  case DOLNUMBER:
494  if ( ( dw = d->where[0] ) > 0 && d->where[dw] != 0 ) break;
495  if ( dtype == MODMAX && CompCoef(ss,d->where) > 0 ) break;
496  if ( dtype == MODMIN && CompCoef(ss,d->where) < 0 ) break;
497  if ( ss ) { M_free(ss,"Sort of $"); ss = 0; }
498  AR.DeferFlag = olddefer; AR.NoCompress = oldcompress;
499  goto NoChange;
500  default: {
501  WORD extraterm[4];
502  numvalue = DolToNumber(BHEAD numdollar);
503  if ( AN.ErrorInDollar != 0 ) break;
504  if ( numvalue == 0 ) {
505  d->type = DOLZERO;
506  d->where[0] = 0;
507  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
508  cbuf[AM.dbufnum].NumTerms[numdollar] = 0;
509  goto HandleDolZero1;
510  }
511  d->where[0] = extraterm[0] = 4;
512  d->where[1] = extraterm[1] = ABS(numvalue);
513  d->where[2] = extraterm[2] = 1;
514  d->where[3] = extraterm[3] = numvalue > 0 ? 3 : -3;
515  d->where[4] = 0;
516  d->type = DOLNUMBER;
517  if ( dtype == MODMAX && CompCoef(ss,extraterm) > 0 ) break;
518  if ( dtype == MODMIN && CompCoef(ss,extraterm) < 0 ) break;
519  if ( ss ) { M_free(ss,"Sort of $"); ss = 0; }
520  AR.DeferFlag = olddefer; AR.NoCompress = oldcompress;
521  goto NoChange;
522  }
523  }
524  }
525  else {
526  if ( ss ) { M_free(ss,"Sort of $"); ss = 0; }
527  AR.DeferFlag = olddefer; AR.NoCompress = oldcompress;
528  goto NoChange;
529  }
530  }
531 #endif
532 /*
533  #] Thread version :
534 */
535  d->type = DOLTERMS;
536  if ( d->where && d->where != &(AM.dollarzero) ) { M_free(d->where,"dollar contents"); d->where = 0; }
537  d->size = newsize + 1;
538  d->where = ss;
539  cbuf[AM.dbufnum].rhs[numdollar] = w = d->where;
540  }
541  AR.DeferFlag = olddefer; AR.NoCompress = oldcompress;
542 /*
543  Now find the special cases
544 */
545  if ( numterms == 0 ) {
546  d->type = DOLZERO;
547  }
548  else if ( numterms == 1 ) {
549  t = d->where;
550  n = *t;
551  nsize = t[n-1];
552  if ( nsize < 0 ) { nsize = -nsize; }
553  if ( nsize == (n-1) ) {
554  nsize = (nsize-1)/2;
555  w = t + 1 + nsize;
556  if ( *w == 1 ) {
557  w++; while ( w < ( t + n - 1 ) ) { if ( *w ) break; w++; }
558  if ( w >= ( t + n - 1 ) ) d->type = DOLNUMBER;
559  }
560  }
561  else if ( n == 7 && t[6] == 3 && t[5] == 1 && t[4] == 1
562  && t[1] == INDEX && t[2] == 3 ) {
563  d->type = DOLINDEX;
564  d->index = t[3];
565  }
566  }
567  if ( d->type == DOLTERMS ) {
568  cbuf[AM.dbufnum].CanCommu[numdollar] = numcommute(d->where,
569  &(cbuf[AM.dbufnum].NumTerms[numdollar]));
570  }
571  else {
572  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
573  cbuf[AM.dbufnum].NumTerms[numdollar] = 1;
574  }
575 #ifdef WITHPTHREADS
576 NoChange:;
577 /* UNLOCK(d->pthreadslockwrite); */
578  UNLOCK(d->pthreadslockread);
579 #endif
580  AN.ncmod = oldncmod;
581  return(0);
582 }
583 
584 /*
585  #] AssignDollar :
586  #[ WriteDollarToBuffer :
587 
588  Takes the numbered dollar expression and writes it to output.
589  We catch however the output in a buffer and return its address.
590  This routine is needed when we need a text representation of
591  a dollar expression like for the construction `$name' in the preprocessor.
592  If par==0 we leave the current printing mode.
593  If par==1 we insist on normal mode
594 */
595 
596 UBYTE *WriteDollarToBuffer(WORD numdollar, WORD par)
597 {
598  DOLLARS d = Dollars+numdollar;
599  UBYTE *s, *oldcurbufwrt = AO.CurBufWrt;
600  WORD *t, lbrac = 0, first = 0, arg[2], oldOutputMode = AC.OutputMode;
601  WORD oldinfbrack = AO.InFbrack;
602  int error = 0;
603  int dict = AO.CurrentDictionary;
604 
605  AO.DollarOutSizeBuffer = 32;
606  AO.DollarOutBuffer = (UBYTE *)Malloc1(AO.DollarOutSizeBuffer,"DollarOutBuffer");
607  AO.DollarInOutBuffer = 1;
608  AO.PrintType = 1;
609  AO.InFbrack = 0;
610  s = AO.DollarOutBuffer;
611  *s = 0;
612  if ( par > 0 && AO.CurDictInDollars == 0 ) {
613  AC.OutputMode = NORMALFORMAT;
614  AO.CurrentDictionary = 0;
615  }
616  else {
617  AO.CurBufWrt = (UBYTE *)underscore;
618  }
619  AO.OutInBuffer = 1;
620  switch ( d->type ) {
621  case DOLARGUMENT:
622  WriteArgument(d->where);
623  break;
624  case DOLSUBTERM:
625  WriteSubTerm(d->where,1);
626  break;
627  case DOLNUMBER:
628  case DOLTERMS:
629  t = d->where;
630  while ( *t ) {
631  if ( WriteTerm(t,&lbrac,first,PRINTON,0) ) {
632  error = 1; break;
633  }
634  t += *t;
635  }
636  break;
637  case DOLWILDARGS:
638  t = d->where+1;
639  while ( *t ) {
640  WriteArgument(t);
641  NEXTARG(t)
642  if ( *t ) TokenToLine((UBYTE *)(","));
643  }
644  break;
645  case DOLINDEX:
646  arg[0] = -INDEX; arg[1] = d->index;
647  WriteArgument(arg);
648  break;
649  case DOLZERO:
650  *s++ = '0'; *s = 0;
651  AO.DollarInOutBuffer = 1;
652  break;
653  case DOLUNDEFINED:
654  *s = 0;
655  AO.DollarInOutBuffer = 1;
656  break;
657  }
658  AC.OutputMode = oldOutputMode;
659  AO.OutInBuffer = 0;
660  AO.InFbrack = oldinfbrack;
661  AO.CurBufWrt = oldcurbufwrt;
662  AO.CurrentDictionary = dict;
663  if ( error ) {
664  MLOCK(ErrorMessageLock);
665  MesPrint("&Illegal dollar object for writing");
666  MUNLOCK(ErrorMessageLock);
667  M_free(AO.DollarOutBuffer,"DollarOutBuffer");
668  AO.DollarOutBuffer = 0;
669  AO.DollarOutSizeBuffer = 0;
670  return(0);
671  }
672  return(AO.DollarOutBuffer);
673 }
674 
675 /*
676  #] WriteDollarToBuffer :
677  #[ WriteDollarFactorToBuffer :
678 
679  Takes the numbered dollar expression and writes it to output.
680  We catch however the output in a buffer and return its address.
681  This routine is needed when we need a text representation of
682  a dollar expression like for the construction `$name' in the preprocessor.
683  If par==0 we leave the current printing mode.
684  If par==1 we insist on normal mode
685 */
686 
687 UBYTE *WriteDollarFactorToBuffer(WORD numdollar, WORD numfac, WORD par)
688 {
689  DOLLARS d = Dollars+numdollar;
690  UBYTE *s, *oldcurbufwrt = AO.CurBufWrt;
691  WORD *t, lbrac = 0, first = 0, n[5], oldOutputMode = AC.OutputMode;
692  WORD oldinfbrack = AO.InFbrack;
693  int error = 0;
694  int dict = AO.CurrentDictionary;
695 
696  if ( numfac > d->nfactors || numfac < 0 ) {
697  MLOCK(ErrorMessageLock);
698  MesPrint("&Illegal factor number for this dollar variable: %d",numfac);
699  MesPrint("&There are %d factors",d->nfactors);
700  MUNLOCK(ErrorMessageLock);
701  return(0);
702  }
703 
704  AO.DollarOutSizeBuffer = 32;
705  AO.DollarOutBuffer = (UBYTE *)Malloc1(AO.DollarOutSizeBuffer,"DollarOutBuffer");
706  AO.DollarInOutBuffer = 1;
707  AO.PrintType = 1;
708  AO.InFbrack = 0;
709  s = AO.DollarOutBuffer;
710  *s = 0;
711  if ( par > 0 ) {
712  AC.OutputMode = NORMALFORMAT;
713  AO.CurrentDictionary = 0;
714  }
715  else {
716  AO.CurBufWrt = (UBYTE *)underscore;
717  }
718  AO.OutInBuffer = 1;
719  if ( numfac == 0 ) { /* write the number d->nfactors */
720  n[0] = 4; n[1] = d->nfactors; n[2] = 1; n[3] = 3; n[4] = 0; t = n;
721  }
722  else if ( numfac == 1 && d->factors == 0 ) { /* Here d->factors is zero and d->where is fine */
723  t = d->where;
724  }
725  else if ( d->factors[numfac-1].where == 0 ) { /* write the value */
726  if ( d->factors[numfac-1].value < 0 ) {
727  n[0] = 4; n[1] = -d->factors[numfac-1].value; n[2] = 1; n[3] = -3; n[4] = 0; t = n;
728  }
729  else {
730  n[0] = 4; n[1] = d->factors[numfac-1].value; n[2] = 1; n[3] = 3; n[4] = 0; t = n;
731  }
732  }
733  else { t = d->factors[numfac-1].where; }
734  while ( *t ) {
735  if ( WriteTerm(t,&lbrac,first,PRINTON,0) ) {
736  error = 1; break;
737  }
738  t += *t;
739  }
740  AC.OutputMode = oldOutputMode;
741  AO.OutInBuffer = 0;
742  AO.InFbrack = oldinfbrack;
743  AO.CurBufWrt = oldcurbufwrt;
744  AO.CurrentDictionary = dict;
745  if ( error ) {
746  MLOCK(ErrorMessageLock);
747  MesPrint("&Illegal dollar object for writing");
748  MUNLOCK(ErrorMessageLock);
749  M_free(AO.DollarOutBuffer,"DollarOutBuffer");
750  AO.DollarOutBuffer = 0;
751  AO.DollarOutSizeBuffer = 0;
752  return(0);
753  }
754  return(AO.DollarOutBuffer);
755 }
756 
757 /*
758  #] WriteDollarFactorToBuffer :
759  #[ AddToDollarBuffer :
760 */
761 
762 void AddToDollarBuffer(UBYTE *s)
763 {
764  int i;
765  UBYTE *t = s, *u, *newdob;
766  LONG j;
767  while ( *t ) { t++; }
768  i = t - s;
769  while ( i + AO.DollarInOutBuffer >= AO.DollarOutSizeBuffer ) {
770  j = AO.DollarInOutBuffer;
771  AO.DollarOutSizeBuffer *= 2;
772  t = AO.DollarOutBuffer;
773  newdob = (UBYTE *)Malloc1(AO.DollarOutSizeBuffer,"DollarOutBuffer");
774  u = newdob;
775  while ( --j >= 0 ) *u++ = *t++;
776  M_free(AO.DollarOutBuffer,"DollarOutBuffer");
777  AO.DollarOutBuffer = newdob;
778  }
779  t = AO.DollarOutBuffer + AO.DollarInOutBuffer-1;
780  while ( t == AO.DollarOutBuffer && ( *s == '+' || *s == ' ' ) ) s++;
781  i = 0;
782  if ( AO.CurrentDictionary == 0 ) {
783  while ( *s ) {
784  if ( *s == ' ' ) { s++; continue; }
785  *t++ = *s++; i++;
786  }
787  }
788  else {
789  while ( *s ) { *t++ = *s++; i++; }
790  }
791  *t = 0;
792  AO.DollarInOutBuffer += i;
793 }
794 
795 /*
796  #] AddToDollarBuffer :
797  #[ TermAssign :
798 
799  This routine is called from a piece of code in Normalize that has been
800  commented out.
801 */
802 
803 void TermAssign(WORD *term)
804 {
805  DOLLARS d;
806  WORD *t, *tstop, *astop, *w, *m;
807  WORD i, newsize;
808  for (;;) {
809  astop = term + *term;
810  tstop = astop - ABS(astop[-1]);
811  t = term + 1;
812  while ( t < tstop ) {
813  if ( *t == AM.termfunnum && t[1] == FUNHEAD+2
814  && t[FUNHEAD] == -DOLLAREXPRESSION ) {
815  d = Dollars + t[FUNHEAD+1];
816  newsize = *term - FUNHEAD - 1;
817  if ( newsize < MINALLOC ) newsize = MINALLOC;
818  newsize = ((newsize+7)/8)*8;
819  if ( d->size > 2*newsize && d->size > 1000 ) {
820  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
821  d->size = 0;
822  d->where = &(AM.dollarzero);
823  }
824  if ( d->size < newsize ) {
825  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
826  d->size = newsize;
827  d->where = (WORD *)Malloc1(newsize*sizeof(WORD),"dollar contents");
828  }
829  cbuf[AM.dbufnum].rhs[t[FUNHEAD+1]] = w = d->where;
830  m = term;
831  while ( m < t ) *w++ = *m++;
832  m += t[1];
833  while ( m < tstop ) {
834  if ( *m == AM.termfunnum && m[1] == FUNHEAD+2
835  && m[FUNHEAD] == -DOLLAREXPRESSION ) { m += m[1]; }
836  else {
837  i = m[1];
838  while ( --i >= 0 ) *w++ = *m++;
839  }
840  }
841  while ( m < astop ) *w++ = *m++;
842  *(d->where) = w - d->where;
843  *w = 0;
844  d->type = DOLTERMS;
845  w = t; m = t + t[1];
846  while ( m < astop ) *w++ = *m++;
847  *term = w - term;
848  break;
849  }
850  t += t[1];
851  }
852  if ( t >= tstop ) return;
853  }
854 }
855 
856 /*
857  #] TermAssign :
858  #[ PutTermInDollar :
859 
860  We assume here that the dollar is local.
861 */
862 
863 int PutTermInDollar(WORD *term, WORD numdollar)
864 {
865  DOLLARS d = Dollars+numdollar;
866  WORD i;
867  if ( term == 0 || *term == 0 ) {
868  d->type = DOLZERO;
869  return(0);
870  }
871  if ( d->size < *term || d->size > 2*term[0] || d->where == 0 ) {
872  if ( d->size > 0 && d->where ) {
873  M_free(d->where,"dollar contents");
874  }
875  d->where = Malloc1((term[0]+1)*sizeof(WORD),"dollar contents");
876  d->size = term[0]+1;
877  }
878  d->type = DOLTERMS;
879  for ( i = 0; i < term[0]; i++ ) d->where[i] = term[i];
880  d->where[i] = 0;
881  return(0);
882 }
883 
884 /*
885  #] PutTermInDollar :
886  #[ WildDollars :
887 
888  Note that we cannot upload wildcards into dollar variables when WITHPTHREADS.
889 LONG alloccounter = 0;
890 */
891 
892 
893 void WildDollars(PHEAD WORD *term)
894 {
895  GETBIDENTITY
896  DOLLARS d;
897  WORD *m, *t, *w, *ww, *orig = 0, *wildvalue, *wildstop;
898  int numdollar;
899  LONG weneed, i;
900  struct DoLlArS;
901 #ifdef WITHPTHREADS
902  int dtype = -1;
903 #endif
904 /* alloccounter++; */
905  if ( term == 0 ) {
906  m = wildvalue = AN.WildValue;
907  wildstop = AN.WildStop;
908  }
909  else {
910  ww = term + *term; ww -= ABS(ww[-1]); w = term+1;
911  while ( w < ww && *w != SUBEXPRESSION ) w += w[1];
912  if ( w >= ww ) return;
913  wildstop = w + w[1];
914  w += SUBEXPSIZE;
915  wildvalue = m = w;
916  }
917  while ( m < wildstop ) {
918  if ( *m != LOADDOLLAR ) { m += m[1]; continue; }
919  t = m - 4;
920  while ( *t == LOADDOLLAR || *t == FROMSET || *t == SETTONUM ) t -= 4;
921  if ( t < wildvalue ) {
922  MLOCK(ErrorMessageLock);
923  MesPrint("&Serious bug in wildcard prototype. Found in WildDollars");
924  MUNLOCK(ErrorMessageLock);
925  Terminate(-1);
926  }
927  numdollar = m[2];
928  d = Dollars + numdollar;
929 #ifdef WITHPTHREADS
930  {
931  int nummodopt;
932  dtype = -1;
933  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
934  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
935  if ( numdollar == ModOptdollars[nummodopt].number ) break;
936  }
937  if ( nummodopt < NumModOptdollars ) {
938  dtype = ModOptdollars[nummodopt].type;
939  if ( dtype == MODLOCAL ) {
940  d = ModOptdollars[nummodopt].dstruct+AT.identity;
941  }
942  else {
943  MLOCK(ErrorMessageLock);
944  MesPrint("&Illegal attempt to use $-variable %s in module %l",
945  DOLLARNAME(Dollars,numdollar),AC.CModule);
946  MUNLOCK(ErrorMessageLock);
947  Terminate(-1);
948  }
949  }
950  }
951  }
952 #endif
953 /*
954  The value of this wildcard goes into our $-variable
955  First compute the space we need.
956 */
957  switch ( *t ) {
958  case SYMTONUM:
959  weneed = 5;
960  break;
961  case SYMTOSYM:
962  weneed = 9;
963  break;
964  case SYMTOSUB:
965  case VECTOSUB:
966  case INDTOSUB:
967  orig = cbuf[AT.ebufnum].rhs[t[3]];
968  w = orig; while ( *w ) w += *w;
969  weneed = w - orig + 1;
970  break;
971  case VECTOMIN:
972  case VECTOVEC:
973  case INDTOIND:
974  weneed = 8;
975  break;
976  case FUNTOFUN:
977  weneed = FUNHEAD+5;
978  break;
979  case ARGTOARG:
980  orig = cbuf[AT.ebufnum].rhs[t[3]];
981  if ( *orig > 0 ) weneed = *orig+2;
982  else {
983  w = orig+1; while ( *w ) { NEXTARG(w) }
984  weneed = w - orig + 1;
985  }
986  break;
987  default:
988  weneed = MINALLOC;
989  break;
990  }
991  if ( weneed < MINALLOC ) weneed = MINALLOC;
992  weneed = ((weneed+7)/8)*8;
993  if ( d->size > 2*weneed && d->size > 1000 ) {
994  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollarspace");
995  d->where = &(AM.dollarzero);
996  d->size = 0;
997  }
998  if ( d->size < weneed ) {
999  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollarspace");
1000  d->where = (WORD *)Malloc1(weneed*sizeof(WORD),"dollarspace");
1001  d->size = weneed;
1002  }
1003 /*
1004  It is not clear what the following code does for TFORM
1005 
1006  if ( dtype != MODLOCAL ) {
1007 */
1008  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
1009  cbuf[AM.dbufnum].NumTerms[numdollar] = 1;
1010 /* cbuf[AM.dbufnum].rhs[numdollar] = d->where; */
1011  cbuf[AM.dbufnum].rhs[numdollar] = (WORD *)(1);
1012 /*
1013  }
1014  Now load up the value of the wildcard in compiler buffer format
1015 */
1016  w = d->where;
1017  d->type = DOLTERMS;
1018  switch ( *t ) {
1019  case SYMTONUM:
1020  d->where[0] = 4; d->where[2] = 1;
1021  if ( t[3] >= 0 ) { d->where[1] = t[3]; d->where[3] = 3; }
1022  else { d->where[1] = -t[3]; d->where[3] = -3; }
1023  if ( t[3] == 0 ) { d->type = DOLZERO; d->where[0] = 0; }
1024  else { d->type = DOLNUMBER; d->where[4] = 0; }
1025  break;
1026  case SYMTOSYM:
1027  *w++ = 8;
1028  *w++ = SYMBOL;
1029  *w++ = 4;
1030  *w++ = t[3];
1031  *w++ = 1;
1032  *w++ = 1;
1033  *w++ = 1;
1034  *w++ = 3;
1035  *w = 0;
1036  break;
1037  case SYMTOSUB:
1038  case VECTOSUB:
1039  case INDTOSUB:
1040  while ( *orig ) {
1041  i = *orig; while ( --i >= 0 ) *w++ = *orig++;
1042  }
1043  *w = 0;
1044 /*
1045  And then we have to fix up CanCommu
1046 */
1047  break;
1048  case VECTOMIN:
1049  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[3];
1050  *w++ = 1; *w++ = 1; *w++ = -3; *w = 0;
1051  break;
1052  case VECTOVEC:
1053  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[3];
1054  *w++ = 1; *w++ = 1; *w++ = 3; *w = 0;
1055  break;
1056  case INDTOIND:
1057  d->type = DOLINDEX; d->index = t[3]; *w = 0;
1058  break;
1059  case FUNTOFUN:
1060  *w++ = FUNHEAD+4; *w++ = t[3]; *w++ = FUNHEAD;
1061  FILLFUN(w)
1062  *w++ = 1; *w++ = 1; *w++ = 3; *w = 0;
1063  break;
1064  case ARGTOARG:
1065  if ( *orig > 0 ) ww = orig + *orig + 1;
1066  else {
1067  ww = orig+1; while ( *ww ) { NEXTARG(ww) }
1068  }
1069  while ( orig < ww ) *w++ = *orig++;
1070  *w = 0;
1071  d->type = DOLWILDARGS;
1072  break;
1073  default:
1074  d->type = DOLUNDEFINED;
1075  break;
1076  }
1077  m += m[1];
1078  }
1079 }
1080 
1081 /*
1082  #] WildDollars :
1083  #[ DolToTensor : with LOCK
1084 */
1085 
1086 WORD DolToTensor(PHEAD WORD numdollar)
1087 {
1088  GETBIDENTITY
1089  DOLLARS d = Dollars + numdollar;
1090  WORD retval;
1091 #ifdef WITHPTHREADS
1092  int nummodopt, dtype = -1;
1093  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1094  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1095  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1096  }
1097  if ( nummodopt < NumModOptdollars ) {
1098  dtype = ModOptdollars[nummodopt].type;
1099  if ( dtype == MODLOCAL ) {
1100  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1101  }
1102  else {
1103  LOCK(d->pthreadslockread);
1104  }
1105  }
1106  }
1107 #endif
1108  AN.ErrorInDollar = 0;
1109  if ( d->type == DOLTERMS && d->where[0] == FUNHEAD+4 &&
1110  d->where[FUNHEAD+4] == 0 && d->where[FUNHEAD+3] == 3 &&
1111  d->where[FUNHEAD+2] == 1 && d->where[FUNHEAD+1] == 1 &&
1112  d->where[1] >= FUNCTION && d->where[1] < FUNCTION+WILDOFFSET
1113  && functions[d->where[1]-FUNCTION].spec >= TENSORFUNCTION ) {
1114  retval = d->where[1];
1115  }
1116  else if ( d->type == DOLARGUMENT &&
1117  d->where[0] <= -FUNCTION && d->where[0] > -FUNCTION-WILDOFFSET
1118  && functions[-d->where[0]-FUNCTION].spec >= TENSORFUNCTION ) {
1119  retval = -d->where[0];
1120  }
1121  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1122  && d->where[1] <= -FUNCTION && d->where[1] > -FUNCTION-WILDOFFSET
1123  && d->where[2] == 0
1124  && functions[-d->where[1]-FUNCTION].spec >= TENSORFUNCTION ) {
1125  retval = -d->where[1];
1126  }
1127  else if ( d->type == DOLSUBTERM &&
1128  d->where[0] >= FUNCTION && d->where[0] < FUNCTION+WILDOFFSET
1129  && functions[d->where[0]-FUNCTION].spec >= TENSORFUNCTION ) {
1130  retval = d->where[0];
1131  }
1132  else {
1133  AN.ErrorInDollar = 1;
1134  retval = 0;
1135  }
1136 #ifdef WITHPTHREADS
1137  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1138 #endif
1139  return(retval);
1140 }
1141 
1142 /*
1143  #] DolToTensor :
1144  #[ DolToFunction : with LOCK
1145 */
1146 
1147 WORD DolToFunction(PHEAD WORD numdollar)
1148 {
1149  GETBIDENTITY
1150  DOLLARS d = Dollars + numdollar;
1151  WORD retval;
1152 #ifdef WITHPTHREADS
1153  int nummodopt, dtype = -1;
1154  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1155  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1156  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1157  }
1158  if ( nummodopt < NumModOptdollars ) {
1159  dtype = ModOptdollars[nummodopt].type;
1160  if ( dtype == MODLOCAL ) {
1161  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1162  }
1163  else {
1164  LOCK(d->pthreadslockread);
1165  }
1166  }
1167  }
1168 #endif
1169  AN.ErrorInDollar = 0;
1170  if ( d->type == DOLTERMS && d->where[0] == FUNHEAD+4 &&
1171  d->where[FUNHEAD+4] == 0 && d->where[FUNHEAD+3] == 3 &&
1172  d->where[FUNHEAD+2] == 1 && d->where[FUNHEAD+1] == 1 &&
1173  d->where[1] >= FUNCTION && d->where[1] < FUNCTION+WILDOFFSET ) {
1174  retval = d->where[1];
1175  }
1176  else if ( d->type == DOLARGUMENT &&
1177  d->where[0] <= -FUNCTION && d->where[0] > -FUNCTION-WILDOFFSET ) {
1178  retval = -d->where[0];
1179  }
1180  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1181  && d->where[1] <= -FUNCTION && d->where[1] > -FUNCTION-WILDOFFSET
1182  && d->where[2] == 0 ) {
1183  retval = -d->where[1];
1184  }
1185  else if ( d->type == DOLSUBTERM &&
1186  d->where[0] >= FUNCTION && d->where[0] < FUNCTION+WILDOFFSET ) {
1187  retval = d->where[0];
1188  }
1189  else {
1190  AN.ErrorInDollar = 1;
1191  retval = 0;
1192  }
1193 #ifdef WITHPTHREADS
1194  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1195 #endif
1196  return(retval);
1197 }
1198 
1199 /*
1200  #] DolToFunction :
1201  #[ DolToVector : with LOCK
1202 */
1203 
1204 WORD DolToVector(PHEAD WORD numdollar)
1205 {
1206  GETBIDENTITY
1207  DOLLARS d = Dollars + numdollar;
1208  WORD retval;
1209 #ifdef WITHPTHREADS
1210  int nummodopt, dtype = -1;
1211  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1212  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1213  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1214  }
1215  if ( nummodopt < NumModOptdollars ) {
1216  dtype = ModOptdollars[nummodopt].type;
1217  if ( dtype == MODLOCAL ) {
1218  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1219  }
1220  else {
1221  LOCK(d->pthreadslockread);
1222  }
1223  }
1224  }
1225 #endif
1226  AN.ErrorInDollar = 0;
1227  if ( d->type == DOLINDEX && d->index < 0 ) {
1228  retval = d->index;
1229  }
1230  else if ( d->type == DOLARGUMENT && ( d->where[0] == -VECTOR
1231  || d->where[0] == -MINVECTOR ) ) {
1232  retval = d->where[1];
1233  }
1234  else if ( d->type == DOLSUBTERM && d->where[0] == INDEX
1235  && d->where[1] == 3 && d->where[2] < 0 ) {
1236  retval = d->where[2];
1237  }
1238  else if ( d->type == DOLTERMS && d->where[0] == 7 &&
1239  d->where[7] == 0 && d->where[6] == 3 &&
1240  d->where[5] == 1 && d->where[4] == 1 &&
1241  d->where[1] >= INDEX && d->where[3] < 0 ) {
1242  retval = d->where[3];
1243  }
1244  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1245  && ( d->where[1] == -VECTOR || d->where[1] == -MINVECTOR )
1246  && d->where[3] == 0 ) {
1247  retval = d->where[2];
1248  }
1249  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1250  && d->where[1] < 0 ) {
1251  retval = d->where[1];
1252  }
1253  else {
1254  AN.ErrorInDollar = 1;
1255  retval = 0;
1256  }
1257 #ifdef WITHPTHREADS
1258  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1259 #endif
1260  return(retval);
1261 }
1262 
1263 /*
1264  #] DolToVector :
1265  #[ DolToNumber :
1266 */
1267 
1268 WORD DolToNumber(PHEAD WORD numdollar)
1269 {
1270  GETBIDENTITY
1271  DOLLARS d = Dollars + numdollar;
1272 #ifdef WITHPTHREADS
1273  int nummodopt, dtype = -1;
1274  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1275  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1276  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1277  }
1278  if ( nummodopt < NumModOptdollars ) {
1279  dtype = ModOptdollars[nummodopt].type;
1280  if ( dtype == MODLOCAL ) {
1281  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1282  }
1283  }
1284  }
1285 #endif
1286  AN.ErrorInDollar = 0;
1287  if ( ( d->type == DOLTERMS || d->type == DOLNUMBER )
1288  && d->where[0] == 4 &&
1289  d->where[4] == 0 && ( d->where[3] == 3 || d->where[3] == -3 )
1290  && d->where[2] == 1 && ( d->where[1] & TOPBITONLY ) == 0 ) {
1291  if ( d->where[3] > 0 ) return(d->where[1]);
1292  else return(-d->where[1]);
1293  }
1294  else if ( d->type == DOLARGUMENT && d->where[0] == -SNUMBER ) {
1295  return(d->where[1]);
1296  }
1297  else if ( d->type == DOLARGUMENT && d->where[0] == -INDEX
1298  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1299  return(d->where[1]);
1300  }
1301  else if ( d->type == DOLZERO ) return(0);
1302  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1303  && d->where[1] == -SNUMBER && d->where[3] == 0 ) {
1304  return(d->where[2]);
1305  }
1306  else if ( d->type == DOLINDEX && d->index >= 0 && d->index < AM.OffsetIndex ) {
1307  return(d->index);
1308  }
1309  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1310  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1311  return(d->where[1]);
1312  }
1313  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1314  && d->where[1] == -INDEX && d->where[3] == 0 && d->where[2] >= 0
1315  && d->where[2] < AM.OffsetIndex ) {
1316  return(d->where[2]);
1317  }
1318  AN.ErrorInDollar = 1;
1319  return(0);
1320 }
1321 
1322 /*
1323  #] DolToNumber :
1324  #[ DolToSymbol : with LOCK
1325 */
1326 
1327 WORD DolToSymbol(PHEAD WORD numdollar)
1328 {
1329  GETBIDENTITY
1330  DOLLARS d = Dollars + numdollar;
1331  WORD retval;
1332 #ifdef WITHPTHREADS
1333  int nummodopt, dtype = -1;
1334  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1335  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1336  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1337  }
1338  if ( nummodopt < NumModOptdollars ) {
1339  dtype = ModOptdollars[nummodopt].type;
1340  if ( dtype == MODLOCAL ) {
1341  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1342  }
1343  else {
1344  LOCK(d->pthreadslockread);
1345  }
1346  }
1347  }
1348 #endif
1349  AN.ErrorInDollar = 0;
1350  if ( d->type == DOLTERMS && d->where[0] == 8 &&
1351  d->where[8] == 0 && d->where[7] == 3 && d->where[6] == 1
1352  && d->where[5] == 1 && d->where[4] == 1 && d->where[1] == SYMBOL ) {
1353  retval = d->where[3];
1354  }
1355  else if ( d->type == DOLARGUMENT && d->where[0] == -SYMBOL ) {
1356  retval = d->where[1];
1357  }
1358  else if ( d->type == DOLSUBTERM && d->where[0] == SYMBOL
1359  && d->where[1] == 4 && d->where[3] == 1 ) {
1360  retval = d->where[2];
1361  }
1362  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1363  && d->where[1] == -SYMBOL && d->where[3] == 0 ) {
1364  retval = d->where[2];
1365  }
1366  else {
1367  AN.ErrorInDollar = 1;
1368  retval = -1;
1369  }
1370 #ifdef WITHPTHREADS
1371  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1372 #endif
1373  return(retval);
1374 }
1375 
1376 /*
1377  #] DolToSymbol :
1378  #[ DolToIndex : with LOCK
1379 */
1380 
1381 WORD DolToIndex(PHEAD WORD numdollar)
1382 {
1383  GETBIDENTITY
1384  DOLLARS d = Dollars + numdollar;
1385  WORD retval;
1386 #ifdef WITHPTHREADS
1387  int nummodopt, dtype = -1;
1388  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1389  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1390  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1391  }
1392  if ( nummodopt < NumModOptdollars ) {
1393  dtype = ModOptdollars[nummodopt].type;
1394  if ( dtype == MODLOCAL ) {
1395  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1396  }
1397  else {
1398  LOCK(d->pthreadslockread);
1399  }
1400  }
1401  }
1402 #endif
1403  AN.ErrorInDollar = 0;
1404  if ( d->type == DOLTERMS && d->where[0] == 7 &&
1405  d->where[7] == 0 && d->where[6] == 3 && d->where[5] == 1
1406  && d->where[4] == 1 && d->where[1] == INDEX && d->where[3] >= 0 ) {
1407  retval = d->where[3];
1408  }
1409  else if ( d->type == DOLARGUMENT && d->where[0] == -SNUMBER
1410  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1411  retval = d->where[1];
1412  }
1413  else if ( d->type == DOLARGUMENT && d->where[0] == -INDEX
1414  && d->where[1] >= 0 ) {
1415  retval = d->where[1];
1416  }
1417  else if ( d->type == DOLZERO ) return(0);
1418  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1419  && d->where[1] == -SNUMBER && d->where[3] == 0 && d->where[2] >= 0
1420  && d->where[2] < AM.OffsetIndex ) {
1421  retval = d->where[2];
1422  }
1423  else if ( d->type == DOLINDEX && d->index >= 0 ) {
1424  retval = d->index;
1425  }
1426  else if ( d->type == DOLNUMBER && d->where[0] == 4 && d->where[2] == 1
1427  && d->where[3] == 3 && d->where[4] == 0 && d->where[1] < AM.OffsetIndex ) {
1428  retval = d->where[1];
1429  }
1430  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1431  && d->where[1] >= 0 ) {
1432  retval = d->where[1];
1433  }
1434  else if ( d->type == DOLSUBTERM && d->where[0] == INDEX
1435  && d->where[1] == 3 && d->where[2] >= 0 ) {
1436  retval = d->where[2];
1437  }
1438  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1439  && d->where[1] == -INDEX && d->where[3] == 0 && d->where[2] >= 0 ) {
1440  retval = d->where[2];
1441  }
1442  else {
1443  AN.ErrorInDollar = 1;
1444  retval = 0;
1445  }
1446 #ifdef WITHPTHREADS
1447  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1448 #endif
1449  return(retval);
1450 }
1451 
1452 /*
1453  #] DolToIndex :
1454  #[ DolToTerms :
1455 
1456  Returns a struct of type DOLLARS which contains a copy of the
1457  original dollar variable, provided it can be expressed in terms of
1458  an expression (type = DOLTERMS). Otherwise it returns zero.
1459  The dollar is expressed in terms in the buffer "where"
1460 */
1461 
1462 DOLLARS DolToTerms(PHEAD WORD numdollar)
1463 {
1464  GETBIDENTITY
1465  LONG size;
1466  DOLLARS d = Dollars + numdollar, newd;
1467  WORD *t, *w, i;
1468 #ifdef WITHPTHREADS
1469  int nummodopt, dtype = -1;
1470  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1471  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1472  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1473  }
1474  if ( nummodopt < NumModOptdollars ) {
1475  dtype = ModOptdollars[nummodopt].type;
1476  if ( dtype == MODLOCAL ) {
1477  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1478  }
1479  }
1480  }
1481 #endif
1482  AN.ErrorInDollar = 0;
1483  switch ( d->type ) {
1484  case DOLARGUMENT:
1485  t = d->where;
1486  if ( t[0] < 0 ) {
1487 ShortArgument:
1488  w = AT.WorkPointer;
1489  if ( t[0] <= -FUNCTION ) {
1490  *w++ = FUNHEAD+4; *w++ = -t[0];
1491  *w++ = FUNHEAD; FILLFUN(w)
1492  *w++ = 1; *w++ = 1; *w++ = 3;
1493  }
1494  else if ( t[0] == -SYMBOL ) {
1495  *w++ = 8; *w++ = SYMBOL; *w++ = 4; *w++ = t[1];
1496  *w++ = 1; *w++ = 1; *w++ = 1; *w++ = 3;
1497  }
1498  else if ( t[0] == -VECTOR || t[0] == -INDEX ) {
1499  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[1];
1500  *w++ = 1; *w++ = 1; *w++ = 3;
1501  }
1502  else if ( t[0] == -MINVECTOR ) {
1503  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[1];
1504  *w++ = 1; *w++ = 1; *w++ = -3;
1505  }
1506  else if ( t[0] == -SNUMBER ) {
1507  *w++ = 4;
1508  if ( t[1] < 0 ) {
1509  *w++ = -t[1]; *w++ = 1; *w++ = -3;
1510  }
1511  else {
1512  *w++ = t[1]; *w++ = 1; *w++ = 3;
1513  }
1514  }
1515  *w = 0; size = w - AT.WorkPointer;
1516  w = AT.WorkPointer;
1517  break;
1518  }
1519  /* fall through */
1520  case DOLNUMBER:
1521  case DOLTERMS:
1522  t = d->where;
1523  while ( *t ) t += *t;
1524  size = t - d->where;
1525  w = d->where;
1526  break;
1527  case DOLSUBTERM:
1528  w = AT.WorkPointer;
1529  size = d->where[1];
1530  *w++ = size+4; t = d->where; NCOPY(w,t,size)
1531  *w++ = 1; *w++ = 1; *w++ = 3;
1532  w = AT.WorkPointer; size = d->where[1]+4;
1533  break;
1534  case DOLINDEX:
1535  w = AT.WorkPointer;
1536  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = d->index;
1537  *w++ = 1; *w++ = 1; *w++ = 3; *w = 0;
1538  w = AT.WorkPointer; size = 7;
1539  break;
1540  case DOLWILDARGS:
1541 /*
1542  In some cases we can make a copy
1543 */
1544  t = d->where+1;
1545  if ( *t == 0 ) return(0);
1546  NEXTARG(t);
1547  if ( *t ) { /* More than one argument in here */
1548  MLOCK(ErrorMessageLock);
1549  MesPrint("Trying to convert a $ with an argument field into an expression");
1550  MUNLOCK(ErrorMessageLock);
1551  Terminate(-1);
1552  }
1553 /*
1554  Now we have a single argument
1555 */
1556  t = d->where+1;
1557  if ( *t < 0 ) goto ShortArgument;
1558  size = *t - ARGHEAD;
1559  w = t + ARGHEAD;
1560  break;
1561  case DOLUNDEFINED:
1562  MLOCK(ErrorMessageLock);
1563  MesPrint("Trying to use an undefined $ in an expression");
1564  MUNLOCK(ErrorMessageLock);
1565  Terminate(-1);
1566  /* fall through */
1567  case DOLZERO:
1568  if ( d->where ) { d->where[0] = 0; }
1569  else d->where = &(AM.dollarzero);
1570  size = 0;
1571  w = d->where;
1572  break;
1573  default:
1574  return(0);
1575  }
1576  newd = (DOLLARS)Malloc1(sizeof(struct DoLlArS)+(size+1)*sizeof(WORD),
1577  "Copy of dollar variable");
1578  t = (WORD *)(newd+1);
1579  newd->where = t;
1580  newd->name = d->name;
1581  newd->node = d->node;
1582  newd->type = DOLTERMS;
1583  newd->size = size;
1584  newd->numdummies = d->numdummies;
1585 #ifdef WITHPTHREADS
1586  newd->pthreadslockread = dummylock;
1587  newd->pthreadslockwrite = dummylock;
1588 #endif
1589  size++;
1590  NCOPY(t,w,size);
1591  newd->nfactors = d->nfactors;
1592  if ( d->nfactors > 1 ) {
1593  newd->factors = (FACDOLLAR *)Malloc1(d->nfactors*sizeof(FACDOLLAR),"Dollar factors");
1594  for ( i = 0; i < d->nfactors; i++ ) {
1595  newd->factors[i].where = 0;
1596  newd->factors[i].size = 0;
1597  newd->factors[i].type = DOLUNDEFINED;
1598  newd->factors[i].value = d->factors[i].value;
1599  }
1600  }
1601  else { newd->factors = 0; }
1602  return(newd);
1603 }
1604 
1605 /*
1606  #] DolToTerms :
1607  #[ DolToLong :
1608 */
1609 
1610 LONG DolToLong(PHEAD WORD numdollar)
1611 {
1612  GETBIDENTITY
1613  DOLLARS d = Dollars + numdollar;
1614  LONG x;
1615 #ifdef WITHPTHREADS
1616  int nummodopt, dtype = -1;
1617  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1618  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1619  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1620  }
1621  if ( nummodopt < NumModOptdollars ) {
1622  dtype = ModOptdollars[nummodopt].type;
1623  if ( dtype == MODLOCAL ) {
1624  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1625  }
1626  }
1627  }
1628 #endif
1629  AN.ErrorInDollar = 0;
1630  if ( ( d->type == DOLTERMS || d->type == DOLNUMBER )
1631  && d->where[0] == 4 &&
1632  d->where[4] == 0 && ( d->where[3] == 3 || d->where[3] == -3 )
1633  && d->where[2] == 1 && ( d->where[1] & TOPBITONLY ) == 0 ) {
1634  x = d->where[1];
1635  if ( d->where[3] > 0 ) return(x);
1636  else return(-x);
1637  }
1638  else if ( ( d->type == DOLTERMS || d->type == DOLNUMBER )
1639  && d->where[0] == 6 &&
1640  d->where[6] == 0 && ( d->where[5] == 5 || d->where[5] == -5 )
1641  && d->where[3] == 1 && d->where[4] == 1 && ( d->where[2] & TOPBITONLY ) == 0 ) {
1642  x = d->where[1] + ( (LONG)(d->where[2]) << BITSINWORD );
1643  if ( d->where[5] > 0 ) return(x);
1644  else return(-x);
1645  }
1646  else if ( d->type == DOLARGUMENT && d->where[0] == -SNUMBER ) {
1647  x = d->where[1];
1648  return(x);
1649  }
1650  else if ( d->type == DOLARGUMENT && d->where[0] == -INDEX
1651  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1652  x = d->where[1];
1653  return(x);
1654  }
1655  else if ( d->type == DOLZERO ) return(0);
1656  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1657  && d->where[1] == -SNUMBER && d->where[3] == 0 ) {
1658  x = d->where[2];
1659  return(x);
1660  }
1661  else if ( d->type == DOLINDEX && d->index >= 0 && d->index < AM.OffsetIndex ) {
1662  x = d->index;
1663  return(x);
1664  }
1665  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1666  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1667  x = d->where[1];
1668  return(x);
1669  }
1670  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1671  && d->where[1] == -INDEX && d->where[3] == 0 && d->where[2] >= 0
1672  && d->where[2] < AM.OffsetIndex ) {
1673  x = d->where[2];
1674  return(x);
1675  }
1676  AN.ErrorInDollar = 1;
1677  return(0);
1678 }
1679 
1680 /*
1681  #] DolToLong :
1682  #[ ExecInside :
1683 */
1684 
1685 int ExecInside(UBYTE *s)
1686 {
1687  GETIDENTITY
1688  UBYTE *t, c;
1689  WORD *w, number;
1690  int error = 0;
1691  w = AT.WorkPointer;
1692  if ( AC.insidelevel >= MAXNEST ) {
1693  MLOCK(ErrorMessageLock);
1694  MesPrint("@Nesting of inside statements more than %d levels",(WORD)MAXNEST);
1695  MUNLOCK(ErrorMessageLock);
1696  return(-1);
1697  }
1698  AC.insidesumcheck[AC.insidelevel] = NestingChecksum();
1699  AC.insidestack[AC.insidelevel] = cbuf[AC.cbufnum].Pointer
1700  - cbuf[AC.cbufnum].Buffer + 2;
1701  AC.insidelevel++;
1702  *w++ = TYPEINSIDE;
1703  w++; w++;
1704  for(;;) { /* Look for a (comma separated) list of dollar variables */
1705  while ( *s == ',' ) s++;
1706  if ( *s == 0 ) break;
1707  if ( *s == '$' ) {
1708  s++; t = s;
1709  if ( FG.cTable[*s] != 0 ) {
1710  MLOCK(ErrorMessageLock);
1711  MesPrint("Illegal name for $ variable: %s",s-1);
1712  MUNLOCK(ErrorMessageLock);
1713  goto skipdol;
1714  }
1715  while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
1716  c = *s; *s = 0;
1717  if ( ( number = GetDollar(t) ) < 0 ) {
1718  number = AddDollar(t,0,0,0);
1719  }
1720  *s = c;
1721  *w++ = number;
1722  AddPotModdollar(number);
1723  }
1724  else {
1725  MLOCK(ErrorMessageLock);
1726  MesPrint("&Illegal object in Inside statement");
1727  MUNLOCK(ErrorMessageLock);
1728 skipdol: error = 1;
1729  while ( *s && *s != ',' && s[1] != '$' ) s++;
1730  if ( *s == 0 ) break;
1731  }
1732  }
1733  AT.WorkPointer[1] = w - AT.WorkPointer;
1734  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
1735  return(error);
1736 }
1737 
1738 /*
1739  #] ExecInside :
1740  #[ InsideDollar :
1741 
1742  Execution part of Inside $a;
1743  We have to take the variables one by one and then
1744  convert them into proper terms and call Generator for the proper levels.
1745  The conversion copies the whole dollar into a new buffer, making us
1746  insensitive to redefinitions of $a inside the Inside.
1747  In the end we sort and redefine $a.
1748 */
1749 
1750 int InsideDollar(PHEAD WORD *ll, WORD level)
1751 {
1752  GETBIDENTITY
1753  int numvar = (int)(ll[1]-3), j, error = 0;
1754  WORD numdol, *oldcterm, *oldwork = AT.WorkPointer, olddefer, *r, *m;
1755  WORD oldnumlhs, *dbuffer;
1756  DOLLARS d, newd;
1757  oldcterm = AN.cTerm; AN.cTerm = 0;
1758  oldnumlhs = AR.Cnumlhs; AR.Cnumlhs = ll[2];
1759  ll += 3;
1760  olddefer = AR.DeferFlag;
1761  AR.DeferFlag = 0;
1762  while ( --numvar >= 0 ) {
1763  numdol = *ll++;
1764  d = Dollars + numdol;
1765  {
1766 #ifdef WITHPTHREADS
1767  int nummodopt, dtype = -1;
1768  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1769  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1770  if ( numdol == ModOptdollars[nummodopt].number ) break;
1771  }
1772  if ( nummodopt < NumModOptdollars ) {
1773  dtype = ModOptdollars[nummodopt].type;
1774  if ( dtype == MODLOCAL ) {
1775  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1776  }
1777  else {
1778 /* LOCK(d->pthreadslockwrite); */
1779  LOCK(d->pthreadslockread);
1780  }
1781  }
1782  }
1783 #endif
1784  newd = DolToTerms(BHEAD numdol);
1785  if ( newd == 0 || newd->where[0] == 0 ) continue;
1786  r = newd->where;
1787  NewSort(BHEAD0);
1788  while ( *r ) { /* Sum over the terms */
1789  m = AT.WorkPointer;
1790  j = *r;
1791  while ( --j >= 0 ) *m++ = *r++;
1792  AT.WorkPointer = m;
1793 /*
1794  What to do with dummy indices?
1795 */
1796  if ( Generator(BHEAD oldwork,level) ) {
1797  LowerSortLevel();
1798  error = -1; goto idcall;
1799  }
1800  AT.WorkPointer = oldwork;
1801  }
1802  AN.tryterm = 0; /* for now */
1803  if ( EndSort(BHEAD (WORD *)((VOID *)(&dbuffer)),2) < 0 ) { error = 1; break; }
1804  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"old buffer of dollar");
1805  d->where = dbuffer;
1806  if ( dbuffer == 0 || *dbuffer == 0 ) {
1807  d->type = DOLZERO;
1808  if ( dbuffer ) M_free(dbuffer,"buffer of dollar");
1809  d->where = &(AM.dollarzero); d->size = 0;
1810  }
1811  else {
1812  d->type = DOLTERMS;
1813  r = d->where; while ( *r ) r += *r;
1814  d->size = (r-d->where)+1;
1815  }
1816 /* cbuf[AM.dbufnum].rhs[numdol] = d->where; */
1817  cbuf[AM.dbufnum].rhs[numdol] = (WORD *)(1);
1818 /*
1819  Now we have a little cleaning up to do
1820 */
1821 #ifdef WITHPTHREADS
1822  if ( dtype > 0 && dtype != MODLOCAL ) {
1823 /* UNLOCK(d->pthreadslockwrite); */
1824  UNLOCK(d->pthreadslockread);
1825  }
1826 #endif
1827  if ( newd->factors ) M_free(newd->factors,"Dollar factors");
1828  M_free(newd,"Copy of dollar variable");
1829  }
1830  }
1831 idcall:;
1832  AR.Cnumlhs = oldnumlhs;
1833  AR.DeferFlag = olddefer;
1834  AN.cTerm = oldcterm;
1835  AT.WorkPointer = oldwork;
1836  return(error);
1837 }
1838 
1839 /*
1840  #] InsideDollar :
1841  #[ ExchangeDollars :
1842 */
1843 
1844 void ExchangeDollars(int num1, int num2)
1845 {
1846  DOLLARS d1, d2;
1847  WORD node1, node2;
1848  LONG nam;
1849  d1 = Dollars + num1; node1 = d1->node;
1850  d2 = Dollars + num2; node2 = d2->node;
1851  nam = d1->name; d1->name = d2->name; d2->name = nam;
1852  d1->node = node2; d2->node = node1;
1853  AC.dollarnames->namenode[node1].number = num2;
1854  AC.dollarnames->namenode[node2].number = num1;
1855 }
1856 
1857 /*
1858  #] ExchangeDollars :
1859  #[ TermsInDollar :
1860 */
1861 
1862 LONG TermsInDollar(WORD num)
1863 {
1864  GETIDENTITY
1865  DOLLARS d = Dollars + num;
1866  WORD *t;
1867  LONG n;
1868 #ifdef WITHPTHREADS
1869  int nummodopt, dtype = -1;
1870  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1871  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1872  if ( num == ModOptdollars[nummodopt].number ) break;
1873  }
1874  if ( nummodopt < NumModOptdollars ) {
1875  dtype = ModOptdollars[nummodopt].type;
1876  if ( dtype == MODLOCAL ) {
1877  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1878  }
1879  else {
1880  LOCK(d->pthreadslockread);
1881  }
1882  }
1883  }
1884 #endif
1885  if ( d->type == DOLTERMS ) {
1886  n = 0;
1887  t = d->where;
1888  while ( *t ) { t += *t; n++; }
1889  }
1890  else if ( d->type == DOLWILDARGS ) {
1891  n = 0;
1892  if ( d->where[0] == 0 ) {
1893  t = d->where+1;
1894  while ( *t != 0 ) { NEXTARG(t); n++; }
1895  }
1896  else if ( d->where[0] == 1 ) n = 1;
1897  }
1898  else if ( d->type == DOLZERO ) n = 0;
1899  else n = 1;
1900 #ifdef WITHPTHREADS
1901  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1902 #endif
1903  return(n);
1904 }
1905 
1906 /*
1907  #] TermsInDollar :
1908  #[ SizeOfDollar :
1909 */
1910 
1911 LONG SizeOfDollar(WORD num)
1912 {
1913  GETIDENTITY
1914  DOLLARS d = Dollars + num;
1915  WORD *t;
1916  LONG n;
1917 #ifdef WITHPTHREADS
1918  int nummodopt, dtype = -1;
1919  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1920  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1921  if ( num == ModOptdollars[nummodopt].number ) break;
1922  }
1923  if ( nummodopt < NumModOptdollars ) {
1924  dtype = ModOptdollars[nummodopt].type;
1925  if ( dtype == MODLOCAL ) {
1926  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1927  }
1928  else {
1929  LOCK(d->pthreadslockread);
1930  }
1931  }
1932  }
1933 #endif
1934  if ( d->type == DOLTERMS ) {
1935  t = d->where;
1936  while ( *t ) t += *t;
1937  t++;
1938  n = (LONG)(t - d->where);
1939  }
1940  else if ( d->type == DOLWILDARGS ) {
1941  n = 0;
1942  if ( d->where[0] == 0 ) {
1943  t = d->where+1;
1944  while ( *t != 0 ) { NEXTARG(t); n++; }
1945  t++;
1946  n = (LONG)(t - d->where);
1947  }
1948  else if ( d->where[0] == 1 ) n = 1;
1949  }
1950  else if ( d->type == DOLZERO ) n = 0;
1951  else n = 1;
1952 #ifdef WITHPTHREADS
1953  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1954 #endif
1955  return(n);
1956 }
1957 
1958 /*
1959  #] SizeOfDollar :
1960  #[ PreIfDollarEval :
1961 
1962  Routine is invoked in #if etc after $( is encountered.
1963  $(expr1 operator expr2) makes compares between expressions,
1964  $(expr1 operator _keyword) makes compares between expressions,
1965  interpreted as expressions. We are here mainly looking at $variables.
1966  First we look for the operator:
1967  >, <, ==, >=, <=, != : < means that it comes before.
1968  _keywords can be:
1969  _set(setname) (does the expr belong to the set (only with == or !=))
1970  _productof(expr)
1971 */
1972 
1973 UBYTE *PreIfDollarEval(UBYTE *s, int *value)
1974 {
1975  GETIDENTITY
1976  UBYTE *s1,*s2,*s3,*s4,*s5,*t,c,c1,c2,c3;
1977  int oprtr, type;
1978  WORD *buf1 = 0, *buf2 = 0, numset, *oldwork = AT.WorkPointer;
1979  EXCHINOUT
1980 /*
1981  Find the three composing objects (epxression, operator, expression or keyw
1982 */
1983  while ( *s == ' ' || *s == '\t' || *s == '\n' || *s == '\r' ) s++;
1984  s1 = t = s;
1985  while ( *t != '=' && *t != '!' && *t != '>' && *t != '<' ) {
1986  if ( *t == '[' ) { SKIPBRA1(t) }
1987  else if ( *t == '{' ) { SKIPBRA2(t) }
1988  else if ( *t == '(' ) { SKIPBRA3(t) }
1989  else if ( *t == ']' || *t == '}' || *t == ')' ) {
1990  MLOCK(ErrorMessageLock);
1991  MesPrint("@Improper bracketting in #if");
1992  MUNLOCK(ErrorMessageLock);
1993  goto onerror;
1994  }
1995  t++;
1996  }
1997  s2 = t;
1998  while ( *t == '=' || *t == '!' || *t == '>' || *t == '<' ) t++;
1999  s3 = t;
2000  while ( *t && *t != ')' ) {
2001  if ( *t == '[' ) { SKIPBRA1(t) }
2002  else if ( *t == '{' ) { SKIPBRA2(t) }
2003  else if ( *t == '(' ) { SKIPBRA3(t) }
2004  else if ( *t == ']' || *t == '}' ) {
2005  MLOCK(ErrorMessageLock);
2006  MesPrint("@Improper brackets in #if");
2007  MUNLOCK(ErrorMessageLock);
2008  goto onerror;
2009  }
2010  t++;
2011  }
2012  if ( *t == 0 ) {
2013  MLOCK(ErrorMessageLock);
2014  MesPrint("@Missing ) to match $( in #if");
2015  MUNLOCK(ErrorMessageLock);
2016  goto onerror;
2017  }
2018  s4 = t; c2 = *s4; *s4 = 0;
2019  if ( s2+2 < s3 || s2 == s3 ) {
2020 IllOp:;
2021  MLOCK(ErrorMessageLock);
2022  MesPrint("@Illegal operator in $( option of #if");
2023  MUNLOCK(ErrorMessageLock);
2024  goto onerror;
2025  }
2026  if ( s2+1 == s3 ) {
2027  if ( *s2 == '=' ) oprtr = EQUAL;
2028  else if ( *s2 == '>' ) oprtr = GREATER;
2029  else if ( *s2 == '<' ) oprtr = LESS;
2030  else goto IllOp;
2031  }
2032  else if ( *s2 == '!' && s2[1] == '=' ) oprtr = NOTEQUAL;
2033  else if ( *s2 == '=' && s2[1] == '=' ) oprtr = EQUAL;
2034  else if ( *s2 == '<' && s2[1] == '=' ) oprtr = LESSEQUAL;
2035  else if ( *s2 == '>' && s2[1] == '=' ) oprtr = GREATEREQUAL;
2036  else goto IllOp;
2037  c1 = *s2; *s2 = 0;
2038 /*
2039  The two expressions are now zero terminated
2040  Look for the special keywords
2041 */
2042  while ( *s3 == ' ' || *s3 == '\t' || *s3 == '\n' || *s3 == '\r' ) s3++;
2043  t = s3;
2044  while ( chartype[*t] == 0 ) t++;
2045  if ( *t == '_' ) {
2046  t++; c = *t; *t = 0;
2047  if ( StrICmp(s3,(UBYTE *)"set_") == 0 ) {
2048  if ( oprtr != EQUAL && oprtr != NOTEQUAL ) {
2049 ImpOp:;
2050  MLOCK(ErrorMessageLock);
2051  MesPrint("@Improper operator for special keyword in $( ) option");
2052  MUNLOCK(ErrorMessageLock);
2053  goto onerror;
2054  }
2055  type = 1;
2056  }
2057  else if ( StrICmp(s3,(UBYTE *)"multipleof_") == 0 ) {
2058  if ( oprtr != EQUAL && oprtr != NOTEQUAL ) goto ImpOp;
2059  type = 2;
2060  }
2061 /*
2062  else if ( StrICmp(s3,(UBYTE *)"productof_") == 0 ) {
2063  if ( oprtr != EQUAL && oprtr != NOTEQUAL ) goto ImpOp;
2064  type = 3;
2065  }
2066 */
2067  else type = 0;
2068  }
2069  else { type = 0; c = *t; }
2070  if ( type > 0 ) {
2071  *t++ = c; s3 = t; s5 = s4-1;
2072  while ( *s5 != ')' ) {
2073  if ( *s5 == ' ' || *s5 == '\t' || *s5 == '\n' || *s5 == '\r' ) s5--;
2074  else {
2075  MLOCK(ErrorMessageLock);
2076  MesPrint("@Improper use of special keyword in $( ) option");
2077  MUNLOCK(ErrorMessageLock);
2078  goto onerror;
2079  }
2080  }
2081  c3 = *s5; *s5 = 0;
2082  }
2083  else { c3 = c2; s5 = s4; }
2084 /*
2085  Expand the first expression.
2086 */
2087  if ( ( buf1 = TranslateExpression(s1) ) == 0 ) {
2088  AT.WorkPointer = oldwork;
2089  goto onerror;
2090  }
2091  if ( type == 1 ) { /* determine the set */
2092  if ( *s3 == '{' ) {
2093  t = s3+1;
2094  SKIPBRA2(s3)
2095  numset = DoTempSet(t,s3);
2096  s3++;
2097  if ( numset < 0 ) {
2098 noset:;
2099  MLOCK(ErrorMessageLock);
2100  MesPrint("@Argument of set_ is not a valid set");
2101  MUNLOCK(ErrorMessageLock);
2102  goto onerror;
2103  }
2104  }
2105  else {
2106  t = s3;
2107  while ( FG.cTable[*s3] == 0 || FG.cTable[*s3] == 1
2108  || *s3 == '_' ) s3++;
2109  c = *s3; *s3 = 0;
2110  if ( GetName(AC.varnames,t,&numset,NOAUTO) != CSET ) {
2111  *s3 = c; goto noset;
2112  }
2113  *s3 = c;
2114  }
2115  while ( *s3 == ' ' || *s3 == '\t' || *s3 == '\n' || *s3 == '\r' ) s3++;
2116  if ( s3 != s5 ) goto noset;
2117  *value = IsSetMember(buf1,numset);
2118  if ( oprtr == NOTEQUAL ) *value ^= 1;
2119  }
2120  else {
2121  if ( ( buf2 = TranslateExpression(s3) ) == 0 ) goto onerror;
2122  }
2123  if ( type == 0 ) {
2124  *value = TwoExprCompare(buf1,buf2,oprtr);
2125  }
2126  else if ( type == 2 ) {
2127  *value = IsMultipleOf(buf1,buf2);
2128  if ( oprtr == NOTEQUAL ) *value ^= 1;
2129  }
2130 /*
2131  else if ( type == 3 ) {
2132  *value = IsProductOf(buf1,buf2);
2133  if ( oprtr == NOTEQUAL ) *value ^= 1;
2134  }
2135 */
2136  if ( buf1 ) M_free(buf1,"Buffer in $()");
2137  if ( buf2 ) M_free(buf2,"Buffer in $()");
2138  *s5 = c3; *s4++ = c2; *s2 = c1;
2139  AT.WorkPointer = oldwork;
2140  BACKINOUT
2141  return(s4);
2142 onerror:
2143  if ( buf1 ) M_free(buf1,"Buffer in $()");
2144  if ( buf2 ) M_free(buf2,"Buffer in $()");
2145  AT.WorkPointer = oldwork;
2146  BACKINOUT
2147  return(0);
2148 }
2149 
2150 /*
2151  #] PreIfDollarEval :
2152  #[ TranslateExpression :
2153 */
2154 
2155 WORD *TranslateExpression(UBYTE *s)
2156 {
2157  GETIDENTITY
2158  CBUF *C = cbuf+AC.cbufnum;
2159  WORD oldnumrhs = C->numrhs;
2160  LONG oldcpointer = C->Pointer - C->Buffer;
2161  WORD *w = AT.WorkPointer;
2162  WORD retcode, oldEside;
2163  WORD *outbuffer;
2164  *w++ = SUBEXPSIZE + 4;
2165  AC.ProtoType = w;
2166  *w++ = SUBEXPRESSION;
2167  *w++ = SUBEXPSIZE;
2168  *w++ = C->numrhs+1;
2169  *w++ = 1;
2170  *w++ = AC.cbufnum;
2171  FILLSUB(w)
2172  *w++ = 1; *w++ = 1; *w++ = 3; *w++ = 0;
2173  AT.WorkPointer = w;
2174  if ( ( retcode = CompileAlgebra(s,RHSIDE,AC.ProtoType) ) < 0 ) {
2175  MLOCK(ErrorMessageLock);
2176  MesPrint("@Error translating first expression in $( ) option");
2177  MUNLOCK(ErrorMessageLock);
2178  return(0);
2179  }
2180  else { AC.ProtoType[2] = retcode; }
2181 /*
2182  Evaluate this expression
2183 */
2184  if ( NewSort(BHEAD0) || NewSort(BHEAD0) ) { return(0); }
2185  AN.RepPoint = AT.RepCount + 1;
2186  oldEside = AR.Eside; AR.Eside = RHSIDE;
2187  AR.Cnumlhs = C->numlhs;
2188  if ( Generator(BHEAD AC.ProtoType-1,C->numlhs) ) {
2189  AR.Eside = oldEside;
2190  LowerSortLevel(); LowerSortLevel(); return(0);
2191  }
2192  AR.Eside = oldEside;
2193  AT.WorkPointer = w;
2194  AN.tryterm = 0; /* for now */
2195  if ( EndSort(BHEAD (WORD *)((VOID *)(&outbuffer)),2) < 0 ) { LowerSortLevel(); return(0); }
2196  LowerSortLevel();
2197  C->Pointer = C->Buffer + oldcpointer;
2198  C->numrhs = oldnumrhs;
2199  AT.WorkPointer = AC.ProtoType - 1;
2200  return(outbuffer);
2201 }
2202 
2203 /*
2204  #] TranslateExpression :
2205  #[ IsSetMember :
2206 
2207  Checks whether the expression in the buffer can be seen as an element
2208  of the given set.
2209  For the special sets: if more than one term: no match!!!
2210 */
2211 
2212 int IsSetMember(WORD *buffer, WORD numset)
2213 {
2214  WORD *t = buffer, *tt, num, csize, num1;
2215  WORD bufterm[4];
2216  int i, j, type;
2217  if ( numset < AM.NumFixedSets ) {
2218  if ( t[*t] != 0 ) return(0); /* More than one term */
2219  if ( *t == 0 ) {
2220  if ( numset == POS0_ || numset == NEG0_ || numset == EVEN_
2221  || numset == Z_ || numset == Q_ ) return(1);
2222  else return(0);
2223  }
2224  if ( numset == SYMBOL_ ) {
2225  if ( *t == 8 && t[1] == SYMBOL && t[7] == 3 && t[6] == 1
2226  && t[5] == 1 && t[4] == 1 ) return(1);
2227  else return(0);
2228  }
2229  if ( numset == INDEX_ ) {
2230  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2231  && t[4] == 1 && t[3] > 0 ) return(1);
2232  if ( *t == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex)
2233  return(1);
2234  return(0);
2235  }
2236  if ( numset == FIXED_ ) {
2237  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2238  && t[4] == 1 && t[3] > 0 && t[3] < AM.OffsetIndex ) return(1);
2239  if ( *t == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex)
2240  return(1);
2241  return(0);
2242  }
2243  if ( numset == DUMMYINDEX_ ) {
2244  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2245  && t[4] == 1 && t[3] >= AM.IndDum && t[3] < AM.IndDum+MAXDUMMIES ) return(1);
2246  if ( *t == 4 && t[3] == 3 && t[2] == 1
2247  && t[1] >= AM.IndDum && t[1] < AM.IndDum+MAXDUMMIES ) return(1);
2248  return(0);
2249  }
2250  if ( numset == VECTOR_ ) {
2251  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2252  && t[4] == 1 && t[3] < (AM.OffsetVector+WILDOFFSET) && t[3] >= AM.OffsetVector ) return(1);
2253  return(0);
2254  }
2255  tt = t + *t - 1;
2256  if ( ABS(tt[0]) != *t-1 ) return(0);
2257  if ( numset == Q_ ) return(1);
2258  if ( numset == POS_ || numset == POS0_ ) return(tt[0]>0);
2259  else if ( numset == NEG_ || numset == NEG0_ ) return(tt[0]<0);
2260  i = (ABS(tt[0])-1)/2;
2261  tt -= i;
2262  if ( tt[0] != 1 ) return(0);
2263  for ( j = 1; j < i; j++ ) { if ( tt[j] != 0 ) return(0); }
2264  if ( numset == Z_ ) return(1);
2265  if ( numset == ODD_ ) return(t[1]&1);
2266  if ( numset == EVEN_ ) return(1-(t[1]&1));
2267  return(0);
2268  }
2269  if ( t[*t] != 0 ) return(0); /* More than one term */
2270  type = Sets[numset].type;
2271  switch ( type ) {
2272  case CSYMBOL:
2273  if ( t[0] == 8 && t[1] == SYMBOL && t[7] == 3 && t[6] == 1
2274  && t[5] == 1 && t[4] == 1 ) {
2275  num = t[3];
2276  }
2277  else if ( t[0] == 4 && t[2] == 1 && t[1] <= MAXPOWER ) {
2278  num = t[1];
2279  if ( t[3] < 0 ) num = -num;
2280  num += 2*MAXPOWER;
2281  }
2282  else return(0);
2283  break;
2284  case CVECTOR:
2285  if ( t[0] == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2286  && t[4] == 1 && t[3] < 0 ) {
2287  num = t[3];
2288  }
2289  else return(0);
2290  break;
2291  case CINDEX:
2292  if ( t[0] == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2293  && t[4] == 1 && t[3] > 0 ) {
2294  num = t[3];
2295  }
2296  else if ( t[0] == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex ) {
2297  num = t[1];
2298  }
2299  else return(0);
2300  break;
2301  case CFUNCTION:
2302  if ( t[0] == 4+FUNHEAD && t[3+FUNHEAD] == 3 && t[2+FUNHEAD] == 1
2303  && t[1+FUNHEAD] == 1 && t[1] >= FUNCTION ) {
2304  num = t[1];
2305  }
2306  else return(0);
2307  break;
2308  case CNUMBER:
2309  if ( t[0] == 4 && t[2] == 1 && t[1] <= AM.OffsetIndex && t[3] == 3 ) {
2310  num = t[1];
2311  }
2312  else return(0);
2313  break;
2314  case CRANGE:
2315  csize = t[t[0]-1];
2316  csize = ABS(csize);
2317  if ( csize != t[0]-1 ) return(0);
2318  if ( Sets[numset].first < 3*MAXPOWER ) {
2319  num1 = num = Sets[numset].first;
2320  if ( num >= MAXPOWER ) num -= 2*MAXPOWER;
2321  if ( num == 0 ) {
2322  if ( num1 < MAXPOWER ) {
2323  if ( t[t[0]-1] >= 0 ) return(0);
2324  }
2325  else if ( t[t[0]-1] > 0 ) return(0);
2326  }
2327  else {
2328  bufterm[0] = 4; bufterm[1] = ABS(num);
2329  bufterm[2] = 1;
2330  if ( num < 0 ) bufterm[3] = -3;
2331  else bufterm[3] = 3;
2332  num = CompCoef(t,bufterm);
2333  if ( num1 < MAXPOWER ) {
2334  if ( num >= 0 ) return(0);
2335  }
2336  else if ( num > 0 ) return(0);
2337  }
2338  }
2339  if ( Sets[numset].last > -3*MAXPOWER ) {
2340  num1 = num = Sets[numset].last;
2341  if ( num <= -MAXPOWER ) num += 2*MAXPOWER;
2342  if ( num == 0 ) {
2343  if ( num1 > -MAXPOWER ) {
2344  if ( t[t[0]-1] <= 0 ) return(0);
2345  }
2346  else if ( t[t[0]-1] < 0 ) return(0);
2347  }
2348  else {
2349  bufterm[0] = 4; bufterm[1] = ABS(num);
2350  bufterm[2] = 1;
2351  if ( num < 0 ) bufterm[3] = -3;
2352  else bufterm[3] = 3;
2353  num = CompCoef(t,bufterm);
2354  if ( num1 > -MAXPOWER ) {
2355  if ( num <= 0 ) return(0);
2356  }
2357  else if ( num < 0 ) return(0);
2358  }
2359  }
2360  return(1);
2361  break;
2362  default: return(0);
2363  }
2364  t = SetElements + Sets[numset].first;
2365  tt = SetElements + Sets[numset].last;
2366  do {
2367  if ( num == *t ) return(1);
2368  t++;
2369  } while ( t < tt );
2370  return(0);
2371 }
2372 
2373 /*
2374  #] IsSetMember :
2375  #[ IsProductOf :
2376 
2377  Checks whether the expression in buf1 is a single term multiple of
2378  the expression in buf2.
2379 
2380 int IsProductOf(WORD *buf1, WORD *buf2)
2381 {
2382  return(0);
2383 }
2384 
2385 
2386  #] IsProductOf :
2387  #[ IsMultipleOf :
2388 
2389  Checks whether the expression in buf1 is a numerical multiple of
2390  the expression in buf2.
2391 */
2392 
2393 int IsMultipleOf(WORD *buf1, WORD *buf2)
2394 {
2395  GETIDENTITY
2396  LONG num1, num2;
2397  WORD *t1, *t2, *m1, *m2, *r1, *r2, nc1, nc2, ni1, ni2;
2398  UWORD *IfScrat1, *IfScrat2;
2399  int i, j;
2400  if ( *buf1 == 0 && *buf2 == 0 ) return(1);
2401 /*
2402  First count terms
2403 */
2404  t1 = buf1; t2 = buf2; num1 = 0; num2 = 0;
2405  while ( *t1 ) { t1 += *t1; num1++; }
2406  while ( *t2 ) { t2 += *t2; num2++; }
2407  if ( num1 != num2 ) return(0);
2408 /*
2409  Test similarity of terms. Difference up to a number.
2410 */
2411  t1 = buf1; t2 = buf2;
2412  while ( *t1 ) {
2413  m1 = t1+1; m2 = t2+1; t1 += *t1; t2 += *t2;
2414  r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2415  if ( r1-m1 != r2-m2 ) return(0);
2416  while ( m1 < r1 ) {
2417  if ( *m1 != *m2 ) return(0);
2418  m1++; m2++;
2419  }
2420  }
2421 /*
2422  Now we have to test the constant factor
2423 */
2424  IfScrat1 = (UWORD *)(TermMalloc("IsMultipleOf")); IfScrat2 = (UWORD *)(TermMalloc("IsMultipleOf"));
2425  t1 = buf1; t2 = buf2;
2426  t1 += *t1; t2 += *t2;
2427  if ( *t1 == 0 && *t2 == 0 ) return(1);
2428  r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2429  nc1 = REDLENG(t1[-1]); nc2 = REDLENG(t2[-1]);
2430  if ( DivRat(BHEAD (UWORD *)r1,nc1,(UWORD *)r2,nc2,IfScrat1,&ni1) ) {
2431  MLOCK(ErrorMessageLock);
2432  MesPrint("@Called from MultipleOf in $( )");
2433  MUNLOCK(ErrorMessageLock);
2434  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2435  Terminate(-1);
2436  }
2437  while ( *t1 ) {
2438  t1 += *t1; t2 += *t2;
2439  r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2440  nc1 = REDLENG(t1[-1]); nc2 = REDLENG(t2[-1]);
2441  if ( DivRat(BHEAD (UWORD *)r1,nc1,(UWORD *)r2,nc2,IfScrat2,&ni2) ) {
2442  MLOCK(ErrorMessageLock);
2443  MesPrint("@Called from MultipleOf in $( )");
2444  MUNLOCK(ErrorMessageLock);
2445  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2446  Terminate(-1);
2447  }
2448  if ( ni1 != ni2 ) return(0);
2449  i = 2*ABS(ni1);
2450  for ( j = 0; j < i; j++ ) {
2451  if ( IfScrat1[j] != IfScrat2[j] ) {
2452  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2453  return(0);
2454  }
2455  }
2456  }
2457  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2458  return(1);
2459 }
2460 
2461 /*
2462  #] IsMultipleOf :
2463  #[ TwoExprCompare :
2464 
2465  Compares the expressions in buf1 and buf2 according to oprtr
2466 */
2467 
2468 int TwoExprCompare(WORD *buf1, WORD *buf2, int oprtr)
2469 {
2470  GETIDENTITY
2471  WORD *t1, *t2, cond;
2472  t1 = buf1; t2 = buf2;
2473  while ( *t1 && *t2 ) {
2474  cond = CompareTerms(t1,t2,1);
2475  if ( cond != 0 ) {
2476  if ( cond > 0 ) { /* t1 comes first */
2477  switch ( oprtr ) { /* t1 is less */
2478  case EQUAL: return(0);
2479  case NOTEQUAL: return(1);
2480  case GREATEREQUAL: return(0);
2481  case GREATER: return(0);
2482  case LESS: return(1);
2483  case LESSEQUAL: return(1);
2484  }
2485  }
2486  else {
2487  switch ( oprtr ) {
2488  case EQUAL: return(0);
2489  case NOTEQUAL: return(1);
2490  case GREATEREQUAL: return(1);
2491  case GREATER: return(1);
2492  case LESS: return(0);
2493  case LESSEQUAL: return(0);
2494  }
2495  }
2496  }
2497  t1 += *t1; t2 += *t2;
2498  }
2499  if ( *t1 == *t2 ) { /* They are equal */
2500  switch ( oprtr ) {
2501  case EQUAL: return(1);
2502  case NOTEQUAL: return(0);
2503  case GREATEREQUAL: return(1);
2504  case GREATER: return(0);
2505  case LESS: return(0);
2506  case LESSEQUAL: return(1);
2507  }
2508  }
2509  else if ( *t1 ) { /* t1 is greater */
2510  switch ( oprtr ) {
2511  case EQUAL: return(0);
2512  case NOTEQUAL: return(1);
2513  case GREATEREQUAL: return(1);
2514  case GREATER: return(1);
2515  case LESS: return(0);
2516  case LESSEQUAL: return(0);
2517  }
2518  }
2519  else {
2520  switch ( oprtr ) { /* t1 is less */
2521  case EQUAL: return(0);
2522  case NOTEQUAL: return(1);
2523  case GREATEREQUAL: return(0);
2524  case GREATER: return(0);
2525  case LESS: return(1);
2526  case LESSEQUAL: return(1);
2527  }
2528  }
2529  MLOCK(ErrorMessageLock);
2530  MesPrint("@Internal problems with operator in $( )");
2531  MUNLOCK(ErrorMessageLock);
2532  Terminate(-1);
2533  return(0);
2534 }
2535 
2536 /*
2537  #] TwoExprCompare :
2538  #[ DollarRaiseLow :
2539 
2540  Raises or lowers the numerical value of a dollar variable
2541  Not to be used in parallel.
2542 */
2543 
2544 static UWORD *dscrat = 0;
2545 static WORD ndscrat;
2546 
2547 int DollarRaiseLow(UBYTE *name, LONG value)
2548 {
2549  GETIDENTITY
2550  int num;
2551  DOLLARS d;
2552  int sgn = 1;
2553  WORD lnum[4], nnum, *t1, *t2, i;
2554  UBYTE *s, c;
2555  s = name; while ( *s ) s++;
2556  if ( s[-1] == '-' && s[-2] == '-' && s > name+2 ) s -= 2;
2557  else if ( s[-1] == '+' && s[-2] == '+' && s > name+2 ) s -= 2;
2558  c = *s; *s = 0;
2559  num = GetDollar(name);
2560  *s = c;
2561  d = Dollars + num;
2562  if ( value < 0 ) { value = -value; sgn = -1; }
2563  if ( d->type == DOLZERO ) {
2564  if ( d->where ) M_free(d->where,"DollarRaiseLow");
2565  d->size = MINALLOC;
2566  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"DollarRaiseLow");
2567  if ( ( value & AWORDMASK ) != 0 ) {
2568  d->where[0] = 6; d->where[1] = value >> BITSINWORD;
2569  d->where[2] = (WORD)value; d->where[3] = 1; d->where[4] = 0;
2570  d->where[5] = 5*sgn; d->where[6] = 0;
2571  d->type = DOLTERMS;
2572  }
2573  else {
2574  d->where[0] = 4; d->where[1] = (WORD)value; d->where[2] = 1;
2575  d->where[3] = 3*sgn; d->where[4] = 0;
2576  d->type = DOLNUMBER;
2577  }
2578  }
2579  else if ( d->type == DOLNUMBER || ( d->type == DOLTERMS
2580  && d->where[d->where[0]] == 0
2581  && d->where[0] == ABS(d->where[d->where[0]-1])+1 ) ) {
2582  if ( ( value & AWORDMASK ) != 0 ) {
2583  lnum[0] = value >> BITSINWORD;
2584  lnum[1] = (WORD)value; lnum[2] = 1; lnum[3] = 0;
2585  nnum = 2*sgn;
2586  }
2587  else {
2588  lnum[0] = (WORD)value; lnum[1] = 1; nnum = sgn;
2589  }
2590  i = d->where[d->where[0]-1];
2591  i = REDLENG(i);
2592  if ( dscrat == 0 ) {
2593  dscrat = (UWORD *)Malloc1((AM.MaxTal+2)*sizeof(UWORD),"DollarRaiseLow");
2594  }
2595  if ( AddRat(BHEAD (UWORD *)(d->where+1),i,
2596  (UWORD *)lnum,nnum,dscrat,&ndscrat) ) {
2597  MLOCK(ErrorMessageLock);
2598  MesCall("DollarRaiseLow");
2599  MUNLOCK(ErrorMessageLock);
2600  Terminate(-1);
2601  }
2602  ndscrat = INCLENG(ndscrat);
2603  i = ABS(ndscrat);
2604  if ( i == 0 ) {
2605  M_free(d->where,"DollarRaiseLow");
2606  d->where = 0;
2607  d->type = DOLZERO;
2608  d->size = 0;
2609  return(0);
2610  }
2611  if ( i+2 > d->size ) {
2612  M_free(d->where,"DollarRaiseLow");
2613  d->size = i+2;
2614  if ( d->size < MINALLOC ) d->size = MINALLOC;
2615  d->size = ((d->size+7)/8)*8;
2616  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"DollarRaiseLow");
2617  }
2618  t1 = d->where; *t1++ = i+1; t2 = (WORD *)dscrat;
2619  while ( --i > 0 ) *t1++ = *t2++;
2620  *t1++ = ndscrat; *t1 = 0;
2621  d->type = DOLTERMS;
2622  }
2623  return(0);
2624 }
2625 
2626 /*
2627  #] DollarRaiseLow :
2628  #[ EvalDoLoopArg :
2629 */
2646 WORD EvalDoLoopArg(PHEAD WORD *arg, WORD par)
2647 {
2648  WORD num, type, *td;
2649  DOLLARS d;
2650  if ( *arg == SNUMBER ) return(arg[1]);
2651  if ( *arg == DOLLAREXPR2 && arg[1] < 0 ) return(-arg[1]-1);
2652  d = Dollars + arg[1];
2653 #ifdef WITHPTHREADS
2654  {
2655  int nummodopt, dtype = -1;
2656  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2657  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2658  if ( arg[1] == ModOptdollars[nummodopt].number ) break;
2659  }
2660  if ( nummodopt < NumModOptdollars ) {
2661  dtype = ModOptdollars[nummodopt].type;
2662  if ( dtype == MODLOCAL ) {
2663  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2664  }
2665  }
2666  }
2667  }
2668 #endif
2669  if ( *arg == DOLLAREXPRESSION ) {
2670  if ( arg[2] != DOLLAREXPR2 ) { /* end of chain */
2671 endofchain:
2672  type = d->type;
2673  if ( type == DOLZERO ) {}
2674  else if ( type == DOLNUMBER ) {
2675  td = d->where;
2676  if ( ( td[0] != 4 ) || ( (td[1]&SPECMASK) != 0 ) || ( td[2] != 1 ) ) {
2677  MLOCK(ErrorMessageLock);
2678  if ( par == -1 ) {
2679  MesPrint("$-variable is not a short number in print statement");
2680  }
2681  else {
2682  MesPrint("$-variable is not a short number in do loop");
2683  }
2684  MUNLOCK(ErrorMessageLock);
2685  Terminate(-1);
2686  }
2687  return( td[3] > 0 ? td[1]: -td[1] );
2688  }
2689  else {
2690  MLOCK(ErrorMessageLock);
2691  if ( par == -1 ) {
2692  MesPrint("$-variable is not a number in print statement");
2693  }
2694  else {
2695  MesPrint("$-variable is not a number in do loop");
2696  }
2697  MUNLOCK(ErrorMessageLock);
2698  Terminate(-1);
2699  }
2700  return(0);
2701  }
2702  num = EvalDoLoopArg(BHEAD arg+2,par);
2703  }
2704  else if ( *arg == DOLLAREXPR2 ) {
2705  if ( arg[1] < 0 ) { num = -arg[1]-1; }
2706  else if ( arg[2] != DOLLAREXPR2 && par == -1 ) {
2707  goto endofchain;
2708  }
2709  else { num = EvalDoLoopArg(BHEAD arg+2,par); }
2710  }
2711  else {
2712  MLOCK(ErrorMessageLock);
2713  if ( par == -1 ) {
2714  MesPrint("Invalid $-variable in print statement");
2715  }
2716  else {
2717  MesPrint("Invalid $-variable in do loop");
2718  }
2719  MUNLOCK(ErrorMessageLock);
2720  Terminate(-1);
2721  return(0);
2722  }
2723  if ( num == 0 ) return(d->nfactors);
2724  if ( num > d->nfactors || num < 1 ) {
2725  MLOCK(ErrorMessageLock);
2726  if ( par == -1 ) {
2727  MesPrint("Not a valid factor number for $-variable in print statement");
2728  }
2729  else {
2730  MesPrint("Not a valid factor number for $-variable in do loop");
2731  }
2732  MUNLOCK(ErrorMessageLock);
2733  Terminate(-1);
2734  return(0);
2735  }
2736  if ( d->factors[num].type == DOLNUMBER )
2737  return(d->factors[num].value);
2738  else { /* If correct, type can only be DOLNUMBER or DOLTERMS */
2739  MLOCK(ErrorMessageLock);
2740  if ( par == -1 ) {
2741  MesPrint("$-variable in print statement is not a number");
2742  }
2743  else {
2744  MesPrint("$-variable in do loop is not a number");
2745  }
2746  MUNLOCK(ErrorMessageLock);
2747  Terminate(-1);
2748  return(0);
2749  }
2750 }
2751 
2752 /*
2753  #] EvalDoLoopArg :
2754  #[ TestDoLoop :
2755 */
2756 
2757 WORD TestDoLoop(PHEAD WORD *lhsbuf, WORD level)
2758 {
2759  GETBIDENTITY
2760  WORD start,finish,incr;
2761  WORD *h;
2762  DOLLARS d;
2763  h = lhsbuf + 4; /* address of the start value */
2764  start = EvalDoLoopArg(BHEAD h,0);
2765  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2766  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2767  h += 2;
2768  finish = EvalDoLoopArg(BHEAD h,0);
2769  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2770  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2771  h += 2;
2772  incr = EvalDoLoopArg(BHEAD h,0);
2773 
2774  if ( ( finish == start ) || ( finish > start && incr > 0 )
2775  || ( finish < start && incr < 0 ) ) {}
2776  else { level = lhsbuf[3]; } /* skips the loop */
2777 /*
2778  Put start in the dollar variable indicated by lhsbuf[2]
2779 */
2780  d = Dollars + lhsbuf[2];
2781 #ifdef WITHPTHREADS
2782  {
2783  int nummodopt, dtype = -1;
2784  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2785  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2786  if ( lhsbuf[2] == ModOptdollars[nummodopt].number ) break;
2787  }
2788  if ( nummodopt < NumModOptdollars ) {
2789  dtype = ModOptdollars[nummodopt].type;
2790  if ( dtype == MODLOCAL ) {
2791  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2792  }
2793  }
2794  }
2795  }
2796 #endif
2797 
2798  if ( d->size < MINALLOC ) {
2799  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
2800  d->size = MINALLOC;
2801  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
2802  }
2803  if ( start > 0 ) {
2804  d->where[0] = 4;
2805  d->where[1] = start;
2806  d->where[2] = 1;
2807  d->where[3] = 3;
2808  d->where[4] = 0;
2809  d->type = DOLNUMBER;
2810  }
2811  else if ( start < 0 ) {
2812  d->where[0] = 4;
2813  d->where[1] = -start;
2814  d->where[2] = 1;
2815  d->where[3] = -3;
2816  d->where[4] = 0;
2817  d->type = DOLNUMBER;
2818  }
2819  else
2820  d->type = DOLZERO;
2821 
2822  if ( d == Dollars + lhsbuf[2] ) {
2823  cbuf[AM.dbufnum].CanCommu[lhsbuf[2]] = 0;
2824  cbuf[AM.dbufnum].NumTerms[lhsbuf[2]] = 1;
2825  cbuf[AM.dbufnum].rhs[lhsbuf[2]] = d->where;
2826  }
2827  return(level);
2828 }
2829 
2830 /*
2831  #] TestDoLoop :
2832  #[ TestEndDoLoop :
2833 */
2834 
2835 WORD TestEndDoLoop(PHEAD WORD *lhsbuf, WORD level)
2836 {
2837  GETBIDENTITY
2838  WORD start,finish,incr,value;
2839  WORD *h;
2840  DOLLARS d;
2841  h = lhsbuf + 4; /* address of the start value */
2842  start = EvalDoLoopArg(BHEAD h,0);
2843  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2844  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2845  h += 2;
2846  finish = EvalDoLoopArg(BHEAD h,0);
2847  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2848  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2849  h += 2;
2850  incr = EvalDoLoopArg(BHEAD h,0);
2851 
2852  if ( ( finish == start ) || ( finish > start && incr > 0 )
2853  || ( finish < start && incr < 0 ) ) {}
2854  else { level = lhsbuf[3]; } /* skips the loop */
2855 /*
2856  Put start in the dollar variable indicated by lhsbuf[2]
2857 */
2858  d = Dollars + lhsbuf[2];
2859 #ifdef WITHPTHREADS
2860  {
2861  int nummodopt, dtype = -1;
2862  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2863  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2864  if ( lhsbuf[2] == ModOptdollars[nummodopt].number ) break;
2865  }
2866  if ( nummodopt < NumModOptdollars ) {
2867  dtype = ModOptdollars[nummodopt].type;
2868  if ( dtype == MODLOCAL ) {
2869  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2870  }
2871  }
2872  }
2873  }
2874 #endif
2875 /*
2876  Get the value
2877 */
2878  if ( d->type == DOLZERO ) {
2879  value = 0;
2880  }
2881  else if ( ( d->type == DOLNUMBER || d->type == DOLTERMS )
2882  && ( d->where[4] == 0 ) && ( d->where[0] == 4 )
2883  && ( d->where[1] > 0 ) && ( d->where[2] == 1 ) ) {
2884  value = ( d->where[3] < 0 ) ? -d->where[1]: d->where[1];
2885  }
2886  else {
2887  MLOCK(ErrorMessageLock);
2888  MesPrint("Wrong type of object in do loop parameter");
2889  MUNLOCK(ErrorMessageLock);
2890  Terminate(-1);
2891  return(level);
2892  }
2893  value += incr;
2894  if ( ( finish > start && value <= finish ) ||
2895  ( finish < start && value >= finish ) ||
2896  ( finish == start && value == finish ) ) {}
2897  else level = lhsbuf[3];
2898 
2899  if ( d->size < MINALLOC ) {
2900  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
2901  d->size = MINALLOC;
2902  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
2903  }
2904  if ( value > 0 ) {
2905  d->where[0] = 4;
2906  d->where[1] = value;
2907  d->where[2] = 1;
2908  d->where[3] = 3;
2909  d->where[4] = 0;
2910  d->type = DOLNUMBER;
2911  }
2912  else if ( start < 0 ) {
2913  d->where[0] = 4;
2914  d->where[1] = -value;
2915  d->where[2] = 1;
2916  d->where[3] = -3;
2917  d->where[4] = 0;
2918  d->type = DOLNUMBER;
2919  }
2920  else
2921  d->type = DOLZERO;
2922 
2923  if ( d == Dollars + lhsbuf[2] ) {
2924  cbuf[AM.dbufnum].CanCommu[lhsbuf[2]] = 0;
2925  cbuf[AM.dbufnum].NumTerms[lhsbuf[2]] = 1;
2926  cbuf[AM.dbufnum].rhs[lhsbuf[2]] = d->where;
2927  }
2928  return(level);
2929 }
2930 
2931 /*
2932  #] TestEndDoLoop :
2933  #[ DollarFactorize :
2934 */
2947 /* #define STEP2 */
2948 #define STEP2
2949 
2950 int DollarFactorize(PHEAD WORD numdollar)
2951 {
2952  GETBIDENTITY
2953  DOLLARS d = Dollars + numdollar;
2954  CBUF *C, *CC;
2955  WORD *oldworkpointer;
2956  WORD *buf1, *t, *term, *buf1content, *buf2, *termextra;
2957  WORD *buf3, *argextra;
2958 #ifdef STEP2
2959  WORD *tstop, pow, *r;
2960 #endif
2961  int i, j, jj, action = 0, sign = 1;
2962  LONG insize, ii;
2963  WORD startebuf = cbuf[AT.ebufnum].numrhs;
2964  WORD nfactors, factorsincontent, extrafactor = 0;
2965  WORD oldsorttype = AR.SortType;
2966 
2967 #ifdef WITHPTHREADS
2968  int nummodopt, dtype;
2969  dtype = -1;
2970  if ( AS.MultiThreaded ) {
2971  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2972  if ( numdollar == ModOptdollars[nummodopt].number ) break;
2973  }
2974  if ( nummodopt < NumModOptdollars ) {
2975  dtype = ModOptdollars[nummodopt].type;
2976  if ( dtype == MODLOCAL ) {
2977  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2978  }
2979  else {
2980  LOCK(d->pthreadslockread);
2981  }
2982  }
2983  }
2984 #endif
2985  CleanDollarFactors(d);
2986 #ifdef WITHPTHREADS
2987  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
2988 #endif
2989  if ( d->type != DOLTERMS ) { /* only one term */
2990  if ( d->type != DOLZERO ) d->nfactors = 1;
2991  return(0);
2992  }
2993  if ( d->where[d->where[0]] == 0 ) { /* only one term. easy */
2994  }
2995 /*
2996  Here should come the code for the factorization
2997  We copied the routine ArgFactorize in argument.c and changed the
2998  memory management completely. For the actual factorization it
2999  calls WORD *DoFactorizeDollar(PHEAD WORD *expr) which allocates
3000  space for the answer. Notation:
3001  term,...,term,0,term,...,term,0,term,...,term,0,0
3002 
3003  #[ Step 1: sort the terms properly and/or make copy --> buf1,insize
3004 */
3005  term = d->where;
3006  AR.SortType = SORTHIGHFIRST;
3007  if ( oldsorttype != AR.SortType ) {
3008  NewSort(BHEAD0);
3009  while ( *term ) {
3010  t = term + *term;
3011  if ( AN.ncmod != 0 ) {
3012  if ( AN.ncmod != 1 || ( (WORD)AN.cmod[0] < 0 ) ) {
3013  AR.SortType = oldsorttype;
3014  MLOCK(ErrorMessageLock);
3015  MesPrint("Factorization modulus a number, greater than a WORD not implemented.");
3016  MUNLOCK(ErrorMessageLock);
3017  Terminate(-1);
3018  }
3019  if ( Modulus(term) ) {
3020  AR.SortType = oldsorttype;
3021  MLOCK(ErrorMessageLock);
3022  MesCall("DollarFactorize");
3023  MUNLOCK(ErrorMessageLock);
3024  Terminate(-1);
3025  }
3026  if ( !*term) { term = t; continue; }
3027  }
3028  StoreTerm(BHEAD term);
3029  term = t;
3030  }
3031  AN.tryterm = 0; /* for now */
3032  EndSort(BHEAD (WORD *)((void *)(&buf1)),2);
3033  t = buf1; while ( *t ) t += *t;
3034  insize = t - buf1;
3035  }
3036  else {
3037  t = term; while ( *t ) t += *t;
3038  ii = insize = t - term;
3039  buf1 = (WORD *)Malloc1((insize+1)*sizeof(WORD),"DollarFactorize-1");
3040  t = buf1;
3041  NCOPY(t,term,ii);
3042  *t++ = 0;
3043  }
3044 /*
3045  #] Step 1:
3046  #[ Step 2: take out the 'content'.
3047 */
3048 #ifdef STEP2
3049  buf1content = TermMalloc("DollarContent");
3050  AN.tryterm = -1;
3051  if ( ( buf2 = TakeContent(BHEAD buf1,buf1content) ) == 0 ) {
3052  AN.tryterm = 0;
3053  TermFree(buf1content,"DollarContent");
3054  M_free(buf1,"DollarFactorize-1");
3055  AR.SortType = oldsorttype;
3056  MLOCK(ErrorMessageLock);
3057  MesCall("DollarFactorize");
3058  MUNLOCK(ErrorMessageLock);
3059  Terminate(-1);
3060  return(1);
3061  }
3062  else if ( ( buf1content[0] == 4 ) && ( buf1content[1] == 1 ) &&
3063  ( buf1content[2] == 1 ) && ( buf1content[3] == 3 ) ) { /* Nothing happened */
3064  AN.tryterm = 0;
3065  if ( buf2 != buf1 ) {
3066  M_free(buf2,"DollarFactorize-2");
3067  buf2 = buf1;
3068  }
3069  factorsincontent = 0;
3070  }
3071  else {
3072 /*
3073  The way we took out objects is rather brutish. We have to normalize
3074 */
3075  AN.tryterm = 0;
3076  if ( buf2 != buf1 ) M_free(buf1,"DollarFactorize-1");
3077  buf1 = buf2;
3078  t = buf1; while ( *t ) t += *t;
3079  insize = t - buf1;
3080 /*
3081  Now analyse how many factors there are in the content
3082 */
3083  factorsincontent = 0;
3084  term = buf1content;
3085  tstop = term + *term;
3086  if ( tstop[-1] < 0 ) factorsincontent++;
3087  if ( ABS(tstop[-1]) == 3 && tstop[-2] == 1 && tstop[-3] == 1 ) {
3088  tstop -= ABS(tstop[-1]);
3089  }
3090  else {
3091  factorsincontent++;
3092  tstop -= ABS(tstop[-1]);
3093  }
3094  term++;
3095  while ( term < tstop ) {
3096  switch ( *term ) {
3097  case SYMBOL:
3098  t = term+2; i = (term[1]-2)/2;
3099  while ( i > 0 ) {
3100  factorsincontent += ABS(t[1]);
3101  i--; t += 2;
3102  }
3103  break;
3104  case DOTPRODUCT:
3105  t = term+2; i = (term[1]-2)/3;
3106  while ( i > 0 ) {
3107  factorsincontent += ABS(t[2]);
3108  i--; t += 3;
3109  }
3110  break;
3111  case VECTOR:
3112  case DELTA:
3113  factorsincontent += (term[1]-2)/2;
3114  break;
3115  case INDEX:
3116  factorsincontent += term[1]-2;
3117  break;
3118  default:
3119  if ( *term >= FUNCTION ) factorsincontent++;
3120  break;
3121  }
3122  term += term[1];
3123  }
3124  }
3125 #else
3126  factorsincontent = 0;
3127  buf1content = 0;
3128 #endif
3129 /*
3130  #] Step 2: take out the 'content'.
3131  #[ Step 3: ConvertToPoly
3132  if there are objects that are not SYMBOLs,
3133  invoke ConvertToPoly
3134  We keep the original in buf1 in case there are no factors
3135 */
3136  t = buf1;
3137  while ( *t ) {
3138  if ( ( t[1] != SYMBOL ) && ( *t != (ABS(t[*t-1])+1) ) ) {
3139  action = 1; break;
3140  }
3141  t += *t;
3142  }
3143  if ( DetCommu(buf1) > 1 ) {
3144  MesPrint("Cannot factorize a $-expression with more than one noncommuting object");
3145  AR.SortType = oldsorttype;
3146  M_free(buf1,"DollarFactorize-2");
3147  if ( buf1content ) TermFree(buf1content,"DollarContent");
3148  MesCall("DollarFactorize");
3149  Terminate(-1);
3150  return(-1);
3151  }
3152  if ( action ) {
3153  t = buf1;
3154  termextra = AT.WorkPointer;
3155  NewSort(BHEAD0);
3156  NewSort(BHEAD0);
3157  while ( *t ) {
3158  if ( LocalConvertToPoly(BHEAD t,termextra,startebuf,0) < 0 ) {
3159 getout:
3160  AR.SortType = oldsorttype;
3161  M_free(buf1,"DollarFactorize-2");
3162  if ( buf1content ) TermFree(buf1content,"DollarContent");
3163  MesCall("DollarFactorize");
3164  Terminate(-1);
3165  return(-1);
3166  }
3167  StoreTerm(BHEAD termextra);
3168  t += *t;
3169  }
3170  AN.tryterm = 0; /* for now */
3171  if ( EndSort(BHEAD (WORD *)((void *)(&buf2)),2) < 0 ) { goto getout; }
3172  LowerSortLevel();
3173  t = buf2; while ( *t > 0 ) t += *t;
3174  }
3175  else {
3176  buf2 = buf1;
3177  }
3178 /*
3179  #] Step 3: ConvertToPoly
3180  #[ Step 4: Now the hard work.
3181 */
3182  if ( ( buf3 = poly_factorize_dollar(BHEAD buf2) ) == 0 ) {
3183  MesCall("DollarFactorize");
3184  AR.SortType = oldsorttype;
3185  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-3");
3186  M_free(buf1,"DollarFactorize-3");
3187  if ( buf1content ) TermFree(buf1content,"DollarContent");
3188  Terminate(-1);
3189  return(-1);
3190  }
3191  if ( buf2 != buf1 && buf2 ) {
3192  M_free(buf2,"DollarFactorize-3");
3193  buf2 = 0;
3194  }
3195  term = buf3;
3196  AR.SortType = oldsorttype;
3197 /*
3198  Count the factors and strip a factor -1
3199 */
3200  nfactors = 0;
3201  while ( *term ) {
3202 #ifdef STEP2
3203  if ( *term == 4 && term[4] == 0 && term[3] == -3 && term[2] == 1
3204  && term[1] == 1 ) {
3205  WORD *tt1, *tt2, *ttstop;
3206  sign = -sign;
3207  tt1 = term; tt2 = term + *term + 1;
3208  ttstop = tt2;
3209  while ( *ttstop ) {
3210  while ( *ttstop ) ttstop += *ttstop;
3211  ttstop++;
3212  }
3213  while ( tt2 < ttstop ) *tt1++ = *tt2++;
3214  *tt1 = 0;
3215  factorsincontent++;
3216  extrafactor++;
3217  }
3218  else
3219 #endif
3220  {
3221  term += *term;
3222  while ( *term ) { term += *term; }
3223  nfactors++; term++;
3224  }
3225  }
3226 /*
3227  We have now:
3228  buf1: the original before ConvertToPoly for if only one factor
3229  buf3: the factored expression with nfactors factors
3230 
3231  #] Step 4:
3232  #[ Step 5: ConvertFromPoly
3233  If ConvertToPoly was used, use now ConvertFromPoly
3234  Be careful: there should be more than one factor now.
3235 */
3236 #ifdef WITHPTHREADS
3237  if ( dtype > 0 && dtype != MODLOCAL ) { LOCK(d->pthreadslockread); }
3238 #endif
3239  if ( nfactors == 1 && extrafactor == 0 ) { /* we can use the buf1 contents */
3240  if ( factorsincontent == 0 ) {
3241  d->nfactors = 1;
3242 #ifdef WITHPTHREADS
3243  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
3244 #endif
3245 /*
3246  We used here (before 3-sep-2015) the original and did not make
3247  provisions for having a factors struct, figuring that all info
3248  is identical to the full dollar. This makes things too
3249  complicated at later stages.
3250 */
3251  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR),"factors in dollar");
3252  term = buf1; while ( *term ) term += *term;
3253  d->factors[0].size = i = term - buf1;
3254  d->factors[0].where = t = (WORD *)Malloc1(sizeof(WORD)*(i+1),"DollarFactorize-5");
3255  term = buf1; NCOPY(t,term,i); *t = 0;
3256  AR.SortType = oldsorttype;
3257  M_free(buf3,"DollarFactorize-4");
3258  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-4");
3259  M_free(buf1,"DollarFactorize-4");
3260  if ( buf1content ) TermFree(buf1content,"DollarContent");
3261  return(0);
3262  }
3263  else {
3264  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3265  term = buf1; while ( *term ) term += *term;
3266  d->factors[0].size = i = term - buf1;
3267  d->factors[0].where = t = (WORD *)Malloc1(sizeof(WORD)*(i+1),"DollarFactorize-5");
3268  term = buf1; NCOPY(t,term,i); *t = 0;
3269  M_free(buf3,"DollarFactorize-4");
3270  buf3 = 0;
3271  if ( buf2 != buf1 && buf2 ) {
3272  M_free(buf2,"DollarFactorize-4");
3273  buf2 = 0;
3274  }
3275  }
3276  }
3277  else if ( action ) {
3278  C = cbuf+AC.cbufnum;
3279  CC = cbuf+AT.ebufnum;
3280  oldworkpointer = AT.WorkPointer;
3281  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3282  term = buf3;
3283  for ( i = 0; i < nfactors; i++ ) {
3284  argextra = AT.WorkPointer;
3285  NewSort(BHEAD0);
3286  NewSort(BHEAD0);
3287  while ( *term ) {
3288  if ( ConvertFromPoly(BHEAD term,argextra,numxsymbol,CC->numrhs-startebuf+numxsymbol
3289  ,startebuf-numxsymbol,1) <= 0 ) {
3290  LowerSortLevel();
3291 getout2: AR.SortType = oldsorttype;
3292  M_free(d->factors,"factors in dollar");
3293  d->factors = 0;
3294 #ifdef WITHPTHREADS
3295  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
3296 #endif
3297  M_free(buf3,"DollarFactorize-4");
3298  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-4");
3299  M_free(buf1,"DollarFactorize-4");
3300  if ( buf1content ) TermFree(buf1content,"DollarContent");
3301  return(-3);
3302  }
3303  AT.WorkPointer = argextra + *argextra;
3304 /*
3305  ConvertFromPoly leaves terms with subexpressions. Hence:
3306 */
3307  if ( Generator(BHEAD argextra,C->numlhs+1) ) {
3308  goto getout2;
3309  }
3310  term += *term;
3311  }
3312  term++;
3313  AT.WorkPointer = oldworkpointer;
3314  AN.tryterm = 0; /* for now */
3315  EndSort(BHEAD (WORD *)((void *)(&(d->factors[i].where))),2);
3316  LowerSortLevel();
3317  d->factors[i].type = DOLTERMS;
3318  t = d->factors[i].where;
3319  while ( *t ) t += *t;
3320  d->factors[i].size = t - d->factors[i].where;
3321  }
3322  CC->numrhs = startebuf;
3323  }
3324  else {
3325  C = cbuf+AC.cbufnum;
3326  oldworkpointer = AT.WorkPointer;
3327  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3328  term = buf3;
3329  for ( i = 0; i < nfactors; i++ ) {
3330  NewSort(BHEAD0);
3331  while ( *term ) {
3332  argextra = oldworkpointer;
3333  j = *term;
3334  NCOPY(argextra,term,j)
3335  AT.WorkPointer = argextra;
3336  if ( Generator(BHEAD oldworkpointer,C->numlhs+1) ) {
3337  goto getout2;
3338  }
3339  }
3340  term++;
3341  AT.WorkPointer = oldworkpointer;
3342  AN.tryterm = 0; /* for now */
3343  EndSort(BHEAD (WORD *)((void *)(&(d->factors[i].where))),2);
3344  d->factors[i].type = DOLTERMS;
3345  t = d->factors[i].where;
3346  while ( *t ) t += *t;
3347  d->factors[i].size = t - d->factors[i].where;
3348  }
3349  }
3350  d->nfactors = nfactors + factorsincontent;
3351 /*
3352  #] Step 5: ConvertFromPoly
3353  #[ Step 6: The factors of the content
3354 */
3355  if ( buf3 ) M_free(buf3,"DollarFactorize-5");
3356  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-5");
3357  M_free(buf1,"DollarFactorize-5");
3358  j = nfactors;
3359 #ifdef STEP2
3360  term = buf1content;
3361  tstop = term + *term;
3362  if ( tstop[-1] < 0 ) { tstop[-1] = -tstop[-1]; sign = -sign; }
3363  tstop -= tstop[-1];
3364  term++;
3365  while ( term < tstop ) {
3366  switch ( *term ) {
3367  case SYMBOL:
3368  t = term+2; i = (term[1]-2)/2;
3369  while ( i > 0 ) {
3370  if ( t[1] < 0 ) { t[1] = -t[1]; pow = -1; }
3371  else { pow = 1; }
3372  for ( jj = 0; jj < t[1]; jj++ ) {
3373  r = d->factors[j].where = (WORD *)Malloc1(9*sizeof(WORD),"factor");
3374  r[0] = 8; r[1] = SYMBOL; r[2] = 4; r[3] = *t; r[4] = pow;
3375  r[5] = 1; r[6] = 1; r[7] = 3; r[8] = 0;
3376  d->factors[j].type = DOLTERMS;
3377  d->factors[j].size = 8;
3378  j++;
3379  }
3380  i--; t += 2;
3381  }
3382  break;
3383  case DOTPRODUCT:
3384  t = term+2; i = (term[1]-2)/3;
3385  while ( i > 0 ) {
3386  if ( t[2] < 0 ) { t[2] = -t[2]; pow = -1; }
3387  else { pow = 1; }
3388  for ( jj = 0; jj < t[2]; jj++ ) {
3389  r = d->factors[j].where = (WORD *)Malloc1(10*sizeof(WORD),"factor");
3390  r[0] = 9; r[1] = DOTPRODUCT; r[2] = 5; r[3] = t[0]; r[4] = t[1];
3391  r[5] = pow; r[6] = 1; r[7] = 1; r[8] = 3; r[9] = 0;
3392  d->factors[j].type = DOLTERMS;
3393  d->factors[j].size = 9;
3394  j++;
3395  }
3396  i--; t += 3;
3397  }
3398  break;
3399  case VECTOR:
3400  case DELTA:
3401  t = term+2; i = (term[1]-2)/2;
3402  while ( i > 0 ) {
3403  for ( jj = 0; jj < t[1]; jj++ ) {
3404  r = d->factors[j].where = (WORD *)Malloc1(9*sizeof(WORD),"factor");
3405  r[0] = 8; r[1] = *term; r[2] = 4; r[3] = *t; r[4] = t[1];
3406  r[5] = 1; r[6] = 1; r[7] = 3; r[8] = 0;
3407  d->factors[j].type = DOLTERMS;
3408  d->factors[j].size = 8;
3409  j++;
3410  }
3411  i--; t += 2;
3412  }
3413  break;
3414  case INDEX:
3415  t = term+2; i = term[1]-2;
3416  while ( i > 0 ) {
3417  for ( jj = 0; jj < t[1]; jj++ ) {
3418  r = d->factors[j].where = (WORD *)Malloc1(8*sizeof(WORD),"factor");
3419  r[0] = 7; r[1] = *term; r[2] = 3; r[3] = *t;
3420  r[4] = 1; r[5] = 1; r[6] = 3; r[7] = 0;
3421  d->factors[j].type = DOLTERMS;
3422  d->factors[j].size = 7;
3423  j++;
3424  }
3425  i--; t++;
3426  }
3427  break;
3428  default:
3429  if ( *term >= FUNCTION ) {
3430  r = d->factors[j].where = (WORD *)Malloc1((term[1]+5)*sizeof(WORD),"factor");
3431  *r++ = d->factors[j].size = term[1]+4;
3432  for ( jj = 0; jj < t[1]; jj++ ) *r++ = term[jj];
3433  *r++ = 1; *r++ = 1; *r++ = 3; *r = 0;
3434  j++;
3435  }
3436  break;
3437  }
3438  term += term[1];
3439  }
3440 #endif
3441 /*
3442  #] Step 6:
3443  #[ Step 7: Numerical factors
3444 */
3445 #ifdef STEP2
3446  term = buf1content;
3447  tstop = term + *term;
3448  if ( tstop[-1] == 3 && tstop[-2] == 1 && tstop[-3] == 1 ) {}
3449  else if ( tstop[-1] == 3 && tstop[-2] == 1 && (UWORD)(tstop[-3]) <= MAXPOSITIVE ) {
3450  d->factors[j].where = 0;
3451  d->factors[j].size = 0;
3452  d->factors[j].type = DOLNUMBER;
3453  d->factors[j].value = sign*tstop[-3];
3454  sign = 1;
3455  j++;
3456  }
3457  else {
3458  d->factors[j].where = r = (WORD *)Malloc1((tstop[-1]+2)*sizeof(WORD),"numfactor");
3459  d->factors[j].size = tstop[-1]+1;
3460  d->factors[j].type = DOLTERMS;
3461  d->factors[j].value = 0;
3462  i = tstop[-1];
3463  t = tstop - i;
3464  *r++ = tstop[-1]+1;
3465  NCOPY(r,t,i);
3466  *r = 0;
3467  if ( sign < 0 ) {
3468  r = d->factors[j].where;
3469  while ( *r ) {
3470  r += *r; r[-1] = -r[-1];
3471  }
3472  sign = 1;
3473  }
3474  j++;
3475  }
3476 #endif
3477  if ( sign < 0 ) { /* Note that this guy should come first */
3478  for ( jj = j; jj > 0; jj-- ) {
3479  d->factors[jj] = d->factors[jj-1];
3480  }
3481  d->factors[0].where = 0;
3482  d->factors[0].size = 0;
3483  d->factors[0].type = DOLNUMBER;
3484  d->factors[0].value = -1;
3485  j++;
3486  }
3487  d->nfactors = j;
3488  if ( buf1content ) TermFree(buf1content,"DollarContent");
3489 /*
3490  #] Step 7:
3491  #[ Step 8: Sorting the factors
3492 
3493  There are d->nfactors factors. Look which ones have a 'where'
3494  Sort them by bubble sort
3495 */
3496  if ( d->nfactors > 1 ) {
3497  WORD ***fac, j1, j2, k, ret, *s1, *s2, *s3;
3498  LONG **facsize, x;
3499  facsize = (LONG **)Malloc1((sizeof(WORD **)+sizeof(LONG *))*d->nfactors,"SortDollarFactors");
3500  fac = (WORD ***)(facsize+d->nfactors);
3501  k = 0;
3502  for ( j = 0; j < d->nfactors; j++ ) {
3503  if ( d->factors[j].where ) {
3504  fac[k] = &(d->factors[j].where);
3505  facsize[k] = &(d->factors[j].size);
3506  k++;
3507  }
3508  }
3509  if ( k > 1 ) {
3510  for ( j = 1; j < k; j++ ) { /* bubble sort */
3511  j1 = j; j2 = j1-1;
3512 nextj1:;
3513  s1 = *(fac[j1]); s2 = *(fac[j2]);
3514  while ( *s1 && *s2 ) {
3515  if ( ( ret = CompareTerms(s2, s1, (WORD)2) ) == 0 ) {
3516  s1 += *s1; s2 += *s2;
3517  }
3518  else if ( ret > 0 ) goto nextj;
3519  else {
3520 exch:
3521  s3 = *(fac[j1]); *(fac[j1]) = *(fac[j2]); *(fac[j2]) = s3;
3522  x = *(facsize[j1]); *(facsize[j1]) = *(facsize[j2]); *(facsize[j2]) = x;
3523  j1--; j2--;
3524  if ( j1 > 0 ) goto nextj1;
3525  goto nextj;
3526  }
3527  }
3528  if ( *s1 ) goto nextj;
3529  if ( *s2 ) goto exch;
3530 nextj:;
3531  }
3532  }
3533  M_free(facsize,"SortDollarFactors");
3534  }
3535 /*
3536  #] Step 8:
3537 */
3538 #ifdef WITHPTHREADS
3539  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
3540 #endif
3541  return(0);
3542 }
3543 
3544 /*
3545  #] DollarFactorize :
3546  #[ CleanDollarFactors :
3547 */
3548 
3549 void CleanDollarFactors(DOLLARS d)
3550 {
3551  int i;
3552  if ( d->nfactors > 1 ) {
3553  for ( i = 0; i < d->nfactors; i++ ) {
3554  if ( d->factors[i].where )
3555  M_free(d->factors[i].where,"dollar factors");
3556  }
3557  }
3558  if ( d->factors ) {
3559  M_free(d->factors,"dollar factors");
3560  d->factors = 0;
3561  }
3562  d->nfactors = 0;
3563 }
3564 
3565 /*
3566  #] CleanDollarFactors :
3567  #[ TakeDollarContent :
3568 */
3569 
3570 WORD *TakeDollarContent(PHEAD WORD *dollarbuffer, WORD **factor)
3571 {
3572  WORD *remain, *t;
3573  int pow;
3574 /*
3575  We force the sign of the first term to be positive.
3576 */
3577  t = dollarbuffer; pow = 1;
3578  t += *t;
3579  if ( t[-1] < 0 ) {
3580  pow = 0;
3581  t[-1] = -t[-1];
3582  while ( *t ) {
3583  t += *t; t[-1] = -t[-1];
3584  }
3585  }
3586 /*
3587  Now the GCD of the numerators and the LCM of the denominators:
3588 */
3589  if ( AN.cmod != 0 ) {
3590  if ( ( *factor = MakeDollarMod(BHEAD dollarbuffer,&remain) ) == 0 ) {
3591  Terminate(-1);
3592  }
3593  if ( pow == 0 ) {
3594  (*factor)[**factor-1] = -(*factor)[**factor-1];
3595  (*factor)[**factor-1] += AN.cmod[0];
3596  }
3597  }
3598  else {
3599  if ( ( *factor = MakeDollarInteger(BHEAD dollarbuffer,&remain) ) == 0 ) {
3600  Terminate(-1);
3601  }
3602  if ( pow == 0 ) {
3603  (*factor)[**factor-1] = -(*factor)[**factor-1];
3604  }
3605  }
3606  return(remain);
3607 }
3608 
3609 /*
3610  #] TakeDollarContent :
3611  #[ MakeDollarInteger :
3612 */
3622 WORD *MakeDollarInteger(PHEAD WORD *bufin,WORD **bufout)
3623 {
3624  GETBIDENTITY
3625  UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc;
3626  WORD *r, *r1, *r2, *r3, *rnext, i, k, j, *oldworkpointer, *factor;
3627  WORD kGCD, kLCM, kGCD2, kkLCM, jLCM, jGCD;
3628  CBUF *C = cbuf+AC.cbufnum;
3629 
3630  GCDbuffer = NumberMalloc("MakeDollarInteger");
3631  GCDbuffer2 = NumberMalloc("MakeDollarInteger");
3632  LCMbuffer = NumberMalloc("MakeDollarInteger");
3633  LCMb = NumberMalloc("MakeDollarInteger");
3634  LCMc = NumberMalloc("MakeDollarInteger");
3635  r = bufin;
3636 /*
3637  First take the first term to load up the LCM and the GCD
3638 */
3639  r2 = r + *r;
3640  j = r2[-1];
3641  r3 = r2 - ABS(j);
3642  k = REDLENG(j);
3643  if ( k < 0 ) k = -k;
3644  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3645  for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD];
3646  k = REDLENG(j);
3647  if ( k < 0 ) k = -k;
3648  r3 += k;
3649  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3650  for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM];
3651  r1 = r2;
3652 /*
3653  Now go through the rest of the terms in this argument.
3654 */
3655  while ( *r1 ) {
3656  r2 = r1 + *r1;
3657  j = r2[-1];
3658  r3 = r2 - ABS(j);
3659  k = REDLENG(j);
3660  if ( k < 0 ) k = -k;
3661  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3662  if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) {
3663 /*
3664  GCD is already 1
3665 */
3666  }
3667  else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) {
3668  if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) {
3669  goto MakeDollarIntegerErr;
3670  }
3671  kGCD = kGCD2;
3672  for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i];
3673  }
3674  else {
3675  kGCD = 1; GCDbuffer[0] = 1;
3676  }
3677  k = REDLENG(j);
3678  if ( k < 0 ) k = -k;
3679  r3 += k;
3680  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3681  if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) {
3682  for ( kLCM = 0; kLCM < k; kLCM++ )
3683  LCMbuffer[kLCM] = r3[kLCM];
3684  }
3685  else if ( ( k != 1 ) || ( r3[0] != 1 ) ) {
3686  if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) {
3687  goto MakeDollarIntegerErr;
3688  }
3689  DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM);
3690  MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM);
3691  for ( kLCM = 0; kLCM < jLCM; kLCM++ )
3692  LCMbuffer[kLCM] = LCMc[kLCM];
3693  }
3694  else {} /* LCM doesn't change */
3695  r1 = r2;
3696  }
3697 /*
3698  Now put the factor together: GCD/LCM
3699 */
3700  r3 = (WORD *)(GCDbuffer);
3701  if ( kGCD == kLCM ) {
3702  for ( jGCD = 0; jGCD < kGCD; jGCD++ )
3703  r3[jGCD+kGCD] = LCMbuffer[jGCD];
3704  k = kGCD;
3705  }
3706  else if ( kGCD > kLCM ) {
3707  for ( jGCD = 0; jGCD < kLCM; jGCD++ )
3708  r3[jGCD+kGCD] = LCMbuffer[jGCD];
3709  for ( jGCD = kLCM; jGCD < kGCD; jGCD++ )
3710  r3[jGCD+kGCD] = 0;
3711  k = kGCD;
3712  }
3713  else {
3714  for ( jGCD = kGCD; jGCD < kLCM; jGCD++ )
3715  r3[jGCD] = 0;
3716  for ( jGCD = 0; jGCD < kLCM; jGCD++ )
3717  r3[jGCD+kLCM] = LCMbuffer[jGCD];
3718  k = kLCM;
3719  }
3720  j = 2*k+1;
3721 /*
3722  Now we have to write this to factor
3723 */
3724  factor = r1 = (WORD *)Malloc1((j+2)*sizeof(WORD),"MakeDollarInteger");
3725  *r1++ = j+1; r2 = r3;
3726  for ( i = 0; i < k; i++ ) { *r1++ = *r2++; *r1++ = *r2++; }
3727  *r1++ = j;
3728  *r1 = 0;
3729 /*
3730  Next we have to take the factor out from the argument.
3731  This cannot be done in location, because the denominator stuff can make
3732  coefficients longer.
3733 
3734  We do this via a sort because the things may be jumbled any way and we
3735  do not know in advance how much space we need.
3736 */
3737  NewSort(BHEAD0);
3738  r = bufin;
3739  oldworkpointer = AT.WorkPointer;
3740  while ( *r ) {
3741  rnext = r + *r;
3742  j = ABS(rnext[-1]);
3743  r3 = rnext - j;
3744  r2 = oldworkpointer;
3745  while ( r < r3 ) *r2++ = *r++;
3746  j = (j-1)/2; /* reduced length. Remember, k is the other red length */
3747  if ( DivRat(BHEAD (UWORD *)r3,j,GCDbuffer,k,(UWORD *)r2,&i) ) {
3748  goto MakeDollarIntegerErr;
3749  }
3750  i = 2*i+1;
3751  r2 = r2 + i;
3752  if ( rnext[-1] < 0 ) r2[-1] = -i;
3753  else r2[-1] = i;
3754  *oldworkpointer = r2-oldworkpointer;
3755  AT.WorkPointer = r2;
3756  if ( Generator(BHEAD oldworkpointer,C->numlhs) ) {
3757  goto MakeDollarIntegerErr;
3758  }
3759  r = rnext;
3760  }
3761  AT.WorkPointer = oldworkpointer;
3762  AN.tryterm = 0; /* for now */
3763  EndSort(BHEAD (WORD *)bufout,2);
3764 /*
3765  Cleanup
3766 */
3767  NumberFree(LCMc,"MakeDollarInteger");
3768  NumberFree(LCMb,"MakeDollarInteger");
3769  NumberFree(LCMbuffer,"MakeDollarInteger");
3770  NumberFree(GCDbuffer2,"MakeDollarInteger");
3771  NumberFree(GCDbuffer,"MakeDollarInteger");
3772  return(factor);
3773 
3774 MakeDollarIntegerErr:
3775  NumberFree(LCMc,"MakeDollarInteger");
3776  NumberFree(LCMb,"MakeDollarInteger");
3777  NumberFree(LCMbuffer,"MakeDollarInteger");
3778  NumberFree(GCDbuffer2,"MakeDollarInteger");
3779  NumberFree(GCDbuffer,"MakeDollarInteger");
3780  MesCall("MakeDollarInteger");
3781  Terminate(-1);
3782  return(0);
3783 }
3784 
3785 /*
3786  #] MakeDollarInteger :
3787  #[ MakeDollarMod :
3788 */
3796 WORD *MakeDollarMod(PHEAD WORD *buffer, WORD **bufout)
3797 {
3798  GETBIDENTITY
3799  WORD *r, *r1, x, xx, ix, ip;
3800  WORD *factor, *oldworkpointer;
3801  int i;
3802  CBUF *C = cbuf+AC.cbufnum;
3803  r = buffer;
3804  x = r[*r-3];
3805  if ( r[*r-1] < 0 ) x += AN.cmod[0];
3806  if ( GetModInverses(x,(WORD)(AN.cmod[0]),&ix,&ip) ) {
3807  Terminate(-1);
3808  }
3809  factor = (WORD *)Malloc1(5*sizeof(WORD),"MakeDollarMod");
3810  factor[0] = 4; factor[1] = x; factor[2] = 1; factor[3] = 3; factor[4] = 0;
3811 /*
3812  Now we have to multiply all coefficients by ix.
3813  This does not make things longer, but we should keep to the conventions
3814  of MakeDollarInteger.
3815 */
3816  NewSort(BHEAD0);
3817  r = buffer;
3818  oldworkpointer = AT.WorkPointer;
3819  while ( *r ) {
3820  r1 = oldworkpointer; i = *r;
3821  NCOPY(r1,r,i);
3822  xx = r1[-3]; if ( r1[-1] < 0 ) xx += AN.cmod[0];
3823  r1[-1] = (WORD)((((LONG)xx)*ix) % AN.cmod[0]);
3824  *r1 = 0; AT.WorkPointer = r1;
3825  if ( Generator(BHEAD oldworkpointer,C->numlhs) ) {
3826  Terminate(-1);
3827  }
3828  }
3829  AT.WorkPointer = oldworkpointer;
3830  AN.tryterm = 0; /* for now */
3831  EndSort(BHEAD (WORD *)bufout,2);
3832  return(factor);
3833 }
3834 /*
3835  #] MakeDollarMod :
3836  #[ GetDolNum :
3837 
3838  Evaluates a chain of DOLLAREXPR2 into a number
3839 */
3840 
3841 int GetDolNum(PHEAD WORD *t, WORD *tstop)
3842 {
3843  DOLLARS d;
3844  WORD num, *w;
3845  if ( t+3 < tstop && t[3] == DOLLAREXPR2 ) {
3846  d = Dollars + t[2];
3847 #ifdef WITHPTHREADS
3848  {
3849  int nummodopt, dtype;
3850  dtype = -1;
3851  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
3852  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3853  if ( t[2] == ModOptdollars[nummodopt].number ) break;
3854  }
3855  if ( nummodopt < NumModOptdollars ) {
3856  dtype = ModOptdollars[nummodopt].type;
3857  if ( dtype == MODLOCAL ) {
3858  d = ModOptdollars[nummodopt].dstruct+AT.identity;
3859  }
3860  else {
3861  MLOCK(ErrorMessageLock);
3862  MesPrint("&Illegal attempt to use $-variable %s in module %l",
3863  DOLLARNAME(Dollars,t[2]),AC.CModule);
3864  MUNLOCK(ErrorMessageLock);
3865  Terminate(-1);
3866  }
3867  }
3868  }
3869  }
3870 #endif
3871  if ( d->factors == 0 ) {
3872  MLOCK(ErrorMessageLock);
3873  MesPrint("Attempt to use a factor of an unfactored $-variable");
3874  MUNLOCK(ErrorMessageLock);
3875  Terminate(-1);
3876  }
3877  num = GetDolNum(BHEAD t+t[1],tstop);
3878  if ( num == 0 ) return(d->nfactors);
3879  if ( num > d->nfactors ) {
3880  MLOCK(ErrorMessageLock);
3881  MesPrint("Attempt to use an nonexisting factor %d of a $-variable",num);
3882  MUNLOCK(ErrorMessageLock);
3883  Terminate(-1);
3884  }
3885  w = d->factors[num-1].where;
3886  if ( w == 0 ) return(d->factors[num-1].value);
3887  if ( w[0] == 4 && w[4] == 0 && w[3] == 3 && w[2] == 1 && w[1] > 0
3888  && w[1] < MAXPOSITIVE ) return(w[1]);
3889  else {
3890  MLOCK(ErrorMessageLock);
3891  MesPrint("Illegal type of factor number of a $-variable");
3892  MUNLOCK(ErrorMessageLock);
3893  Terminate(-1);
3894  }
3895  }
3896  else if ( t[2] < 0 ) {
3897  return(-t[2]-1);
3898  }
3899  else {
3900  d = Dollars + t[2];
3901 #ifdef WITHPTHREADS
3902  {
3903  int nummodopt, dtype;
3904  dtype = -1;
3905  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
3906  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3907  if ( t[2] == ModOptdollars[nummodopt].number ) break;
3908  }
3909  if ( nummodopt < NumModOptdollars ) {
3910  dtype = ModOptdollars[nummodopt].type;
3911  if ( dtype == MODLOCAL ) {
3912  d = ModOptdollars[nummodopt].dstruct+AT.identity;
3913  }
3914  else {
3915  MLOCK(ErrorMessageLock);
3916  MesPrint("&Illegal attempt to use $-variable %s in module %l",
3917  DOLLARNAME(Dollars,t[2]),AC.CModule);
3918  MUNLOCK(ErrorMessageLock);
3919  Terminate(-1);
3920  }
3921  }
3922  }
3923  }
3924 #endif
3925  if ( d->type == DOLZERO ) return(0);
3926  if ( d->type == DOLTERMS || d->type == DOLNUMBER ) {
3927  if ( d->where[0] == 4 && d->where[4] == 0 && d->where[3] == 3
3928  && d->where[2] == 1 && d->where[1] > 0
3929  && d->where[1] < MAXPOSITIVE ) return(d->where[1]);
3930  MLOCK(ErrorMessageLock);
3931  MesPrint("Attempt to use an nonexisting factor of a $-variable");
3932  MUNLOCK(ErrorMessageLock);
3933  Terminate(-1);
3934  }
3935  MLOCK(ErrorMessageLock);
3936  MesPrint("Illegal type of factor number of a $-variable");
3937  MUNLOCK(ErrorMessageLock);
3938  Terminate(-1);
3939  }
3940  return(0);
3941 }
3942 
3943 /*
3944  #] GetDolNum :
3945  #[ AddPotModdollar :
3946 */
3947 
3954 void AddPotModdollar(WORD numdollar)
3955 {
3956  int i, n = NumPotModdollars;
3957  for ( i = 0; i < n; i++ ) {
3958  if ( numdollar == PotModdollars[i] ) break;
3959  }
3960  if ( i >= n ) {
3961  *(WORD *)FromList(&AC.PotModDolList) = numdollar;
3962  }
3963 }
3964 
3965 /*
3966  #] AddPotModdollar :
3967 */
void AddPotModdollar(WORD)
Definition: dollar.c:3954
int LocalConvertToPoly(PHEAD WORD *, WORD *, WORD, WORD)
Definition: notation.c:510
Definition: structs.h:938
WORD * MakeDollarInteger(PHEAD WORD *, WORD **)
Definition: dollar.c:3622
int GetModInverses(WORD, WORD, WORD *, WORD *)
Definition: reken.c:1466
WORD StoreTerm(PHEAD WORD *)
Definition: sort.c:4332
int AddNtoL(int n, WORD *array)
Definition: comtool.c:288
WORD * MakeDollarMod(PHEAD WORD *, WORD **)
Definition: dollar.c:3796
VOID LowerSortLevel()
Definition: sort.c:4726
int PF_BroadcastPreDollar(WORD **dbuffer, LONG *newsize, int *numterms)
Definition: parallel.c:2207
WORD NewSort(PHEAD0)
Definition: sort.c:591
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3072
WORD * TakeContent(PHEAD WORD *, WORD *)
Definition: ratio.c:1376
WORD EvalDoLoopArg(PHEAD WORD *, WORD)
Definition: dollar.c:2646
WORD CompCoef(WORD *, WORD *)
Definition: reken.c:3037
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:681