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