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