FORM v5.0.0-35-g6318119
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 ( dtype == MODLOCAL ) {
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 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 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 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 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 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 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 ( dtype == MODLOCAL ) {
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 ( dtype == MODLOCAL ) {
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 && dtype != MODLOCAL ) { 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 ( dtype == MODLOCAL ) {
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 && dtype != MODLOCAL ) { 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 ( dtype == MODLOCAL ) {
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 && dtype != MODLOCAL ) { 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 ( dtype == MODLOCAL ) {
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 ( dtype == MODLOCAL ) {
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 && dtype != MODLOCAL ) { 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 ( dtype == MODLOCAL ) {
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 && dtype != MODLOCAL ) { 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 ( dtype == MODLOCAL ) {
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 ( dtype == MODLOCAL ) {
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 ( dtype == MODLOCAL ) {
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 && dtype != MODLOCAL ) {
1811 UNLOCK(d->pthreadslock);
1812 }
1813#endif
1814 if ( newd->factors ) M_free(newd->factors,"Dollar factors");
1815 M_free(newd,"Copy of dollar variable");
1816 }
1817 }
1818idcall:;
1819 AR.Cnumlhs = oldnumlhs;
1820 AR.DeferFlag = olddefer;
1821 AN.cTerm = oldcterm;
1822 AT.WorkPointer = oldwork;
1823 return(error);
1824}
1825
1826/*
1827 #] InsideDollar :
1828 #[ ExchangeDollars :
1829*/
1830
1831void ExchangeDollars(int num1, int num2)
1832{
1833 DOLLARS d1, d2;
1834 WORD node1, node2;
1835 LONG nam;
1836 d1 = Dollars + num1; node1 = d1->node;
1837 d2 = Dollars + num2; node2 = d2->node;
1838 nam = d1->name; d1->name = d2->name; d2->name = nam;
1839 d1->node = node2; d2->node = node1;
1840 AC.dollarnames->namenode[node1].number = num2;
1841 AC.dollarnames->namenode[node2].number = num1;
1842}
1843
1844/*
1845 #] ExchangeDollars :
1846 #[ TermsInDollar :
1847*/
1848
1849LONG TermsInDollar(WORD num)
1850{
1851 GETIDENTITY
1852 DOLLARS d = Dollars + num;
1853 WORD *t;
1854 LONG n;
1855#ifdef WITHPTHREADS
1856 int nummodopt, dtype = -1;
1857 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1858 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1859 if ( num == ModOptdollars[nummodopt].number ) break;
1860 }
1861 if ( nummodopt < NumModOptdollars ) {
1862 dtype = ModOptdollars[nummodopt].type;
1863 if ( dtype == MODLOCAL ) {
1864 d = ModOptdollars[nummodopt].dstruct+AT.identity;
1865 }
1866 else {
1867 LOCK(d->pthreadslock);
1868 }
1869 }
1870 }
1871#endif
1872 if ( d->type == DOLTERMS ) {
1873 n = 0;
1874 t = d->where;
1875 while ( *t ) { t += *t; n++; }
1876 }
1877 else if ( d->type == DOLWILDARGS ) {
1878 n = 0;
1879 if ( d->where[0] == 0 ) {
1880 t = d->where+1;
1881 while ( *t != 0 ) { NEXTARG(t); n++; }
1882 }
1883 else if ( d->where[0] == 1 ) n = 1;
1884 }
1885 else if ( d->type == DOLZERO ) n = 0;
1886 else n = 1;
1887#ifdef WITHPTHREADS
1888 if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslock); }
1889#endif
1890 return(n);
1891}
1892
1893/*
1894 #] TermsInDollar :
1895 #[ SizeOfDollar :
1896*/
1897
1898LONG SizeOfDollar(WORD num)
1899{
1900 GETIDENTITY
1901 DOLLARS d = Dollars + num;
1902 WORD *t;
1903 LONG n;
1904#ifdef WITHPTHREADS
1905 int nummodopt, dtype = -1;
1906 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
1907 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
1908 if ( num == ModOptdollars[nummodopt].number ) break;
1909 }
1910 if ( nummodopt < NumModOptdollars ) {
1911 dtype = ModOptdollars[nummodopt].type;
1912 if ( dtype == MODLOCAL ) {
1913 d = ModOptdollars[nummodopt].dstruct+AT.identity;
1914 }
1915 else {
1916 LOCK(d->pthreadslock);
1917 }
1918 }
1919 }
1920#endif
1921 if ( d->type == DOLTERMS ) {
1922 t = d->where;
1923 while ( *t ) t += *t;
1924 t++;
1925 n = (LONG)(t - d->where);
1926 }
1927 else if ( d->type == DOLWILDARGS ) {
1928 n = 0;
1929 if ( d->where[0] == 0 ) {
1930 t = d->where+1;
1931 while ( *t != 0 ) { NEXTARG(t); n++; }
1932 t++;
1933 n = (LONG)(t - d->where);
1934 }
1935 else if ( d->where[0] == 1 ) n = 1;
1936 }
1937 else if ( d->type == DOLZERO ) n = 0;
1938 else n = 1;
1939#ifdef WITHPTHREADS
1940 if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslock); }
1941#endif
1942 return(n);
1943}
1944
1945/*
1946 #] SizeOfDollar :
1947 #[ PreIfDollarEval :
1948
1949 Routine is invoked in #if etc after $( is encountered.
1950 $(expr1 operator expr2) makes compares between expressions,
1951 $(expr1 operator _keyword) makes compares between expressions,
1952 interpreted as expressions. We are here mainly looking at $variables.
1953 First we look for the operator:
1954 >, <, ==, >=, <=, != : < means that it comes before.
1955 _keywords can be:
1956 _set(setname) (does the expr belong to the set (only with == or !=))
1957 _productof(expr)
1958*/
1959
1960UBYTE *PreIfDollarEval(UBYTE *s, int *value)
1961{
1962 GETIDENTITY
1963 UBYTE *s1,*s2,*s3,*s4,*s5,*t,c,c1,c2,c3;
1964 int oprtr, type;
1965 WORD *buf1 = 0, *buf2 = 0, numset, *oldwork = AT.WorkPointer;
1966 EXCHINOUT
1967/*
1968 Find the three composing objects (epxression, operator, expression or keyw
1969*/
1970 while ( *s == ' ' || *s == '\t' || *s == '\n' || *s == '\r' ) s++;
1971 s1 = t = s;
1972 while ( *t != '=' && *t != '!' && *t != '>' && *t != '<' ) {
1973 if ( *t == '[' ) { SKIPBRA1(t) }
1974 else if ( *t == '{' ) { SKIPBRA2(t) }
1975 else if ( *t == '(' ) { SKIPBRA3(t) }
1976 else if ( *t == ']' || *t == '}' || *t == ')' ) {
1977 MLOCK(ErrorMessageLock);
1978 MesPrint("@Improper bracketting in #if");
1979 MUNLOCK(ErrorMessageLock);
1980 goto onerror;
1981 }
1982 t++;
1983 }
1984 s2 = t;
1985 while ( *t == '=' || *t == '!' || *t == '>' || *t == '<' ) t++;
1986 s3 = t;
1987 while ( *t && *t != ')' ) {
1988 if ( *t == '[' ) { SKIPBRA1(t) }
1989 else if ( *t == '{' ) { SKIPBRA2(t) }
1990 else if ( *t == '(' ) { SKIPBRA3(t) }
1991 else if ( *t == ']' || *t == '}' ) {
1992 MLOCK(ErrorMessageLock);
1993 MesPrint("@Improper brackets in #if");
1994 MUNLOCK(ErrorMessageLock);
1995 goto onerror;
1996 }
1997 t++;
1998 }
1999 if ( *t == 0 ) {
2000 MLOCK(ErrorMessageLock);
2001 MesPrint("@Missing ) to match $( in #if");
2002 MUNLOCK(ErrorMessageLock);
2003 goto onerror;
2004 }
2005 s4 = t; c2 = *s4; *s4 = 0;
2006 if ( s2+2 < s3 || s2 == s3 ) {
2007IllOp:;
2008 MLOCK(ErrorMessageLock);
2009 MesPrint("@Illegal operator in $( option of #if");
2010 MUNLOCK(ErrorMessageLock);
2011 goto onerror;
2012 }
2013 if ( s2+1 == s3 ) {
2014 if ( *s2 == '=' ) oprtr = EQUAL;
2015 else if ( *s2 == '>' ) oprtr = GREATER;
2016 else if ( *s2 == '<' ) oprtr = LESS;
2017 else goto IllOp;
2018 }
2019 else if ( *s2 == '!' && s2[1] == '=' ) oprtr = NOTEQUAL;
2020 else if ( *s2 == '=' && s2[1] == '=' ) oprtr = EQUAL;
2021 else if ( *s2 == '<' && s2[1] == '=' ) oprtr = LESSEQUAL;
2022 else if ( *s2 == '>' && s2[1] == '=' ) oprtr = GREATEREQUAL;
2023 else goto IllOp;
2024 c1 = *s2; *s2 = 0;
2025/*
2026 The two expressions are now zero terminated
2027 Look for the special keywords
2028*/
2029 while ( *s3 == ' ' || *s3 == '\t' || *s3 == '\n' || *s3 == '\r' ) s3++;
2030 t = s3;
2031 while ( chartype[*t] == 0 ) t++;
2032 if ( *t == '_' ) {
2033 t++; c = *t; *t = 0;
2034 if ( StrICmp(s3,(UBYTE *)"set_") == 0 ) {
2035 if ( oprtr != EQUAL && oprtr != NOTEQUAL ) {
2036ImpOp:;
2037 MLOCK(ErrorMessageLock);
2038 MesPrint("@Improper operator for special keyword in $( ) option");
2039 MUNLOCK(ErrorMessageLock);
2040 goto onerror;
2041 }
2042 type = 1;
2043 }
2044 else if ( StrICmp(s3,(UBYTE *)"multipleof_") == 0 ) {
2045 if ( oprtr != EQUAL && oprtr != NOTEQUAL ) goto ImpOp;
2046 type = 2;
2047 }
2048/*
2049 else if ( StrICmp(s3,(UBYTE *)"productof_") == 0 ) {
2050 if ( oprtr != EQUAL && oprtr != NOTEQUAL ) goto ImpOp;
2051 type = 3;
2052 }
2053*/
2054 else type = 0;
2055 }
2056 else { type = 0; c = *t; }
2057 if ( type > 0 ) {
2058 *t++ = c; s3 = t; s5 = s4-1;
2059 while ( *s5 != ')' ) {
2060 if ( *s5 == ' ' || *s5 == '\t' || *s5 == '\n' || *s5 == '\r' ) s5--;
2061 else {
2062 MLOCK(ErrorMessageLock);
2063 MesPrint("@Improper use of special keyword in $( ) option");
2064 MUNLOCK(ErrorMessageLock);
2065 goto onerror;
2066 }
2067 }
2068 c3 = *s5; *s5 = 0;
2069 }
2070 else { c3 = c2; s5 = s4; }
2071/*
2072 Expand the first expression.
2073*/
2074 if ( ( buf1 = TranslateExpression(s1) ) == 0 ) {
2075 AT.WorkPointer = oldwork;
2076 goto onerror;
2077 }
2078 if ( type == 1 ) { /* determine the set */
2079 if ( *s3 == '{' ) {
2080 t = s3+1;
2081 SKIPBRA2(s3)
2082 numset = DoTempSet(t,s3);
2083 s3++;
2084 if ( numset < 0 ) {
2085noset:;
2086 MLOCK(ErrorMessageLock);
2087 MesPrint("@Argument of set_ is not a valid set");
2088 MUNLOCK(ErrorMessageLock);
2089 goto onerror;
2090 }
2091 }
2092 else {
2093 t = s3;
2094 while ( FG.cTable[*s3] == 0 || FG.cTable[*s3] == 1
2095 || *s3 == '_' ) s3++;
2096 c = *s3; *s3 = 0;
2097 if ( GetName(AC.varnames,t,&numset,NOAUTO) != CSET ) {
2098 *s3 = c; goto noset;
2099 }
2100 *s3 = c;
2101 }
2102 while ( *s3 == ' ' || *s3 == '\t' || *s3 == '\n' || *s3 == '\r' ) s3++;
2103 if ( s3 != s5 ) goto noset;
2104 *value = IsSetMember(buf1,numset);
2105 if ( oprtr == NOTEQUAL ) *value ^= 1;
2106 }
2107 else {
2108 if ( ( buf2 = TranslateExpression(s3) ) == 0 ) goto onerror;
2109 }
2110 if ( type == 0 ) {
2111 *value = TwoExprCompare(buf1,buf2,oprtr);
2112 }
2113 else if ( type == 2 ) {
2114 *value = IsMultipleOf(buf1,buf2);
2115 if ( oprtr == NOTEQUAL ) *value ^= 1;
2116 }
2117/*
2118 else if ( type == 3 ) {
2119 *value = IsProductOf(buf1,buf2);
2120 if ( oprtr == NOTEQUAL ) *value ^= 1;
2121 }
2122*/
2123 if ( buf1 ) M_free(buf1,"Buffer in $()");
2124 if ( buf2 ) M_free(buf2,"Buffer in $()");
2125 *s5 = c3; *s4++ = c2; *s2 = c1;
2126 AT.WorkPointer = oldwork;
2127 BACKINOUT
2128 return(s4);
2129onerror:
2130 if ( buf1 ) M_free(buf1,"Buffer in $()");
2131 if ( buf2 ) M_free(buf2,"Buffer in $()");
2132 AT.WorkPointer = oldwork;
2133 BACKINOUT
2134 return(0);
2135}
2136
2137/*
2138 #] PreIfDollarEval :
2139 #[ TranslateExpression :
2140*/
2141
2142WORD *TranslateExpression(UBYTE *s)
2143{
2144 GETIDENTITY
2145 CBUF *C = cbuf+AC.cbufnum;
2146 WORD oldnumrhs = C->numrhs;
2147 LONG oldcpointer = C->Pointer - C->Buffer;
2148 WORD *w = AT.WorkPointer;
2149 WORD retcode, oldEside;
2150 WORD *outbuffer;
2151 *w++ = SUBEXPSIZE + 4;
2152 AC.ProtoType = w;
2153 *w++ = SUBEXPRESSION;
2154 *w++ = SUBEXPSIZE;
2155 *w++ = C->numrhs+1;
2156 *w++ = 1;
2157 *w++ = AC.cbufnum;
2158 FILLSUB(w)
2159 *w++ = 1; *w++ = 1; *w++ = 3; *w++ = 0;
2160 AT.WorkPointer = w;
2161 if ( ( retcode = CompileAlgebra(s,RHSIDE,AC.ProtoType) ) < 0 ) {
2162 MLOCK(ErrorMessageLock);
2163 MesPrint("@Error translating first expression in $( ) option");
2164 MUNLOCK(ErrorMessageLock);
2165 return(0);
2166 }
2167 else { AC.ProtoType[2] = retcode; }
2168/*
2169 Evaluate this expression
2170*/
2171 if ( NewSort(BHEAD0) || NewSort(BHEAD0) ) { return(0); }
2172 AN.RepPoint = AT.RepCount + 1;
2173 oldEside = AR.Eside; AR.Eside = RHSIDE;
2174 AR.Cnumlhs = C->numlhs;
2175 if ( Generator(BHEAD AC.ProtoType-1,C->numlhs) ) {
2176 AR.Eside = oldEside;
2177 LowerSortLevel(); LowerSortLevel(); return(0);
2178 }
2179 AR.Eside = oldEside;
2180 AT.WorkPointer = w;
2181 AN.tryterm = 0; /* for now */
2182 if ( EndSort(BHEAD (WORD *)((void *)(&outbuffer)),2) < 0 ) { LowerSortLevel(); return(0); }
2183 LowerSortLevel();
2184 C->Pointer = C->Buffer + oldcpointer;
2185 C->numrhs = oldnumrhs;
2186 AT.WorkPointer = AC.ProtoType - 1;
2187 return(outbuffer);
2188}
2189
2190/*
2191 #] TranslateExpression :
2192 #[ IsSetMember :
2193
2194 Checks whether the expression in the buffer can be seen as an element
2195 of the given set.
2196 For the special sets: if more than one term: no match!!!
2197*/
2198
2199int IsSetMember(WORD *buffer, WORD numset)
2200{
2201 WORD *t = buffer, *tt, num, csize, num1;
2202 WORD bufterm[4];
2203 int i, j, type;
2204 if ( numset < AM.NumFixedSets ) {
2205 if ( t[*t] != 0 ) return(0); /* More than one term */
2206 if ( *t == 0 ) {
2207 if ( numset == POS0_ || numset == NEG0_ || numset == EVEN_
2208 || numset == Z_ || numset == Q_ ) return(1);
2209 else return(0);
2210 }
2211 if ( numset == SYMBOL_ ) {
2212 if ( *t == 8 && t[1] == SYMBOL && t[7] == 3 && t[6] == 1
2213 && t[5] == 1 && t[4] == 1 ) return(1);
2214 else return(0);
2215 }
2216 if ( numset == INDEX_ ) {
2217 if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2218 && t[4] == 1 && t[3] > 0 ) return(1);
2219 if ( *t == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex)
2220 return(1);
2221 return(0);
2222 }
2223 if ( numset == FIXED_ ) {
2224 if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2225 && t[4] == 1 && t[3] > 0 && t[3] < AM.OffsetIndex ) return(1);
2226 if ( *t == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex)
2227 return(1);
2228 return(0);
2229 }
2230 if ( numset == DUMMYINDEX_ ) {
2231 if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2232 && t[4] == 1 && t[3] >= AM.IndDum && t[3] < AM.IndDum+MAXDUMMIES ) return(1);
2233 if ( *t == 4 && t[3] == 3 && t[2] == 1
2234 && t[1] >= AM.IndDum && t[1] < AM.IndDum+MAXDUMMIES ) return(1);
2235 return(0);
2236 }
2237 if ( numset == VECTOR_ ) {
2238 if ( *t == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2239 && t[4] == 1 && t[3] < (AM.OffsetVector+WILDOFFSET) && t[3] >= AM.OffsetVector ) return(1);
2240 return(0);
2241 }
2242 tt = t + *t - 1;
2243 if ( ABS(tt[0]) != *t-1 ) return(0);
2244 if ( numset == Q_ ) return(1);
2245 if ( numset == POS_ || numset == POS0_ ) return(tt[0]>0);
2246 else if ( numset == NEG_ || numset == NEG0_ ) return(tt[0]<0);
2247 i = (ABS(tt[0])-1)/2;
2248 tt -= i;
2249 if ( tt[0] != 1 ) return(0);
2250 for ( j = 1; j < i; j++ ) { if ( tt[j] != 0 ) return(0); }
2251 if ( numset == Z_ ) return(1);
2252 if ( numset == ODD_ ) return(t[1]&1);
2253 if ( numset == EVEN_ ) return(1-(t[1]&1));
2254 return(0);
2255 }
2256 if ( t[*t] != 0 ) return(0); /* More than one term */
2257 type = Sets[numset].type;
2258 switch ( type ) {
2259 case CSYMBOL:
2260 if ( t[0] == 8 && t[1] == SYMBOL && t[7] == 3 && t[6] == 1
2261 && t[5] == 1 && t[4] == 1 ) {
2262 num = t[3];
2263 }
2264 else if ( t[0] == 4 && t[2] == 1 && t[1] <= MAXPOWER ) {
2265 num = t[1];
2266 if ( t[3] < 0 ) num = -num;
2267 num += 2*MAXPOWER;
2268 }
2269 else return(0);
2270 break;
2271 case CVECTOR:
2272 if ( t[0] == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2273 && t[4] == 1 && t[3] < 0 ) {
2274 num = t[3];
2275 }
2276 else return(0);
2277 break;
2278 case CINDEX:
2279 if ( t[0] == 7 && t[1] == INDEX && t[6] == 3 && t[5] == 1
2280 && t[4] == 1 && t[3] > 0 ) {
2281 num = t[3];
2282 }
2283 else if ( t[0] == 4 && t[3] == 3 && t[2] == 1 && t[1] < AM.OffsetIndex ) {
2284 num = t[1];
2285 }
2286 else return(0);
2287 break;
2288 case CFUNCTION:
2289 if ( t[0] == 4+FUNHEAD && t[3+FUNHEAD] == 3 && t[2+FUNHEAD] == 1
2290 && t[1+FUNHEAD] == 1 && t[1] >= FUNCTION ) {
2291 num = t[1];
2292 }
2293 else return(0);
2294 break;
2295 case CNUMBER:
2296 if ( t[0] == 4 && t[2] == 1 && t[1] <= AM.OffsetIndex && t[3] == 3 ) {
2297 num = t[1];
2298 }
2299 else return(0);
2300 break;
2301 case CRANGE:
2302 csize = t[t[0]-1];
2303 csize = ABS(csize);
2304 if ( csize != t[0]-1 ) return(0);
2305 if ( Sets[numset].first < 3*MAXPOWER ) {
2306 num1 = num = Sets[numset].first;
2307 if ( num >= MAXPOWER ) num -= 2*MAXPOWER;
2308 if ( num == 0 ) {
2309 if ( num1 < MAXPOWER ) {
2310 if ( t[t[0]-1] >= 0 ) return(0);
2311 }
2312 else if ( t[t[0]-1] > 0 ) return(0);
2313 }
2314 else {
2315 bufterm[0] = 4; bufterm[1] = ABS(num);
2316 bufterm[2] = 1;
2317 if ( num < 0 ) bufterm[3] = -3;
2318 else bufterm[3] = 3;
2319 num = CompCoef(t,bufterm);
2320 if ( num1 < MAXPOWER ) {
2321 if ( num >= 0 ) return(0);
2322 }
2323 else if ( num > 0 ) return(0);
2324 }
2325 }
2326 if ( Sets[numset].last > -3*MAXPOWER ) {
2327 num1 = num = Sets[numset].last;
2328 if ( num <= -MAXPOWER ) num += 2*MAXPOWER;
2329 if ( num == 0 ) {
2330 if ( num1 > -MAXPOWER ) {
2331 if ( t[t[0]-1] <= 0 ) return(0);
2332 }
2333 else if ( t[t[0]-1] < 0 ) return(0);
2334 }
2335 else {
2336 bufterm[0] = 4; bufterm[1] = ABS(num);
2337 bufterm[2] = 1;
2338 if ( num < 0 ) bufterm[3] = -3;
2339 else bufterm[3] = 3;
2340 num = CompCoef(t,bufterm);
2341 if ( num1 > -MAXPOWER ) {
2342 if ( num <= 0 ) return(0);
2343 }
2344 else if ( num < 0 ) return(0);
2345 }
2346 }
2347 return(1);
2348 break;
2349 default: return(0);
2350 }
2351 t = SetElements + Sets[numset].first;
2352 tt = SetElements + Sets[numset].last;
2353 do {
2354 if ( num == *t ) return(1);
2355 t++;
2356 } while ( t < tt );
2357 return(0);
2358}
2359
2360/*
2361 #] IsSetMember :
2362 #[ IsProductOf :
2363
2364 Checks whether the expression in buf1 is a single term multiple of
2365 the expression in buf2.
2366
2367int IsProductOf(WORD *buf1, WORD *buf2)
2368{
2369 return(0);
2370}
2371
2372
2373 #] IsProductOf :
2374 #[ IsMultipleOf :
2375
2376 Checks whether the expression in buf1 is a numerical multiple of
2377 the expression in buf2.
2378*/
2379
2380int IsMultipleOf(WORD *buf1, WORD *buf2)
2381{
2382 GETIDENTITY
2383 LONG num1, num2;
2384 WORD *t1, *t2, *m1, *m2, *r1, *r2, nc1, nc2, ni1, ni2;
2385 UWORD *IfScrat1, *IfScrat2;
2386 int i, j;
2387 if ( *buf1 == 0 && *buf2 == 0 ) return(1);
2388/*
2389 First count terms
2390*/
2391 t1 = buf1; t2 = buf2; num1 = 0; num2 = 0;
2392 while ( *t1 ) { t1 += *t1; num1++; }
2393 while ( *t2 ) { t2 += *t2; num2++; }
2394 if ( num1 != num2 ) return(0);
2395/*
2396 Test similarity of terms. Difference up to a number.
2397*/
2398 t1 = buf1; t2 = buf2;
2399 while ( *t1 ) {
2400 m1 = t1+1; m2 = t2+1; t1 += *t1; t2 += *t2;
2401 r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2402 if ( r1-m1 != r2-m2 ) return(0);
2403 while ( m1 < r1 ) {
2404 if ( *m1 != *m2 ) return(0);
2405 m1++; m2++;
2406 }
2407 }
2408/*
2409 Now we have to test the constant factor
2410*/
2411 IfScrat1 = (UWORD *)(TermMalloc("IsMultipleOf")); IfScrat2 = (UWORD *)(TermMalloc("IsMultipleOf"));
2412 t1 = buf1; t2 = buf2;
2413 t1 += *t1; t2 += *t2;
2414 if ( *t1 == 0 && *t2 == 0 ) return(1);
2415 r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2416 nc1 = REDLENG(t1[-1]); nc2 = REDLENG(t2[-1]);
2417 if ( DivRat(BHEAD (UWORD *)r1,nc1,(UWORD *)r2,nc2,IfScrat1,&ni1) ) {
2418 MLOCK(ErrorMessageLock);
2419 MesPrint("@Called from MultipleOf in $( )");
2420 MUNLOCK(ErrorMessageLock);
2421 TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2422 Terminate(-1);
2423 }
2424 while ( *t1 ) {
2425 t1 += *t1; t2 += *t2;
2426 r1 = t1 - ABS(t1[-1]); r2 = t2 - ABS(t2[-1]);
2427 nc1 = REDLENG(t1[-1]); nc2 = REDLENG(t2[-1]);
2428 if ( DivRat(BHEAD (UWORD *)r1,nc1,(UWORD *)r2,nc2,IfScrat2,&ni2) ) {
2429 MLOCK(ErrorMessageLock);
2430 MesPrint("@Called from MultipleOf in $( )");
2431 MUNLOCK(ErrorMessageLock);
2432 TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2433 Terminate(-1);
2434 }
2435 if ( ni1 != ni2 ) return(0);
2436 i = 2*ABS(ni1);
2437 for ( j = 0; j < i; j++ ) {
2438 if ( IfScrat1[j] != IfScrat2[j] ) {
2439 TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2440 return(0);
2441 }
2442 }
2443 }
2444 TermFree(IfScrat1,"IsMultipleOf"); TermFree(IfScrat2,"IsMultipleOf");
2445 return(1);
2446}
2447
2448/*
2449 #] IsMultipleOf :
2450 #[ TwoExprCompare :
2451
2452 Compares the expressions in buf1 and buf2 according to oprtr
2453*/
2454
2455int TwoExprCompare(WORD *buf1, WORD *buf2, int oprtr)
2456{
2457 GETIDENTITY
2458 WORD *t1, *t2, cond;
2459 t1 = buf1; t2 = buf2;
2460 while ( *t1 && *t2 ) {
2461 cond = CompareTerms(BHEAD t1,t2,1);
2462 if ( cond != 0 ) {
2463 if ( cond > 0 ) { /* t1 comes first */
2464 switch ( oprtr ) { /* t1 is less */
2465 case EQUAL: return(0);
2466 case NOTEQUAL: return(1);
2467 case GREATEREQUAL: return(0);
2468 case GREATER: return(0);
2469 case LESS: return(1);
2470 case LESSEQUAL: return(1);
2471 }
2472 }
2473 else {
2474 switch ( oprtr ) {
2475 case EQUAL: return(0);
2476 case NOTEQUAL: return(1);
2477 case GREATEREQUAL: return(1);
2478 case GREATER: return(1);
2479 case LESS: return(0);
2480 case LESSEQUAL: return(0);
2481 }
2482 }
2483 }
2484 t1 += *t1; t2 += *t2;
2485 }
2486 if ( *t1 == *t2 ) { /* They are equal */
2487 switch ( oprtr ) {
2488 case EQUAL: return(1);
2489 case NOTEQUAL: return(0);
2490 case GREATEREQUAL: return(1);
2491 case GREATER: return(0);
2492 case LESS: return(0);
2493 case LESSEQUAL: return(1);
2494 }
2495 }
2496 else if ( *t1 ) { /* t1 is greater */
2497 switch ( oprtr ) {
2498 case EQUAL: return(0);
2499 case NOTEQUAL: return(1);
2500 case GREATEREQUAL: return(1);
2501 case GREATER: return(1);
2502 case LESS: return(0);
2503 case LESSEQUAL: return(0);
2504 }
2505 }
2506 else {
2507 switch ( oprtr ) { /* t1 is less */
2508 case EQUAL: return(0);
2509 case NOTEQUAL: return(1);
2510 case GREATEREQUAL: return(0);
2511 case GREATER: return(0);
2512 case LESS: return(1);
2513 case LESSEQUAL: return(1);
2514 }
2515 }
2516 MLOCK(ErrorMessageLock);
2517 MesPrint("@Internal problems with operator in $( )");
2518 MUNLOCK(ErrorMessageLock);
2519 Terminate(-1);
2520 return(0);
2521}
2522
2523/*
2524 #] TwoExprCompare :
2525 #[ DollarRaiseLow :
2526
2527 Raises or lowers the numerical value of a dollar variable
2528 Not to be used in parallel.
2529*/
2530
2531static UWORD *dscrat = 0;
2532static WORD ndscrat;
2533
2534int DollarRaiseLow(UBYTE *name, LONG value)
2535{
2536 GETIDENTITY
2537 int num;
2538 DOLLARS d;
2539 int sgn = 1;
2540 WORD lnum[4], nnum, *t1, *t2, i;
2541 UBYTE *s, c;
2542 s = name; while ( *s ) s++;
2543 if ( s[-1] == '-' && s[-2] == '-' && s > name+2 ) s -= 2;
2544 else if ( s[-1] == '+' && s[-2] == '+' && s > name+2 ) s -= 2;
2545 c = *s; *s = 0;
2546 num = GetDollar(name);
2547 *s = c;
2548 d = Dollars + num;
2549 if ( value < 0 ) { value = -value; sgn = -1; }
2550 if ( d->type == DOLZERO ) {
2551 if ( d->where ) M_free(d->where,"DollarRaiseLow");
2552 d->size = MINALLOC;
2553 d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"DollarRaiseLow");
2554 if ( ( value & AWORDMASK ) != 0 ) {
2555 d->where[0] = 6; d->where[1] = value >> BITSINWORD;
2556 d->where[2] = (WORD)value; d->where[3] = 1; d->where[4] = 0;
2557 d->where[5] = 5*sgn; d->where[6] = 0;
2558 d->type = DOLTERMS;
2559 }
2560 else {
2561 d->where[0] = 4; d->where[1] = (WORD)value; d->where[2] = 1;
2562 d->where[3] = 3*sgn; d->where[4] = 0;
2563 d->type = DOLNUMBER;
2564 }
2565 }
2566 else if ( d->type == DOLNUMBER || ( d->type == DOLTERMS
2567 && d->where[d->where[0]] == 0
2568 && d->where[0] == ABS(d->where[d->where[0]-1])+1 ) ) {
2569 if ( ( value & AWORDMASK ) != 0 ) {
2570 lnum[0] = value >> BITSINWORD;
2571 lnum[1] = (WORD)value; lnum[2] = 1; lnum[3] = 0;
2572 nnum = 2*sgn;
2573 }
2574 else {
2575 lnum[0] = (WORD)value; lnum[1] = 1; nnum = sgn;
2576 }
2577 i = d->where[d->where[0]-1];
2578 i = REDLENG(i);
2579 if ( dscrat == 0 ) {
2580 dscrat = (UWORD *)Malloc1((AM.MaxTal+2)*sizeof(UWORD),"DollarRaiseLow");
2581 }
2582 if ( AddRat(BHEAD (UWORD *)(d->where+1),i,
2583 (UWORD *)lnum,nnum,dscrat,&ndscrat) ) {
2584 MLOCK(ErrorMessageLock);
2585 MesCall("DollarRaiseLow");
2586 MUNLOCK(ErrorMessageLock);
2587 Terminate(-1);
2588 }
2589 ndscrat = INCLENG(ndscrat);
2590 i = ABS(ndscrat);
2591 if ( i == 0 ) {
2592 M_free(d->where,"DollarRaiseLow");
2593 d->where = 0;
2594 d->type = DOLZERO;
2595 d->size = 0;
2596 return(0);
2597 }
2598 if ( i+2 > d->size ) {
2599 M_free(d->where,"DollarRaiseLow");
2600 d->size = i+2;
2601 if ( d->size < MINALLOC ) d->size = MINALLOC;
2602 d->size = ((d->size+7)/8)*8;
2603 d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"DollarRaiseLow");
2604 }
2605 t1 = d->where; *t1++ = i+1; t2 = (WORD *)dscrat;
2606 while ( --i > 0 ) *t1++ = *t2++;
2607 *t1++ = ndscrat; *t1 = 0;
2608 d->type = DOLTERMS;
2609 }
2610 return(0);
2611}
2612
2613/*
2614 #] DollarRaiseLow :
2615 #[ EvalDoLoopArg :
2616*/
2633WORD EvalDoLoopArg(PHEAD WORD *arg, WORD par)
2634{
2635 WORD num, type, *td;
2636 DOLLARS d;
2637 if ( *arg == SNUMBER ) return(arg[1]);
2638 if ( *arg == DOLLAREXPR2 && arg[1] < 0 ) return(-arg[1]-1);
2639 d = Dollars + arg[1];
2640#ifdef WITHPTHREADS
2641 {
2642 int nummodopt, dtype = -1;
2643 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2644 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2645 if ( arg[1] == ModOptdollars[nummodopt].number ) break;
2646 }
2647 if ( nummodopt < NumModOptdollars ) {
2648 dtype = ModOptdollars[nummodopt].type;
2649 if ( dtype == MODLOCAL ) {
2650 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2651 }
2652 }
2653 }
2654 }
2655#endif
2656 if ( *arg == DOLLAREXPRESSION ) {
2657 if ( arg[2] != DOLLAREXPR2 ) { /* end of chain */
2658endofchain:
2659 type = d->type;
2660 if ( type == DOLZERO ) {}
2661 else if ( type == DOLNUMBER ) {
2662 td = d->where;
2663 if ( ( td[0] != 4 ) || ( (td[1]&SPECMASK) != 0 ) || ( td[2] != 1 ) ) {
2664 MLOCK(ErrorMessageLock);
2665 if ( par == -1 ) {
2666 MesPrint("$-variable is not a short number in print statement");
2667 }
2668 else {
2669 MesPrint("$-variable is not a short number in do loop");
2670 }
2671 MUNLOCK(ErrorMessageLock);
2672 Terminate(-1);
2673 }
2674 return( td[3] > 0 ? td[1]: -td[1] );
2675 }
2676 else {
2677 MLOCK(ErrorMessageLock);
2678 if ( par == -1 ) {
2679 MesPrint("$-variable is not a number in print statement");
2680 }
2681 else {
2682 MesPrint("$-variable is not a number in do loop");
2683 }
2684 MUNLOCK(ErrorMessageLock);
2685 Terminate(-1);
2686 }
2687 return(0);
2688 }
2689 num = EvalDoLoopArg(BHEAD arg+2,par);
2690 }
2691 else if ( *arg == DOLLAREXPR2 ) {
2692 if ( arg[1] < 0 ) { num = -arg[1]-1; }
2693 else if ( arg[2] != DOLLAREXPR2 && par == -1 ) {
2694 goto endofchain;
2695 }
2696 else { num = EvalDoLoopArg(BHEAD arg+2,par); }
2697 }
2698 else {
2699 MLOCK(ErrorMessageLock);
2700 if ( par == -1 ) {
2701 MesPrint("Invalid $-variable in print statement");
2702 }
2703 else {
2704 MesPrint("Invalid $-variable in do loop");
2705 }
2706 MUNLOCK(ErrorMessageLock);
2707 Terminate(-1);
2708 return(0);
2709 }
2710 if ( num == 0 ) return(d->nfactors);
2711 if ( num > d->nfactors || num < 1 ) {
2712 MLOCK(ErrorMessageLock);
2713 if ( par == -1 ) {
2714 MesPrint("Not a valid factor number for $-variable in print statement");
2715 }
2716 else {
2717 MesPrint("Not a valid factor number for $-variable in do loop");
2718 }
2719 MUNLOCK(ErrorMessageLock);
2720 Terminate(-1);
2721 return(0);
2722 }
2723 if ( d->factors[num].type == DOLNUMBER )
2724 return(d->factors[num].value);
2725 else { /* If correct, type can only be DOLNUMBER or DOLTERMS */
2726 MLOCK(ErrorMessageLock);
2727 if ( par == -1 ) {
2728 MesPrint("$-variable in print statement is not a number");
2729 }
2730 else {
2731 MesPrint("$-variable in do loop is not a number");
2732 }
2733 MUNLOCK(ErrorMessageLock);
2734 Terminate(-1);
2735 return(0);
2736 }
2737}
2738
2739/*
2740 #] EvalDoLoopArg :
2741 #[ TestDoLoop :
2742*/
2743
2744WORD TestDoLoop(PHEAD WORD *lhsbuf, WORD level)
2745{
2746 GETBIDENTITY
2747 WORD start,finish,incr;
2748 WORD *h;
2749 DOLLARS d;
2750 h = lhsbuf + 4; /* address of the start value */
2751 start = EvalDoLoopArg(BHEAD h,0);
2752 while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2753 && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2754 h += 2;
2755 finish = EvalDoLoopArg(BHEAD h,0);
2756 while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2757 && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2758 h += 2;
2759 incr = EvalDoLoopArg(BHEAD h,0);
2760
2761 if ( ( finish == start ) || ( finish > start && incr > 0 )
2762 || ( finish < start && incr < 0 ) ) {}
2763 else { level = lhsbuf[3]; } /* skips the loop */
2764/*
2765 Put start in the dollar variable indicated by lhsbuf[2]
2766*/
2767 d = Dollars + lhsbuf[2];
2768#ifdef WITHPTHREADS
2769 {
2770 int nummodopt, dtype = -1;
2771 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2772 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2773 if ( lhsbuf[2] == ModOptdollars[nummodopt].number ) break;
2774 }
2775 if ( nummodopt < NumModOptdollars ) {
2776 dtype = ModOptdollars[nummodopt].type;
2777 if ( dtype == MODLOCAL ) {
2778 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2779 }
2780 }
2781 }
2782 }
2783#endif
2784
2785 if ( d->size < MINALLOC ) {
2786 if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
2787 d->size = MINALLOC;
2788 d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
2789 }
2790 if ( start > 0 ) {
2791 d->where[0] = 4;
2792 d->where[1] = start;
2793 d->where[2] = 1;
2794 d->where[3] = 3;
2795 d->where[4] = 0;
2796 d->type = DOLNUMBER;
2797 }
2798 else if ( start < 0 ) {
2799 d->where[0] = 4;
2800 d->where[1] = -start;
2801 d->where[2] = 1;
2802 d->where[3] = -3;
2803 d->where[4] = 0;
2804 d->type = DOLNUMBER;
2805 }
2806 else
2807 d->type = DOLZERO;
2808
2809 if ( d == Dollars + lhsbuf[2] ) {
2810 cbuf[AM.dbufnum].CanCommu[lhsbuf[2]] = 0;
2811 cbuf[AM.dbufnum].NumTerms[lhsbuf[2]] = 1;
2812 cbuf[AM.dbufnum].rhs[lhsbuf[2]] = d->where;
2813 }
2814 return(level);
2815}
2816
2817/*
2818 #] TestDoLoop :
2819 #[ TestEndDoLoop :
2820*/
2821
2822WORD TestEndDoLoop(PHEAD WORD *lhsbuf, WORD level)
2823{
2824 GETBIDENTITY
2825 WORD start,finish,incr,value;
2826 WORD *h;
2827 DOLLARS d;
2828 h = lhsbuf + 4; /* address of the start value */
2829 start = EvalDoLoopArg(BHEAD h,0);
2830 while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2831 && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2832 h += 2;
2833 finish = EvalDoLoopArg(BHEAD h,0);
2834 while ( ( *h == DOLLAREXPRESSION || *h == DOLLAREXPR2 )
2835 && ( h[2] == DOLLAREXPR2 ) ) h += 2;
2836 h += 2;
2837 incr = EvalDoLoopArg(BHEAD h,0);
2838
2839 if ( ( finish == start ) || ( finish > start && incr > 0 )
2840 || ( finish < start && incr < 0 ) ) {}
2841 else { level = lhsbuf[3]; } /* skips the loop */
2842/*
2843 Put start in the dollar variable indicated by lhsbuf[2]
2844*/
2845 d = Dollars + lhsbuf[2];
2846#ifdef WITHPTHREADS
2847 {
2848 int nummodopt, dtype = -1;
2849 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2850 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2851 if ( lhsbuf[2] == ModOptdollars[nummodopt].number ) break;
2852 }
2853 if ( nummodopt < NumModOptdollars ) {
2854 dtype = ModOptdollars[nummodopt].type;
2855 if ( dtype == MODLOCAL ) {
2856 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2857 }
2858 }
2859 }
2860 }
2861#endif
2862/*
2863 Get the value
2864*/
2865 if ( d->type == DOLZERO ) {
2866 value = 0;
2867 }
2868 else if ( ( d->type == DOLNUMBER || d->type == DOLTERMS )
2869 && ( d->where[4] == 0 ) && ( d->where[0] == 4 )
2870 && ( d->where[1] > 0 ) && ( d->where[2] == 1 ) ) {
2871 value = ( d->where[3] < 0 ) ? -d->where[1]: d->where[1];
2872 }
2873 else {
2874 MLOCK(ErrorMessageLock);
2875 MesPrint("Wrong type of object in do loop parameter");
2876 MUNLOCK(ErrorMessageLock);
2877 Terminate(-1);
2878 return(level);
2879 }
2880 value += incr;
2881 if ( ( finish > start && value <= finish ) ||
2882 ( finish < start && value >= finish ) ||
2883 ( finish == start && value == finish ) ) {}
2884 else level = lhsbuf[3];
2885
2886 if ( d->size < MINALLOC ) {
2887 if ( d->where && d->where != &(AM.dollarzero) ) M_free(d->where,"dollar contents");
2888 d->size = MINALLOC;
2889 d->where = (WORD *)Malloc1(d->size*sizeof(WORD),"dollar contents");
2890 }
2891 if ( value > 0 ) {
2892 d->where[0] = 4;
2893 d->where[1] = value;
2894 d->where[2] = 1;
2895 d->where[3] = 3;
2896 d->where[4] = 0;
2897 d->type = DOLNUMBER;
2898 }
2899 else if ( start < 0 ) {
2900 d->where[0] = 4;
2901 d->where[1] = -value;
2902 d->where[2] = 1;
2903 d->where[3] = -3;
2904 d->where[4] = 0;
2905 d->type = DOLNUMBER;
2906 }
2907 else
2908 d->type = DOLZERO;
2909
2910 if ( d == Dollars + lhsbuf[2] ) {
2911 cbuf[AM.dbufnum].CanCommu[lhsbuf[2]] = 0;
2912 cbuf[AM.dbufnum].NumTerms[lhsbuf[2]] = 1;
2913 cbuf[AM.dbufnum].rhs[lhsbuf[2]] = d->where;
2914 }
2915 return(level);
2916}
2917
2918/*
2919 #] TestEndDoLoop :
2920 #[ DollarFactorize :
2921*/
2934/* #define STEP2 */
2935#define STEP2
2936
2937int DollarFactorize(PHEAD WORD numdollar)
2938{
2939 GETBIDENTITY
2940 DOLLARS d = Dollars + numdollar;
2941 CBUF *C, *CC;
2942 WORD *oldworkpointer;
2943 WORD *buf1, *t, *term, *buf1content, *buf2, *termextra;
2944 WORD *buf3, *argextra;
2945#ifdef STEP2
2946 WORD *tstop, pow, *r;
2947#endif
2948 int i, j, jj, action = 0, sign = 1;
2949 LONG insize, ii;
2950 WORD startebuf = cbuf[AT.ebufnum].numrhs;
2951 WORD nfactors, factorsincontent, extrafactor = 0;
2952 WORD oldsorttype = AR.SortType;
2953
2954#ifdef WITHPTHREADS
2955 int nummodopt, dtype;
2956 dtype = -1;
2957 if ( AS.MultiThreaded ) {
2958 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2959 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2960 }
2961 if ( nummodopt < NumModOptdollars ) {
2962 dtype = ModOptdollars[nummodopt].type;
2963 if ( dtype == MODLOCAL ) {
2964 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2965 }
2966 else {
2967 LOCK(d->pthreadslock);
2968 }
2969 }
2970 }
2971#endif
2972 CleanDollarFactors(d);
2973#ifdef WITHPTHREADS
2974 if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslock); }
2975#endif
2976 if ( d->type != DOLTERMS ) { /* only one term */
2977 if ( d->type != DOLZERO ) d->nfactors = 1;
2978 return(0);
2979 }
2980 if ( d->where[d->where[0]] == 0 ) { /* only one term. easy */
2981 }
2982/*
2983 Here should come the code for the factorization
2984 We copied the routine ArgFactorize in argument.c and changed the
2985 memory management completely. For the actual factorization it
2986 calls WORD *DoFactorizeDollar(PHEAD WORD *expr) which allocates
2987 space for the answer. Notation:
2988 term,...,term,0,term,...,term,0,term,...,term,0,0
2989
2990 #[ Step 1: sort the terms properly and/or make copy --> buf1,insize
2991*/
2992 term = d->where;
2993 AR.SortType = SORTHIGHFIRST;
2994 if ( oldsorttype != AR.SortType ) {
2995 NewSort(BHEAD0);
2996 while ( *term ) {
2997 t = term + *term;
2998 if ( AN.ncmod != 0 ) {
2999 if ( AN.ncmod != 1 || ( (WORD)AN.cmod[0] < 0 ) ) {
3000 AR.SortType = oldsorttype;
3001 MLOCK(ErrorMessageLock);
3002 MesPrint("Factorization modulus a number, greater than a WORD not implemented.");
3003 MUNLOCK(ErrorMessageLock);
3004 Terminate(-1);
3005 }
3006 if ( Modulus(term) ) {
3007 AR.SortType = oldsorttype;
3008 MLOCK(ErrorMessageLock);
3009 MesCall("DollarFactorize");
3010 MUNLOCK(ErrorMessageLock);
3011 Terminate(-1);
3012 }
3013 if ( !*term) { term = t; continue; }
3014 }
3015 StoreTerm(BHEAD term);
3016 term = t;
3017 }
3018 AN.tryterm = 0; /* for now */
3019 EndSort(BHEAD (WORD *)((void *)(&buf1)),2);
3020 t = buf1; while ( *t ) t += *t;
3021 insize = t - buf1;
3022 }
3023 else {
3024 t = term; while ( *t ) t += *t;
3025 ii = insize = t - term;
3026 buf1 = (WORD *)Malloc1((insize+1)*sizeof(WORD),"DollarFactorize-1");
3027 t = buf1;
3028 NCOPY(t,term,ii);
3029 *t++ = 0;
3030 }
3031/*
3032 #] Step 1:
3033 #[ Step 2: take out the 'content'.
3034*/
3035#ifdef STEP2
3036 buf1content = TermMalloc("DollarContent");
3037 AN.tryterm = -1;
3038 if ( ( buf2 = TakeContent(BHEAD buf1,buf1content) ) == 0 ) {
3039 AN.tryterm = 0;
3040 TermFree(buf1content,"DollarContent");
3041 M_free(buf1,"DollarFactorize-1");
3042 AR.SortType = oldsorttype;
3043 MLOCK(ErrorMessageLock);
3044 MesCall("DollarFactorize");
3045 MUNLOCK(ErrorMessageLock);
3046 Terminate(-1);
3047 return(1);
3048 }
3049 else if ( ( buf1content[0] == 4 ) && ( buf1content[1] == 1 ) &&
3050 ( buf1content[2] == 1 ) && ( buf1content[3] == 3 ) ) { /* Nothing happened */
3051 AN.tryterm = 0;
3052 if ( buf2 != buf1 ) {
3053 M_free(buf2,"DollarFactorize-2");
3054 buf2 = buf1;
3055 }
3056 factorsincontent = 0;
3057 }
3058 else {
3059/*
3060 The way we took out objects is rather brutish. We have to normalize
3061*/
3062 AN.tryterm = 0;
3063 if ( buf2 != buf1 ) M_free(buf1,"DollarFactorize-1");
3064 buf1 = buf2;
3065 t = buf1; while ( *t ) t += *t;
3066 insize = t - buf1;
3067/*
3068 Now analyse how many factors there are in the content
3069*/
3070 factorsincontent = 0;
3071 term = buf1content;
3072 tstop = term + *term;
3073 if ( tstop[-1] < 0 ) factorsincontent++;
3074 if ( ABS(tstop[-1]) == 3 && tstop[-2] == 1 && tstop[-3] == 1 ) {
3075 tstop -= ABS(tstop[-1]);
3076 }
3077 else {
3078 factorsincontent++;
3079 tstop -= ABS(tstop[-1]);
3080 }
3081 term++;
3082 while ( term < tstop ) {
3083 switch ( *term ) {
3084 case SYMBOL:
3085 t = term+2; i = (term[1]-2)/2;
3086 while ( i > 0 ) {
3087 factorsincontent += ABS(t[1]);
3088 i--; t += 2;
3089 }
3090 break;
3091 case DOTPRODUCT:
3092 t = term+2; i = (term[1]-2)/3;
3093 while ( i > 0 ) {
3094 factorsincontent += ABS(t[2]);
3095 i--; t += 3;
3096 }
3097 break;
3098 case VECTOR:
3099 case DELTA:
3100 factorsincontent += (term[1]-2)/2;
3101 break;
3102 case INDEX:
3103 factorsincontent += term[1]-2;
3104 break;
3105 default:
3106 if ( *term >= FUNCTION ) factorsincontent++;
3107 break;
3108 }
3109 term += term[1];
3110 }
3111 }
3112#else
3113 factorsincontent = 0;
3114 buf1content = 0;
3115#endif
3116/*
3117 #] Step 2: take out the 'content'.
3118 #[ Step 3: ConvertToPoly
3119 if there are objects that are not SYMBOLs,
3120 invoke ConvertToPoly
3121 We keep the original in buf1 in case there are no factors
3122*/
3123 t = buf1;
3124 while ( *t ) {
3125 if ( ( t[1] != SYMBOL ) && ( *t != (ABS(t[*t-1])+1) ) ) {
3126 action = 1; break;
3127 }
3128 t += *t;
3129 }
3130 if ( DetCommu(buf1) > 1 ) {
3131 MesPrint("Cannot factorize a $-expression with more than one noncommuting object");
3132 AR.SortType = oldsorttype;
3133 M_free(buf1,"DollarFactorize-2");
3134 if ( buf1content ) TermFree(buf1content,"DollarContent");
3135 MesCall("DollarFactorize");
3136 Terminate(-1);
3137 return(-1);
3138 }
3139 if ( action ) {
3140 t = buf1;
3141 termextra = AT.WorkPointer;
3142 NewSort(BHEAD0);
3143 NewSort(BHEAD0);
3144 while ( *t ) {
3145 if ( LocalConvertToPoly(BHEAD t,termextra,startebuf,0) < 0 ) {
3146getout:
3147 AR.SortType = oldsorttype;
3148 M_free(buf1,"DollarFactorize-2");
3149 if ( buf1content ) TermFree(buf1content,"DollarContent");
3150 MesCall("DollarFactorize");
3151 Terminate(-1);
3152 return(-1);
3153 }
3154 StoreTerm(BHEAD termextra);
3155 t += *t;
3156 }
3157 AN.tryterm = 0; /* for now */
3158 if ( EndSort(BHEAD (WORD *)((void *)(&buf2)),2) < 0 ) { goto getout; }
3159 LowerSortLevel();
3160 t = buf2; while ( *t > 0 ) t += *t;
3161 }
3162 else {
3163 buf2 = buf1;
3164 }
3165/*
3166 #] Step 3: ConvertToPoly
3167 #[ Step 4: Now the hard work.
3168*/
3169 if ( ( buf3 = poly_factorize_dollar(BHEAD buf2) ) == 0 ) {
3170 MesCall("DollarFactorize");
3171 AR.SortType = oldsorttype;
3172 if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-3");
3173 M_free(buf1,"DollarFactorize-3");
3174 if ( buf1content ) TermFree(buf1content,"DollarContent");
3175 Terminate(-1);
3176 return(-1);
3177 }
3178 if ( buf2 != buf1 && buf2 ) {
3179 M_free(buf2,"DollarFactorize-3");
3180 buf2 = 0;
3181 }
3182 term = buf3;
3183 AR.SortType = oldsorttype;
3184/*
3185 Count the factors and strip a factor -1
3186*/
3187 nfactors = 0;
3188 while ( *term ) {
3189#ifdef STEP2
3190 if ( *term == 4 && term[4] == 0 && term[3] == -3 && term[2] == 1
3191 && term[1] == 1 ) {
3192 WORD *tt1, *tt2, *ttstop;
3193 sign = -sign;
3194 tt1 = term; tt2 = term + *term + 1;
3195 ttstop = tt2;
3196 while ( *ttstop ) {
3197 while ( *ttstop ) ttstop += *ttstop;
3198 ttstop++;
3199 }
3200 while ( tt2 < ttstop ) *tt1++ = *tt2++;
3201 *tt1 = 0;
3202 factorsincontent++;
3203 extrafactor++;
3204 }
3205 else
3206#endif
3207 {
3208 term += *term;
3209 while ( *term ) { term += *term; }
3210 nfactors++; term++;
3211 }
3212 }
3213/*
3214 We have now:
3215 buf1: the original before ConvertToPoly for if only one factor
3216 buf3: the factored expression with nfactors factors
3217
3218 #] Step 4:
3219 #[ Step 5: ConvertFromPoly
3220 If ConvertToPoly was used, use now ConvertFromPoly
3221 Be careful: there should be more than one factor now.
3222*/
3223#ifdef WITHPTHREADS
3224 if ( dtype > 0 && dtype != MODLOCAL ) { LOCK(d->pthreadslock); }
3225#endif
3226 if ( nfactors == 1 && extrafactor == 0 ) { /* we can use the buf1 contents */
3227 if ( factorsincontent == 0 ) {
3228 d->nfactors = 1;
3229#ifdef WITHPTHREADS
3230 if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslock); }
3231#endif
3232/*
3233 We used here (before 3-sep-2015) the original and did not make
3234 provisions for having a factors struct, figuring that all info
3235 is identical to the full dollar. This makes things too
3236 complicated at later stages.
3237*/
3238 d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR),"factors in dollar");
3239 term = buf1; while ( *term ) term += *term;
3240 d->factors[0].size = i = term - buf1;
3241 d->factors[0].where = t = (WORD *)Malloc1(sizeof(WORD)*(i+1),"DollarFactorize-5");
3242 term = buf1; NCOPY(t,term,i); *t = 0;
3243 AR.SortType = oldsorttype;
3244 M_free(buf3,"DollarFactorize-4");
3245 if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-4");
3246 M_free(buf1,"DollarFactorize-4");
3247 if ( buf1content ) TermFree(buf1content,"DollarContent");
3248 return(0);
3249 }
3250 else {
3251 d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3252 term = buf1; while ( *term ) term += *term;
3253 d->factors[0].size = i = term - buf1;
3254 d->factors[0].where = t = (WORD *)Malloc1(sizeof(WORD)*(i+1),"DollarFactorize-5");
3255 term = buf1; NCOPY(t,term,i); *t = 0;
3256 M_free(buf3,"DollarFactorize-4");
3257 buf3 = 0;
3258 if ( buf2 != buf1 && buf2 ) {
3259 M_free(buf2,"DollarFactorize-4");
3260 buf2 = 0;
3261 }
3262 }
3263 }
3264 else if ( action ) {
3265 C = cbuf+AC.cbufnum;
3266 CC = cbuf+AT.ebufnum;
3267 oldworkpointer = AT.WorkPointer;
3268 d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3269 term = buf3;
3270 for ( i = 0; i < nfactors; i++ ) {
3271 argextra = AT.WorkPointer;
3272 NewSort(BHEAD0);
3273 NewSort(BHEAD0);
3274 while ( *term ) {
3275 if ( ConvertFromPoly(BHEAD term,argextra,numxsymbol,CC->numrhs-startebuf+numxsymbol
3276 ,startebuf-numxsymbol,1) <= 0 ) {
3277 LowerSortLevel();
3278getout2: AR.SortType = oldsorttype;
3279 M_free(d->factors,"factors in dollar");
3280 d->factors = 0;
3281#ifdef WITHPTHREADS
3282 if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslock); }
3283#endif
3284 M_free(buf3,"DollarFactorize-4");
3285 if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-4");
3286 M_free(buf1,"DollarFactorize-4");
3287 if ( buf1content ) TermFree(buf1content,"DollarContent");
3288 return(-3);
3289 }
3290 AT.WorkPointer = argextra + *argextra;
3291/*
3292 ConvertFromPoly leaves terms with subexpressions. Hence:
3293*/
3294 if ( Generator(BHEAD argextra,C->numlhs+1) ) {
3295 goto getout2;
3296 }
3297 term += *term;
3298 }
3299 term++;
3300 AT.WorkPointer = oldworkpointer;
3301 AN.tryterm = 0; /* for now */
3302 EndSort(BHEAD (WORD *)((void *)(&(d->factors[i].where))),2);
3303 LowerSortLevel();
3304 d->factors[i].type = DOLTERMS;
3305 t = d->factors[i].where;
3306 while ( *t ) t += *t;
3307 d->factors[i].size = t - d->factors[i].where;
3308 }
3309 CC->numrhs = startebuf;
3310 }
3311 else {
3312 C = cbuf+AC.cbufnum;
3313 oldworkpointer = AT.WorkPointer;
3314 d->factors = (FACDOLLAR *)Malloc1(sizeof(FACDOLLAR)*(nfactors+factorsincontent),"factors in dollar");
3315 term = buf3;
3316 for ( i = 0; i < nfactors; i++ ) {
3317 NewSort(BHEAD0);
3318 while ( *term ) {
3319 argextra = oldworkpointer;
3320 j = *term;
3321 NCOPY(argextra,term,j)
3322 AT.WorkPointer = argextra;
3323 if ( Generator(BHEAD oldworkpointer,C->numlhs+1) ) {
3324 goto getout2;
3325 }
3326 }
3327 term++;
3328 AT.WorkPointer = oldworkpointer;
3329 AN.tryterm = 0; /* for now */
3330 EndSort(BHEAD (WORD *)((void *)(&(d->factors[i].where))),2);
3331 d->factors[i].type = DOLTERMS;
3332 t = d->factors[i].where;
3333 while ( *t ) t += *t;
3334 d->factors[i].size = t - d->factors[i].where;
3335 }
3336 }
3337 d->nfactors = nfactors + factorsincontent;
3338/*
3339 #] Step 5: ConvertFromPoly
3340 #[ Step 6: The factors of the content
3341*/
3342 if ( buf3 ) M_free(buf3,"DollarFactorize-5");
3343 if ( buf2 != buf1 && buf2 ) M_free(buf2,"DollarFactorize-5");
3344 M_free(buf1,"DollarFactorize-5");
3345 j = nfactors;
3346#ifdef STEP2
3347 term = buf1content;
3348 tstop = term + *term;
3349 if ( tstop[-1] < 0 ) { tstop[-1] = -tstop[-1]; sign = -sign; }
3350 tstop -= tstop[-1];
3351 term++;
3352 while ( term < tstop ) {
3353 switch ( *term ) {
3354 case SYMBOL:
3355 t = term+2; i = (term[1]-2)/2;
3356 while ( i > 0 ) {
3357 if ( t[1] < 0 ) { t[1] = -t[1]; pow = -1; }
3358 else { pow = 1; }
3359 for ( jj = 0; jj < t[1]; jj++ ) {
3360 r = d->factors[j].where = (WORD *)Malloc1(9*sizeof(WORD),"factor");
3361 r[0] = 8; r[1] = SYMBOL; r[2] = 4; r[3] = *t; r[4] = pow;
3362 r[5] = 1; r[6] = 1; r[7] = 3; r[8] = 0;
3363 d->factors[j].type = DOLTERMS;
3364 d->factors[j].size = 8;
3365 j++;
3366 }
3367 i--; t += 2;
3368 }
3369 break;
3370 case DOTPRODUCT:
3371 t = term+2; i = (term[1]-2)/3;
3372 while ( i > 0 ) {
3373 if ( t[2] < 0 ) { t[2] = -t[2]; pow = -1; }
3374 else { pow = 1; }
3375 for ( jj = 0; jj < t[2]; jj++ ) {
3376 r = d->factors[j].where = (WORD *)Malloc1(10*sizeof(WORD),"factor");
3377 r[0] = 9; r[1] = DOTPRODUCT; r[2] = 5; r[3] = t[0]; r[4] = t[1];
3378 r[5] = pow; r[6] = 1; r[7] = 1; r[8] = 3; r[9] = 0;
3379 d->factors[j].type = DOLTERMS;
3380 d->factors[j].size = 9;
3381 j++;
3382 }
3383 i--; t += 3;
3384 }
3385 break;
3386 case VECTOR:
3387 case DELTA:
3388 t = term+2; i = (term[1]-2)/2;
3389 while ( i > 0 ) {
3390 for ( jj = 0; jj < t[1]; jj++ ) {
3391 r = d->factors[j].where = (WORD *)Malloc1(9*sizeof(WORD),"factor");
3392 r[0] = 8; r[1] = *term; r[2] = 4; r[3] = *t; r[4] = t[1];
3393 r[5] = 1; r[6] = 1; r[7] = 3; r[8] = 0;
3394 d->factors[j].type = DOLTERMS;
3395 d->factors[j].size = 8;
3396 j++;
3397 }
3398 i--; t += 2;
3399 }
3400 break;
3401 case INDEX:
3402 t = term+2; i = term[1]-2;
3403 while ( i > 0 ) {
3404 for ( jj = 0; jj < t[1]; jj++ ) {
3405 r = d->factors[j].where = (WORD *)Malloc1(8*sizeof(WORD),"factor");
3406 r[0] = 7; r[1] = *term; r[2] = 3; r[3] = *t;
3407 r[4] = 1; r[5] = 1; r[6] = 3; r[7] = 0;
3408 d->factors[j].type = DOLTERMS;
3409 d->factors[j].size = 7;
3410 j++;
3411 }
3412 i--; t++;
3413 }
3414 break;
3415 default:
3416 if ( *term >= FUNCTION ) {
3417 r = d->factors[j].where = (WORD *)Malloc1((term[1]+5)*sizeof(WORD),"factor");
3418 *r++ = d->factors[j].size = term[1]+4;
3419 for ( jj = 0; jj < t[1]; jj++ ) *r++ = term[jj];
3420 *r++ = 1; *r++ = 1; *r++ = 3; *r = 0;
3421 j++;
3422 }
3423 break;
3424 }
3425 term += term[1];
3426 }
3427#endif
3428/*
3429 #] Step 6:
3430 #[ Step 7: Numerical factors
3431*/
3432#ifdef STEP2
3433 term = buf1content;
3434 tstop = term + *term;
3435 if ( tstop[-1] == 3 && tstop[-2] == 1 && tstop[-3] == 1 ) {}
3436 else if ( tstop[-1] == 3 && tstop[-2] == 1 && (UWORD)(tstop[-3]) <= MAXPOSITIVE ) {
3437 d->factors[j].where = 0;
3438 d->factors[j].size = 0;
3439 d->factors[j].type = DOLNUMBER;
3440 d->factors[j].value = sign*tstop[-3];
3441 sign = 1;
3442 j++;
3443 }
3444 else {
3445 d->factors[j].where = r = (WORD *)Malloc1((tstop[-1]+2)*sizeof(WORD),"numfactor");
3446 d->factors[j].size = tstop[-1]+1;
3447 d->factors[j].type = DOLTERMS;
3448 d->factors[j].value = 0;
3449 i = tstop[-1];
3450 t = tstop - i;
3451 *r++ = tstop[-1]+1;
3452 NCOPY(r,t,i);
3453 *r = 0;
3454 if ( sign < 0 ) {
3455 r = d->factors[j].where;
3456 while ( *r ) {
3457 r += *r; r[-1] = -r[-1];
3458 }
3459 sign = 1;
3460 }
3461 j++;
3462 }
3463#endif
3464 if ( sign < 0 ) { /* Note that this guy should come first */
3465 for ( jj = j; jj > 0; jj-- ) {
3466 d->factors[jj] = d->factors[jj-1];
3467 }
3468 d->factors[0].where = 0;
3469 d->factors[0].size = 0;
3470 d->factors[0].type = DOLNUMBER;
3471 d->factors[0].value = -1;
3472 j++;
3473 }
3474 d->nfactors = j;
3475 if ( buf1content ) TermFree(buf1content,"DollarContent");
3476/*
3477 #] Step 7:
3478 #[ Step 8: Sorting the factors
3479
3480 There are d->nfactors factors. Look which ones have a 'where'
3481 Sort them by bubble sort
3482*/
3483 if ( d->nfactors > 1 ) {
3484 WORD ***fac, j1, j2, k, ret, *s1, *s2, *s3;
3485 LONG **facsize, x;
3486 facsize = (LONG **)Malloc1((sizeof(WORD **)+sizeof(LONG *))*d->nfactors,"SortDollarFactors");
3487 fac = (WORD ***)(facsize+d->nfactors);
3488 k = 0;
3489 for ( j = 0; j < d->nfactors; j++ ) {
3490 if ( d->factors[j].where ) {
3491 fac[k] = &(d->factors[j].where);
3492 facsize[k] = &(d->factors[j].size);
3493 k++;
3494 }
3495 }
3496 if ( k > 1 ) {
3497 for ( j = 1; j < k; j++ ) { /* bubble sort */
3498 j1 = j; j2 = j1-1;
3499nextj1:;
3500 s1 = *(fac[j1]); s2 = *(fac[j2]);
3501 while ( *s1 && *s2 ) {
3502 if ( ( ret = CompareTerms(BHEAD s2, s1, (WORD)2) ) == 0 ) {
3503 s1 += *s1; s2 += *s2;
3504 }
3505 else if ( ret > 0 ) goto nextj;
3506 else {
3507exch:
3508 s3 = *(fac[j1]); *(fac[j1]) = *(fac[j2]); *(fac[j2]) = s3;
3509 x = *(facsize[j1]); *(facsize[j1]) = *(facsize[j2]); *(facsize[j2]) = x;
3510 j1--; j2--;
3511 if ( j1 > 0 ) goto nextj1;
3512 goto nextj;
3513 }
3514 }
3515 if ( *s1 ) goto nextj;
3516 if ( *s2 ) goto exch;
3517nextj:;
3518 }
3519 }
3520 M_free(facsize,"SortDollarFactors");
3521 }
3522/*
3523 #] Step 8:
3524*/
3525#ifdef WITHPTHREADS
3526 if ( dtype > 0 && dtype != MODLOCAL ) { UNLOCK(d->pthreadslock); }
3527#endif
3528 return(0);
3529}
3530
3531/*
3532 #] DollarFactorize :
3533 #[ CleanDollarFactors :
3534*/
3535
3536void CleanDollarFactors(DOLLARS d)
3537{
3538 int i;
3539 if ( d->nfactors >= 1 ) {
3540 for ( i = 0; i < d->nfactors; i++ ) {
3541 if ( d->factors )
3542 if ( d->factors[i].where )
3543 M_free(d->factors[i].where,"dollar factors");
3544 }
3545 }
3546 if ( d->factors ) {
3547 M_free(d->factors,"dollar factors");
3548 d->factors = 0;
3549 }
3550 d->nfactors = 0;
3551}
3552
3553/*
3554 #] CleanDollarFactors :
3555 #[ TakeDollarContent :
3556*/
3557
3558WORD *TakeDollarContent(PHEAD WORD *dollarbuffer, WORD **factor)
3559{
3560 WORD *remain, *t;
3561 int pow;
3562/*
3563 We force the sign of the first term to be positive.
3564*/
3565 t = dollarbuffer; pow = 1;
3566 t += *t;
3567 if ( t[-1] < 0 ) {
3568 pow = 0;
3569 t[-1] = -t[-1];
3570 while ( *t ) {
3571 t += *t; t[-1] = -t[-1];
3572 }
3573 }
3574/*
3575 Now the GCD of the numerators and the LCM of the denominators:
3576*/
3577 if ( AN.cmod != 0 ) {
3578 if ( ( *factor = MakeDollarMod(BHEAD dollarbuffer,&remain) ) == 0 ) {
3579 Terminate(-1);
3580 }
3581 if ( pow == 0 ) {
3582 (*factor)[**factor-1] = -(*factor)[**factor-1];
3583 (*factor)[**factor-1] += AN.cmod[0];
3584 }
3585 }
3586 else {
3587 if ( ( *factor = MakeDollarInteger(BHEAD dollarbuffer,&remain) ) == 0 ) {
3588 Terminate(-1);
3589 }
3590 if ( pow == 0 ) {
3591 (*factor)[**factor-1] = -(*factor)[**factor-1];
3592 }
3593 }
3594 return(remain);
3595}
3596
3597/*
3598 #] TakeDollarContent :
3599 #[ MakeDollarInteger :
3600*/
3610WORD *MakeDollarInteger(PHEAD WORD *bufin,WORD **bufout)
3611{
3612 GETBIDENTITY
3613 UWORD *GCDbuffer, *GCDbuffer2, *LCMbuffer, *LCMb, *LCMc;
3614 WORD *r, *r1, *r2, *r3, *rnext, i, k, j, *oldworkpointer, *factor;
3615 WORD kGCD, kLCM, kGCD2, kkLCM, jLCM, jGCD;
3616 CBUF *C = cbuf+AC.cbufnum;
3617
3618 GCDbuffer = NumberMalloc("MakeDollarInteger");
3619 GCDbuffer2 = NumberMalloc("MakeDollarInteger");
3620 LCMbuffer = NumberMalloc("MakeDollarInteger");
3621 LCMb = NumberMalloc("MakeDollarInteger");
3622 LCMc = NumberMalloc("MakeDollarInteger");
3623 r = bufin;
3624/*
3625 First take the first term to load up the LCM and the GCD
3626*/
3627 r2 = r + *r;
3628 j = r2[-1];
3629 r3 = r2 - ABS(j);
3630 k = REDLENG(j);
3631 if ( k < 0 ) k = -k;
3632 while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3633 for ( kGCD = 0; kGCD < k; kGCD++ ) GCDbuffer[kGCD] = r3[kGCD];
3634 k = REDLENG(j);
3635 if ( k < 0 ) k = -k;
3636 r3 += k;
3637 while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3638 for ( kLCM = 0; kLCM < k; kLCM++ ) LCMbuffer[kLCM] = r3[kLCM];
3639 r1 = r2;
3640/*
3641 Now go through the rest of the terms in this argument.
3642*/
3643 while ( *r1 ) {
3644 r2 = r1 + *r1;
3645 j = r2[-1];
3646 r3 = r2 - ABS(j);
3647 k = REDLENG(j);
3648 if ( k < 0 ) k = -k;
3649 while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3650 if ( ( ( GCDbuffer[0] == 1 ) && ( kGCD == 1 ) ) ) {
3651/*
3652 GCD is already 1
3653*/
3654 }
3655 else if ( ( ( k != 1 ) || ( r3[0] != 1 ) ) ) {
3656 if ( GcdLong(BHEAD GCDbuffer,kGCD,(UWORD *)r3,k,GCDbuffer2,&kGCD2) ) {
3657 goto MakeDollarIntegerErr;
3658 }
3659 kGCD = kGCD2;
3660 for ( i = 0; i < kGCD; i++ ) GCDbuffer[i] = GCDbuffer2[i];
3661 }
3662 else {
3663 kGCD = 1; GCDbuffer[0] = 1;
3664 }
3665 k = REDLENG(j);
3666 if ( k < 0 ) k = -k;
3667 r3 += k;
3668 while ( ( k > 1 ) && ( r3[k-1] == 0 ) ) k--;
3669 if ( ( ( LCMbuffer[0] == 1 ) && ( kLCM == 1 ) ) ) {
3670 for ( kLCM = 0; kLCM < k; kLCM++ )
3671 LCMbuffer[kLCM] = r3[kLCM];
3672 }
3673 else if ( ( k != 1 ) || ( r3[0] != 1 ) ) {
3674 if ( GcdLong(BHEAD LCMbuffer,kLCM,(UWORD *)r3,k,LCMb,&kkLCM) ) {
3675 goto MakeDollarIntegerErr;
3676 }
3677 DivLong((UWORD *)r3,k,LCMb,kkLCM,LCMb,&kkLCM,LCMc,&jLCM);
3678 MulLong(LCMbuffer,kLCM,LCMb,kkLCM,LCMc,&jLCM);
3679 for ( kLCM = 0; kLCM < jLCM; kLCM++ )
3680 LCMbuffer[kLCM] = LCMc[kLCM];
3681 }
3682 else {} /* LCM doesn't change */
3683 r1 = r2;
3684 }
3685/*
3686 Now put the factor together: GCD/LCM
3687*/
3688 r3 = (WORD *)(GCDbuffer);
3689 if ( kGCD == kLCM ) {
3690 for ( jGCD = 0; jGCD < kGCD; jGCD++ )
3691 r3[jGCD+kGCD] = LCMbuffer[jGCD];
3692 k = kGCD;
3693 }
3694 else if ( kGCD > kLCM ) {
3695 for ( jGCD = 0; jGCD < kLCM; jGCD++ )
3696 r3[jGCD+kGCD] = LCMbuffer[jGCD];
3697 for ( jGCD = kLCM; jGCD < kGCD; jGCD++ )
3698 r3[jGCD+kGCD] = 0;
3699 k = kGCD;
3700 }
3701 else {
3702 for ( jGCD = kGCD; jGCD < kLCM; jGCD++ )
3703 r3[jGCD] = 0;
3704 for ( jGCD = 0; jGCD < kLCM; jGCD++ )
3705 r3[jGCD+kLCM] = LCMbuffer[jGCD];
3706 k = kLCM;
3707 }
3708 j = 2*k+1;
3709/*
3710 Now we have to write this to factor
3711*/
3712 factor = r1 = (WORD *)Malloc1((j+2)*sizeof(WORD),"MakeDollarInteger");
3713 *r1++ = j+1; r2 = r3;
3714 for ( i = 0; i < k; i++ ) { *r1++ = *r2++; *r1++ = *r2++; }
3715 *r1++ = j;
3716 *r1 = 0;
3717/*
3718 Next we have to take the factor out from the argument.
3719 This cannot be done in location, because the denominator stuff can make
3720 coefficients longer.
3721
3722 We do this via a sort because the things may be jumbled any way and we
3723 do not know in advance how much space we need.
3724*/
3725 NewSort(BHEAD0);
3726 r = bufin;
3727 oldworkpointer = AT.WorkPointer;
3728 while ( *r ) {
3729 rnext = r + *r;
3730 j = ABS(rnext[-1]);
3731 r3 = rnext - j;
3732 r2 = oldworkpointer;
3733 while ( r < r3 ) *r2++ = *r++;
3734 j = (j-1)/2; /* reduced length. Remember, k is the other red length */
3735 if ( DivRat(BHEAD (UWORD *)r3,j,GCDbuffer,k,(UWORD *)r2,&i) ) {
3736 goto MakeDollarIntegerErr;
3737 }
3738 i = 2*i+1;
3739 r2 = r2 + i;
3740 if ( rnext[-1] < 0 ) r2[-1] = -i;
3741 else r2[-1] = i;
3742 *oldworkpointer = r2-oldworkpointer;
3743 AT.WorkPointer = r2;
3744 if ( Generator(BHEAD oldworkpointer,C->numlhs) ) {
3745 goto MakeDollarIntegerErr;
3746 }
3747 r = rnext;
3748 }
3749 AT.WorkPointer = oldworkpointer;
3750 AN.tryterm = 0; /* for now */
3751 EndSort(BHEAD (WORD *)bufout,2);
3752/*
3753 Cleanup
3754*/
3755 NumberFree(LCMc,"MakeDollarInteger");
3756 NumberFree(LCMb,"MakeDollarInteger");
3757 NumberFree(LCMbuffer,"MakeDollarInteger");
3758 NumberFree(GCDbuffer2,"MakeDollarInteger");
3759 NumberFree(GCDbuffer,"MakeDollarInteger");
3760 return(factor);
3761
3762MakeDollarIntegerErr:
3763 NumberFree(LCMc,"MakeDollarInteger");
3764 NumberFree(LCMb,"MakeDollarInteger");
3765 NumberFree(LCMbuffer,"MakeDollarInteger");
3766 NumberFree(GCDbuffer2,"MakeDollarInteger");
3767 NumberFree(GCDbuffer,"MakeDollarInteger");
3768 MesCall("MakeDollarInteger");
3769 Terminate(-1);
3770 return(0);
3771}
3772
3773/*
3774 #] MakeDollarInteger :
3775 #[ MakeDollarMod :
3776*/
3784WORD *MakeDollarMod(PHEAD WORD *buffer, WORD **bufout)
3785{
3786 GETBIDENTITY
3787 WORD *r, *r1, x, xx, ix, ip;
3788 WORD *factor, *oldworkpointer;
3789 int i;
3790 CBUF *C = cbuf+AC.cbufnum;
3791 r = buffer;
3792 x = r[*r-3];
3793 if ( r[*r-1] < 0 ) x += AN.cmod[0];
3794 if ( GetModInverses(x,(WORD)(AN.cmod[0]),&ix,&ip) ) {
3795 Terminate(-1);
3796 }
3797 factor = (WORD *)Malloc1(5*sizeof(WORD),"MakeDollarMod");
3798 factor[0] = 4; factor[1] = x; factor[2] = 1; factor[3] = 3; factor[4] = 0;
3799/*
3800 Now we have to multiply all coefficients by ix.
3801 This does not make things longer, but we should keep to the conventions
3802 of MakeDollarInteger.
3803*/
3804 NewSort(BHEAD0);
3805 r = buffer;
3806 oldworkpointer = AT.WorkPointer;
3807 while ( *r ) {
3808 r1 = oldworkpointer; i = *r;
3809 NCOPY(r1,r,i);
3810 xx = r1[-3]; if ( r1[-1] < 0 ) xx += AN.cmod[0];
3811 r1[-1] = (WORD)((((LONG)xx)*ix) % AN.cmod[0]);
3812 *r1 = 0; AT.WorkPointer = r1;
3813 if ( Generator(BHEAD oldworkpointer,C->numlhs) ) {
3814 Terminate(-1);
3815 }
3816 }
3817 AT.WorkPointer = oldworkpointer;
3818 AN.tryterm = 0; /* for now */
3819 EndSort(BHEAD (WORD *)bufout,2);
3820 return(factor);
3821}
3822/*
3823 #] MakeDollarMod :
3824 #[ GetDolNum :
3825
3826 Evaluates a chain of DOLLAREXPR2 into a number
3827*/
3828
3829int GetDolNum(PHEAD WORD *t, WORD *tstop)
3830{
3831 DOLLARS d;
3832 WORD num, *w;
3833 if ( t+3 < tstop && t[3] == DOLLAREXPR2 ) {
3834 d = Dollars + t[2];
3835#ifdef WITHPTHREADS
3836 {
3837 int nummodopt, dtype;
3838 dtype = -1;
3839 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
3840 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3841 if ( t[2] == ModOptdollars[nummodopt].number ) break;
3842 }
3843 if ( nummodopt < NumModOptdollars ) {
3844 dtype = ModOptdollars[nummodopt].type;
3845 if ( dtype == MODLOCAL ) {
3846 d = ModOptdollars[nummodopt].dstruct+AT.identity;
3847 }
3848 else {
3849 MLOCK(ErrorMessageLock);
3850 MesPrint("&Illegal attempt to use $-variable %s in module %l",
3851 DOLLARNAME(Dollars,t[2]),AC.CModule);
3852 MUNLOCK(ErrorMessageLock);
3853 Terminate(-1);
3854 }
3855 }
3856 }
3857 }
3858#endif
3859 if ( d->factors == 0 ) {
3860 MLOCK(ErrorMessageLock);
3861 MesPrint("Attempt to use a factor of an unfactored $-variable");
3862 MUNLOCK(ErrorMessageLock);
3863 Terminate(-1);
3864 }
3865 num = GetDolNum(BHEAD t+t[1],tstop);
3866 if ( num == 0 ) return(d->nfactors);
3867 if ( num > d->nfactors ) {
3868 MLOCK(ErrorMessageLock);
3869 MesPrint("Attempt to use an nonexisting factor %d of a $-variable",num);
3870 MUNLOCK(ErrorMessageLock);
3871 Terminate(-1);
3872 }
3873 w = d->factors[num-1].where;
3874 if ( w == 0 ) return(d->factors[num-1].value);
3875 if ( w[0] == 4 && w[4] == 0 && w[3] == 3 && w[2] == 1 && w[1] > 0
3876 && w[1] < MAXPOSITIVE ) return(w[1]);
3877 else {
3878 MLOCK(ErrorMessageLock);
3879 MesPrint("Illegal type of factor number of a $-variable");
3880 MUNLOCK(ErrorMessageLock);
3881 Terminate(-1);
3882 }
3883 }
3884 else if ( t[2] < 0 ) {
3885 return(-t[2]-1);
3886 }
3887 else {
3888 d = Dollars + t[2];
3889#ifdef WITHPTHREADS
3890 {
3891 int nummodopt, dtype;
3892 dtype = -1;
3893 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
3894 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
3895 if ( t[2] == ModOptdollars[nummodopt].number ) break;
3896 }
3897 if ( nummodopt < NumModOptdollars ) {
3898 dtype = ModOptdollars[nummodopt].type;
3899 if ( dtype == MODLOCAL ) {
3900 d = ModOptdollars[nummodopt].dstruct+AT.identity;
3901 }
3902 else {
3903 MLOCK(ErrorMessageLock);
3904 MesPrint("&Illegal attempt to use $-variable %s in module %l",
3905 DOLLARNAME(Dollars,t[2]),AC.CModule);
3906 MUNLOCK(ErrorMessageLock);
3907 Terminate(-1);
3908 }
3909 }
3910 }
3911 }
3912#endif
3913 if ( d->type == DOLZERO ) return(0);
3914 if ( d->type == DOLTERMS || d->type == DOLNUMBER ) {
3915 if ( d->where[0] == 4 && d->where[4] == 0 && d->where[3] == 3
3916 && d->where[2] == 1 && d->where[1] > 0
3917 && d->where[1] < MAXPOSITIVE ) return(d->where[1]);
3918 MLOCK(ErrorMessageLock);
3919 MesPrint("Attempt to use an nonexisting factor of a $-variable");
3920 MUNLOCK(ErrorMessageLock);
3921 Terminate(-1);
3922 }
3923 MLOCK(ErrorMessageLock);
3924 MesPrint("Illegal type of factor number of a $-variable");
3925 MUNLOCK(ErrorMessageLock);
3926 Terminate(-1);
3927 }
3928 return(0);
3929}
3930
3931/*
3932 #] GetDolNum :
3933 #[ AddPotModdollar :
3934*/
3935
3942void AddPotModdollar(WORD numdollar)
3943{
3944 int i, n = NumPotModdollars;
3945 for ( i = 0; i < n; i++ ) {
3946 if ( numdollar == PotModdollars[i] ) break;
3947 }
3948 if ( i >= n ) {
3949 *(WORD *)FromList(&AC.PotModDolList) = numdollar;
3950 }
3951}
3952
3953/*
3954 #] AddPotModdollar :
3955*/
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:454
Generator
int Generator(PHEAD WORD *, WORD)
Definition proces.c:3249
TakeContent
WORD * TakeContent(PHEAD WORD *, WORD *)
Definition ratio.c:1376
LowerSortLevel
void LowerSortLevel(void)
Definition sort.c:4661
StoreTerm
int StoreTerm(PHEAD WORD *)
Definition sort.c:4244
NewSort
int NewSort(PHEAD0)
Definition sort.c:359
GetModInverses
int GetModInverses(WORD, WORD, WORD *, WORD *)
Definition reken.c:1477
MakeDollarInteger
WORD * MakeDollarInteger(PHEAD WORD *bufin, WORD **bufout)
Definition dollar.c:3610
AddPotModdollar
void AddPotModdollar(WORD numdollar)
Definition dollar.c:3942
EvalDoLoopArg
WORD EvalDoLoopArg(PHEAD WORD *arg, WORD par)
Definition dollar.c:2633
MakeDollarMod
WORD * MakeDollarMod(PHEAD WORD *buffer, WORD **bufout)
Definition dollar.c:3784
PF_BroadcastPreDollar
int PF_BroadcastPreDollar(WORD **dbuffer, LONG *newsize, int *numterms)
Definition parallel.c:2222
Generated by doxygen 1.9.8