FORM  4.2
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 < 32 ) newsize = 32;
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 < 32 ) {
307  WORD oldsize, *oldwhere, i;
308  oldsize = d->size; oldwhere = d->where;
309  d->size = 32;
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 < 32 ) {
378  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
379  d->size = 32;
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 ( d->factors[numfac-1].where == 0 ) { /* write the value */
723  if ( d->factors[numfac-1].value < 0 ) {
724  n[0] = 4; n[1] = -d->factors[numfac-1].value; n[2] = 1; n[3] = -3; n[4] = 0; t = n;
725  }
726  else {
727  n[0] = 4; n[1] = d->factors[numfac-1].value; n[2] = 1; n[3] = 3; n[4] = 0; t = n;
728  }
729  }
730  else { t = d->factors[numfac-1].where; }
731  while ( *t ) {
732  if ( WriteTerm(t,&lbrac,first,PRINTON,0) ) {
733  error = 1; break;
734  }
735  t += *t;
736  }
737  AC.OutputMode = oldOutputMode;
738  AO.OutInBuffer = 0;
739  AO.InFbrack = oldinfbrack;
740  AO.CurBufWrt = oldcurbufwrt;
741  AO.CurrentDictionary = dict;
742  if ( error ) {
743  MLOCK(ErrorMessageLock);
744  MesPrint("&Illegal dollar object for writing");
745  MUNLOCK(ErrorMessageLock);
746  M_free(AO.DollarOutBuffer,"DollarOutBuffer");
747  AO.DollarOutBuffer = 0;
748  AO.DollarOutSizeBuffer = 0;
749  return(0);
750  }
751  return(AO.DollarOutBuffer);
752 }
753 
754 /*
755  #] WriteDollarFactorToBuffer :
756  #[ AddToDollarBuffer :
757 */
758 
759 void AddToDollarBuffer(UBYTE *s)
760 {
761  int i;
762  UBYTE *t = s, *u, *newdob;
763  LONG j;
764  while ( *t ) { t++; }
765  i = t - s;
766  while ( i + AO.DollarInOutBuffer >= AO.DollarOutSizeBuffer ) {
767  j = AO.DollarInOutBuffer;
768  AO.DollarOutSizeBuffer *= 2;
769  t = AO.DollarOutBuffer;
770  newdob = (UBYTE *)Malloc1(AO.DollarOutSizeBuffer,"DollarOutBuffer");
771  u = newdob;
772  while ( --j >= 0 ) *u++ = *t++;
773  M_free(AO.DollarOutBuffer,"DollarOutBuffer");
774  AO.DollarOutBuffer = newdob;
775  }
776  t = AO.DollarOutBuffer + AO.DollarInOutBuffer-1;
777  while ( t == AO.DollarOutBuffer && ( *s == '+' || *s == ' ' ) ) s++;
778  i = 0;
779  if ( AO.CurrentDictionary == 0 ) {
780  while ( *s ) {
781  if ( *s == ' ' ) { s++; continue; }
782  *t++ = *s++; i++;
783  }
784  }
785  else {
786  while ( *s ) { *t++ = *s++; i++; }
787  }
788  *t = 0;
789  AO.DollarInOutBuffer += i;
790 }
791 
792 /*
793  #] AddToDollarBuffer :
794  #[ TermAssign :
795 
796  This routine is called from a piece of code in Normalize that has been
797  commented out.
798 */
799 
800 void TermAssign(WORD *term)
801 {
802  DOLLARS d;
803  WORD *t, *tstop, *astop, *w, *m;
804  WORD i, newsize;
805  for (;;) {
806  astop = term + *term;
807  tstop = astop - ABS(astop[-1]);
808  t = term + 1;
809  while ( t < tstop ) {
810  if ( *t == AM.termfunnum && t[1] == FUNHEAD+2
811  && t[FUNHEAD] == -DOLLAREXPRESSION ) {
812  d = Dollars + t[FUNHEAD+1];
813  newsize = *term - FUNHEAD - 1;
814  if ( newsize < 32 ) newsize = 32;
815  newsize = ((newsize+7)/8)*8;
816  if ( d->size > 2*newsize && d->size > 1000 ) {
817  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
818  d->size = 0;
819  d->where = &(AM.dollarzero);
820  }
821  if ( d->size < newsize ) {
822  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
823  d->size = newsize;
824  d->where = (WORD *)Malloc1(newsize*sizeof(WORD),"dollar contents");
825  }
826  cbuf[AM.dbufnum].rhs[t[FUNHEAD+1]] = w = d->where;
827  m = term;
828  while ( m < t ) *w++ = *m++;
829  m += t[1];
830  while ( m < tstop ) {
831  if ( *m == AM.termfunnum && m[1] == FUNHEAD+2
832  && m[FUNHEAD] == -DOLLAREXPRESSION ) { m += m[1]; }
833  else {
834  i = m[1];
835  while ( --i >= 0 ) *w++ = *m++;
836  }
837  }
838  while ( m < astop ) *w++ = *m++;
839  *(d->where) = w - d->where;
840  *w = 0;
841  d->type = DOLTERMS;
842  w = t; m = t + t[1];
843  while ( m < astop ) *w++ = *m++;
844  *term = w - term;
845  break;
846  }
847  t += t[1];
848  }
849  if ( t >= tstop ) return;
850  }
851 }
852 
853 /*
854  #] TermAssign :
855  #[ WildDollars :
856 
857  Note that we cannot upload wildcards into dollar variables when WITHPTHREADS.
858 LONG alloccounter = 0;
859 */
860 
861 
862 void WildDollars(PHEAD WORD *term)
863 {
864  GETBIDENTITY
865  DOLLARS d;
866  WORD *m, *t, *w, *ww, *orig = 0, *wildvalue, *wildstop;
867  int numdollar;
868  LONG weneed, i;
869  struct DoLlArS;
870 #ifdef WITHPTHREADS
871  int dtype = -1;
872 #endif
873 /* alloccounter++; */
874  if ( term == 0 ) {
875  m = wildvalue = AN.WildValue;
876  wildstop = AN.WildStop;
877  }
878  else {
879  ww = term + *term; ww -= ABS(ww[-1]); w = term+1;
880  while ( w < ww && *w != SUBEXPRESSION ) w += w[1];
881  if ( w >= ww ) return;
882  wildstop = w + w[1];
883  w += SUBEXPSIZE;
884  wildvalue = m = w;
885  }
886  while ( m < wildstop ) {
887  if ( *m != LOADDOLLAR ) { m += m[1]; continue; }
888  t = m - 4;
889  while ( *t == LOADDOLLAR || *t == FROMSET || *t == SETTONUM ) t -= 4;
890  if ( t < wildvalue ) {
891  MLOCK(ErrorMessageLock);
892  MesPrint("&Serious bug in wildcard prototype. Found in WildDollars");
893  MUNLOCK(ErrorMessageLock);
894  Terminate(-1);
895  }
896  numdollar = m[2];
897  d = Dollars + numdollar;
898 #ifdef WITHPTHREADS
899  {
900  int nummodopt;
901  dtype = -1;
902  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
903  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
904  if ( numdollar == ModOptdollars[nummodopt].number ) break;
905  }
906  if ( nummodopt < NumModOptdollars ) {
907  dtype = ModOptdollars[nummodopt].type;
908  if ( dtype == MODLOCAL ) {
909  d = ModOptdollars[nummodopt].dstruct+AT.identity;
910  }
911  else {
912  MLOCK(ErrorMessageLock);
913  MesPrint("&Illegal attempt to use $-variable %s in module %l",
914  DOLLARNAME(Dollars,numdollar),AC.CModule);
915  MUNLOCK(ErrorMessageLock);
916  Terminate(-1);
917  }
918  }
919  }
920  }
921 #endif
922 /*
923  The value of this wildcard goes into our $-variable
924  First compute the space we need.
925 */
926  switch ( *t ) {
927  case SYMTONUM:
928  weneed = 5;
929  break;
930  case SYMTOSYM:
931  weneed = 9;
932  break;
933  case SYMTOSUB:
934  case VECTOSUB:
935  case INDTOSUB:
936  orig = cbuf[AT.ebufnum].rhs[t[3]];
937  w = orig; while ( *w ) w += *w;
938  weneed = w - orig + 1;
939  break;
940  case VECTOMIN:
941  case VECTOVEC:
942  case INDTOIND:
943  weneed = 8;
944  break;
945  case FUNTOFUN:
946  weneed = FUNHEAD+5;
947  break;
948  case ARGTOARG:
949  orig = cbuf[AT.ebufnum].rhs[t[3]];
950  if ( *orig > 0 ) weneed = *orig+2;
951  else {
952  w = orig+1; while ( *w ) { NEXTARG(w) }
953  weneed = w - orig + 1;
954  }
955  break;
956  default:
957  weneed = 32;
958  break;
959  }
960  if ( weneed < 32 ) weneed = 32;
961  weneed = ((weneed+7)/8)*8;
962  if ( d->size > 2*weneed && d->size > 1000 ) {
963  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollarspace");
964  d->where = &(AM.dollarzero);
965  d->size = 0;
966  }
967  if ( d->size < weneed ) {
968  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollarspace");
969  d->where = (WORD *)Malloc1(weneed*sizeof(WORD),"dollarspace");
970  d->size = weneed;
971  }
972 /*
973  It is not clear what the following code does for TFORM
974 
975  if ( dtype != MODLOCAL ) {
976 */
977  cbuf[AM.dbufnum].CanCommu[numdollar] = 0;
978  cbuf[AM.dbufnum].NumTerms[numdollar] = 1;
979 /* cbuf[AM.dbufnum].rhs[numdollar] = d->where; */
980  cbuf[AM.dbufnum].rhs[numdollar] = (WORD *)(1);
981 /*
982  }
983  Now load up the value of the wildcard in compiler buffer format
984 */
985  w = d->where;
986  d->type = DOLTERMS;
987  switch ( *t ) {
988  case SYMTONUM:
989  d->where[0] = 4; d->where[2] = 1;
990  if ( t[3] >= 0 ) { d->where[1] = t[3]; d->where[3] = 3; }
991  else { d->where[1] = -t[3]; d->where[3] = -3; }
992  if ( t[3] == 0 ) { d->type = DOLZERO; d->where[0] = 0; }
993  else { d->type = DOLNUMBER; d->where[4] = 0; }
994  break;
995  case SYMTOSYM:
996  *w++ = 8;
997  *w++ = SYMBOL;
998  *w++ = 4;
999  *w++ = t[3];
1000  *w++ = 1;
1001  *w++ = 1;
1002  *w++ = 1;
1003  *w++ = 3;
1004  *w = 0;
1005  break;
1006  case SYMTOSUB:
1007  case VECTOSUB:
1008  case INDTOSUB:
1009  while ( *orig ) {
1010  i = *orig; while ( --i >= 0 ) *w++ = *orig++;
1011  }
1012  *w = 0;
1013 /*
1014  And then we have to fix up CanCommu
1015 */
1016  break;
1017  case VECTOMIN:
1018  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[3];
1019  *w++ = 1; *w++ = 1; *w++ = -3; *w = 0;
1020  break;
1021  case VECTOVEC:
1022  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[3];
1023  *w++ = 1; *w++ = 1; *w++ = 3; *w = 0;
1024  break;
1025  case INDTOIND:
1026  d->type = DOLINDEX; d->index = t[3]; *w = 0;
1027  break;
1028  case FUNTOFUN:
1029  *w++ = FUNHEAD+4; *w++ = t[3]; *w++ = FUNHEAD;
1030  FILLFUN(w)
1031  *w++ = 1; *w++ = 1; *w++ = 3; *w = 0;
1032  break;
1033  case ARGTOARG:
1034  if ( *orig > 0 ) ww = orig + *orig + 1;
1035  else {
1036  ww = orig+1; while ( *ww ) { NEXTARG(ww) }
1037  }
1038  while ( orig < ww ) *w++ = *orig++;
1039  *w = 0;
1040  d->type = DOLWILDARGS;
1041  break;
1042  default:
1043  d->type = DOLUNDEFINED;
1044  break;
1045  }
1046  m += m[1];
1047  }
1048 }
1049 
1050 /*
1051  #] WildDollars :
1052  #[ DolToTensor : with LOCK
1053 */
1054 
1055 WORD DolToTensor(PHEAD WORD numdollar)
1056 {
1057  GETBIDENTITY
1058  DOLLARS d = Dollars + numdollar;
1059  WORD retval;
1060 #ifdef WITHPTHREADS
1061  int nummodopt, dtype = -1;
1062  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1063  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1064  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1065  }
1066  if ( nummodopt < NumModOptdollars ) {
1067  dtype = ModOptdollars[nummodopt].type;
1068  if ( dtype == MODLOCAL ) {
1069  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1070  }
1071  else {
1072  LOCK(d->pthreadslockread);
1073  }
1074  }
1075  }
1076 #endif
1077  AN.ErrorInDollar = 0;
1078  if ( d->type == DOLTERMS && d->where[0] == FUNHEAD+4 &&
1079  d->where[FUNHEAD+4] == 0 && d->where[FUNHEAD+3] == 3 &&
1080  d->where[FUNHEAD+2] == 1 && d->where[FUNHEAD+1] == 1 &&
1081  d->where[1] >= FUNCTION && d->where[1] < FUNCTION+WILDOFFSET
1082  && functions[d->where[1]-FUNCTION].spec >= TENSORFUNCTION ) {
1083  retval = d->where[1];
1084  }
1085  else if ( d->type == DOLARGUMENT &&
1086  d->where[0] <= -FUNCTION && d->where[0] > -FUNCTION-WILDOFFSET
1087  && functions[-d->where[0]-FUNCTION].spec >= TENSORFUNCTION ) {
1088  retval = -d->where[0];
1089  }
1090  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1091  && d->where[1] <= -FUNCTION && d->where[1] > -FUNCTION-WILDOFFSET
1092  && d->where[2] == 0
1093  && functions[-d->where[1]-FUNCTION].spec >= TENSORFUNCTION ) {
1094  retval = -d->where[1];
1095  }
1096  else if ( d->type == DOLSUBTERM &&
1097  d->where[0] >= FUNCTION && d->where[0] < FUNCTION+WILDOFFSET
1098  && functions[d->where[0]-FUNCTION].spec >= TENSORFUNCTION ) {
1099  retval = d->where[0];
1100  }
1101  else {
1102  AN.ErrorInDollar = 1;
1103  retval = 0;
1104  }
1105 #ifdef WITHPTHREADS
1106  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1107 #endif
1108  return(retval);
1109 }
1110 
1111 /*
1112  #] DolToTensor :
1113  #[ DolToFunction : with LOCK
1114 */
1115 
1116 WORD DolToFunction(PHEAD WORD numdollar)
1117 {
1118  GETBIDENTITY
1119  DOLLARS d = Dollars + numdollar;
1120  WORD retval;
1121 #ifdef WITHPTHREADS
1122  int nummodopt, dtype = -1;
1123  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1124  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1125  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1126  }
1127  if ( nummodopt < NumModOptdollars ) {
1128  dtype = ModOptdollars[nummodopt].type;
1129  if ( dtype == MODLOCAL ) {
1130  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1131  }
1132  else {
1133  LOCK(d->pthreadslockread);
1134  }
1135  }
1136  }
1137 #endif
1138  AN.ErrorInDollar = 0;
1139  if ( d->type == DOLTERMS && d->where[0] == FUNHEAD+4 &&
1140  d->where[FUNHEAD+4] == 0 && d->where[FUNHEAD+3] == 3 &&
1141  d->where[FUNHEAD+2] == 1 && d->where[FUNHEAD+1] == 1 &&
1142  d->where[1] >= FUNCTION && d->where[1] < FUNCTION+WILDOFFSET ) {
1143  retval = d->where[1];
1144  }
1145  else if ( d->type == DOLARGUMENT &&
1146  d->where[0] <= -FUNCTION && d->where[0] > -FUNCTION-WILDOFFSET ) {
1147  retval = -d->where[0];
1148  }
1149  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1150  && d->where[1] <= -FUNCTION && d->where[1] > -FUNCTION-WILDOFFSET
1151  && d->where[2] == 0 ) {
1152  retval = -d->where[1];
1153  }
1154  else if ( d->type == DOLSUBTERM &&
1155  d->where[0] >= FUNCTION && d->where[0] < FUNCTION+WILDOFFSET ) {
1156  retval = d->where[0];
1157  }
1158  else {
1159  AN.ErrorInDollar = 1;
1160  retval = 0;
1161  }
1162 #ifdef WITHPTHREADS
1163  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1164 #endif
1165  return(retval);
1166 }
1167 
1168 /*
1169  #] DolToFunction :
1170  #[ DolToVector : with LOCK
1171 */
1172 
1173 WORD DolToVector(PHEAD WORD numdollar)
1174 {
1175  GETBIDENTITY
1176  DOLLARS d = Dollars + numdollar;
1177  WORD retval;
1178 #ifdef WITHPTHREADS
1179  int nummodopt, dtype = -1;
1180  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1181  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1182  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1183  }
1184  if ( nummodopt < NumModOptdollars ) {
1185  dtype = ModOptdollars[nummodopt].type;
1186  if ( dtype == MODLOCAL ) {
1187  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1188  }
1189  else {
1190  LOCK(d->pthreadslockread);
1191  }
1192  }
1193  }
1194 #endif
1195  AN.ErrorInDollar = 0;
1196  if ( d->type == DOLINDEX && d->index < 0 ) {
1197  retval = d->index;
1198  }
1199  else if ( d->type == DOLARGUMENT && ( d->where[0] == -VECTOR
1200  || d->where[0] == -MINVECTOR ) ) {
1201  retval = d->where[1];
1202  }
1203  else if ( d->type == DOLSUBTERM && d->where[0] == INDEX
1204  && d->where[1] == 3 && d->where[2] < 0 ) {
1205  retval = d->where[2];
1206  }
1207  else if ( d->type == DOLTERMS && d->where[0] == 7 &&
1208  d->where[7] == 0 && d->where[6] == 3 &&
1209  d->where[5] == 1 && d->where[4] == 1 &&
1210  d->where[1] >= INDEX && d->where[3] < 0 ) {
1211  retval = d->where[3];
1212  }
1213  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1214  && ( d->where[1] == -VECTOR || d->where[1] == -MINVECTOR )
1215  && d->where[3] == 0 ) {
1216  retval = d->where[2];
1217  }
1218  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1219  && d->where[1] < 0 ) {
1220  retval = d->where[1];
1221  }
1222  else {
1223  AN.ErrorInDollar = 1;
1224  retval = 0;
1225  }
1226 #ifdef WITHPTHREADS
1227  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1228 #endif
1229  return(retval);
1230 }
1231 
1232 /*
1233  #] DolToVector :
1234  #[ DolToNumber :
1235 */
1236 
1237 WORD DolToNumber(PHEAD WORD numdollar)
1238 {
1239  GETBIDENTITY
1240  DOLLARS d = Dollars + numdollar;
1241 #ifdef WITHPTHREADS
1242  int nummodopt, dtype = -1;
1243  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1244  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1245  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1246  }
1247  if ( nummodopt < NumModOptdollars ) {
1248  dtype = ModOptdollars[nummodopt].type;
1249  if ( dtype == MODLOCAL ) {
1250  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1251  }
1252  }
1253  }
1254 #endif
1255  AN.ErrorInDollar = 0;
1256  if ( ( d->type == DOLTERMS || d->type == DOLNUMBER )
1257  && d->where[0] == 4 &&
1258  d->where[4] == 0 && ( d->where[3] == 3 || d->where[3] == -3 )
1259  && d->where[2] == 1 && ( d->where[1] & TOPBITONLY ) == 0 ) {
1260  if ( d->where[3] > 0 ) return(d->where[1]);
1261  else return(-d->where[1]);
1262  }
1263  else if ( d->type == DOLARGUMENT && d->where[0] == -SNUMBER ) {
1264  return(d->where[1]);
1265  }
1266  else if ( d->type == DOLARGUMENT && d->where[0] == -INDEX
1267  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1268  return(d->where[1]);
1269  }
1270  else if ( d->type == DOLZERO ) return(0);
1271  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1272  && d->where[1] == -SNUMBER && d->where[3] == 0 ) {
1273  return(d->where[2]);
1274  }
1275  else if ( d->type == DOLINDEX && d->index >= 0 && d->index < AM.OffsetIndex ) {
1276  return(d->index);
1277  }
1278  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1279  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1280  return(d->where[1]);
1281  }
1282  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1283  && d->where[1] == -INDEX && d->where[3] == 0 && d->where[2] >= 0
1284  && d->where[2] < AM.OffsetIndex ) {
1285  return(d->where[2]);
1286  }
1287  AN.ErrorInDollar = 1;
1288  return(0);
1289 }
1290 
1291 /*
1292  #] DolToNumber :
1293  #[ DolToSymbol : with LOCK
1294 */
1295 
1296 WORD DolToSymbol(PHEAD WORD numdollar)
1297 {
1298  GETBIDENTITY
1299  DOLLARS d = Dollars + numdollar;
1300  WORD retval;
1301 #ifdef WITHPTHREADS
1302  int nummodopt, dtype = -1;
1303  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1304  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1305  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1306  }
1307  if ( nummodopt < NumModOptdollars ) {
1308  dtype = ModOptdollars[nummodopt].type;
1309  if ( dtype == MODLOCAL ) {
1310  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1311  }
1312  else {
1313  LOCK(d->pthreadslockread);
1314  }
1315  }
1316  }
1317 #endif
1318  AN.ErrorInDollar = 0;
1319  if ( d->type == DOLTERMS && d->where[0] == 8 &&
1320  d->where[8] == 0 && d->where[7] == 3 && d->where[6] == 1
1321  && d->where[5] == 1 && d->where[4] == 1 && d->where[1] == SYMBOL ) {
1322  retval = d->where[3];
1323  }
1324  else if ( d->type == DOLARGUMENT && d->where[0] == -SYMBOL ) {
1325  retval = d->where[1];
1326  }
1327  else if ( d->type == DOLSUBTERM && d->where[0] == SYMBOL
1328  && d->where[1] == 4 && d->where[3] == 1 ) {
1329  retval = d->where[2];
1330  }
1331  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1332  && d->where[1] == -SYMBOL && d->where[3] == 0 ) {
1333  retval = d->where[2];
1334  }
1335  else {
1336  AN.ErrorInDollar = 1;
1337  retval = -1;
1338  }
1339 #ifdef WITHPTHREADS
1340  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1341 #endif
1342  return(retval);
1343 }
1344 
1345 /*
1346  #] DolToSymbol :
1347  #[ DolToIndex : with LOCK
1348 */
1349 
1350 WORD DolToIndex(PHEAD WORD numdollar)
1351 {
1352  GETBIDENTITY
1353  DOLLARS d = Dollars + numdollar;
1354  WORD retval;
1355 #ifdef WITHPTHREADS
1356  int nummodopt, dtype = -1;
1357  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1358  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1359  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1360  }
1361  if ( nummodopt < NumModOptdollars ) {
1362  dtype = ModOptdollars[nummodopt].type;
1363  if ( dtype == MODLOCAL ) {
1364  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1365  }
1366  else {
1367  LOCK(d->pthreadslockread);
1368  }
1369  }
1370  }
1371 #endif
1372  AN.ErrorInDollar = 0;
1373  if ( d->type == DOLTERMS && d->where[0] == 7 &&
1374  d->where[7] == 0 && d->where[6] == 3 && d->where[5] == 1
1375  && d->where[4] == 1 && d->where[1] == INDEX && d->where[3] >= 0 ) {
1376  retval = d->where[3];
1377  }
1378  else if ( d->type == DOLARGUMENT && d->where[0] == -SNUMBER
1379  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1380  retval = d->where[1];
1381  }
1382  else if ( d->type == DOLARGUMENT && d->where[0] == -INDEX
1383  && d->where[1] >= 0 ) {
1384  retval = d->where[1];
1385  }
1386  else if ( d->type == DOLZERO ) return(0);
1387  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1388  && d->where[1] == -SNUMBER && d->where[3] == 0 && d->where[2] >= 0
1389  && d->where[2] < AM.OffsetIndex ) {
1390  retval = d->where[2];
1391  }
1392  else if ( d->type == DOLINDEX && d->index >= 0 ) {
1393  retval = d->index;
1394  }
1395  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1396  && d->where[1] >= 0 ) {
1397  retval = d->where[1];
1398  }
1399  else if ( d->type == DOLSUBTERM && d->where[0] == INDEX
1400  && d->where[1] == 3 && d->where[2] >= 0 ) {
1401  retval = d->where[2];
1402  }
1403  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1404  && d->where[1] == -INDEX && d->where[3] == 0 && d->where[2] >= 0 ) {
1405  retval = d->where[2];
1406  }
1407  else {
1408  AN.ErrorInDollar = 1;
1409  retval = 0;
1410  }
1411 #ifdef WITHPTHREADS
1412  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1413 #endif
1414  return(retval);
1415 }
1416 
1417 /*
1418  #] DolToIndex :
1419  #[ DolToTerms :
1420 
1421  Returns a struct of type DOLLARS which contains a copy of the
1422  original dollar variable, provided it can be expressed in terms of
1423  an expression (type = DOLTERMS). Otherwise it returns zero.
1424  The dollar is expressed in terms in the buffer "where"
1425 */
1426 
1427 DOLLARS DolToTerms(PHEAD WORD numdollar)
1428 {
1429  GETBIDENTITY
1430  LONG size;
1431  DOLLARS d = Dollars + numdollar, newd;
1432  WORD *t, *w, i;
1433 #ifdef WITHPTHREADS
1434  int nummodopt, dtype = -1;
1435  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1436  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1437  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1438  }
1439  if ( nummodopt < NumModOptdollars ) {
1440  dtype = ModOptdollars[nummodopt].type;
1441  if ( dtype == MODLOCAL ) {
1442  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1443  }
1444  }
1445  }
1446 #endif
1447  AN.ErrorInDollar = 0;
1448  switch ( d->type ) {
1449  case DOLARGUMENT:
1450  t = d->where;
1451  if ( t[0] < 0 ) {
1452 ShortArgument:
1453  w = AT.WorkPointer;
1454  if ( t[0] <= -FUNCTION ) {
1455  *w++ = FUNHEAD+4; *w++ = -t[0];
1456  *w++ = FUNHEAD; FILLFUN(w)
1457  *w++ = 1; *w++ = 1; *w++ = 3;
1458  }
1459  else if ( t[0] == -SYMBOL ) {
1460  *w++ = 8; *w++ = SYMBOL; *w++ = 4; *w++ = t[1];
1461  *w++ = 1; *w++ = 1; *w++ = 1; *w++ = 3;
1462  }
1463  else if ( t[0] == -VECTOR || t[0] == -INDEX ) {
1464  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[1];
1465  *w++ = 1; *w++ = 1; *w++ = 3;
1466  }
1467  else if ( t[0] == -MINVECTOR ) {
1468  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = t[1];
1469  *w++ = 1; *w++ = 1; *w++ = -3;
1470  }
1471  else if ( t[0] == -SNUMBER ) {
1472  *w++ = 4;
1473  if ( t[1] < 0 ) {
1474  *w++ = -t[1]; *w++ = 1; *w++ = -3;
1475  }
1476  else {
1477  *w++ = t[1]; *w++ = 1; *w++ = 3;
1478  }
1479  }
1480  *w = 0; size = w - AT.WorkPointer;
1481  w = AT.WorkPointer;
1482  break;
1483  }
1484  case DOLNUMBER:
1485  case DOLTERMS:
1486  t = d->where;
1487  while ( *t ) t += *t;
1488  size = t - d->where;
1489  w = d->where;
1490  break;
1491  case DOLSUBTERM:
1492  w = AT.WorkPointer;
1493  size = d->where[1];
1494  *w++ = size+4; t = d->where; NCOPY(w,t,size)
1495  *w++ = 1; *w++ = 1; *w++ = 3;
1496  w = AT.WorkPointer; size = d->where[1]+4;
1497  break;
1498  case DOLINDEX:
1499  w = AT.WorkPointer;
1500  *w++ = 7; *w++ = INDEX; *w++ = 3; *w++ = d->index;
1501  *w++ = 1; *w++ = 1; *w++ = 3; *w = 0;
1502  w = AT.WorkPointer; size = 7;
1503  break;
1504  case DOLWILDARGS:
1505 /*
1506  In some cases we can make a copy
1507 */
1508  t = d->where+1;
1509  if ( *t == 0 ) return(0);
1510  NEXTARG(t);
1511  if ( *t ) { /* More than one argument in here */
1512  MLOCK(ErrorMessageLock);
1513  MesPrint("Trying to convert a $ with an argument field into an expression");
1514  MUNLOCK(ErrorMessageLock);
1515  Terminate(-1);
1516  }
1517 /*
1518  Now we have a single argument
1519 */
1520  t = d->where+1;
1521  if ( *t < 0 ) goto ShortArgument;
1522  size = *t - ARGHEAD;
1523  w = t + ARGHEAD;
1524  break;
1525  case DOLUNDEFINED:
1526  MLOCK(ErrorMessageLock);
1527  MesPrint("Trying to use an undefined $ in an expression");
1528  MUNLOCK(ErrorMessageLock);
1529  Terminate(-1);
1530  case DOLZERO:
1531  if ( d->where ) { d->where[0] = 0; }
1532  else d->where = &(AM.dollarzero);
1533  size = 0;
1534  w = d->where;
1535  break;
1536  default:
1537  return(0);
1538  }
1539  newd = (DOLLARS)Malloc1(sizeof(struct DoLlArS)+(size+1)*sizeof(WORD),
1540  "Copy of dollar variable");
1541  t = (WORD *)(newd+1);
1542  newd->where = t;
1543  newd->name = d->name;
1544  newd->node = d->node;
1545  newd->type = DOLTERMS;
1546  newd->size = size;
1547  newd->numdummies = d->numdummies;
1548 #ifdef WITHPTHREADS
1549  newd->pthreadslockread = dummylock;
1550  newd->pthreadslockwrite = dummylock;
1551 #endif
1552  size++;
1553  NCOPY(t,w,size);
1554  newd->nfactors = d->nfactors;
1555  if ( d->nfactors > 1 ) {
1556  newd->factors = (FACDOLLAR *)Malloc1(d->nfactors*sizeof(FACDOLLAR),"Dollar factors");
1557  for ( i = 0; i < d->nfactors; i++ ) {
1558  newd->factors[i].where = 0;
1559  newd->factors[i].size = 0;
1560  newd->factors[i].type = DOLUNDEFINED;
1561  newd->factors[i].value = d->factors[i].value;
1562  }
1563  }
1564  else { newd->factors = 0; }
1565  return(newd);
1566 }
1567 
1568 /*
1569  #] DolToTerms :
1570  #[ DolToLong :
1571 */
1572 
1573 LONG DolToLong(PHEAD WORD numdollar)
1574 {
1575  GETBIDENTITY
1576  DOLLARS d = Dollars + numdollar;
1577  LONG x;
1578 #ifdef WITHPTHREADS
1579  int nummodopt, dtype = -1;
1580  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1581  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1582  if ( numdollar == ModOptdollars[nummodopt].number ) break;
1583  }
1584  if ( nummodopt < NumModOptdollars ) {
1585  dtype = ModOptdollars[nummodopt].type;
1586  if ( dtype == MODLOCAL ) {
1587  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1588  }
1589  }
1590  }
1591 #endif
1592  AN.ErrorInDollar = 0;
1593  if ( ( d->type == DOLTERMS || d->type == DOLNUMBER )
1594  && d->where[0] == 4 &&
1595  d->where[4] == 0 && ( d->where[3] == 3 || d->where[3] == -3 )
1596  && d->where[2] == 1 && ( d->where[1] & TOPBITONLY ) == 0 ) {
1597  x = d->where[1];
1598  if ( d->where[3] > 0 ) return(x);
1599  else return(-x);
1600  }
1601  else if ( ( d->type == DOLTERMS || d->type == DOLNUMBER )
1602  && d->where[0] == 6 &&
1603  d->where[6] == 0 && ( d->where[5] == 5 || d->where[5] == -5 )
1604  && d->where[3] == 1 && d->where[4] == 1 && ( d->where[2] & TOPBITONLY ) == 0 ) {
1605  x = d->where[1] + ( (LONG)(d->where[2]) << BITSINWORD );
1606  if ( d->where[5] > 0 ) return(x);
1607  else return(-x);
1608  }
1609  else if ( d->type == DOLARGUMENT && d->where[0] == -SNUMBER ) {
1610  x = d->where[1];
1611  return(x);
1612  }
1613  else if ( d->type == DOLARGUMENT && d->where[0] == -INDEX
1614  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1615  x = d->where[1];
1616  return(x);
1617  }
1618  else if ( d->type == DOLZERO ) return(0);
1619  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1620  && d->where[1] == -SNUMBER && d->where[3] == 0 ) {
1621  x = d->where[2];
1622  return(x);
1623  }
1624  else if ( d->type == DOLINDEX && d->index >= 0 && d->index < AM.OffsetIndex ) {
1625  x = d->index;
1626  return(x);
1627  }
1628  else if ( d->type == DOLWILDARGS && d->where[0] == 1
1629  && d->where[1] >= 0 && d->where[1] < AM.OffsetIndex ) {
1630  x = d->where[1];
1631  return(x);
1632  }
1633  else if ( d->type == DOLWILDARGS && d->where[0] == 0
1634  && d->where[1] == -INDEX && d->where[3] == 0 && d->where[2] >= 0
1635  && d->where[2] < AM.OffsetIndex ) {
1636  x = d->where[2];
1637  return(x);
1638  }
1639  AN.ErrorInDollar = 1;
1640  return(0);
1641 }
1642 
1643 /*
1644  #] DolToLong :
1645  #[ ExecInside :
1646 */
1647 
1648 int ExecInside(UBYTE *s)
1649 {
1650  GETIDENTITY
1651  UBYTE *t, c;
1652  WORD *w, number;
1653  int error = 0;
1654  w = AT.WorkPointer;
1655  if ( AC.insidelevel >= MAXNEST ) {
1656  MLOCK(ErrorMessageLock);
1657  MesPrint("@Nesting of inside statements more than %d levels",(WORD)MAXNEST);
1658  MUNLOCK(ErrorMessageLock);
1659  return(-1);
1660  }
1661  AC.insidesumcheck[AC.insidelevel] = NestingChecksum();
1662  AC.insidestack[AC.insidelevel] = cbuf[AC.cbufnum].Pointer
1663  - cbuf[AC.cbufnum].Buffer + 2;
1664  AC.insidelevel++;
1665  *w++ = TYPEINSIDE;
1666  w++; w++;
1667  for(;;) { /* Look for a (comma separated) list of dollar variables */
1668  while ( *s == ',' ) s++;
1669  if ( *s == 0 ) break;
1670  if ( *s == '$' ) {
1671  s++; t = s;
1672  if ( FG.cTable[*s] != 0 ) {
1673  MLOCK(ErrorMessageLock);
1674  MesPrint("Illegal name for $ variable: %s",s-1);
1675  MUNLOCK(ErrorMessageLock);
1676  goto skipdol;
1677  }
1678  while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
1679  c = *s; *s = 0;
1680  if ( ( number = GetDollar(t) ) < 0 ) {
1681  number = AddDollar(t,0,0,0);
1682  }
1683  *s = c;
1684  *w++ = number;
1685  AddPotModdollar(number);
1686  }
1687  else {
1688  MLOCK(ErrorMessageLock);
1689  MesPrint("&Illegal object in Inside statement");
1690  MUNLOCK(ErrorMessageLock);
1691 skipdol: error = 1;
1692  while ( *s && *s != ',' && s[1] != '$' ) s++;
1693  if ( *s == 0 ) break;
1694  }
1695  }
1696  AT.WorkPointer[1] = w - AT.WorkPointer;
1697  AddNtoL(AT.WorkPointer[1],AT.WorkPointer);
1698  return(error);
1699 }
1700 
1701 /*
1702  #] ExecInside :
1703  #[ InsideDollar :
1704 
1705  Execution part of Inside $a;
1706  We have to take the variables one by one and then
1707  convert them into proper terms and call Generator for the proper levels.
1708  The conversion copies the whole dollar into a new buffer, making us
1709  insensitive to redefinitions of $a inside the Inside.
1710  In the end we sort and redefine $a.
1711 */
1712 
1713 int InsideDollar(PHEAD WORD *ll, WORD level)
1714 {
1715  GETBIDENTITY
1716  int numvar = (int)(ll[1]-3), j, error = 0;
1717  WORD numdol, *oldcterm, *oldwork = AT.WorkPointer, olddefer, *r, *m;
1718  WORD oldnumlhs, *dbuffer;
1719  DOLLARS d, newd;
1720  oldcterm = AN.cTerm; AN.cTerm = 0;
1721  oldnumlhs = AR.Cnumlhs; AR.Cnumlhs = ll[2];
1722  ll += 3;
1723  olddefer = AR.DeferFlag;
1724  AR.DeferFlag = 0;
1725  while ( --numvar >= 0 ) {
1726  numdol = *ll++;
1727  d = Dollars + numdol;
1728  {
1729 #ifdef WITHPTHREADS
1730  int nummodopt, dtype = -1;
1731  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1732  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1733  if ( numdol == ModOptdollars[nummodopt].number ) break;
1734  }
1735  if ( nummodopt < NumModOptdollars ) {
1736  dtype = ModOptdollars[nummodopt].type;
1737  if ( dtype == MODLOCAL ) {
1738  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1739  }
1740  else {
1741 /* LOCK(d->pthreadslockwrite); */
1742  LOCK(d->pthreadslockread);
1743  }
1744  }
1745  }
1746 #endif
1747  newd = DolToTerms(BHEAD numdol);
1748  if ( newd == 0 || newd->where[0] == 0 ) continue;
1749  r = newd->where;
1750  NewSort(BHEAD0);
1751  while ( *r ) { /* Sum over the terms */
1752  m = AT.WorkPointer;
1753  j = *r;
1754  while ( --j >= 0 ) *m++ = *r++;
1755  AT.WorkPointer = m;
1756 /*
1757  What to do with dummy indices?
1758 */
1759  if ( Generator(BHEAD oldwork,level) ) {
1760  LowerSortLevel();
1761  error = -1; goto idcall;
1762  }
1763  AT.WorkPointer = oldwork;
1764  }
1765  AN.tryterm = 0; /* for now */
1766  if ( EndSort(BHEAD (WORD *)((VOID *)(&dbuffer)),2) < 0 ) { error = 1; break; }
1767  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"old buffer of dollar");
1768  d->where = dbuffer;
1769  if ( dbuffer == 0 || *dbuffer == 0 ) {
1770  d->type = DOLZERO;
1771  if ( dbuffer ) M_free(dbuffer,"buffer of dollar");
1772  d->where = &(AM.dollarzero); d->size = 0;
1773  }
1774  else {
1775  d->type = DOLTERMS;
1776  r = d->where; while ( *r ) r += *r;
1777  d->size = (r-d->where)+1;
1778  }
1779 /* cbuf[AM.dbufnum].rhs[numdol] = d->where; */
1780  cbuf[AM.dbufnum].rhs[numdol] = (WORD *)(1);
1781 /*
1782  Now we have a little cleaning up to do
1783 */
1784 #ifdef WITHPTHREADS
1785  if ( dtype > 0 && dtype != MODLOCAL ) {
1786 /* UNLOCK(d->pthreadslockwrite); */
1787  UNLOCK(d->pthreadslockread);
1788  }
1789 #endif
1790  if ( newd->factors ) M_free(newd->factors,"Dollar factors");
1791  M_free(newd,"Copy of dollar variable");
1792  }
1793  }
1794 idcall:;
1795  AR.Cnumlhs = oldnumlhs;
1796  AR.DeferFlag = olddefer;
1797  AN.cTerm = oldcterm;
1798  AT.WorkPointer = oldwork;
1799  return(error);
1800 }
1801 
1802 /*
1803  #] InsideDollar :
1804  #[ ExchangeDollars :
1805 */
1806 
1807 void ExchangeDollars(int num1, int num2)
1808 {
1809  DOLLARS d1, d2;
1810  WORD node1, node2;
1811  LONG nam;
1812  d1 = Dollars + num1; node1 = d1->node;
1813  d2 = Dollars + num2; node2 = d2->node;
1814  nam = d1->name; d1->name = d2->name; d2->name = nam;
1815  d1->node = node2; d2->node = node1;
1816  AC.dollarnames->namenode[node1].number = num2;
1817  AC.dollarnames->namenode[node2].number = num1;
1818 }
1819 
1820 /*
1821  #] ExchangeDollars :
1822  #[ TermsInDollar :
1823 */
1824 
1825 LONG TermsInDollar(WORD num)
1826 {
1827  GETIDENTITY
1828  DOLLARS d = Dollars + num;
1829  WORD *t;
1830  LONG n;
1831 #ifdef WITHPTHREADS
1832  int nummodopt, dtype = -1;
1833  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1834  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1835  if ( num == ModOptdollars[nummodopt].number ) break;
1836  }
1837  if ( nummodopt < NumModOptdollars ) {
1838  dtype = ModOptdollars[nummodopt].type;
1839  if ( dtype == MODLOCAL ) {
1840  d = ModOptdollars[nummodopt].dstruct+AT.identity;
1841  }
1842  else {
1843  LOCK(d->pthreadslockread);
1844  }
1845  }
1846  }
1847 #endif
1848  if ( d->type == DOLTERMS ) {
1849  n = 0;
1850  t = d->where;
1851  while ( *t ) { t += *t; n++; }
1852  }
1853  else if ( d->type == DOLWILDARGS ) {
1854  n = 0;
1855  if ( d->where[0] == 0 ) {
1856  t = d->where+1;
1857  while ( *t != 0 ) { NEXTARG(t); n++; }
1858  }
1859  else if ( d->where[0] == 1 ) n = 1;
1860  }
1861  else if ( d->type == DOLZERO ) n = 0;
1862  else n = 1;
1863 #ifdef WITHPTHREADS
1864  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
1865 #endif
1866  return(n);
1867 }
1868 
1869 /*
1870  #] TermsInDollar :
1871  #[ PreIfDollarEval :
1872 
1873  Routine is invoked in #if etc after $( is encountered.
1874  $(expr1 operator expr2) makes compares between expressions,
1875  $(expr1 operator _keyword) makes compares between expressions,
1876  interpreted as expressions. We are here mainly looking at $variables.
1877  First we look for the operator:
1878  >, <, ==, >=, <=, != : < means that it comes before.
1879  _keywords can be:
1880  _set(setname) (does the expr belong to the set (only with == or !=))
1881  _productof(expr)
1882 */
1883 
1884 UBYTE *PreIfDollarEval(UBYTE *s, int *value)
1885 {
1886  GETIDENTITY
1887  UBYTE *s1,*s2,*s3,*s4,*s5,*t,c,c1,c2,c3;
1888  int oprtr, type;
1889  WORD *buf1 = 0, *buf2 = 0, numset, *oldwork = AT.WorkPointer;
1890  EXCHINOUT
1891 /*
1892  Find the three composing objects (epxression, operator, expression or keyw
1893 */
1894  while ( *s == ' ' || *s == '\t' || *s == '\n' || *s == '\r' ) s++;
1895  s1 = t = s;
1896  while ( *t != '=' && *t != '!' && *t != '>' && *t != '<' ) {
1897  if ( *t == '[' ) { SKIPBRA1(t) }
1898  else if ( *t == '{' ) { SKIPBRA2(t) }
1899  else if ( *t == '(' ) { SKIPBRA3(t) }
1900  else if ( *t == ']' || *t == '}' || *t == ')' ) {
1901  MLOCK(ErrorMessageLock);
1902  MesPrint("@Improper bracketting in #if");
1903  MUNLOCK(ErrorMessageLock);
1904  goto onerror;
1905  }
1906  t++;
1907  }
1908  s2 = t;
1909  while ( *t == '=' || *t == '!' || *t == '>' || *t == '<' ) t++;
1910  s3 = t;
1911  while ( *t && *t != ')' ) {
1912  if ( *t == '[' ) { SKIPBRA1(t) }
1913  else if ( *t == '{' ) { SKIPBRA2(t) }
1914  else if ( *t == '(' ) { SKIPBRA3(t) }
1915  else if ( *t == ']' || *t == '}' ) {
1916  MLOCK(ErrorMessageLock);
1917  MesPrint("@Improper brackets in #if");
1918  MUNLOCK(ErrorMessageLock);
1919  goto onerror;
1920  }
1921  t++;
1922  }
1923  if ( *t == 0 ) {
1924  MLOCK(ErrorMessageLock);
1925  MesPrint("@Missing ) to match $( in #if");
1926  MUNLOCK(ErrorMessageLock);
1927  goto onerror;
1928  }
1929  s4 = t; c2 = *s4; *s4 = 0;
1930  if ( s2+2 < s3 || s2 == s3 ) {
1931 IllOp:;
1932  MLOCK(ErrorMessageLock);
1933  MesPrint("@Illegal operator in $( option of #if");
1934  MUNLOCK(ErrorMessageLock);
1935  goto onerror;
1936  }
1937  if ( s2+1 == s3 ) {
1938  if ( *s2 == '=' ) oprtr = EQUAL;
1939  else if ( *s2 == '>' ) oprtr = GREATER;
1940  else if ( *s2 == '<' ) oprtr = LESS;
1941  else goto IllOp;
1942  }
1943  else if ( *s2 == '!' && s2[1] == '=' ) oprtr = NOTEQUAL;
1944  else if ( *s2 == '=' && s2[1] == '=' ) oprtr = EQUAL;
1945  else if ( *s2 == '<' && s2[1] == '=' ) oprtr = LESSEQUAL;
1946  else if ( *s2 == '>' && s2[1] == '=' ) oprtr = GREATEREQUAL;
1947  else goto IllOp;
1948  c1 = *s2; *s2 = 0;
1949 /*
1950  The two expressions are now zero terminated
1951  Look for the special keywords
1952 */
1953  while ( *s3 == ' ' || *s3 == '\t' || *s3 == '\n' || *s3 == '\r' ) s3++;
1954  t = s3;
1955  while ( chartype[*t] == 0 ) t++;
1956  if ( *t == '_' ) {
1957  t++; c = *t; *t = 0;
1958  if ( StrICmp(s3,(UBYTE *)"set_") == 0 ) {
1959  if ( oprtr != EQUAL && oprtr != NOTEQUAL ) {
1960 ImpOp:;
1961  MLOCK(ErrorMessageLock);
1962  MesPrint("@Improper operator for special keyword in $( ) option");
1963  MUNLOCK(ErrorMessageLock);
1964  goto onerror;
1965  }
1966  type = 1;
1967  }
1968  else if ( StrICmp(s3,(UBYTE *)"multipleof_") == 0 ) {
1969  if ( oprtr != EQUAL && oprtr != NOTEQUAL ) goto ImpOp;
1970  type = 2;
1971  }
1972 /*
1973  else if ( StrICmp(s3,(UBYTE *)"productof_") == 0 ) {
1974  if ( oprtr != EQUAL && oprtr != NOTEQUAL ) goto ImpOp;
1975  type = 3;
1976  }
1977 */
1978  else type = 0;
1979  }
1980  else { type = 0; c = *t; }
1981  if ( type > 0 ) {
1982  *t++ = c; s3 = t; s5 = s4-1;
1983  while ( *s5 != ')' ) {
1984  if ( *s5 == ' ' || *s5 == '\t' || *s5 == '\n' || *s5 == '\r' ) s5--;
1985  else {
1986  MLOCK(ErrorMessageLock);
1987  MesPrint("@Improper use of special keyword in $( ) option");
1988  MUNLOCK(ErrorMessageLock);
1989  goto onerror;
1990  }
1991  }
1992  c3 = *s5; *s5 = 0;
1993  }
1994  else { c3 = c2; s5 = s4; }
1995 /*
1996  Expand the first expression.
1997 */
1998  if ( ( buf1 = TranslateExpression(s1) ) == 0 ) {
1999  AT.WorkPointer = oldwork;
2000  goto onerror;
2001  }
2002  if ( type == 1 ) { /* determine the set */
2003  if ( *s3 == '{' ) {
2004  t = s3+1;
2005  SKIPBRA2(s3)
2006  numset = DoTempSet(t,s3);
2007  s3++;
2008  if ( numset < 0 ) {
2009 noset:;
2010  MLOCK(ErrorMessageLock);
2011  MesPrint("@Argument of set_ is not a valid set");
2012  MUNLOCK(ErrorMessageLock);
2013  goto onerror;
2014  }
2015  }
2016  else {
2017  t = s3;
2018  while ( FG.cTable[*s3] == 0 || FG.cTable[*s3] == 1
2019  || *s3 == '_' ) s3++;
2020  c = *s3; *s3 = 0;
2021  if ( GetName(AC.varnames,t,&numset,NOAUTO) != CSET ) {
2022  *s3 = c; goto noset;
2023  }
2024  *s3 = c;
2025  }
2026  while ( *s3 == ' ' || *s3 == '\t' || *s3 == '\n' || *s3 == '\r' ) s3++;
2027  if ( s3 != s5 ) goto noset;
2028  *value = IsSetMember(buf1,numset);
2029  if ( oprtr == NOTEQUAL ) *value ^= 1;
2030  }
2031  else {
2032  if ( ( buf2 = TranslateExpression(s3) ) == 0 ) goto onerror;
2033  }
2034  if ( type == 0 ) {
2035  *value = TwoExprCompare(buf1,buf2,oprtr);
2036  }
2037  else if ( type == 2 ) {
2038  *value = IsMultipleOf(buf1,buf2);
2039  if ( oprtr == NOTEQUAL ) *value ^= 1;
2040  }
2041 /*
2042  else if ( type == 3 ) {
2043  *value = IsProductOf(buf1,buf2);
2044  if ( oprtr == NOTEQUAL ) *value ^= 1;
2045  }
2046 */
2047  if ( buf1 ) M_free(buf1,"Buffer in $()");
2048  if ( buf2 ) M_free(buf2,"Buffer in $()");
2049  *s5 = c3; *s4++ = c2; *s2 = c1;
2050  AT.WorkPointer = oldwork;
2051  BACKINOUT
2052  return(s4);
2053 onerror:
2054  if ( buf1 ) M_free(buf1,"Buffer in $()");
2055  if ( buf2 ) M_free(buf2,"Buffer in $()");
2056  AT.WorkPointer = oldwork;
2057  BACKINOUT
2058  return(0);
2059 }
2060 
2061 /*
2062  #] PreIfDollarEval :
2063  #[ TranslateExpression :
2064 */
2065 
2066 WORD *TranslateExpression(UBYTE *s)
2067 {
2068  GETIDENTITY
2069  CBUF *C = cbuf+AC.cbufnum;
2070  WORD oldnumrhs = C->numrhs;
2071  LONG oldcpointer = C->Pointer - C->Buffer;
2072  WORD *w = AT.WorkPointer;
2073  WORD retcode, oldEside;
2074  WORD *outbuffer;
2075  *w++ = SUBEXPSIZE + 4;
2076  AC.ProtoType = w;
2077  *w++ = SUBEXPRESSION;
2078  *w++ = SUBEXPSIZE;
2079  *w++ = C->numrhs+1;
2080  *w++ = 1;
2081  *w++ = AC.cbufnum;
2082  FILLSUB(w)
2083  *w++ = 1; *w++ = 1; *w++ = 3; *w++ = 0;
2084  AT.WorkPointer = w;
2085  if ( ( retcode = CompileAlgebra(s,RHSIDE,AC.ProtoType) ) < 0 ) {
2086  MLOCK(ErrorMessageLock);
2087  MesPrint("@Error translating first expression in $( ) option");
2088  MUNLOCK(ErrorMessageLock);
2089  return(0);
2090  }
2091  else { AC.ProtoType[2] = retcode; }
2092 /*
2093  Evaluate this expression
2094 */
2095  if ( NewSort(BHEAD0) || NewSort(BHEAD0) ) { return(0); }
2096  AN.RepPoint = AT.RepCount + 1;
2097  oldEside = AR.Eside; AR.Eside = RHSIDE;
2098  AR.Cnumlhs = C->numlhs;
2099  if ( Generator(BHEAD AC.ProtoType-1,C->numlhs) ) {
2100  AR.Eside = oldEside;
2101  LowerSortLevel(); LowerSortLevel(); return(0);
2102  }
2103  AR.Eside = oldEside;
2104  AT.WorkPointer = w;
2105  AN.tryterm = 0; /* for now */
2106  if ( EndSort(BHEAD (WORD *)((VOID *)(&outbuffer)),2) < 0 ) { LowerSortLevel(); return(0); }
2107  LowerSortLevel();
2108  C->Pointer = C->Buffer + oldcpointer;
2109  C->numrhs = oldnumrhs;
2110  AT.WorkPointer = AC.ProtoType - 1;
2111  return(outbuffer);
2112 }
2113 
2114 /*
2115  #] TranslateExpression :
2116  #[ IsSetMember :
2117 
2118  Checks whether the expression in the buffer can be seen as an element
2119  of the given set.
2120  For the special sets: if more than one term: no match!!!
2121 */
2122 
2123 int IsSetMember(WORD *buffer, WORD numset)
2124 {
2125  WORD *t = buffer, *tt, num, csize, num1;
2126  WORD bufterm[4];
2127  int i, j, type;
2128  if ( numset < AM.NumFixedSets ) {
2129  if ( t[*t] != 0 ) return(0); /* More than one term */
2130  if ( *t == 0 ) {
2131  if ( numset == POS0_ || numset == NEG0_ || numset == EVEN_
2132  || numset == Z_ || numset == Q_ ) return(1);
2133  else return(0);
2134  }
2135  if ( numset == SYMBOL_ ) {
2136  if ( *t == 8 && t[1] == SYMBOL && t[7] == 3 && t[6] == 1
2137  && t[5] == 1 && t[4] == 1 ) return(1);
2138  else return(0);
2139  }
2140  if ( numset == INDEX_ ) {
2141  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2142  && t[4] == 1 && t[3] > 0 ) return(1);
2143  if ( *t == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex)
2144  return(1);
2145  return(0);
2146  }
2147  if ( numset == FIXED_ ) {
2148  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2149  && t[4] == 1 && t[3] > 0 && t[3] < AM.OffsetIndex ) return(1);
2150  if ( *t == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex)
2151  return(1);
2152  return(0);
2153  }
2154  if ( numset == DUMMYINDEX_ ) {
2155  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2156  && t[4] == 1 && t[3] >= AM.IndDum && t[3] < AM.IndDum+MAXDUMMIES ) return(1);
2157  if ( *t == 4 && t[3] == 3 && t[2] == 1
2158  && t[1] >= AM.IndDum && t[1] < AM.IndDum+MAXDUMMIES ) return(1);
2159  return(0);
2160  }
2161  if ( numset == VECTOR_ ) {
2162  if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2163  && t[4] == 1 && t[3] < (AM.OffsetVector+WILDOFFSET) && t[3] >= AM.OffsetVector ) return(1);
2164  return(0);
2165  }
2166  tt = t + *t - 1;
2167  if ( ABS(tt[0]) != *t-1 ) return(0);
2168  if ( numset == Q_ ) return(1);
2169  if ( numset == POS_ || numset == POS0_ ) return(tt[0]>0);
2170  else if ( numset == NEG_ || numset == NEG0_ ) return(tt[0]<0);
2171  i = (ABS(tt[0])-1)/2;
2172  tt -= i;
2173  if ( tt[0] != 1 ) return(0);
2174  for ( j = 1; j < i; j++ ) { if ( tt[j] != 0 ) return(0); }
2175  if ( numset == Z_ ) return(1);
2176  if ( numset == ODD_ ) return(t[1]&1);
2177  if ( numset == EVEN_ ) return(1-(t[1]&1));
2178  return(0);
2179  }
2180  if ( t[*t] != 0 ) return(0); /* More than one term */
2181  type = Sets[numset].type;
2182  switch ( type ) {
2183  case CSYMBOL:
2184  if ( t[0] == 8 && t[1] == SYMBOL && t[7] == 3 && t[6] == 1
2185  && t[5] == 1 && t[4] == 1 ) {
2186  num = t[3];
2187  }
2188  else if ( t[0] == 4 && t[2] == 1 && t[1] <= MAXPOWER ) {
2189  num = t[1];
2190  if ( t[3] < 0 ) num = -num;
2191  num += 2*MAXPOWER;
2192  }
2193  else return(0);
2194  break;
2195  case CVECTOR:
2196  if ( t[0] == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2197  && t[4] == 1 && t[3] < 0 ) {
2198  num = t[3];
2199  }
2200  else return(0);
2201  break;
2202  case CINDEX:
2203  if ( t[0] == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2204  && t[4] == 1 && t[3] > 0 ) {
2205  num = t[3];
2206  }
2207  else if ( t[0] == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex ) {
2208  num = t[1];
2209  }
2210  else return(0);
2211  break;
2212  case CFUNCTION:
2213  if ( t[0] == 4+FUNHEAD && t[3+FUNHEAD] == 3 && t[2+FUNHEAD] == 1
2214  && t[1+FUNHEAD] == 1 && t[1] >= FUNCTION ) {
2215  num = t[1];
2216  }
2217  else return(0);
2218  break;
2219  case CNUMBER:
2220  if ( t[0] == 4 && t[2] == 1 && t[1] <= AM.OffsetIndex && t[3] == 3 ) {
2221  num = t[1];
2222  }
2223  else return(0);
2224  break;
2225  case CRANGE:
2226  csize = t[t[0]-1];
2227  csize = ABS(csize);
2228  if ( csize != t[0]-1 ) return(0);
2229  if ( Sets[numset].first < 3*MAXPOWER ) {
2230  num1 = num = Sets[numset].first;
2231  if ( num >= MAXPOWER ) num -= 2*MAXPOWER;
2232  if ( num == 0 ) {
2233  if ( num1 < MAXPOWER ) {
2234  if ( t[t[0]-1] >= 0 ) return(0);
2235  }
2236  else if ( t[t[0]-1] > 0 ) return(0);
2237  }
2238  else {
2239  bufterm[0] = 4; bufterm[1] = ABS(num);
2240  bufterm[2] = 1;
2241  if ( num < 0 ) bufterm[3] = -3;
2242  else bufterm[3] = 3;
2243  num = CompCoef(t,bufterm);
2244  if ( num1 < MAXPOWER ) {
2245  if ( num >= 0 ) return(0);
2246  }
2247  else if ( num > 0 ) return(0);
2248  }
2249  }
2250  if ( Sets[numset].last > -3*MAXPOWER ) {
2251  num1 = num = Sets[numset].last;
2252  if ( num <= -MAXPOWER ) num += 2*MAXPOWER;
2253  if ( num == 0 ) {
2254  if ( num1 > -MAXPOWER ) {
2255  if ( t[t[0]-1] <= 0 ) return(0);
2256  }
2257  else if ( t[t[0]-1] < 0 ) return(0);
2258  }
2259  else {
2260  bufterm[0] = 4; bufterm[1] = ABS(num);
2261  bufterm[2] = 1;
2262  if ( num < 0 ) bufterm[3] = -3;
2263  else bufterm[3] = 3;
2264  num = CompCoef(t,bufterm);
2265  if ( num1 > -MAXPOWER ) {
2266  if ( num <= 0 ) return(0);
2267  }
2268  else if ( num < 0 ) return(0);
2269  }
2270  }
2271  return(1);
2272  break;
2273  default: return(0);
2274  }
2275  t = SetElements + Sets[numset].first;
2276  tt = SetElements + Sets[numset].last;
2277  do {
2278  if ( num == *t ) return(1);
2279  t++;
2280  } while ( t < tt );
2281  return(0);
2282 }
2283 
2284 /*
2285  #] IsSetMember :
2286  #[ IsProductOf :
2287 
2288  Checks whether the expression in buf1 is a single term multiple of
2289  the expression in buf2.
2290 
2291 int IsProductOf(WORD *buf1, WORD *buf2)
2292 {
2293  return(0);
2294 }
2295 
2296 
2297  #] IsProductOf :
2298  #[ IsMultipleOf :
2299 
2300  Checks whether the expression in buf1 is a numerical multiple of
2301  the expression in buf2.
2302 */
2303 
2304 int IsMultipleOf(WORD *buf1, WORD *buf2)
2305 {
2306  GETIDENTITY
2307  LONG num1, num2;
2308  WORD *t1, *t2, *m1, *m2, *r1, *r2, nc1, nc2, ni1, ni2;
2309  UWORD *IfScrat1, *IfScrat2;
2310  int i, j;
2311  if ( *buf1 == 0 && *buf2 == 0 ) return(1);
2312 /*
2313  First count terms
2314 */
2315  t1 = buf1; t2 = buf2; num1 = 0; num2 = 0;
2316  while ( *t1 ) { t1 += *t1; num1++; }
2317  while ( *t2 ) { t2 += *t2; num2++; }
2318  if ( num1 != num2 ) return(0);
2319 /*
2320  Test similarity of terms. Difference up to a number.
2321 */
2322  t1 = buf1; t2 = buf2;
2323  while ( *t1 ) {
2324  m1 = t1+1; m2 = t2+1; t1 += *t1; t2 += *t2;
2325  r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2326  if ( r1-m1 != r2-m2 ) return(0);
2327  while ( m1 < r1 ) {
2328  if ( *m1 != *m2 ) return(0);
2329  m1++; m2++;
2330  }
2331  }
2332 /*
2333  Now we have to test the constant factor
2334 */
2335  IfScrat1 = (UWORD *)(TermMalloc("IsMultipleOf")); IfScrat2 = (UWORD *)(TermMalloc("IsMultipleOf"));
2336  t1 = buf1; t2 = buf2;
2337  t1 += *t1; t2 += *t2;
2338  if ( *t1 == 0 && *t2 == 0 ) return(1);
2339  r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2340  nc1 = REDLENG(t1[-1]); nc2 = REDLENG(t2[-1]);
2341  if ( DivRat(BHEAD (UWORD *)r1,nc1,(UWORD *)r2,nc2,IfScrat1,&ni1) ) {
2342  MLOCK(ErrorMessageLock);
2343  MesPrint("@Called from MultipleOf in $( )");
2344  MUNLOCK(ErrorMessageLock);
2345  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2346  Terminate(-1);
2347  }
2348  while ( *t1 ) {
2349  t1 += *t1; t2 += *t2;
2350  r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2351  nc1 = REDLENG(t1[-1]); nc2 = REDLENG(t2[-1]);
2352  if ( DivRat(BHEAD (UWORD *)r1,nc1,(UWORD *)r2,nc2,IfScrat2,&ni2) ) {
2353  MLOCK(ErrorMessageLock);
2354  MesPrint("@Called from MultipleOf in $( )");
2355  MUNLOCK(ErrorMessageLock);
2356  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2357  Terminate(-1);
2358  }
2359  if ( ni1 != ni2 ) return(0);
2360  i = 2*ABS(ni1);
2361  for ( j = 0; j < i; j++ ) {
2362  if ( IfScrat1[j] != IfScrat2[j] ) {
2363  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2364  return(0);
2365  }
2366  }
2367  }
2368  TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2369  return(1);
2370 }
2371 
2372 /*
2373  #] IsMultipleOf :
2374  #[ TwoExprCompare :
2375 
2376  Compares the expressions in buf1 and buf2 according to oprtr
2377 */
2378 
2379 int TwoExprCompare(WORD *buf1, WORD *buf2, int oprtr)
2380 {
2381  GETIDENTITY
2382  WORD *t1, *t2, cond;
2383  t1 = buf1; t2 = buf2;
2384  while ( *t1 && *t2 ) {
2385  cond = CompareTerms(BHEAD t1,t2,1);
2386  if ( cond != 0 ) {
2387  if ( cond > 0 ) { /* t1 comes first */
2388  switch ( oprtr ) { /* t1 is less */
2389  case EQUAL: return(0);
2390  case NOTEQUAL: return(1);
2391  case GREATEREQUAL: return(0);
2392  case GREATER: return(0);
2393  case LESS: return(1);
2394  case LESSEQUAL: return(1);
2395  }
2396  }
2397  else {
2398  switch ( oprtr ) {
2399  case EQUAL: return(0);
2400  case NOTEQUAL: return(1);
2401  case GREATEREQUAL: return(1);
2402  case GREATER: return(1);
2403  case LESS: return(0);
2404  case LESSEQUAL: return(0);
2405  }
2406  }
2407  }
2408  t1 += *t1; t2 += *t2;
2409  }
2410  if ( *t1 == *t2 ) { /* They are equal */
2411  switch ( oprtr ) {
2412  case EQUAL: return(1);
2413  case NOTEQUAL: return(0);
2414  case GREATEREQUAL: return(1);
2415  case GREATER: return(0);
2416  case LESS: return(0);
2417  case LESSEQUAL: return(1);
2418  }
2419  }
2420  else if ( *t1 ) { /* t1 is greater */
2421  switch ( oprtr ) {
2422  case EQUAL: return(0);
2423  case NOTEQUAL: return(1);
2424  case GREATEREQUAL: return(1);
2425  case GREATER: return(1);
2426  case LESS: return(0);
2427  case LESSEQUAL: return(0);
2428  }
2429  }
2430  else {
2431  switch ( oprtr ) { /* t1 is less */
2432  case EQUAL: return(0);
2433  case NOTEQUAL: return(1);
2434  case GREATEREQUAL: return(0);
2435  case GREATER: return(0);
2436  case LESS: return(1);
2437  case LESSEQUAL: return(1);
2438  }
2439  }
2440  MLOCK(ErrorMessageLock);
2441  MesPrint("@Internal problems with operator in $( )");
2442  MUNLOCK(ErrorMessageLock);
2443  Terminate(-1);
2444  return(0);
2445 }
2446 
2447 /*
2448  #] TwoExprCompare :
2449  #[ DollarRaiseLow :
2450 
2451  Raises or lowers the numerical value of a dollar variable
2452  Not to be used in parallel.
2453 */
2454 
2455 static UWORD *dscrat = 0;
2456 static WORD ndscrat;
2457 
2458 int DollarRaiseLow(UBYTE *name, LONG value)
2459 {
2460  GETIDENTITY
2461  int num;
2462  DOLLARS d;
2463  int sgn = 1;
2464  WORD lnum[4], nnum, *t1, *t2, i;
2465  UBYTE *s, c;
2466  s = name; while ( *s ) s++;
2467  if ( s[-1] == '-' && s[-2] == '-' && s > name+2 ) s -= 2;
2468  else if ( s[-1] == '+' && s[-2] == '+' && s > name+2 ) s -= 2;
2469  c = *s; *s = 0;
2470  num = GetDollar(name);
2471  *s = c;
2472  d = Dollars + num;
2473  if ( value < 0 ) { value = -value; sgn = -1; }
2474  if ( d->type == DOLZERO ) {
2475  if ( d->where ) M_free(d->where,"DollarRaiseLow");
2476  d->size = 32;
2477  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"DollarRaiseLow");
2478  if ( ( value & AWORDMASK ) != 0 ) {
2479  d->where[0] = 6; d->where[1] = value >> BITSINWORD;
2480  d->where[2] = (WORD)value; d->where[3] = 1; d->where[4] = 0;
2481  d->where[5] = 5*sgn; d->where[6] = 0;
2482  d->type = DOLTERMS;
2483  }
2484  else {
2485  d->where[0] = 4; d->where[1] = (WORD)value; d->where[2] = 1;
2486  d->where[3] = 3*sgn; d->where[4] = 0;
2487  d->type = DOLNUMBER;
2488  }
2489  }
2490  else if ( d->type == DOLNUMBER || ( d->type == DOLTERMS
2491  && d->where[d->where[0]] == 0
2492  && d->where[0] == ABS(d->where[d->where[0]-1])+1 ) ) {
2493  if ( ( value & AWORDMASK ) != 0 ) {
2494  lnum[0] = value >> BITSINWORD;
2495  lnum[1] = (WORD)value; lnum[2] = 1; lnum[3] = 0;
2496  nnum = 2*sgn;
2497  }
2498  else {
2499  lnum[0] = (WORD)value; lnum[1] = 1; nnum = sgn;
2500  }
2501  i = d->where[d->where[0]-1];
2502  i = REDLENG(i);
2503  if ( dscrat == 0 ) {
2504  dscrat = (UWORD *)Malloc1((AM.MaxTal+2)*sizeof(UWORD),"DollarRaiseLow");
2505  }
2506  if ( AddRat(BHEAD (UWORD *)(d->where+1),i,
2507  (UWORD *)lnum,nnum,dscrat,&ndscrat) ) {
2508  MLOCK(ErrorMessageLock);
2509  MesCall("DollarRaiseLow");
2510  MUNLOCK(ErrorMessageLock);
2511  Terminate(-1);
2512  }
2513  ndscrat = INCLENG(ndscrat);
2514  i = ABS(ndscrat);
2515  if ( i == 0 ) {
2516  M_free(d->where,"DollarRaiseLow");
2517  d->where = 0;
2518  d->type = DOLZERO;
2519  d->size = 0;
2520  return(0);
2521  }
2522  if ( i+2 > d->size ) {
2523  M_free(d->where,"DollarRaiseLow");
2524  d->size = i+2;
2525  if ( d->size < 32 ) d->size = 32;
2526  d->size = ((d->size+7)/8)*8;
2527  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"DollarRaiseLow");
2528  }
2529  t1 = d->where; *t1++ = i+1; t2 = (WORD *)dscrat;
2530  while ( --i > 0 ) *t1++ = *t2++;
2531  *t1++ = ndscrat; *t1 = 0;
2532  d->type = DOLTERMS;
2533  }
2534  return(0);
2535 }
2536 
2537 /*
2538  #] DollarRaiseLow :
2539  #[ EvalDoLoopArg :
2540 */
2557 WORD EvalDoLoopArg(PHEAD WORD *arg, WORD par)
2558 {
2559  WORD num, type, *td;
2560  DOLLARS d;
2561  if ( *arg == SNUMBER ) return(arg[1]);
2562  if ( *arg == DOLLAREXPR2 && arg[1] < 0 ) return(-arg[1]-1);
2563  d = Dollars + arg[1];
2564 #ifdef WITHPTHREADS
2565  {
2566  int nummodopt, dtype = -1;
2567  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2568  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2569  if ( arg[1] == ModOptdollars[nummodopt].number ) break;
2570  }
2571  if ( nummodopt < NumModOptdollars ) {
2572  dtype = ModOptdollars[nummodopt].type;
2573  if ( dtype == MODLOCAL ) {
2574  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2575  }
2576  }
2577  }
2578  }
2579 #endif
2580  if ( *arg == DOLLAREXPRESSION ) {
2581  if ( arg[2] != DOLLAREXPR2 ) { /* end of chain */
2582 endofchain:
2583  type = d->type;
2584  if ( type == DOLZERO ) {}
2585  else if ( type == DOLNUMBER ) {
2586  td = d->where;
2587  if ( ( td[0] != 4 ) || ( (td[1]&SPECMASK) != 0 ) || ( td[2] != 1 ) ) {
2588  MLOCK(ErrorMessageLock);
2589  if ( par == -1 ) {
2590  MesPrint("$-variable is not a short number in print statement");
2591  }
2592  else {
2593  MesPrint("$-variable is not a short number in do loop");
2594  }
2595  MUNLOCK(ErrorMessageLock);
2596  Terminate(-1);
2597  }
2598  return( td[3] > 0 ? td[1]: -td[1] );
2599  }
2600  else {
2601  MLOCK(ErrorMessageLock);
2602  if ( par == -1 ) {
2603  MesPrint("$-variable is not a number in print statement");
2604  }
2605  else {
2606  MesPrint("$-variable is not a number in do loop");
2607  }
2608  MUNLOCK(ErrorMessageLock);
2609  Terminate(-1);
2610  }
2611  return(0);
2612  }
2613  num = EvalDoLoopArg(BHEAD arg+2,par);
2614  }
2615  else if ( *arg == DOLLAREXPR2 ) {
2616  if ( arg[1] < 0 ) { num = -arg[1]-1; }
2617  else if ( arg[2] != DOLLAREXPR2 && par == -1 ) {
2618  goto endofchain;
2619  }
2620  else { num = EvalDoLoopArg(BHEAD arg+2,par); }
2621  }
2622  else {
2623  MLOCK(ErrorMessageLock);
2624  if ( par == -1 ) {
2625  MesPrint("Invalid $-variable in print statement");
2626  }
2627  else {
2628  MesPrint("Invalid $-variable in do loop");
2629  }
2630  MUNLOCK(ErrorMessageLock);
2631  Terminate(-1);
2632  return(0);
2633  }
2634  if ( num == 0 ) return(d->nfactors);
2635  if ( num > d->nfactors || num < 1 ) {
2636  MLOCK(ErrorMessageLock);
2637  if ( par == -1 ) {
2638  MesPrint("Not a valid factor number for $-variable in print statement");
2639  }
2640  else {
2641  MesPrint("Not a valid factor number for $-variable in do loop");
2642  }
2643  MUNLOCK(ErrorMessageLock);
2644  Terminate(-1);
2645  return(0);
2646  }
2647  if ( d->factors[num].type == DOLNUMBER )
2648  return(d->factors[num].value);
2649  else { /* If correct, type can only be DOLNUMBER or DOLTERMS */
2650  MLOCK(ErrorMessageLock);
2651  if ( par == -1 ) {
2652  MesPrint("$-variable in print statement is not a number");
2653  }
2654  else {
2655  MesPrint("$-variable in do loop is not a number");
2656  }
2657  MUNLOCK(ErrorMessageLock);
2658  Terminate(-1);
2659  return(0);
2660  }
2661 }
2662 
2663 /*
2664  #] EvalDoLoopArg :
2665  #[ TestDoLoop :
2666 */
2667 
2668 WORD TestDoLoop(PHEAD WORD *lhsbuf, WORD level)
2669 {
2670  GETBIDENTITY
2671  WORD start,finish,incr;
2672  WORD *h;
2673  DOLLARS d;
2674  h = lhsbuf + 4; /* address of the start value */
2675  start = EvalDoLoopArg(BHEAD h,0);
2676  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2677  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2678  h += 2;
2679  finish = EvalDoLoopArg(BHEAD h,0);
2680  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2681  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2682  h += 2;
2683  incr = EvalDoLoopArg(BHEAD h,0);
2684 
2685  if ( ( finish == start ) || ( finish > start && incr > 0 )
2686  || ( finish < start && incr < 0 ) ) {}
2687  else { level = lhsbuf[3]; } /* skips the loop */
2688 /*
2689  Put start in the dollar variable indicated by lhsbuf[2]
2690 */
2691  d = Dollars + lhsbuf[2];
2692 #ifdef WITHPTHREADS
2693  {
2694  int nummodopt, dtype = -1;
2695  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2696  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2697  if ( lhsbuf[2] == ModOptdollars[nummodopt].number ) break;
2698  }
2699  if ( nummodopt < NumModOptdollars ) {
2700  dtype = ModOptdollars[nummodopt].type;
2701  if ( dtype == MODLOCAL ) {
2702  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2703  }
2704  }
2705  }
2706  }
2707 #endif
2708 
2709  if ( d->size < 32 ) {
2710  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
2711  d->size = 32;
2712  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
2713  }
2714  if ( start > 0 ) {
2715  d->where[0] = 4;
2716  d->where[1] = start;
2717  d->where[2] = 1;
2718  d->where[3] = 3;
2719  d->where[4] = 0;
2720  d->type = DOLNUMBER;
2721  }
2722  else if ( start < 0 ) {
2723  d->where[0] = 4;
2724  d->where[1] = -start;
2725  d->where[2] = 1;
2726  d->where[3] = -3;
2727  d->where[4] = 0;
2728  d->type = DOLNUMBER;
2729  }
2730  else
2731  d->type = DOLZERO;
2732 
2733  if ( d == Dollars + lhsbuf[2] ) {
2734  cbuf[AM.dbufnum].CanCommu[lhsbuf[2]] = 0;
2735  cbuf[AM.dbufnum].NumTerms[lhsbuf[2]] = 1;
2736  cbuf[AM.dbufnum].rhs[lhsbuf[2]] = d->where;
2737  }
2738  return(level);
2739 }
2740 
2741 /*
2742  #] TestDoLoop :
2743  #[ TestEndDoLoop :
2744 */
2745 
2746 WORD TestEndDoLoop(PHEAD WORD *lhsbuf, WORD level)
2747 {
2748  GETBIDENTITY
2749  WORD start,finish,incr,value;
2750  WORD *h;
2751  DOLLARS d;
2752  h = lhsbuf + 4; /* address of the start value */
2753  start = EvalDoLoopArg(BHEAD h,0);
2754  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2755  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2756  h += 2;
2757  finish = EvalDoLoopArg(BHEAD h,0);
2758  while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2759  && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2760  h += 2;
2761  incr = EvalDoLoopArg(BHEAD h,0);
2762 
2763  if ( ( finish == start ) || ( finish > start && incr > 0 )
2764  || ( finish < start && incr < 0 ) ) {}
2765  else { level = lhsbuf[3]; } /* skips the loop */
2766 /*
2767  Put start in the dollar variable indicated by lhsbuf[2]
2768 */
2769  d = Dollars + lhsbuf[2];
2770 #ifdef WITHPTHREADS
2771  {
2772  int nummodopt, dtype = -1;
2773  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2774  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2775  if ( lhsbuf[2] == ModOptdollars[nummodopt].number ) break;
2776  }
2777  if ( nummodopt < NumModOptdollars ) {
2778  dtype = ModOptdollars[nummodopt].type;
2779  if ( dtype == MODLOCAL ) {
2780  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2781  }
2782  }
2783  }
2784  }
2785 #endif
2786 /*
2787  Get the value
2788 */
2789  if ( d->type == DOLZERO ) {
2790  value = 0;
2791  }
2792  else if ( ( d->type == DOLNUMBER || d->type == DOLTERMS )
2793  && ( d->where[4] == 0 ) && ( d->where[0] == 4 )
2794  && ( d->where[1] > 0 ) && ( d->where[2] == 1 ) ) {
2795  value = ( d->where[3] < 0 ) ? -d->where[1]: d->where[1];
2796  }
2797  else {
2798  MLOCK(ErrorMessageLock);
2799  MesPrint("Wrong type of object in do loop parameter");
2800  MUNLOCK(ErrorMessageLock);
2801  Terminate(-1);
2802  return(level);
2803  }
2804  value += incr;
2805  if ( ( finish > start && value <= finish ) ||
2806  ( finish < start && value >= finish ) ||
2807  ( finish == start && value == finish ) ) {}
2808  else level = lhsbuf[3];
2809 
2810  if ( d->size < 32 ) {
2811  if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
2812  d->size = 32;
2813  d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
2814  }
2815  if ( value > 0 ) {
2816  d->where[0] = 4;
2817  d->where[1] = value;
2818  d->where[2] = 1;
2819  d->where[3] = 3;
2820  d->where[4] = 0;
2821  d->type = DOLNUMBER;
2822  }
2823  else if ( start < 0 ) {
2824  d->where[0] = 4;
2825  d->where[1] = -value;
2826  d->where[2] = 1;
2827  d->where[3] = -3;
2828  d->where[4] = 0;
2829  d->type = DOLNUMBER;
2830  }
2831  else
2832  d->type = DOLZERO;
2833 
2834  if ( d == Dollars + lhsbuf[2] ) {
2835  cbuf[AM.dbufnum].CanCommu[lhsbuf[2]] = 0;
2836  cbuf[AM.dbufnum].NumTerms[lhsbuf[2]] = 1;
2837  cbuf[AM.dbufnum].rhs[lhsbuf[2]] = d->where;
2838  }
2839  return(level);
2840 }
2841 
2842 /*
2843  #] TestEndDoLoop :
2844  #[ DollarFactorize :
2845 */
2858 /* #define STEP2 */
2859 #define STEP2
2860 
2861 int DollarFactorize(PHEAD WORD numdollar)
2862 {
2863  GETBIDENTITY
2864  DOLLARS d = Dollars + numdollar;
2865  CBUF *C, *CC;
2866  WORD *oldworkpointer;
2867  WORD *buf1, *t, *term, *buf1content, *buf2, *termextra;
2868  WORD *buf3, *argextra;
2869 #ifdef STEP2
2870  WORD *tstop, pow, *r;
2871 #endif
2872  int i, j, jj, action = 0, sign = 1;
2873  LONG insize, ii;
2874  WORD startebuf = cbuf[AT.ebufnum].numrhs;
2875  WORD nfactors, factorsincontent, extrafactor = 0;
2876  WORD oldsorttype = AR.SortType;
2877 
2878 #ifdef WITHPTHREADS
2879  int nummodopt, dtype;
2880  dtype = -1;
2881  if ( AS.MultiThreaded ) {
2882  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2883  if ( numdollar == ModOptdollars[nummodopt].number ) break;
2884  }
2885  if ( nummodopt < NumModOptdollars ) {
2886  dtype = ModOptdollars[nummodopt].type;
2887  if ( dtype == MODLOCAL ) {
2888  d = ModOptdollars[nummodopt].dstruct+AT.identity;
2889  }
2890  else {
2891  LOCK(d->pthreadslockread);
2892  }
2893  }
2894  }
2895 #endif
2896  CleanDollarFactors(d);
2897 #ifdef WITHPTHREADS
2898  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
2899 #endif
2900  if ( d->type != DOLTERMS ) { /* only one term */
2901  if ( d->type != DOLZERO ) d->nfactors = 1;
2902  return(0);
2903  }
2904  if ( d->where[d->where[0]] == 0 ) { /* only one term. easy */
2905  }
2906 /*
2907  Here should come the code for the factorization
2908  We copied the routine ArgFactorize in argument.c and changed the
2909  memory management completely. For the actual factorization it
2910  calls WORD *DoFactorizeDollar(PHEAD WORD *expr) which allocates
2911  space for the answer. Notation:
2912  term,...,term,0,term,...,term,0,term,...,term,0,0
2913 
2914  #[ Step 1: sort the terms properly and/or make copy --> buf1,insize
2915 */
2916  term = d->where;
2917  AR.SortType = SORTHIGHFIRST;
2918  if ( oldsorttype != AR.SortType ) {
2919  NewSort(BHEAD0);
2920  while ( *term ) {
2921  t = term + *term;
2922  if ( AN.ncmod != 0 ) {
2923  if ( AN.ncmod != 1 || ( (WORD)AN.cmod[0] < 0 ) ) {
2924  AR.SortType = oldsorttype;
2925  MLOCK(ErrorMessageLock);
2926  MesPrint("Factorization modulus a number, greater than a WORD not implemented.");
2927  MUNLOCK(ErrorMessageLock);
2928  Terminate(-1);
2929  }
2930  if ( Modulus(term) ) {
2931  AR.SortType = oldsorttype;
2932  MLOCK(ErrorMessageLock);
2933  MesCall("DollarFactorize");
2934  MUNLOCK(ErrorMessageLock);
2935  Terminate(-1);
2936  }
2937  if ( !*term) { term = t; continue; }
2938  }
2939  StoreTerm(BHEAD term);
2940  term = t;
2941  }
2942  AN.tryterm = 0; /* for now */
2943  EndSort(BHEAD (WORD *)((void *)(&buf1)),2);
2944  t = buf1; while ( *t ) t += *t;
2945  insize = t - buf1;
2946  }
2947  else {
2948  t = term; while ( *t ) t += *t;
2949  ii = insize = t - term;
2950  buf1 = (WORD *)Malloc1((insize+1)*sizeof(WORD),"DollarFactorize-1");
2951  t = buf1;
2952  NCOPY(t,term,ii);
2953  *t++ = 0;
2954  }
2955 /*
2956  #] Step 1:
2957  #[ Step 2: take out the 'content'.
2958 */
2959 #ifdef STEP2
2960  buf1content = TermMalloc("DollarContent");
2961  AN.tryterm = -1;
2962  if ( ( buf2 = TakeContent(BHEAD buf1,buf1content) ) == 0 ) {
2963  AN.tryterm = 0;
2964  TermFree(buf1content,"DollarContent");
2965  M_free(buf1,"DollarFactorize-1");
2966  AR.SortType = oldsorttype;
2967  MLOCK(ErrorMessageLock);
2968  MesCall("DollarFactorize");
2969  MUNLOCK(ErrorMessageLock);
2970  Terminate(-1);
2971  return(1);
2972  }
2973  else if ( ( buf1content[0] == 4 ) && ( buf1content[1] == 1 ) &&
2974  ( buf1content[2] == 1 ) && ( buf1content[3] == 3 ) ) { /* Nothing happened */
2975  AN.tryterm = 0;
2976  if ( buf2 != buf1 ) {
2977  M_free(buf2,"DollarFactorize-2");
2978  buf2 = buf1;
2979  }
2980  factorsincontent = 0;
2981  }
2982  else {
2983 /*
2984  The way we took out objects is rather brutish. We have to normalize
2985 */
2986  AN.tryterm = 0;
2987  if ( buf2 != buf1 ) M_free(buf1,"DollarFactorize-1");
2988  buf1 = buf2;
2989  t = buf1; while ( *t ) t += *t;
2990  insize = t - buf1;
2991 /*
2992  Now analyse how many factors there are in the content
2993 */
2994  factorsincontent = 0;
2995  term = buf1content;
2996  tstop = term + *term;
2997  if ( tstop[-1] < 0 ) factorsincontent++;
2998  if ( ABS(tstop[-1]) == 3 && tstop[-2] == 1 && tstop[-3] == 1 ) {
2999  tstop -= ABS(tstop[-1]);
3000  }
3001  else {
3002  factorsincontent++;
3003  tstop -= ABS(tstop[-1]);
3004  }
3005  term++;
3006  while ( term < tstop ) {
3007  switch ( *term ) {
3008  case SYMBOL:
3009  t = term+2; i = (term[1]-2)/2;
3010  while ( i > 0 ) {
3011  factorsincontent += ABS(t[1]);
3012  i--; t += 2;
3013  }
3014  break;
3015  case DOTPRODUCT:
3016  t = term+2; i = (term[1]-2)/3;
3017  while ( i > 0 ) {
3018  factorsincontent += ABS(t[2]);
3019  i--; t += 3;
3020  }
3021  break;
3022  case VECTOR:
3023  case DELTA:
3024  factorsincontent += (term[1]-2)/2;
3025  break;
3026  case INDEX:
3027  factorsincontent += term[1]-2;
3028  break;
3029  default:
3030  if ( *term >= FUNCTION ) factorsincontent++;
3031  break;
3032  }
3033  term += term[1];
3034  }
3035  }
3036 #else
3037  factorsincontent = 0;
3038  buf1content = 0;
3039 #endif
3040 /*
3041  #] Step 2: take out the 'content'.
3042  #[ Step 3: ConvertToPoly
3043  if there are objects that are not SYMBOLs,
3044  invoke ConvertToPoly
3045  We keep the original in buf1 in case there are no factors
3046 */
3047  t = buf1;
3048  while ( *t ) {
3049  if ( ( t[1] != SYMBOL ) && ( *t != (ABS(t[*t-1])+1) ) ) {
3050  action = 1; break;
3051  }
3052  t += *t;
3053  }
3054  if ( DetCommu(buf1) > 1 ) {
3055  MesPrint("Cannot factorize a $-expression with more than one noncommuting object");
3056  AR.SortType = oldsorttype;
3057  M_free(buf1,"DollarFactorize-2");
3058  if ( buf1content ) TermFree(buf1content,"DollarContent");
3059  MesCall("DollarFactorize");
3060  Terminate(-1);
3061  return(-1);
3062  }
3063  if ( action ) {
3064  t = buf1;
3065  termextra = AT.WorkPointer;
3066  NewSort(BHEAD0);
3067  NewSort(BHEAD0);
3068  while ( *t ) {
3069  if ( LocalConvertToPoly(BHEAD t,termextra,startebuf,0) < 0 ) {
3070 getout:
3071  AR.SortType = oldsorttype;
3072  M_free(buf1,"DollarFactorize-2");
3073  if ( buf1content ) TermFree(buf1content,"DollarContent");
3074  MesCall("DollarFactorize");
3075  Terminate(-1);
3076  return(-1);
3077  }
3078  StoreTerm(BHEAD termextra);
3079  t += *t;
3080  }
3081  AN.tryterm = 0; /* for now */
3082  if ( EndSort(BHEAD (WORD *)((void *)(&buf2)),2) < 0 ) { goto getout; }
3083  LowerSortLevel();
3084  t = buf2; while ( *t > 0 ) t += *t;
3085  }
3086  else {
3087  buf2 = buf1;
3088  }
3089 /*
3090  #] Step 3: ConvertToPoly
3091  #[ Step 4: Now the hard work.
3092 */
3093  if ( ( buf3 = poly_factorize_dollar(BHEAD buf2) ) == 0 ) {
3094  MesCall("DollarFactorize");
3095  AR.SortType = oldsorttype;
3096  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-3");
3097  M_free(buf1,"DollarFactorize-3");
3098  if ( buf1content ) TermFree(buf1content,"DollarContent");
3099  Terminate(-1);
3100  return(-1);
3101  }
3102  if ( buf2 != buf1 && buf2 ) {
3103  M_free(buf2,"DollarFactorize-3");
3104  buf2 = 0;
3105  }
3106  term = buf3;
3107  AR.SortType = oldsorttype;
3108 /*
3109  Count the factors and strip a factor -1
3110 */
3111  nfactors = 0;
3112  while ( *term ) {
3113 #ifdef STEP2
3114  if ( *term == 4 && term[4] == 0 && term[3] == -3 && term[2] == 1
3115  && term[1] == 1 ) {
3116  WORD *tt1, *tt2, *ttstop;
3117  sign = -sign;
3118  tt1 = term; tt2 = term + *term + 1;
3119  ttstop = tt2;
3120  while ( *ttstop ) {
3121  while ( *ttstop ) ttstop += *ttstop;
3122  ttstop++;
3123  }
3124  while ( tt2 < ttstop ) *tt1++ = *tt2++;
3125  *tt1 = 0;
3126  factorsincontent++;
3127  extrafactor++;
3128  }
3129  else
3130 #endif
3131  {
3132  term += *term;
3133  while ( *term ) { term += *term; }
3134  nfactors++; term++;
3135  }
3136  }
3137 /*
3138  We have now:
3139  buf1: the original before ConvertToPoly for if only one factor
3140  buf3: the factored expression with nfactors factors
3141 
3142  #] Step 4:
3143  #[ Step 5: ConvertFromPoly
3144  If ConvertToPoly was used, use now ConvertFromPoly
3145  Be careful: there should be more than one factor now.
3146 */
3147 #ifdef WITHPTHREADS
3148  if ( dtype > 0 && dtype != MODLOCAL ) { LOCK(d->pthreadslockread); }
3149 #endif
3150  if ( nfactors == 1 && extrafactor == 0 ) { /* we can use the buf1 contents */
3151  if ( factorsincontent == 0 ) {
3152  d->nfactors = 1;
3153 #ifdef WITHPTHREADS
3154  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
3155 #endif
3156 /*
3157  We used here (before 3-sep-2015) the original and did not make
3158  provisions for having a factors struct, figuring that all info
3159  is identical to the full dollar. This makes things too
3160  complicated at later stages.
3161 */
3162  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR),"factors in dollar");
3163  term = buf1; while ( *term ) term += *term;
3164  d->factors[0].size = i = term - buf1;
3165  d->factors[0].where = t = (WORD *)Malloc1(sizeof(WORD)*(i+1),"DollarFactorize-5");
3166  term = buf1; NCOPY(t,term,i); *t = 0;
3167  AR.SortType = oldsorttype;
3168  M_free(buf3,"DollarFactorize-4");
3169  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-4");
3170  M_free(buf1,"DollarFactorize-4");
3171  if ( buf1content ) TermFree(buf1content,"DollarContent");
3172  return(0);
3173  }
3174  else {
3175  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3176  term = buf1; while ( *term ) term += *term;
3177  d->factors[0].size = i = term - buf1;
3178  d->factors[0].where = t = (WORD *)Malloc1(sizeof(WORD)*(i+1),"DollarFactorize-5");
3179  term = buf1; NCOPY(t,term,i); *t = 0;
3180  M_free(buf3,"DollarFactorize-4");
3181  buf3 = 0;
3182  if ( buf2 != buf1 && buf2 ) {
3183  M_free(buf2,"DollarFactorize-4");
3184  buf2 = 0;
3185  }
3186  }
3187  }
3188  else if ( action ) {
3189  C = cbuf+AC.cbufnum;
3190  CC = cbuf+AT.ebufnum;
3191  oldworkpointer = AT.WorkPointer;
3192  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3193  term = buf3;
3194  for ( i = 0; i < nfactors; i++ ) {
3195  argextra = AT.WorkPointer;
3196  NewSort(BHEAD0);
3197  NewSort(BHEAD0);
3198  while ( *term ) {
3199  if ( ConvertFromPoly(BHEAD term,argextra,numxsymbol,CC->numrhs-startebuf+numxsymbol
3200  ,startebuf-numxsymbol,1) <= 0 ) {
3201  LowerSortLevel();
3202 getout2: AR.SortType = oldsorttype;
3203  M_free(d->factors,"factors in dollar");
3204  d->factors = 0;
3205 #ifdef WITHPTHREADS
3206  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
3207 #endif
3208  M_free(buf3,"DollarFactorize-4");
3209  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-4");
3210  M_free(buf1,"DollarFactorize-4");
3211  if ( buf1content ) TermFree(buf1content,"DollarContent");
3212  return(-3);
3213  }
3214  AT.WorkPointer = argextra + *argextra;
3215 /*
3216  ConvertFromPoly leaves terms with subexpressions. Hence:
3217 */
3218  if ( Generator(BHEAD argextra,C->numlhs+1) ) {
3219  goto getout2;
3220  }
3221  term += *term;
3222  }
3223  term++;
3224  AT.WorkPointer = oldworkpointer;
3225  AN.tryterm = 0; /* for now */
3226  EndSort(BHEAD (WORD *)((void *)(&(d->factors[i].where))),2);
3227  LowerSortLevel();
3228  d->factors[i].type = DOLTERMS;
3229  t = d->factors[i].where;
3230  while ( *t ) t += *t;
3231  d->factors[i].size = t - d->factors[i].where;
3232  }
3233  CC->numrhs = startebuf;
3234  }
3235  else {
3236  C = cbuf+AC.cbufnum;
3237  oldworkpointer = AT.WorkPointer;
3238  d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3239  term = buf3;
3240  for ( i = 0; i < nfactors; i++ ) {
3241  NewSort(BHEAD0);
3242  while ( *term ) {
3243  argextra = oldworkpointer;
3244  j = *term;
3245  NCOPY(argextra,term,j)
3246  AT.WorkPointer = argextra;
3247  if ( Generator(BHEAD oldworkpointer,C->numlhs+1) ) {
3248  goto getout2;
3249  }
3250  }
3251  term++;
3252  AT.WorkPointer = oldworkpointer;
3253  AN.tryterm = 0; /* for now */
3254  EndSort(BHEAD (WORD *)((void *)(&(d->factors[i].where))),2);
3255  d->factors[i].type = DOLTERMS;
3256  t = d->factors[i].where;
3257  while ( *t ) t += *t;
3258  d->factors[i].size = t - d->factors[i].where;
3259  }
3260  }
3261  d->nfactors = nfactors + factorsincontent;
3262 /*
3263  #] Step 5: ConvertFromPoly
3264  #[ Step 6: The factors of the content
3265 */
3266  if ( buf3 ) M_free(buf3,"DollarFactorize-5");
3267  if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-5");
3268  M_free(buf1,"DollarFactorize-5");
3269  j = nfactors;
3270 #ifdef STEP2
3271  term = buf1content;
3272  tstop = term + *term;
3273  if ( tstop[-1] < 0 ) { tstop[-1] = -tstop[-1]; sign = -sign; }
3274  tstop -= tstop[-1];
3275  term++;
3276  while ( term < tstop ) {
3277  switch ( *term ) {
3278  case SYMBOL:
3279  t = term+2; i = (term[1]-2)/2;
3280  while ( i > 0 ) {
3281  if ( t[1] < 0 ) { t[1] = -t[1]; pow = -1; }
3282  else { pow = 1; }
3283  for ( jj = 0; jj < t[1]; jj++ ) {
3284  r = d->factors[j].where = (WORD *)Malloc1(9*sizeof(WORD),"factor");
3285  r[0] = 8; r[1] = SYMBOL; r[2] = 4; r[3] = *t; r[4] = pow;
3286  r[5] = 1; r[6] = 1; r[7] = 3; r[8] = 0;
3287  d->factors[j].type = DOLTERMS;
3288  d->factors[j].size = 8;
3289  j++;
3290  }
3291  i--; t += 2;
3292  }
3293  break;
3294  case DOTPRODUCT:
3295  t = term+2; i = (term[1]-2)/3;
3296  while ( i > 0 ) {
3297  if ( t[2] < 0 ) { t[2] = -t[2]; pow = -1; }
3298  else { pow = 1; }
3299  for ( jj = 0; jj < t[2]; jj++ ) {
3300  r = d->factors[j].where = (WORD *)Malloc1(10*sizeof(WORD),"factor");
3301  r[0] = 9; r[1] = DOTPRODUCT; r[2] = 5; r[3] = t[0]; r[4] = t[1];
3302  r[5] = pow; r[6] = 1; r[7] = 1; r[8] = 3; r[9] = 0;
3303  d->factors[j].type = DOLTERMS;
3304  d->factors[j].size = 9;
3305  j++;
3306  }
3307  i--; t += 3;
3308  }
3309  break;
3310  case VECTOR:
3311  case DELTA:
3312  t = term+2; i = (term[1]-2)/2;
3313  while ( i > 0 ) {
3314  for ( jj = 0; jj < t[1]; jj++ ) {
3315  r = d->factors[j].where = (WORD *)Malloc1(9*sizeof(WORD),"factor");
3316  r[0] = 8; r[1] = *term; r[2] = 4; r[3] = *t; r[4] = t[1];
3317  r[5] = 1; r[6] = 1; r[7] = 3; r[8] = 0;
3318  d->factors[j].type = DOLTERMS;
3319  d->factors[j].size = 8;
3320  j++;
3321  }
3322  i--; t += 2;
3323  }
3324  break;
3325  case INDEX:
3326  t = term+2; i = term[1]-2;
3327  while ( i > 0 ) {
3328  for ( jj = 0; jj < t[1]; jj++ ) {
3329  r = d->factors[j].where = (WORD *)Malloc1(8*sizeof(WORD),"factor");
3330  r[0] = 7; r[1] = *term; r[2] = 3; r[3] = *t;
3331  r[4] = 1; r[5] = 1; r[6] = 3; r[7] = 0;
3332  d->factors[j].type = DOLTERMS;
3333  d->factors[j].size = 7;
3334  j++;
3335  }
3336  i--; t++;
3337  }
3338  break;
3339  default:
3340  if ( *term >= FUNCTION ) {
3341  r = d->factors[j].where = (WORD *)Malloc1((term[1]+5)*sizeof(WORD),"factor");
3342  *r++ = d->factors[j].size = term[1]+4;
3343  for ( jj = 0; jj < t[1]; jj++ ) *r++ = term[jj];
3344  *r++ = 1; *r++ = 1; *r++ = 3; *r = 0;
3345  j++;
3346  }
3347  break;
3348  }
3349  term += term[1];
3350  }
3351 #endif
3352 /*
3353  #] Step 6:
3354  #[ Step 7: Numerical factors
3355 */
3356 #ifdef STEP2
3357  term = buf1content;
3358  tstop = term + *term;
3359  if ( tstop[-1] == 3 && tstop[-2] == 1 && tstop[-3] == 1 ) {}
3360  else if ( tstop[-1] == 3 && tstop[-2] == 1 && (UWORD)(tstop[-3]) <= MAXPOSITIVE ) {
3361  d->factors[j].where = 0;
3362  d->factors[j].size = 0;
3363  d->factors[j].type = DOLNUMBER;
3364  d->factors[j].value = sign*tstop[-3];
3365  sign = 1;
3366  j++;
3367  }
3368  else {
3369  d->factors[j].where = r = (WORD *)Malloc1((tstop[-1]+2)*sizeof(WORD),"numfactor");
3370  d->factors[j].size = tstop[-1]+1;
3371  d->factors[j].type = DOLTERMS;
3372  d->factors[j].value = 0;
3373  i = tstop[-1];
3374  t = tstop - i;
3375  *r++ = tstop[-1]+1;
3376  NCOPY(r,t,i);
3377  *r = 0;
3378  if ( sign < 0 ) {
3379  r = d->factors[j].where;
3380  while ( *r ) {
3381  r += *r; r[-1] = -r[-1];
3382  }
3383  sign = 1;
3384  }
3385  j++;
3386  }
3387 #endif
3388  if ( sign < 0 ) { /* Note that this guy should come first */
3389  for ( jj = j; jj > 0; jj-- ) {
3390  d->factors[jj] = d->factors[jj-1];
3391  }
3392  d->factors[0].where = 0;
3393  d->factors[0].size = 0;
3394  d->factors[0].type = DOLNUMBER;
3395  d->factors[0].value = -1;
3396  j++;
3397  }
3398  d->nfactors = j;
3399  if ( buf1content ) TermFree(buf1content,"DollarContent");
3400 /*
3401  #] Step 7:
3402  #[ Step 8: Sorting the factors
3403 
3404  There are d->nfactors factors. Look which ones have a 'where'
3405  Sort them by bubble sort
3406 */
3407  if ( d->nfactors > 1 ) {
3408  WORD ***fac, j1, j2, k, ret, *s1, *s2, *s3;
3409  LONG **facsize, x;
3410  facsize = (LONG **)Malloc1((sizeof(WORD **)+sizeof(LONG *))*d->nfactors,"SortDollarFactors");
3411  fac = (WORD ***)(facsize+d->nfactors);
3412  k = 0;
3413  for ( j = 0; j < d->nfactors; j++ ) {
3414  if ( d->factors[j].where ) {
3415  fac[k] = &(d->factors[j].where);
3416  facsize[k] = &(d->factors[j].size);
3417  k++;
3418  }
3419  }
3420  if ( k > 1 ) {
3421  for ( j = 1; j < k; j++ ) { /* bubble sort */
3422  j1 = j; j2 = j1-1;
3423 nextj1:;
3424  s1 = *(fac[j1]); s2 = *(fac[j2]);
3425  while ( *s1 && *s2 ) {
3426  if ( ( ret = CompareTerms(BHEAD s2, s1, (WORD)2) ) == 0 ) {
3427  s1 += *s1; s2 += *s2;
3428  }
3429  else if ( ret > 0 ) goto nextj;
3430  else {
3431 exch:
3432  s3 = *(fac[j1]); *(fac[j1]) = *(fac[j2]); *(fac[j2]) = s3;
3433  x = *(facsize[j1]); *(facsize[j1]) = *(facsize[j2]); *(facsize[j2]) = x;
3434  j1--; j2--;
3435  if ( j1 > 0 ) goto nextj1;
3436  goto nextj;
3437  }
3438  }
3439  if ( *s1 ) goto nextj;
3440  if ( *s2 ) goto exch;
3441 nextj:;
3442  }
3443  }
3444  M_free(facsize,"SortDollarFactors");
3445  }
3446 /*
3447  #] Step 8:
3448 */
3449 #ifdef WITHPTHREADS
3450  if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslockread); }
3451 #endif
3452  return(0);
3453 }
3454 
3455 /*
3456  #] DollarFactorize :
3457  #[ CleanDollarFactors :
3458 */
3459 
3460 void CleanDollarFactors(DOLLARS d)
3461 {
3462  int i;
3463  if ( d->nfactors > 1 ) {
3464  for ( i = 0; i < d->nfactors; i++ ) {
3465  if ( d->factors[i].where )
3466  M_free(d->factors[i].where,"dollar factors");
3467  }
3468  }
3469  if ( d->factors ) {
3470  M_free(d->factors,"dollar factors");
3471  d->factors = 0;
3472  }
3473  d->nfactors = 0;
3474 }
3475 
3476 /*
3477  #] CleanDollarFactors :
3478  #[ TakeDollarContent :
3479 */
3480 
3481 WORD *TakeDollarContent(PHEAD WORD *dollarbuffer, WORD **factor)
3482 {
3483  WORD *remain, *t;
3484  int pow;
3485 /*
3486  We force the sign of the first term to be positive.
3487 */
3488  t = dollarbuffer; pow = 1;
3489  t += *t;
3490  if ( t[-1] < 0 ) {
3491  pow = 0;
3492  t[-1] = -t[-1];
3493  while ( *t ) {
3494  t += *t; t[-1] = -t[-1];
3495  }
3496  }
3497 /*
3498  Now the GCD of the numerators and the LCM of the denominators:
3499 */
3500  if ( AN.cmod != 0 ) {
3501  if ( ( *factor = MakeDollarMod(BHEAD dollarbuffer,&remain) ) == 0 ) {
3502  Terminate(-1);
3503  }
3504  if ( pow == 0 ) {
3505  (*factor)[**factor-1] = -(*factor)[**factor-1];
3506  (*factor)[**factor-1] += AN.cmod[0];
3507  }
3508  }
3509  else {
3510  if ( ( *factor = MakeDollarInteger(BHEAD dollarbuffer,&remain) ) == 0 ) {
3511  Terminate(-1);
3512  }
3513  if ( pow == 0 ) {
3514  (*factor)[**factor-1] = -(*factor)[**factor-1];
3515  }
3516  }
3517  return(remain);
3518 }
3519 
3520 /*
3521  #] TakeDollarContent :
3522  #[ MakeDollarInteger :
3523 */
3533 WORD *MakeDollarInteger(PHEAD WORD *bufin,WORD **bufout)
3534 {
3535  GETBIDENTITY
3536  UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc;
3537  WORD *r, *r1, *r2, *r3, *rnext, i, k, j, *oldworkpointer, *factor;
3538  WORD kGCD, kLCM, kGCD2, kkLCM, jLCM, jGCD;
3539  CBUF *C = cbuf+AC.cbufnum;
3540 
3541  GCDbuffer = NumberMalloc("MakeDollarInteger");
3542  GCDbuffer2 = NumberMalloc("MakeDollarInteger");
3543  LCMbuffer = NumberMalloc("MakeDollarInteger");
3544  LCMb = NumberMalloc("MakeDollarInteger");
3545  LCMc = NumberMalloc("MakeDollarInteger");
3546  r = bufin;
3547 /*
3548  First take the first term to load up the LCM and the GCD
3549 */
3550  r2 = r + *r;
3551  j = r2[-1];
3552  r3 = r2 - ABS(j);
3553  k = REDLENG(j);
3554  if ( k < 0 ) k = -k;
3555  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3556  for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD];
3557  k = REDLENG(j);
3558  if ( k < 0 ) k = -k;
3559  r3 += k;
3560  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3561  for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM];
3562  r1 = r2;
3563 /*
3564  Now go through the rest of the terms in this argument.
3565 */
3566  while ( *r1 ) {
3567  r2 = r1 + *r1;
3568  j = r2[-1];
3569  r3 = r2 - ABS(j);
3570  k = REDLENG(j);
3571  if ( k < 0 ) k = -k;
3572  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3573  if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) {
3574 /*
3575  GCD is already 1
3576 */
3577  }
3578  else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) {
3579  if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) {
3580  goto MakeDollarIntegerErr;
3581  }
3582  kGCD = kGCD2;
3583  for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i];
3584  }
3585  else {
3586  kGCD = 1; GCDbuffer[0] = 1;
3587  }
3588  k = REDLENG(j);
3589  if ( k < 0 ) k = -k;
3590  r3 += k;
3591  while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3592  if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) {
3593  for ( kLCM = 0; kLCM < k; kLCM++ )
3594  LCMbuffer[kLCM] = r3[kLCM];
3595  }
3596  else if ( ( k != 1 ) || ( r3[0] != 1 ) ) {
3597  if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) {
3598  goto MakeDollarIntegerErr;
3599  }
3600  DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM);
3601  MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM);
3602  for ( kLCM = 0; kLCM < jLCM; kLCM++ )
3603  LCMbuffer[kLCM] = LCMc[kLCM];
3604  }
3605  else {} /* LCM doesn't change */
3606  r1 = r2;
3607  }
3608 /*
3609  Now put the factor together: GCD/LCM
3610 */
3611  r3 = (WORD *)(GCDbuffer);
3612  if ( kGCD == kLCM ) {
3613  for ( jGCD = 0; jGCD < kGCD; jGCD++ )
3614  r3[jGCD+kGCD] = LCMbuffer[jGCD];
3615  k = kGCD;
3616  }
3617  else if ( kGCD > kLCM ) {
3618  for ( jGCD = 0; jGCD < kLCM; jGCD++ )
3619  r3[jGCD+kGCD] = LCMbuffer[jGCD];
3620  for ( jGCD = kLCM; jGCD < kGCD; jGCD++ )
3621  r3[jGCD+kGCD] = 0;
3622  k = kGCD;
3623  }
3624  else {
3625  for ( jGCD = kGCD; jGCD < kLCM; jGCD++ )
3626  r3[jGCD] = 0;
3627  for ( jGCD = 0; jGCD < kLCM; jGCD++ )
3628  r3[jGCD+kLCM] = LCMbuffer[jGCD];
3629  k = kLCM;
3630  }
3631  j = 2*k+1;
3632 /*
3633  Now we have to write this to factor
3634 */
3635  factor = r1 = (WORD *)Malloc1((j+2)*sizeof(WORD),"MakeDollarInteger");
3636  *r1++ = j+1; r2 = r3;
3637  for ( i = 0; i < k; i++ ) { *r1++ = *r2++; *r1++ = *r2++; }
3638  *r1++ = j;
3639  *r1 = 0;
3640 /*
3641  Next we have to take the factor out from the argument.
3642  This cannot be done in location, because the denominator stuff can make
3643  coefficients longer.
3644 
3645  We do this via a sort because the things may be jumbled any way and we
3646  do not know in advance how much space we need.
3647 */
3648  NewSort(BHEAD0);
3649  r = bufin;
3650  oldworkpointer = AT.WorkPointer;
3651  while ( *r ) {
3652  rnext = r + *r;
3653  j = ABS(rnext[-1]);
3654  r3 = rnext - j;
3655  r2 = oldworkpointer;
3656  while ( r < r3 ) *r2++ = *r++;
3657  j = (j-1)/2; /* reduced length. Remember, k is the other red length */
3658  if ( DivRat(BHEAD (UWORD *)r3,j,GCDbuffer,k,(UWORD *)r2,&i) ) {
3659  goto MakeDollarIntegerErr;
3660  }
3661  i = 2*i+1;
3662  r2 = r2 + i;
3663  if ( rnext[-1] < 0 ) r2[-1] = -i;
3664  else r2[-1] = i;
3665  *oldworkpointer = r2-oldworkpointer;
3666  AT.WorkPointer = r2;
3667  if ( Generator(BHEAD oldworkpointer,C->numlhs) ) {
3668  goto MakeDollarIntegerErr;
3669  }
3670  r = rnext;
3671  }
3672  AT.WorkPointer = oldworkpointer;
3673  AN.tryterm = 0; /* for now */
3674  EndSort(BHEAD (WORD *)bufout,2);
3675 /*
3676  Cleanup
3677 */
3678  NumberFree(LCMc,"MakeDollarInteger");
3679  NumberFree(LCMb,"MakeDollarInteger");
3680  NumberFree(LCMbuffer,"MakeDollarInteger");
3681  NumberFree(GCDbuffer2,"MakeDollarInteger");
3682  NumberFree(GCDbuffer,"MakeDollarInteger");
3683  return(factor);
3684 
3685 MakeDollarIntegerErr:
3686  NumberFree(LCMc,"MakeDollarInteger");
3687  NumberFree(LCMb,"MakeDollarInteger");
3688  NumberFree(LCMbuffer,"MakeDollarInteger");
3689  NumberFree(GCDbuffer2,"MakeDollarInteger");
3690  NumberFree(GCDbuffer,"MakeDollarInteger");
3691  MesCall("MakeDollarInteger");
3692  Terminate(-1);
3693  return(0);
3694 }
3695 
3696 /*
3697  #] MakeDollarInteger :
3698  #[ MakeDollarMod :
3699 */
3707 WORD *MakeDollarMod(PHEAD WORD *buffer, WORD **bufout)
3708 {
3709  GETBIDENTITY
3710  WORD *r, *r1, x, xx, ix, ip;
3711  WORD *factor, *oldworkpointer;
3712  int i;
3713  CBUF *C = cbuf+AC.cbufnum;
3714  r = buffer;
3715  x = r[*r-3];
3716  if ( r[*r-1] < 0 ) x += AN.cmod[0];
3717  if ( GetModInverses(x,(WORD)(AN.cmod[0]),&ix,&ip) ) {
3718  Terminate(-1);
3719  }
3720  factor = (WORD *)Malloc1(5*sizeof(WORD),"MakeDollarMod");
3721  factor[0] = 4; factor[1] = x; factor[2] = 1; factor[3] = 3; factor[4] = 0;
3722 /*
3723  Now we have to multiply all coefficients by ix.
3724  This does not make things longer, but we should keep to the conventions
3725  of MakeDollarInteger.
3726 */
3727  NewSort(BHEAD0);
3728  r = buffer;
3729  oldworkpointer = AT.WorkPointer;
3730  while ( *r ) {
3731  r1 = oldworkpointer; i = *r;
3732  NCOPY(r1,r,i);
3733  xx = r1[-3]; if ( r1[-1] < 0 ) xx += AN.cmod[0];
3734  r1[-1] = (WORD)((((LONG)xx)*ix) % AN.cmod[0]);
3735  *r1 = 0; AT.WorkPointer = r1;
3736  if ( Generator(BHEAD oldworkpointer,C->numlhs) ) {
3737  Terminate(-1);
3738  }
3739  }
3740  AT.WorkPointer = oldworkpointer;
3741  AN.tryterm = 0; /* for now */
3742  EndSort(BHEAD (WORD *)bufout,2);
3743  return(factor);
3744 }
3745 /*
3746  #] MakeDollarMod :
3747  #[ GetDolNum :
3748 
3749  Evaluates a chain of DOLLAREXPR2 into a number
3750 */
3751 
3752 int GetDolNum(PHEAD WORD *t, WORD *tstop)
3753 {
3754  DOLLARS d;
3755  WORD num, *w;
3756  if ( t+3 < tstop && t[3] == DOLLAREXPR2 ) {
3757  d = Dollars + t[2];
3758 #ifdef WITHPTHREADS
3759  {
3760  int nummodopt, dtype;
3761  dtype = -1;
3762  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
3763  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3764  if ( t[2] == ModOptdollars[nummodopt].number ) break;
3765  }
3766  if ( nummodopt < NumModOptdollars ) {
3767  dtype = ModOptdollars[nummodopt].type;
3768  if ( dtype == MODLOCAL ) {
3769  d = ModOptdollars[nummodopt].dstruct+AT.identity;
3770  }
3771  else {
3772  MLOCK(ErrorMessageLock);
3773  MesPrint("&Illegal attempt to use $-variable %s in module %l",
3774  DOLLARNAME(Dollars,t[2]),AC.CModule);
3775  MUNLOCK(ErrorMessageLock);
3776  Terminate(-1);
3777  }
3778  }
3779  }
3780  }
3781 #endif
3782  if ( d->factors == 0 ) {
3783  MLOCK(ErrorMessageLock);
3784  MesPrint("Attempt to use a factor of an unfactored $-variable");
3785  MUNLOCK(ErrorMessageLock);
3786  Terminate(-1);
3787  }
3788  num = GetDolNum(BHEAD t+t[1],tstop);
3789  if ( num == 0 ) return(d->nfactors);
3790  if ( num > d->nfactors ) {
3791  MLOCK(ErrorMessageLock);
3792  MesPrint("Attempt to use an nonexisting factor %d of a $-variable",num);
3793  MUNLOCK(ErrorMessageLock);
3794  Terminate(-1);
3795  }
3796  w = d->factors[num-1].where;
3797  if ( w == 0 ) return(d->factors[num-1].value);
3798  if ( w[0] == 4 && w[4] == 0 && w[3] == 3 && w[2] == 1 && w[1] > 0
3799  && w[1] < MAXPOSITIVE ) return(w[1]);
3800  else {
3801  MLOCK(ErrorMessageLock);
3802  MesPrint("Illegal type of factor number of a $-variable");
3803  MUNLOCK(ErrorMessageLock);
3804  Terminate(-1);
3805  }
3806  }
3807  else if ( t[2] < 0 ) {
3808  return(-t[2]-1);
3809  }
3810  else {
3811  d = Dollars + t[2];
3812 #ifdef WITHPTHREADS
3813  {
3814  int nummodopt, dtype;
3815  dtype = -1;
3816  if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
3817  for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3818  if ( t[2] == ModOptdollars[nummodopt].number ) break;
3819  }
3820  if ( nummodopt < NumModOptdollars ) {
3821  dtype = ModOptdollars[nummodopt].type;
3822  if ( dtype == MODLOCAL ) {
3823  d = ModOptdollars[nummodopt].dstruct+AT.identity;
3824  }
3825  else {
3826  MLOCK(ErrorMessageLock);
3827  MesPrint("&Illegal attempt to use $-variable %s in module %l",
3828  DOLLARNAME(Dollars,t[2]),AC.CModule);
3829  MUNLOCK(ErrorMessageLock);
3830  Terminate(-1);
3831  }
3832  }
3833  }
3834  }
3835 #endif
3836  if ( d->type == DOLZERO ) return(0);
3837  if ( d->type == DOLTERMS || d->type == DOLNUMBER ) {
3838  if ( d->where[0] == 4 && d->where[4] == 0 && d->where[3] == 3
3839  && d->where[2] == 1 && d->where[1] > 0
3840  && d->where[1] < MAXPOSITIVE ) return(d->where[1]);
3841  MLOCK(ErrorMessageLock);
3842  MesPrint("Attempt to use an nonexisting factor of a $-variable");
3843  MUNLOCK(ErrorMessageLock);
3844  Terminate(-1);
3845  }
3846  MLOCK(ErrorMessageLock);
3847  MesPrint("Illegal type of factor number of a $-variable");
3848  MUNLOCK(ErrorMessageLock);
3849  Terminate(-1);
3850  }
3851  return(0);
3852 }
3853 
3854 /*
3855  #] GetDolNum :
3856  #[ AddPotModdollar :
3857 */
3858 
3865 void AddPotModdollar(WORD numdollar)
3866 {
3867  int i, n = NumPotModdollars;
3868  for ( i = 0; i < n; i++ ) {
3869  if ( numdollar == PotModdollars[i] ) break;
3870  }
3871  if ( i >= n ) {
3872  *(WORD *)FromList(&AC.PotModDolList) = numdollar;
3873  }
3874 }
3875 
3876 /*
3877  #] AddPotModdollar :
3878 */
WORD * MakeDollarMod(PHEAD WORD *buffer, WORD **bufout)
Definition: dollar.c:3707
WORD EvalDoLoopArg(PHEAD WORD *arg, WORD par)
Definition: dollar.c:2557
#define PHEAD
Definition: ftypes.h:56
int LocalConvertToPoly(PHEAD WORD *, WORD *, WORD, WORD)
Definition: notation.c:510
Definition: structs.h:921
int GetModInverses(WORD, WORD, WORD *, WORD *)
Definition: reken.c:1466
WORD StoreTerm(PHEAD WORD *)
Definition: sort.c:4246
int AddNtoL(int n, WORD *array)
Definition: comtool.c:288
void AddPotModdollar(WORD numdollar)
Definition: dollar.c:3865
WORD * MakeDollarInteger(PHEAD WORD *bufin, WORD **bufout)
Definition: dollar.c:3533
VOID LowerSortLevel()
Definition: sort.c:4610
int PF_BroadcastPreDollar(WORD **dbuffer, LONG *newsize, int *numterms)
Definition: parallel.c:2207
WORD NewSort(PHEAD0)
Definition: sort.c:589
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3034
WORD * TakeContent(PHEAD WORD *, WORD *)
Definition: ratio.c:1376
WORD CompCoef(WORD *, WORD *)
Definition: reken.c:3037
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:675