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