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