FORM v5.0.2-2-gfb12f2e
transform.c
Go to the documentation of this file.
1
5/* #[ License : */
6/*
7 * Copyright (C) 1984-2026 J.A.M. Vermaseren
8 * When using this file you are requested to refer to the publication
9 * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
10 * This is considered a matter of courtesy as the development was paid
11 * for by FOM the Dutch physics granting agency and we would like to
12 * be able to track its scientific use to convince FOM of its value
13 * for the community.
14 *
15 * This file is part of FORM.
16 *
17 * FORM is free software: you can redistribute it and/or modify it under the
18 * terms of the GNU General Public License as published by the Free Software
19 * Foundation, either version 3 of the License, or (at your option) any later
20 * version.
21 *
22 * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
23 * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
24 * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
25 * details.
26 *
27 * You should have received a copy of the GNU General Public License along
28 * with FORM. If not, see <http://www.gnu.org/licenses/>.
29 */
30/* #] License : */
31/*
32 #[ Includes : transform.c
33*/
34
35#include "form3.h"
36
37/*
38 #] Includes :
39 #[ Transform :
40 #[ Intro :
41
42 Here are the routines for the transform statement. This is a
43 group of transformations on function arguments or groups of
44 function arguments. The purpose of this command is that it
45 avoids repetitive pattern matching.
46 Syntax:
47 Transform,SetOfFunctions,OneOrMoreTransformations;
48 Each transformation is given by
49 Replace(argfirst,arglast)=(,,,)
50 Encode(argfirst,arglast):base=#
51 Decode(argfirst,arglast):base=#
52 Implode(argfirst,arglast)
53 Explode(argfirst,arglast)
54 Permute(cycle)(cycle)(cycle)...(cycle)
55 Reverse(argfirst,arglast)
56 Dedup(argfirst,arglast)
57 Cycle(argfirst,arglast)=+/-num
58 IsLyndon(argfirst,arglast)=(yes,no)
59 ToLyndon(argfirst,arglast)=(yes,no)
60 In replace the extra information is
61 a replace_() without the name of the replace_ function.
62 This can be as in (0,1,1,0) or (xarg_,1-xarg_) to indicate
63 a symbolic argument or (x,y,y,x) to exchange x and y, etc.
64 In Encode and Decode argfirst is the most significant 'word' and
65 arglast is the least significant 'word'.
66 Note that we need to introduce the generic symbolic arguments xarg_,
67 parg_, iarg_ and farg_.
68 Examples:
69 Transform,{H,E}
70 ,Replace(1:`WEIGHT')=(0,1,1,0)
71 ,Encode(1:`WEIGHT')=base(2);
72 Transform,{H,E}
73 ,Decode(1:`WEIGHT')=base(3)
74 ,Replace(1:`WEIGHT')=(2,-1,1,0,0,1);
75 Others that can be added:
76 symmetrize?
77
78 6-may-2016: Changed MAXPOSITIVE2 into MAXPOSITIVE4. This makes room
79 for the use of dollar variables as arguments.
80
81 #] Intro :
82 #[ CoTransform :
83*/
84
85static WORD tranarray[10] = { SUBEXPRESSION, SUBEXPSIZE, 0, 1, 0, 0, 0, 0, 0, 0 };
86
87int CoTransform(UBYTE *in)
88{
89 GETIDENTITY
90 UBYTE *s = in, c, *ss, *Tempbuf;
91 WORD number, type, i, *work = AT.WorkPointer+2, *wp, range[2], one = 1;
92 WORD numdol, *wstart;
93 int error = 0, irhs;
94 LONG x;
95 while ( *in == ',' ) in++;
96 wp = work + 1;
97/*
98 #[ Sets :
99
100 First the set specification(s). No sets means all functions (dangerous!)
101*/
102 for(;;) {
103 if ( *in == '{' ) {
104 s = in+1;
105 SKIPBRA2(in)
106 number = DoTempSet(s,in);
107 in++;
108 if ( *in != ',' ) {
109 c = in[1]; in[1] = 0;
110 MesPrint("& %s: A set in a transform statement should be followed by a comma",s);
111 in[1] = c; in++;
112 if ( error == 0 ) error = 1;
113 }
114 }
115 else if ( *in == '[' || FG.cTable[*in] == 0 ) {
116 s = in;
117 in = SkipAName(in);
118 if ( *in != ',' ) break;
119 c = *in; *in = 0;
120 type = GetName(AC.varnames,s,&number,NOAUTO);
121 if ( type == CFUNCTION ) {
122#ifdef WITHFLOAT
123 if ( (number+FUNCTION) == FLOATFUN ) {
124 MesPrint("&Illegal use of a transform statement and float_");
125 if ( error == 0 ) error = 1;
126 }
127#endif
128 number += MAXVARIABLES + FUNCTION; }
129 else if ( type != CSET ) {
130 MesPrint("& %s: A transform statement starts with sets of functions",s);
131 if ( error == 0 ) error = 1;
132 }
133 *in++ = c;
134 }
135 else {
136 MesPrint("&Illegal syntax in Transform statement",s);
137 if ( error == 0 ) error = 1;
138 return(error);
139 }
140 if ( number >= 0 ) {
141 if ( number < MAXVARIABLES ) {
142/*
143 Check that this is a set of functions
144*/
145 if ( Sets[number].type != CFUNCTION ) {
146 MesPrint("&A set in a transform statement should be a set of functions");
147 if ( error == 0 ) error = 1;
148 }
149#ifdef WITHFLOAT
150 WORD *r1, *r2;
151 r1 = SetElements + Sets[number].first;
152 r2 = SetElements + Sets[number].last;
153 while ( r1 < r2 ) {
154 if ( *r1++ == FLOATFUN ) {
155 MesPrint("&Illegal use of a transform statement and float_");
156 if ( error == 0 ) error = 1;
157 }
158 }
159#endif
160 }
161 }
162 else if ( error == 0 ) error = 1;
163/*
164 Now write the number to the right place
165*/
166 *wp++ = number;
167 while ( *in == ',' ) in++;
168 }
169 *work = wp - work;
170 work = wp; wp++;
171/*
172 #] Sets :
173
174 Now we should loop over the various transformations
175*/
176 while ( *s ) {
177 in = s;
178 if ( FG.cTable[*in] != 0 ) {
179 MesPrint("&Illegal character in Transform statement");
180 if ( error == 0 ) error = 1;
181 return(error);
182 }
183 in = SkipAName(in);
184 if ( *in == '>' || *in == '<' || *in == '+' || *in == '-' ) in++;
185 ss = in;
186 c = *ss; *ss = 0;
187 if ( c != '(' ) {
188 MesPrint("&Illegal syntax in specifying a transformation inside a Transform statement");
189 if ( error == 0 ) error = 1;
190 return(error);
191 }
192/*
193 #[ replace :
194*/
195 if ( StrICmp(s,(UBYTE *)"replace") == 0 ) {
196/*
197 Subkeys: (,,,) as in replace_(,,,)
198 The idea here is to read the subkeys as the argument
199 of a replace_ function.
200 We put the whole together as in the multiply statement (which
201 could just be a replace_(....)) and compile it.
202 Then we expand the tree with Generator and check the complete
203 expression for legality.
204*/
205 type = REPLACEARG;
206doreplace:
207 *ss = c;
208 if ( ( in = ReadRange(in,range,0) ) == 0 ) {
209 if ( error == 0 ) error = 1;
210 return(error);
211 }
212 in++;
213/*
214 We have replace(#,#)=(...), and we want dum_(...) (DUMFUN)
215 to send to the compiler. The pointer is after the '=';
216*/
217 s = in;
218 if ( *s != '(' ) {
219 MesPrint("&");
220 if ( error == 0 ) error = 1;
221 return(error);
222 }
223 SKIPBRA3(in);
224 if ( *in != ')' ) {
225 MesPrint("&");
226 if ( error == 0 ) error = 1;
227 return(error);
228 }
229 in++;
230 if ( *in != ',' && *in != '\0' ) {
231 MesPrint("&");
232 if ( error == 0 ) error = 1;
233 return(error);
234 }
235 i = in - s;
236 ss = Tempbuf = (UBYTE *)Malloc1(i+5,"CoTransform/replace");
237 *ss++ = 'd'; *ss++ = 'u'; *ss++ = 'm'; *ss++ = '_';
238 NCOPY(ss,s,i)
239 *ss++ = 0;
240 AC.ProtoType = tranarray;
241 tranarray[4] = AC.cbufnum;
242 irhs = CompileAlgebra(Tempbuf,RHSIDE,AC.ProtoType);
243 M_free(Tempbuf,"CoTransform/replace");
244 if ( irhs < 0 ) {
245 if ( error == 0 ) error = 1;
246 return(error);
247 }
248 tranarray[2] = irhs;
249/*
250 The result of the compilation goes through Generator during
251 execution, because that takes care of $-variables.
252 This is why we could not use replace_ and had to use dum_.
253*/
254 *wp++ = ARGRANGE;
255 *wp++ = range[0];
256 *wp++ = range[1];
257 *wp++ = type;
258 *wp++ = SUBEXPSIZE+4;
259 for ( i = 0; i < SUBEXPSIZE; i++ ) *wp++ = tranarray[i];
260 *wp++ = 1;
261 *wp++ = 1;
262 *wp++ = 3;
263 *work = wp-work;
264 work = wp; *wp++ = 0;
265 s = in;
266 }
267/*
268 #] replace :
269 #[ encode/decode :
270*/
271 else if ( StrICmp(s,(UBYTE *)"decode" ) == 0 ) {
272 type = DECODEARG;
273 goto doencode;
274 }
275 else if ( StrICmp(s,(UBYTE *)"encode" ) == 0 ) {
276 type = ENCODEARG;
277doencode: *ss = c;
278 if ( ( in = ReadRange(in,range,2) ) == 0 ) {
279 if ( error == 0 ) error = 1;
280 return(error);
281 }
282 in++;
283 s = in; while ( FG.cTable[*in] == 0 ) in++;
284 c = *in; *in = 0;
285/*
286 Subkeys: base=# or base=$var
287*/
288 if ( StrICmp(s,(UBYTE *)"base") == 0 ) {
289 *in = c;
290 if ( *in != '=' ) {
291 MesPrint("&Illegal base specification in encode/decode transformation");
292 if ( error == 0 ) error = 1;
293 return(error);
294 }
295 in++;
296 if ( *in == '$' ) {
297 in++; ss = in;
298 in = SkipAName(in);
299 c = *in; *in = 0;
300 if ( GetName(AC.dollarnames,ss,&numdol,NOAUTO) != CDOLLAR ) {
301 MesPrint("&%s is undefined",ss-1);
302 numdol = AddDollar(ss,DOLINDEX,&one,1);
303 return(1);
304 }
305 *in = c;
306 x = -numdol;
307 }
308 else {
309 x = 0;
310 while ( FG.cTable[*in] == 1 ) {
311 x = 10*x + *in++ - '0';
312 if ( x > MAXPOSITIVE4 ) {
313illsize: MesPrint("&Illegal value for base in encode/decode transformation");
314 if ( error == 0 ) error = 1;
315 return(error);
316 }
317 }
318 if ( x <= 1 ) goto illsize;
319 }
320 if ( *in != ',' && *in != '\0' ) {
321 MesPrint("&Illegal termination of transformation");
322 if ( error == 0 ) error = 1;
323 return(error);
324 }
325 }
326 else {
327 MesPrint("&Illegal option in encode/decode transformation");
328 if ( error == 0 ) error = 1;
329 return(error);
330 }
331/*
332 Now we can put the whole statement together
333 We have the set(s) in work up to wp and the range in range.
334 The base is in x and the type tells whether it is encode or decode.
335*/
336 *wp++ = ARGRANGE;
337 *wp++ = range[0];
338 *wp++ = range[1];
339 *wp++ = type;
340 *wp++ = 4;
341 *wp++ = BASECODE;
342 *wp++ = (WORD)x;
343 *work = wp-work;
344 work = wp; *wp++ = 0;
345 s = in;
346 }
347/*
348 #] encode/decode :
349 #[ implode :
350*/
351 else if ( StrICmp(s,(UBYTE *)"implode") == 0
352 || StrICmp(s,(UBYTE *)"tosumnotation") == 0 ) {
353/*
354 Subkeys: ?
355*/
356 type = IMPLODEARG;
357 *ss = c;
358 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
359 if ( error == 0 ) error = 1;
360 return(error);
361 }
362 *wp++ = ARGRANGE;
363 *wp++ = range[0];
364 *wp++ = range[1];
365 *wp++ = type;
366 *work = wp-work;
367 work = wp; *wp++ = 0;
368 s = in;
369 }
370/*
371 #] implode :
372 #[ explode :
373*/
374 else if ( StrICmp(s,(UBYTE *)"explode") == 0
375 || StrICmp(s,(UBYTE *)"tointegralnotation") == 0 ) {
376/*
377 Subkeys: ?
378*/
379 type = EXPLODEARG;
380 *ss = c;
381 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
382 if ( error == 0 ) error = 1;
383 return(error);
384 }
385 *wp++ = ARGRANGE;
386 *wp++ = range[0];
387 *wp++ = range[1];
388 *wp++ = type;
389 *work = wp-work;
390 work = wp; *wp++ = 0;
391 s = in;
392 }
393/*
394 #] explode :
395 #[ permute :
396*/
397 else if ( StrICmp(s,(UBYTE *)"permute") == 0 ) {
398 type = PERMUTEARG;
399 *ss = c;
400 *wp++ = ARGRANGE;
401 *wp++ = 1;
402 *wp++ = MAXPOSITIVE4;
403 *wp++ = type;
404/*
405 Now a sequence of cycles
406*/
407 do {
408 wstart = wp; wp++;
409 do {
410 in++;
411 if ( *in == '$' ) {
412 WORD number; UBYTE *t;
413 in++; t = in;
414 while ( FG.cTable[*in] < 2 ) in++;
415 c = *in; *in = 0;
416 if ( ( number = GetDollar(t) ) < 0 ) {
417 MesPrint("&Undefined variable $%s",t);
418 if ( !error ) error = 1;
419 number = AddDollar(t,0,0,0);
420 }
421 *in = c;
422 *wp++ = -number-1;
423 }
424 else {
425 x = 0;
426 while ( FG.cTable[*in] == 1 ) {
427 x = 10*x + *in++ - '0';
428 if ( x > MAXPOSITIVE4 ) {
429 MesPrint("&value in permute transformation too large");
430 if ( error == 0 ) error = 1;
431 return(error);
432 }
433 }
434 if ( x == 0 ) {
435 MesPrint("&value 0 in permute transformation not allowed");
436 if ( error == 0 ) error = 1;
437 return(error);
438 }
439 *wp++ = (WORD)x-1;
440 }
441 } while ( *in == ',' );
442 if ( *in != ')' ) {
443 MesPrint("&Illegal syntax in permute transformation");
444 if ( error == 0 ) error = 1;
445 return(error);
446 }
447 in++;
448 if ( *in != ',' && *in != '(' && *in != '\0' ) {
449 MesPrint("&Illegal ending in permute transformation");
450 if ( error == 0 ) error = 1;
451 return(error);
452 }
453 *wstart = wp-wstart;
454 if ( *wstart == 1 ) wstart--;
455 } while ( *in == '(' );
456 *work = wp-work;
457 work = wp; *wp++ = 0;
458 s = in;
459 }
460/*
461 #] permute :
462 #[ reverse :
463*/
464 else if ( StrICmp(s,(UBYTE *)"reverse") == 0 ) {
465 type = REVERSEARG;
466 *ss = c;
467 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
468 if ( error == 0 ) error = 1;
469 return(error);
470 }
471 *wp++ = ARGRANGE;
472 *wp++ = range[0];
473 *wp++ = range[1];
474 *wp++ = type;
475 *work = wp-work;
476 work = wp; *wp++ = 0;
477 s = in;
478 }
479/*
480 #] reverse :
481 #[ dedup :
482*/
483 else if ( StrICmp(s,(UBYTE *)"dedup") == 0 ) {
484 type = DEDUPARG;
485 *ss = c;
486 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
487 if ( error == 0 ) error = 1;
488 return(error);
489 }
490 *wp++ = ARGRANGE;
491 *wp++ = range[0];
492 *wp++ = range[1];
493 *wp++ = type;
494 *work = wp-work;
495 work = wp; *wp++ = 0;
496 s = in;
497 }
498/*
499 #] dedup :
500 #[ cycle :
501*/
502 else if ( StrICmp(s,(UBYTE *)"cycle") == 0 ) {
503 type = CYCLEARG;
504 *ss = c;
505 if ( ( in = ReadRange(in,range,0) ) == 0 ) {
506 if ( error == 0 ) error = 1;
507 return(error);
508 }
509 *wp++ = ARGRANGE;
510 *wp++ = range[0];
511 *wp++ = range[1];
512 *wp++ = type;
513/*
514 Now a sequence of cycles
515*/
516 in++;
517 if ( *in == '+' ) {
518 }
519 else if ( *in == '-' ) {
520 one = -1;
521 }
522 else {
523 MesPrint("&Cycle in a Transform statement should be followed by =+/-number/$");
524 if ( error == 0 ) error = 1;
525 return(error);
526 }
527 in++; x = 0;
528 if ( *in == '$' ) {
529 UBYTE *si = in;
530 in++; si = in;
531 while ( FG.cTable[*in] == 0 || FG.cTable[*in] == 1 ) in++;
532 c = *in; *in = 0;
533 if ( ( x = GetDollar(si) ) < 0 ) {
534 MesPrint("&Undefined $-variable in transform,cycle statement.");
535 error = 1;
536 }
537 *in = c;
538 if ( one < 0 ) x += MAXPOSITIVE4;
539 x += MAXPOSITIVE2;
540 *wp++ = x;
541 }
542 else {
543 while ( FG.cTable[*in] == 1 ) {
544 x = 10*x + *in++ - '0';
545 if ( x > MAXPOSITIVE4 ) {
546 MesPrint("&Number in cycle in a Transform statement too big");
547 if ( error == 0 ) error = 1;
548 return(error);
549 }
550 }
551 *wp++ = x*one;
552 }
553 *work = wp-work;
554 work = wp; *wp++ = 0;
555 s = in;
556 }
557/*
558 #] cycle :
559 #[ islyndon/tolyndon :
560*/
561 else if ( StrICmp(s,(UBYTE *)"islyndon" ) == 0 ) {
562 type = ISLYNDON;
563 goto doreplace;
564 }
565 else if ( StrICmp(s,(UBYTE *)"islyndon<" ) == 0 ) {
566 type = ISLYNDON;
567 goto doreplace;
568 }
569 else if ( StrICmp(s,(UBYTE *)"islyndon-" ) == 0 ) {
570 type = ISLYNDON;
571 goto doreplace;
572 }
573 else if ( StrICmp(s,(UBYTE *)"islyndon>" ) == 0 ) {
574 type = ISLYNDONR;
575 goto doreplace;
576 }
577 else if ( StrICmp(s,(UBYTE *)"islyndon+" ) == 0 ) {
578 type = ISLYNDONR;
579 goto doreplace;
580 }
581 else if ( StrICmp(s,(UBYTE *)"tolyndon" ) == 0 ) {
582 type = TOLYNDON;
583 goto doreplace;
584 }
585 else if ( StrICmp(s,(UBYTE *)"tolyndon<" ) == 0 ) {
586 type = TOLYNDON;
587 goto doreplace;
588 }
589 else if ( StrICmp(s,(UBYTE *)"tolyndon-" ) == 0 ) {
590 type = TOLYNDON;
591 goto doreplace;
592 }
593 else if ( StrICmp(s,(UBYTE *)"tolyndon>" ) == 0 ) {
594 type = TOLYNDONR;
595 goto doreplace;
596 }
597 else if ( StrICmp(s,(UBYTE *)"tolyndon+" ) == 0 ) {
598 type = TOLYNDONR;
599 goto doreplace;
600 }
601/*
602 #] islyndon/tolyndon :
603 #[ addarg :
604*/
605 else if ( StrICmp(s,(UBYTE *)"addargs" ) == 0 ) {
606 type = ADDARG;
607 *ss = c;
608 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
609 if ( error == 0 ) error = 1;
610 return(error);
611 }
612 *wp++ = ARGRANGE;
613 *wp++ = range[0];
614 *wp++ = range[1];
615 *wp++ = type;
616 *work = wp-work;
617 work = wp; *wp++ = 0;
618 s = in;
619 }
620/*
621 #] addarg :
622 #[ mularg :
623*/
624 else if ( ( StrICmp(s,(UBYTE *)"mulargs" ) == 0 )
625 || ( StrICmp(s,(UBYTE *)"multiplyargs" ) == 0 ) ) {
626 type = MULTIPLYARG;
627 *ss = c;
628 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
629 if ( error == 0 ) error = 1;
630 return(error);
631 }
632 *wp++ = ARGRANGE;
633 *wp++ = range[0];
634 *wp++ = range[1];
635 *wp++ = type;
636 *work = wp-work;
637 work = wp; *wp++ = 0;
638 s = in;
639 }
640/*
641 #] mularg :
642 #[ droparg :
643*/
644 else if ( StrICmp(s,(UBYTE *)"dropargs" ) == 0 ) {
645 type = DROPARG;
646 *ss = c;
647 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
648 if ( error == 0 ) error = 1;
649 return(error);
650 }
651 *wp++ = ARGRANGE;
652 *wp++ = range[0];
653 *wp++ = range[1];
654 *wp++ = type;
655 *work = wp-work;
656 work = wp; *wp++ = 0;
657 s = in;
658 }
659/*
660 #] droparg :
661 #[ selectarg :
662*/
663 else if ( StrICmp(s,(UBYTE *)"selectargs" ) == 0 ) {
664 type = SELECTARG;
665 *ss = c;
666 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
667 if ( error == 0 ) error = 1;
668 return(error);
669 }
670 *wp++ = ARGRANGE;
671 *wp++ = range[0];
672 *wp++ = range[1];
673 *wp++ = type;
674 *work = wp-work;
675 work = wp; *wp++ = 0;
676 s = in;
677 }
678/*
679 #] selectarg :
680 #[ ZtoH :
681*/
682 else if ( StrICmp(s,(UBYTE *)"ztoh") == 0 ) {
683/*
684 Subkeys: ?
685*/
686 type = ZTOHARG;
687 *ss = c;
688 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
689 if ( error == 0 ) error = 1;
690 return(error);
691 }
692 *wp++ = ARGRANGE;
693 *wp++ = range[0];
694 *wp++ = range[1];
695 *wp++ = type;
696 *work = wp-work;
697 work = wp; *wp++ = 0;
698 s = in;
699 }
700/*
701 #] ZtoH :
702 #[ HtoZ :
703*/
704 else if ( StrICmp(s,(UBYTE *)"htoz") == 0 ) {
705/*
706 Subkeys: ?
707*/
708 type = HTOZARG;
709 *ss = c;
710 if ( ( in = ReadRange(in,range,1) ) == 0 ) {
711 if ( error == 0 ) error = 1;
712 return(error);
713 }
714 *wp++ = ARGRANGE;
715 *wp++ = range[0];
716 *wp++ = range[1];
717 *wp++ = type;
718 *work = wp-work;
719 work = wp; *wp++ = 0;
720 s = in;
721 }
722/*
723 #] HtoZ :
724*/
725 else {
726 MesPrint("&Unknown transformation inside a Transform statement: %s",s);
727 *ss = c;
728 if ( error == 0 ) error = 1;
729 return(error);
730 }
731 while ( *s == ',') s++;
732 }
733 AT.WorkPointer[0] = TYPETRANSFORM;
734 AT.WorkPointer[1] = i = wp - AT.WorkPointer;
735 AddNtoL(i,AT.WorkPointer);
736 return(error);
737}
738
739/*
740 #] CoTransform :
741 #[ RunTransform :
742
743 Executes the transform statement.
744 This routine hunts down the functions and sends them to the various
745 action routines.
746 params: size,#set1,...,#setn, transformations
747
748*/
749
750int RunTransform(PHEAD WORD *term, WORD *params)
751{
752 WORD *t, *tstop, *w, *m, *out, *in, *tt, retval;
753 WORD *fun, *args, *info, *infoend, *onetransform, *funs, *endfun;
754 WORD *thearg = 0, *iterm, *newterm, *nt, *oldwork = AT.WorkPointer, sign = 1;
755 int i;
756 out = tstop = term + *term;
757 tstop -= ABS(tstop[-1]);
758 in = term;
759 t = term + 1;
760 while ( t < tstop ) {
761 endfun = onetransform = params + *params;
762 funs = params + 1;
763 if ( *t < FUNCTION ) {}
764 else if ( funs == endfun ) { /* we do all functions */
765hit:;
766#ifdef WITHFLOAT
767 if ( *t == FLOATFUN ) goto next;
768#endif
769 while ( in < t ) *out++ = *in++;
770 tt = t + t[1]; fun = out;
771 while ( in < tt ) *out++ = *in++;
772 do {
773 args = onetransform + 1;
774 info = args; while ( *info <= MAXRANGEINDICATOR ) {
775 if ( *info == ALLARGS ) info++;
776 else if ( *info == NUMARG ) info += 2;
777 else if ( *info == ARGRANGE ) info += 3;
778 else if ( *info == MAKEARGS ) info += 3;
779 }
780 switch ( *info ) {
781 case REPLACEARG:
782 if ( RunReplace(BHEAD fun,args,info) ) goto abo;
783 out = fun + fun[1];
784 break;
785 case ENCODEARG:
786 if ( RunEncode(BHEAD fun,args,info) ) goto abo;
787 out = fun + fun[1];
788 break;
789 case DECODEARG:
790 if ( RunDecode(BHEAD fun,args,info) ) goto abo;
791 out = fun + fun[1];
792 break;
793 case IMPLODEARG:
794 if ( RunImplode(fun,args) ) goto abo;
795 out = fun + fun[1];
796 break;
797 case EXPLODEARG:
798 if ( RunExplode(BHEAD fun,args) ) goto abo;
799 out = fun + fun[1];
800 break;
801 case PERMUTEARG:
802 if ( RunPermute(BHEAD fun,args,info) ) goto abo;
803 out = fun + fun[1];
804 break;
805 case REVERSEARG:
806 if ( RunReverse(BHEAD fun,args) ) goto abo;
807 out = fun + fun[1];
808 break;
809 case DEDUPARG:
810 if ( RunDedup(BHEAD fun,args) ) goto abo;
811 out = fun + fun[1];
812 break;
813 case CYCLEARG:
814 if ( RunCycle(BHEAD fun,args,info) ) goto abo;
815 out = fun + fun[1];
816 break;
817 case ADDARG:
818 if ( RunAddArg(BHEAD fun,args) ) goto abo;
819 out = fun + fun[1];
820 break;
821 case MULTIPLYARG:
822 if ( RunMulArg(BHEAD fun,args) ) goto abo;
823 out = fun + fun[1];
824 break;
825 case ISLYNDON:
826 if ( ( retval = RunIsLyndon(BHEAD fun,args,1) ) < -1 ) goto abo;
827 goto returnvalues;
828 break;
829 case ISLYNDONR:
830 if ( ( retval = RunIsLyndon(BHEAD fun,args,-1) ) < -1 ) goto abo;
831 goto returnvalues;
832 break;
833 case TOLYNDON:
834 if ( ( retval = RunToLyndon(BHEAD fun,args,1) ) < -1 ) goto abo;
835 goto returnvalues;
836 break;
837 case TOLYNDONR:
838 if ( ( retval = RunToLyndon(BHEAD fun,args,-1) ) < -1 ) goto abo;
839returnvalues:;
840 out = fun + fun[1];
841 if ( retval == -1 ) break;
842/*
843 Work out the yes/no stuff
844*/
845 AT.WorkPointer += 2*AM.MaxTer;
846 if ( AT.WorkPointer > AT.WorkTop ) {
847 MLOCK(ErrorMessageLock);
848 MesWork();
849 MUNLOCK(ErrorMessageLock);
850 return(-1);
851 }
852 iterm = AT.WorkPointer;
853 info++;
854 for ( i = 0; i < *info; i++ ) iterm[i] = info[i];
855 AT.WorkPointer = iterm + *iterm;
856 AR.Eside = LHSIDEX;
857 NewSort(BHEAD0);
858 if ( Generator(BHEAD iterm,AR.Cnumlhs) ) {
859 LowerSortLevel();
860 AT.WorkPointer = oldwork;
861 return(-1);
862 }
863 newterm = AT.WorkPointer;
864 if ( EndSort(BHEAD newterm,1) < 0 ) {}
865 if ( ( *newterm && *(newterm+*newterm) != 0 ) || *newterm == 0 ) {
866 MLOCK(ErrorMessageLock);
867 MesPrint("&yes/no information in islyndon/tolyndon does not evaluate into a single term");
868 MUNLOCK(ErrorMessageLock);
869 return(-1);
870 }
871 AR.Eside = RHSIDE;
872 i = *newterm; tt = iterm; nt = newterm;
873 NCOPY(tt,nt,i);
874 AT.WorkPointer = iterm + *iterm;
875 info = iterm + 1;
876 infoend = info+info[1];
877 info += FUNHEAD;
878
879 if ( retval == 0 ) {
880/*
881 Need second argument (=no)
882*/
883 if ( info >= infoend ) {
884abortlyndon:;
885 MLOCK(ErrorMessageLock);
886 MesPrint("There should be a yes and a no argument in islyndon/tolyndon");
887 MUNLOCK(ErrorMessageLock);
888 Terminate(-1);
889 }
890 NEXTARG(info)
891 if ( info >= infoend ) goto abortlyndon;
892 thearg = info;
893 }
894 else if ( retval == 1 ) {
895/*
896 Need first argument (=yes)
897*/
898 if ( info >= infoend ) goto abortlyndon;
899 thearg = info;
900 NEXTARG(info)
901 if ( info >= infoend ) goto abortlyndon;
902 }
903 NEXTARG(info)
904 if ( info < infoend ) goto abortlyndon;
905/*
906 The argument in thearg needs to be copied
907 We did not pull it through generator to guarantee
908 that it is a single argument.
909 The easiest way is to let the routine Normalize
910 do the job and put everything in an exponent function
911 with the power one.
912*/
913 if ( *thearg == -SNUMBER && thearg[1] == 0 ) {
914 *term = 0; return(0);
915 }
916 if ( *thearg == -SNUMBER && thearg[1] == 1 ) { }
917 else {
918 fun = out;
919 *out++ = EXPONENT; out++; *out++ = 1; FILLFUN3(out);
920 COPY1ARG(out,thearg);
921 *out++ = -SNUMBER; *out++ = 1;
922 fun[1] = out-fun;
923 }
924 break;
925 case DROPARG:
926 if ( RunDropArg(BHEAD fun,args) ) goto abo;
927 out = fun + fun[1];
928 break;
929 case SELECTARG:
930 if ( RunSelectArg(BHEAD fun,args) ) goto abo;
931 out = fun + fun[1];
932 break;
933 case ZTOHARG:
934 {
935 WORD s = RunZtoHArg(BHEAD fun,args);
936 if ( s < 0 ) goto abo;
937 if ( s == 1 ) sign = -sign;
938 out = fun + fun[1];
939 }
940 break;
941 case HTOZARG:
942 {
943 WORD s = RunHtoZArg(BHEAD fun,args);
944 if ( s < 0 ) goto abo;
945 if ( s == 1 ) sign = -sign;
946 out = fun + fun[1];
947 }
948 break;
949 default:
950/* INTERNAL_ERROR_EXCL_START */
951 MLOCK(ErrorMessageLock);
952 MesPrint("!>Irregular code in execution of transform statement");
953 MUNLOCK(ErrorMessageLock);
954 Terminate(-1);
955/* INTERNAL_ERROR_EXCL_STOP */
956 }
957 onetransform += *onetransform;
958 } while ( *onetransform );
959 }
960 else {
961 while ( funs < endfun ) { /* sum over sets */
962 if ( *funs > MAXVARIABLES ) {
963 if ( *t == *funs-MAXVARIABLES ) goto hit;
964 }
965 else {
966 w = SetElements + Sets[*funs].first;
967 m = SetElements + Sets[*funs].last;
968 while ( w < m ) { /* sum over set elements */
969 if ( *w == *t ) goto hit;
970 w++;
971 }
972 }
973 funs++;
974 }
975 }
976#ifdef WITHFLOAT
977next:
978#endif
979 t += t[1];
980 }
981 tt = term + *term; while ( in < tt ) *out++ = *in++;
982 if ( sign == -1 ) out[-1] = -out[-1];
983 *tt = i = out - tt;
984/*
985 Now copy the whole thing back
986*/
987 NCOPY(term,tt,i)
988 return(0);
989abo:
990 MLOCK(ErrorMessageLock);
991 MesCall("RunTransform");
992 MUNLOCK(ErrorMessageLock);
993 return(-1);
994}
995
996/*
997 #] RunTransform :
998 #[ RunEncode :
999
1000 The info is given by
1001 ENCODEARG,size,BASECODE,num
1002 and possibly more codes to follow.
1003 Only one range is allowed and for now, it should be fully numerical
1004 If the range is in reverse order, we need to either revert it
1005 first or work with an array of pointers.
1006*/
1007
1008int RunEncode(PHEAD WORD *fun, WORD *args, WORD *info)
1009{
1010 WORD base, *f, *funstop, *fun1, *t, size1, size2, size3, *arg;
1011 int num, num1, num2, n, i, i1, i2;
1012 UWORD *scrat1, *scrat2, *scrat3;
1013 WORD *tt, *tstop, totarg, arg1, arg2;
1014 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1015 if ( *args != ARGRANGE ) {
1016 MLOCK(ErrorMessageLock);
1017 MesPrint("Illegal range encountered in RunEncode");
1018 MUNLOCK(ErrorMessageLock);
1019 Terminate(-1);
1020 }
1021 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1022 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1023 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1024 if ( arg1 > totarg || arg2 > totarg ) return(0);
1025
1026 if ( info[2] == BASECODE ) {
1027 base = info[3];
1028 if ( base <= 0 ) { /* is a dollar variable */
1029 i1 = -base;
1030 base = DolToNumber(BHEAD i1);
1031 if ( AN.ErrorInDollar || base < 2 ) {
1032 MLOCK(ErrorMessageLock);
1033 MesPrint("$%s does not have a number value > 1 in base/encode/transform statement in module %l",
1034 DOLLARNAME(Dollars,i1),AC.CModule);
1035 MUNLOCK(ErrorMessageLock);
1036 Terminate(-1);
1037 }
1038 }
1039/*
1040 Compute number of pointers needed and make sure there is space
1041*/
1042 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1043 else { num1 = arg1; num2 = arg2; }
1044 num = num2-num1+1;
1045 WantAddPointers(num);
1046/*
1047 Collect the pointers in pWorkSpace
1048*/
1049 n = 1; funstop = fun+fun[1]; f = fun+FUNHEAD;
1050 while ( n < num1 ) {
1051 if ( f >= funstop ) return(0);
1052 NEXTARG(f);
1053 n++;
1054 }
1055 fun1 = f; i = 0;
1056 while ( n <= num2 ) {
1057 if ( f >= funstop ) return(0);
1058 if ( *f != -SNUMBER ) {
1059 if ( *f < 0 ) return(0);
1060 t = f + *f - 1;
1061 i1 = ABS(*t);
1062 if ( (*f-i1) != (ARGHEAD+1) ) return(0); /* Not numerical */
1063 i1 = (i1-1)/2 - 1;
1064 t--;
1065 while ( i1 > 0 ) {
1066 if ( *t != 0 ) return(0); /* Not an integer */
1067 t--; i1--;
1068 }
1069 }
1070 AT.pWorkSpace[AT.pWorkPointer+i] = f;
1071 i++;
1072 NEXTARG(f);
1073 n++;
1074 }
1075/*
1076 f points now to after the arguments; fun1 at the first.
1077 Now check whether we need to revert the order
1078*/
1079 if ( arg1 > arg2 ) {
1080 i1 = 0; i2 = i-1;
1081 while ( i1 < i2 ) {
1082 t = AT.pWorkSpace[AT.pWorkPointer+i1];
1083 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
1084 AT.pWorkSpace[AT.pWorkPointer+i2] = t;
1085 i1++; i2--;
1086 }
1087 }
1088/*
1089 Now we can put the thing together.
1090 x = arg1;
1091 x = base*x+arg2
1092 x = base*x+arg3 etc.
1093 We need three scratch arrays for long integers
1094 (see NumberMalloc in tools.c).
1095*/
1096 scrat1 = NumberMalloc("RunEncode");
1097 scrat2 = NumberMalloc("RunEncode");
1098 scrat3 = NumberMalloc("RunEncode");
1099 arg = AT.pWorkSpace[AT.pWorkPointer];
1100 size1 = PutArgInScratch(arg,scrat1);
1101 i--;
1102 while ( i > 0 ) {
1103 if ( MulLong(scrat1,size1,(UWORD *)(&base),1,scrat2,&size2) ) {
1104 NumberFree(scrat3,"RunEncode");
1105 NumberFree(scrat2,"RunEncode");
1106 NumberFree(scrat1,"RunEncode");
1107 goto CalledFrom;
1108 }
1109 NEXTARG(arg);
1110 size3 = PutArgInScratch(arg,scrat3);
1111 if ( AddLong(scrat2,size2,scrat3,size3,scrat1,&size1) ) {
1112 NumberFree(scrat3,"RunEncode");
1113 NumberFree(scrat2,"RunEncode");
1114 NumberFree(scrat1,"RunEncode");
1115 goto CalledFrom;
1116 }
1117 i--;
1118 }
1119/*
1120 Now put the output in place. There are two cases, one being much
1121 faster than the other. Hence we program both.
1122 Fast: it fits inside the old location.
1123 Slow: it does not.
1124 The total space is f-fun1
1125*/
1126 if ( size1 == 0 ) { /* Fits! */
1127 *fun1++ = -SNUMBER; *fun1++ = 0;
1128 while ( f < funstop ) *fun1++ = *f++;
1129 fun[1] = funstop-fun;
1130 }
1131 else if ( size1 == 1 && scrat1[0] <= MAXPOSITIVE ) { /* Fits! */
1132 *fun1++ = -SNUMBER; *fun1++ = scrat1[0];
1133 while ( f < funstop ) *fun1++ = *f++;
1134 fun[1] = fun1-fun;
1135 }
1136 else if ( size1 == -1 && scrat1[0] <= MAXPOSITIVE+1 ) { /* Fits! */
1137 *fun1++ = -SNUMBER;
1138 if ( scrat1[0] < MAXPOSITIVE ) *fun1++ = scrat1[0];
1139 else *fun1++ = (WORD)(MAXPOSITIVE+1);
1140 while ( f < funstop ) *fun1++ = *f++;
1141 fun[1] = fun1-fun;
1142 }
1143 else if ( ABS(size1)*2+2+ARGHEAD <= f-fun1 ) { /* Fits! */
1144 if ( size1 < 0 ) { size2 = size1*2-1; size1 = -size1; size3 = -size2; }
1145 else { size2 = 2*size1+1; size3 = size2; }
1146 *fun1++ = size3+ARGHEAD+1;
1147 *fun1++ = 0; FILLARG(fun1);
1148 *fun1++ = size3+1;
1149 for ( i = 0; i < size1; i++ ) *fun1++ = scrat1[i];
1150 *fun1++ = 1;
1151 for ( i = 1; i < size1; i++ ) *fun1++ = 0;
1152 *fun1++ = size2;
1153 while ( f < funstop ) *fun1++ = *f++;
1154 fun[1] = fun1-fun;
1155 }
1156 else { /* Does not fit */
1157 t = funstop;
1158 if ( size1 < 0 ) { size2 = size1*2-1; size1 = -size1; size3 = -size2; }
1159 else { size2 = 2*size1+1; size3 = size2; }
1160 *t++ = size3+ARGHEAD+1;
1161 *t++ = 0; FILLARG(t);
1162 *t++ = size3+1;
1163 for ( i = 0; i < size1; i++ ) *t++ = scrat1[i];
1164 *t++ = 1;
1165 for ( i = 1; i < size1; i++ ) *t++ = 0;
1166 *t++ = size2;
1167 while ( f < funstop ) *t++ = *f++;
1168 f = funstop;
1169 while ( f < t ) *fun1++ = *f++;
1170 fun[1] = fun1-fun;
1171 }
1172 NumberFree(scrat3,"RunEncode");
1173 NumberFree(scrat2,"RunEncode");
1174 NumberFree(scrat1,"RunEncode");
1175 }
1176 else {
1177/* INTERNAL_ERROR_EXCL_START */
1178 MLOCK(ErrorMessageLock);
1179 MesPrint("!>Unimplemented type of encoding encountered in RunEncode");
1180 MUNLOCK(ErrorMessageLock);
1181 Terminate(-1);
1182/* INTERNAL_ERROR_EXCL_STOP */
1183 }
1184 return(0);
1185CalledFrom:
1186 MLOCK(ErrorMessageLock);
1187 MesCall("RunEncode");
1188 MUNLOCK(ErrorMessageLock);
1189 return(-1);
1190}
1191
1192/*
1193 #] RunEncode :
1194 #[ RunDecode :
1195*/
1196
1197int RunDecode(PHEAD WORD *fun, WORD *args, WORD *info)
1198{
1199 WORD base, num, num1, num2, n, *f, *funstop, *fun1, size1, size2, size3, *t;
1200 WORD i1, i2, i, sig;
1201 UWORD *scrat1, *scrat2, *scrat3;
1202 WORD *tt, *tstop, totarg, arg1, arg2;
1203 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1204 if ( *args != ARGRANGE ) {
1205 MLOCK(ErrorMessageLock);
1206 MesPrint("Illegal range encountered in RunDecode");
1207 MUNLOCK(ErrorMessageLock);
1208 Terminate(-1);
1209 }
1210 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1211 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1212 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1213 if ( arg1 > totarg && arg2 > totarg ) return(0);
1214 if ( info[2] == BASECODE ) {
1215 base = info[3];
1216 if ( base <= 0 ) { /* is a dollar variable */
1217 i1 = -base;
1218 base = DolToNumber(BHEAD i1);
1219 if ( AN.ErrorInDollar || base < 2 ) {
1220 MLOCK(ErrorMessageLock);
1221 MesPrint("$%s does not have a number value > 1 in base/decode/transform statement in module %l",
1222 DOLLARNAME(Dollars,i1),AC.CModule);
1223 MUNLOCK(ErrorMessageLock);
1224 Terminate(-1);
1225 }
1226 }
1227/*
1228 Compute number of output arguments needed
1229*/
1230 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1231 else { num1 = arg1; num2 = arg2; }
1232 num = num2-num1+1;
1233 if ( num <= 1 ) return(0);
1234/*
1235 Find argument num1
1236*/
1237 funstop = fun + fun[1];
1238 f = fun + FUNHEAD; n = 1;
1239 while ( f < funstop ) {
1240 if ( n == num1 ) break;
1241 NEXTARG(f); n++;
1242 }
1243 if ( f >= funstop ) return(0); /* not enough arguments */
1244/*
1245 Check that f is integer
1246*/
1247 if ( *f == -SNUMBER ) {}
1248 else if ( *f < 0 ) return(0);
1249 else {
1250 t = f + *f - 1;
1251 i1 = ABS(*t);
1252 if ( (*f-i1) != (ARGHEAD+1) ) return(0); /* Not numerical */
1253 i1 = (i1-1)/2 - 1;
1254 t--;
1255 while ( i1 > 0 ) {
1256 if ( *t != 0 ) return(0); /* Not an integer */
1257 t--; i1--;
1258 }
1259 }
1260 fun1 = f;
1261/*
1262 The argument that should be decoded is in fun1
1263 We have to copy it to scratch
1264*/
1265 scrat1 = NumberMalloc("RunEncode");
1266 scrat2 = NumberMalloc("RunEncode");
1267 scrat3 = NumberMalloc("RunEncode");
1268 size1 = PutArgInScratch(fun1,scrat1);
1269 if ( size1 < 0 ) { sig = -1; size1 = -size1; }
1270 else sig = 1;
1271/*
1272 We can check first whether this number can be decoded
1273*/
1274 scrat2[0] = base; size2 = 1;
1275 if ( RaisPow(BHEAD scrat2,&size2,num) ) {
1276 NumberFree(scrat3,"RunEncode");
1277 NumberFree(scrat2,"RunEncode");
1278 NumberFree(scrat1,"RunEncode");
1279 goto CalledFrom;
1280 }
1281 if ( BigLong(scrat1,size1,scrat2,size2) >= 0 ) { /* Number too big */
1282 NumberFree(scrat3,"RunEncode");
1283 NumberFree(scrat2,"RunEncode");
1284 NumberFree(scrat1,"RunEncode");
1285 return(0);
1286 }
1287/*
1288 We need num*2 spaces
1289*/
1290 if ( *fun1 > num*2 ) { /* shrink space */
1291 t = fun1 + 2*num; f = fun1 + *fun1;
1292 while ( f < funstop ) *t++ = *f++;
1293 fun[1] = t - fun;
1294 }
1295 else if ( *fun1 < num*2 ) { /* case includes -SNUMBER */
1296 if ( *fun1 < 0 ) { /* expand space from -SNUMBER */
1297 fun[1] += (num-1)*2;
1298 t = funstop + (num-1)*2;
1299 }
1300 else { /* expand space from general argument */
1301 fun[1] += 2*num - *fun1;
1302 t = funstop +2*num - *fun1;
1303 }
1304 f = funstop;
1305 while ( f > fun1 ) *--t = *--f;
1306 }
1307/*
1308 Now there is space for num -SNUMBER arguments filled from the top.
1309*/
1310 for ( i = num-1; i >= 0; i-- ) {
1311 DivLong(scrat1,size1,(UWORD *)(&base),1,scrat2,&size2,scrat3,&size3);
1312 fun1[2*i] = -SNUMBER;
1313 if ( size3 == 0 ) fun1[2*i+1] = 0;
1314 else fun1[2*i+1] = (WORD)(scrat3[0])*sig;
1315 for ( i1 = 0; i1 < size2; i1++ ) scrat1[i1] = scrat2[i1];
1316 size1 = size2;
1317 }
1318 if ( size2 != 0 ) {
1319 MLOCK(ErrorMessageLock);
1320 MesPrint("RunDecode: number to be decoded is too big");
1321 MUNLOCK(ErrorMessageLock);
1322 NumberFree(scrat3,"RunEncode");
1323 NumberFree(scrat2,"RunEncode");
1324 NumberFree(scrat1,"RunEncode");
1325 goto CalledFrom;
1326 }
1327/*
1328 Now check whether we should change the order of the arguments
1329*/
1330 if ( arg1 > arg2 ) {
1331 i1 = 1; i2 = 2*num-1;
1332 while ( i2 > i1 ) {
1333 i = fun1[i1]; fun1[i1] = fun1[i2]; fun1[i2] = i;
1334 i1 += 2; i2 -= 2;
1335 }
1336 }
1337 NumberFree(scrat3,"RunEncode");
1338 NumberFree(scrat2,"RunEncode");
1339 NumberFree(scrat1,"RunEncode");
1340 }
1341 else {
1342/* INTERNAL_ERROR_EXCL_START */
1343 MLOCK(ErrorMessageLock);
1344 MesPrint("!>Unimplemented type of encoding encountered in RunDecode");
1345 MUNLOCK(ErrorMessageLock);
1346 Terminate(-1);
1347/* INTERNAL_ERROR_EXCL_STOP */
1348 }
1349 return(0);
1350CalledFrom:
1351 MLOCK(ErrorMessageLock);
1352 MesCall("RunDecode");
1353 MUNLOCK(ErrorMessageLock);
1354 return(-1);
1355}
1356
1357/*
1358 #] RunDecode :
1359 #[ RunReplace :
1360
1361 Gets the function, passes the arguments and looks whether they
1362 need to be treated. If so, the exact treatment is found in info.
1363 The info is given as if it is a function of type REPLACEMENT but
1364 its name is REPLACEARG (which is NOT a function).
1365 It is performed on the arguments.
1366 The output is at first written after fun and in the end overwrites fun.
1367*/
1368
1369int RunReplace(PHEAD WORD *fun, WORD *args, WORD *info)
1370{
1371 int n = 0, i, dirty = 0, totarg, nfix, nwild, ngeneral;
1372 WORD *t, *tt, *u, *tstop, *info1, *infoend, *oldwork = AT.WorkPointer;
1373 WORD *term, *newterm, *nt, *term1, *term2;
1374 WORD wild[4], mask, *term3, *term4, *oldmask = AT.WildMask;
1375 WORD n1, n2, doanyway;
1376 info++;
1377 t = fun; tstop = fun + fun[1]; u = tstop;
1378 for ( i = 0; i < FUNHEAD; i++ ) *u++ = *t++;
1379 tt = t;
1380 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1381 totarg = 0;
1382 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1383 }
1384 else {
1385 totarg = tstop - tt;
1386 }
1387/*
1388 Now get the info through Generator to bring it to standard form.
1389 info points at a single term that should be sent to Generator.
1390
1391 We want to put the information in the WorkSpace but fun etc lies there
1392 already. This means that we have to move the WorkPointer quite high up.
1393*/
1394 AT.WorkPointer += 2*AM.MaxTer;
1395 if ( AT.WorkPointer > AT.WorkTop ) {
1396 MLOCK(ErrorMessageLock);
1397 MesWork();
1398 MUNLOCK(ErrorMessageLock);
1399 return(-1);
1400 }
1401 term = AT.WorkPointer;
1402 for ( i = 0; i < *info; i++ ) term[i] = info[i];
1403 AT.WorkPointer = term + *term;
1404 AR.Eside = LHSIDEX;
1405 NewSort(BHEAD0);
1406 if ( Generator(BHEAD term,AR.Cnumlhs) ) {
1407 LowerSortLevel();
1408 AT.WorkPointer = oldwork;
1409 return(-1);
1410 }
1411 newterm = AT.WorkPointer;
1412 if ( EndSort(BHEAD newterm,1) < 0 ) {}
1413 if ( ( *newterm && *(newterm+*newterm) != 0 ) || *newterm == 0 ) {
1414 MLOCK(ErrorMessageLock);
1415 MesPrint("&information in replace transformation does not evaluate into a single term");
1416 MUNLOCK(ErrorMessageLock);
1417 return(-1);
1418 }
1419 AR.Eside = RHSIDE;
1420 i = *newterm; tt = term; nt = newterm;
1421 NCOPY(tt,nt,i);
1422 AT.WorkPointer = term + *term;
1423 info = term + 1;
1424
1425 term1 = term + *term;
1426 term2 = term1+1;
1427 *term2++ = REPLACEMENT;
1428 term2++; FILLFUN(term2)
1429/*
1430 First we count the different types of objects
1431*/
1432 infoend = info + info[1];
1433 info1 = info + FUNHEAD;
1434 nfix = nwild = ngeneral = 0;
1435 while ( info1 < infoend ) {
1436 if ( *info1 == -SNUMBER ) {
1437 nfix++;
1438 info1 += 2; NEXTARG(info1)
1439 }
1440 else if ( *info1 <= -FUNCTION ) {
1441 if ( *info1 == -WILDARGFUN ) {
1442 nwild++;
1443 info1++; NEXTARG(info1)
1444 }
1445 else {
1446 *term2++ = *info1++; COPY1ARG(term2,info1)
1447 ngeneral++;
1448 }
1449 }
1450 else if ( *info1 == -INDEX ) {
1451 if ( info1[1] == WILDARGINDEX + AM.OffsetIndex ) {
1452 nwild++;
1453 info1 += 2; NEXTARG(info1)
1454 }
1455 else {
1456 *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1457 ngeneral++;
1458 }
1459 }
1460 else if ( *info1 == -SYMBOL ) {
1461 if ( info1[1] == WILDARGSYMBOL ) {
1462 nwild++;
1463 info1 += 2; NEXTARG(info1)
1464 }
1465 else {
1466 *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1467 ngeneral++;
1468 }
1469 }
1470 else if ( *info1 == -MINVECTOR || *info1 == -VECTOR ) {
1471 if ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) {
1472 nwild++;
1473 info1 += 2; NEXTARG(info1)
1474 }
1475 else {
1476 *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1477 ngeneral++;
1478 }
1479 }
1480 else {
1481/* INTERNAL_ERROR_EXCL_START */
1482 MLOCK(ErrorMessageLock);
1483 MesPrint("!>irregular code found in replace transformation (RunReplace)");
1484 MUNLOCK(ErrorMessageLock);
1485 Terminate(-1);
1486/* INTERNAL_ERROR_EXCL_STOP */
1487 }
1488 }
1489 AT.WorkPointer = term2;
1490 *term1 = term2 - term1;
1491 term1[2] = *term1 - 1;
1492/*
1493 And now stepping through the arguments
1494*/
1495 while ( t < tstop ) {
1496 n++; /* The number of the argument. Now check whether we need it */
1497 if ( TestArgNum(n,totarg,args) == 0 ) {
1498 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1499 if ( *t <= -FUNCTION ) { *u++ = *t++; }
1500 else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1501 else { i = *t; NCOPY(u,t,i) }
1502 }
1503 else *u++ = *t++;
1504 continue;
1505 }
1506/*
1507 Here we have in info effectively a replace_ function, but with
1508 additionally the possibility of integer arguments. We treat those first
1509 and for the rest we have to do some pattern matching.
1510 Note that the compilation routine should check that there is an
1511 even number of arguments in the replace function.
1512
1513 First we go for number -> something
1514*/
1515 doanyway = 0;
1516 if ( nfix > 0 ) {
1517 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1518 if ( *t == -SNUMBER ) {
1519 info1 = info + FUNHEAD;
1520 while ( info1 < infoend ) {
1521 if ( *info1 == -SNUMBER ) {
1522 if ( info1[1] == t[1] ) {
1523 if ( info1[2] == -SNUMBER ) {
1524 *u++ = -SNUMBER; *u++ = info1[3];
1525 info1 += 4;
1526 }
1527 else {
1528 info1 += 2;
1529 if ( info1[0] <= -FUNCTION ) i = 1;
1530 else if ( info1[0] < 0 ) i = 2;
1531 else i = *info1;
1532 NCOPY(u,info1,i)
1533 }
1534 t += 2; goto nextt;
1535 }
1536 info1 += 2;
1537 NEXTARG(info1);
1538 }
1539 else {
1540 NEXTARG(info1);
1541 NEXTARG(info1);
1542 }
1543 }
1544/*
1545 Here we had no match in the style of 1->2. It could however
1546 be that xarg_ does something
1547*/
1548 doanyway = 1; n2 = t[1];
1549 }
1550 }
1551 else { /* Tensor */
1552 if ( *t < AM.OffsetIndex && *t >= 0 ) {
1553 info1 = info + FUNHEAD;
1554 while ( info1 < infoend ) {
1555 if ( ( *info1 == -SNUMBER ) && ( info1[1] == *t )
1556 && ( ( ( info1[2] == -SNUMBER ) && ( info1[3] >= 0 )
1557 && ( info1[3] < AM.OffsetIndex ) )
1558 || ( info1[2] == -INDEX || info1[2] == -VECTOR
1559 || info1[2] == -MINVECTOR ) ) ) {
1560 *u++ = info1[3];
1561 info1 += 4;
1562 t++; goto nextt;
1563 }
1564 else {
1565 NEXTARG(info1);
1566 NEXTARG(info1);
1567 }
1568 }
1569 }
1570 }
1571 }
1572 else if ( *t == -SNUMBER ) {
1573 doanyway = 1; n2 = t[1];
1574 }
1575/*
1576 First we try to catch those elements that have an exact match
1577 in the traditional replace_ part.
1578 This means that *t should be less than zero and match an entry
1579 in the replace_ function that we prepared.
1580*/
1581 if ( ngeneral > 0 ) {
1582 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1583 if ( *t < 0 ) {
1584 term3 = term1 + *term1;
1585 term4 = term1 + FUNHEAD;
1586 while ( term4 < term3 ) {
1587 if ( *term4 == *t && ( *t <= -FUNCTION ||
1588 ( t[1] == term4[1] ) ) ) break;
1589 NEXTARG(term4)
1590 }
1591 if ( term4 < term3 ) goto dothisnow;
1592 }
1593 }
1594 else {
1595 term3 = term1 + *term1;
1596 term4 = term1 + FUNHEAD;
1597 while ( term4 < term3 ) {
1598 if ( ( term4[1] == *t ) &&
1599 ( ( *term4 == -INDEX || *term4 == -VECTOR ||
1600 ( *term4 == -SYMBOL && term4[1] < AM.OffsetIndex
1601 && term4[1] >= 0 ) ) ) ) break;
1602 NEXTARG(term4)
1603 }
1604 if ( term4 < term3 ) goto dothisnow;
1605 }
1606 }
1607/*
1608 First we eliminate the fixed arguments and make a 'new info'
1609 If there is anything left we can continue.
1610 Now we look for whole argument wildcards (arg_, parg_, iarg_ or farg_)
1611*/
1612 if ( nwild > 0 ) {
1613/*
1614 If we have f(a)*replace_(xarg_,b(xarg_)) this gives f(b(a))
1615 In testing the wildcard we have CheckWild do the work.
1616 This means that we have to set op the special variables
1617 (AT.WildMask,AN.WildValue,AN.NumWild,AN.WildStop)
1618
1619*/
1620 wild[1] = 4;
1621 info1 = info + FUNHEAD;
1622 while ( info1 < infoend ) {
1623 if ( *info1 == -SYMBOL && info1[1] == WILDARGSYMBOL
1624 && ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) ) {
1625 wild[0] = SYMTOSUB;
1626 wild[2] = WILDARGSYMBOL;
1627 wild[3] = 0;
1628 AN.WildValue = wild;
1629 AN.WildStop = wild + wild[1];
1630 AT.WildMask = &mask;
1631 mask = 0;
1632 AN.NumWild = 1;
1633 if ( *t == -SYMBOL || ( *t > 0 && CheckWild(BHEAD WILDARGSYMBOL,SYMTOSUB,1,t) == 0 )
1634 || doanyway ) {
1635/*
1636 We put the part in replace in a function and make
1637 a replace_(xarg_,(t argument)).
1638*/
1639 n1 = SYMBOL; n2 = WILDARGSYMBOL;
1640 info1 += 2;
1641getthisone:;
1642 term3 = term2+1;
1643 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1644 *term3++ = DUMFUN; term3++; FILLFUN(term3)
1645 COPY1ARG(term3,info1)
1646 }
1647 else {
1648 *term3++ = fun[0]; term3++; FILLFUN(term3)
1649 *term3++ = *info1;
1650 }
1651 term2[2] = term3 - term2 - 1;
1652 tt = term3;
1653 *term3++ = REPLACEMENT;
1654 term3++; FILLFUN(term3)
1655 *term3++ = -n1;
1656 if ( n1 < FUNCTION ) *term3++ = n2;
1657 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1658 term4 = t;
1659 COPY1ARG(term3,term4)
1660 }
1661 else {
1662 *term3++ = *t;
1663 }
1664 tt[1] = term3 - tt;
1665 *term3++ = 1; *term3++ = 1; *term3++ = 3;
1666 *term2 = term3 - term2;
1667
1668 AT.WorkPointer = term3;
1669 NewSort(BHEAD0);
1670 if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1671 LowerSortLevel();
1672 AT.WorkPointer = oldwork;
1673 AT.WildMask = oldmask;
1674 return(-1);
1675 }
1676 term4 = AT.WorkPointer;
1677 if ( EndSort(BHEAD term4,1) < 0 ) {}
1678 if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1679 MLOCK(ErrorMessageLock);
1680 MesPrint("&information in replace transformation does not evaluate into a single term");
1681 MUNLOCK(ErrorMessageLock);
1682 return(-1);
1683 }
1684/*
1685 Now we can copy the new function argument to the output u
1686*/
1687 i = term4[2]-FUNHEAD;
1688 term3 = term4+FUNHEAD+1;
1689 NCOPY(u,term3,i)
1690 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1691 NEXTARG(t)
1692 }
1693 else t++;
1694 AT.WorkPointer = term2;
1695
1696 goto nextt;
1697 }
1698 info1 += 2; NEXTARG(info1)
1699 }
1700 else if ( ( *info1 == -INDEX )
1701 && ( info[1] == WILDARGINDEX + AM.OffsetIndex ) ) {
1702 wild[0] = INDTOSUB;
1703 wild[2] = WILDARGINDEX+AM.OffsetIndex;
1704 wild[3] = 0;
1705 AN.WildValue = wild;
1706 AN.WildStop = wild + wild[1];
1707 AT.WildMask = &mask;
1708 mask = 0;
1709 AN.NumWild = 1;
1710 if ( ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION )
1711 || ( *t == -INDEX || ( *t > 0 && CheckWild(BHEAD WILDARGINDEX,INDTOSUB,1,t) == 0 ) ) ) {
1712/*
1713 We put the part in replace in a function and make
1714 a replace_(xarg_,(t argument)).
1715*/
1716 n1 = INDEX; n2 = WILDARGINDEX+AM.OffsetIndex;
1717 info1 += 2;
1718 goto getthisone;
1719 }
1720 info1 += 2; NEXTARG(info1)
1721 }
1722 else if ( ( *info1 == -VECTOR )
1723 && ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) ) {
1724 wild[0] = VECTOSUB;
1725 wild[2] = WILDARGVECTOR+AM.OffsetVector;
1726 wild[3] = 0;
1727 AN.WildValue = wild;
1728 AN.WildStop = wild + wild[1];
1729 AT.WildMask = &mask;
1730 mask = 0;
1731 AN.NumWild = 1;
1732 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
1733 if ( *t < MINSPEC ) {
1734 n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1735 info1 += 2;
1736 goto getthisone;
1737 }
1738 }
1739 else if ( *t == -VECTOR || *t == -MINVECTOR ||
1740 ( *t > 0 && CheckWild(BHEAD WILDARGVECTOR,VECTOSUB,1,t) == 0 ) ) {
1741/*
1742 We put the part in replace in a function and make
1743 a replace_(xarg_,(t argument)).
1744*/
1745 n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1746 info1 += 2;
1747 goto getthisone;
1748 }
1749 info1 += 2; NEXTARG(info1)
1750 }
1751 else if ( *info1 == -WILDARGFUN ) {
1752 wild[0] = FUNTOFUN;
1753 wild[2] = WILDARGFUN;
1754 wild[3] = 0;
1755 AN.WildValue = wild;
1756 AN.WildStop = wild + wild[1];
1757 AT.WildMask = &mask;
1758 mask = 0;
1759 AN.NumWild = 1;
1760 if ( *t <= -FUNCTION || ( *t > 0 && CheckWild(BHEAD WILDARGFUN,FUNTOFUN,1,t) == 0 ) ) {
1761/*
1762 We put the part in replace in a function and make
1763 a replace_(xarg_,(t argument)).
1764*/
1765 n2 = n1 = -WILDARGFUN; /* n2 is to keep the compiler quiet */
1766 info1++;
1767 goto getthisone;
1768 }
1769 info1++; NEXTARG(info1)
1770 }
1771 else {
1772 NEXTARG(info1) NEXTARG(info1)
1773 }
1774 }
1775 }
1776 if ( ngeneral > 0 ) {
1777/*
1778 They are all in a replace_ function.
1779 Compose the whole thing into a term with replace_()*dum_(arg)
1780 which will be given to Generator.
1781 If we have f(a(x))*replace_(x,b) this gives f(a(b))
1782*/
1783dothisnow:;
1784 term3 = term2; term4 = term1; i = *term1;
1785 NCOPY(term3,term4,i)
1786 term4 = term3;
1787 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1788 *term3++ = DUMFUN; term3++; FILLFUN(term3);
1789 tt = t;
1790 COPY1ARG(term3,tt)
1791 }
1792 else {
1793 *term3++ = fun[0]; term3++; FILLFUN(term3); *term3++ = *t;
1794 }
1795 term4[1] = term3-term4;
1796 *term3++ = 1; *term3++ = 1; *term3++ = 3;
1797 *term2 = term3-term2;
1798 AT.WorkPointer = term3;
1799 NewSort(BHEAD0);
1800 if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1801 LowerSortLevel();
1802 AT.WorkPointer = oldwork;
1803 AT.WildMask = oldmask;
1804 return(-1);
1805 }
1806 term4 = AT.WorkPointer;
1807 if ( EndSort(BHEAD term4,1) < 0 ) {}
1808 if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1809 MLOCK(ErrorMessageLock);
1810 MesPrint("&information in replace transformation does not evaluate into a single term");
1811 MUNLOCK(ErrorMessageLock);
1812 return(-1);
1813 }
1814/*
1815 Now we can copy the new function argument to the output u
1816*/
1817 i = term4[2]-FUNHEAD;
1818 term3 = term4+FUNHEAD+1;
1819 NCOPY(u,term3,i)
1820 NEXTARG(t)
1821 AT.WorkPointer = term2;
1822
1823 goto nextt;
1824 }
1825
1826/*
1827 No catch. Copy the argument and continue.
1828*/
1829 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1830 if ( *t <= -FUNCTION ) { *u++ = *t++; }
1831 else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1832 else { i = *t; NCOPY(u,t,i) }
1833 }
1834 else {
1835 *u++ = *t++;
1836 }
1837nextt:;
1838 }
1839 i = u - tstop; tstop[1] = i; tstop[2] = dirty;
1840 t = fun; u = tstop; NCOPY(t,u,i)
1841 AT.WorkPointer = oldwork;
1842 AT.WildMask = oldmask;
1843 return(0);
1844}
1845
1846/*
1847 #] RunReplace :
1848 #[ RunImplode :
1849
1850 Note that we restrict ourselves to short integers and/or single symbols
1851*/
1852
1853int RunImplode(WORD *fun, WORD *args)
1854{
1855 GETIDENTITY
1856 WORD *tt, *tstop, totarg, arg1, arg2, num1, num2, i1, n;
1857 WORD *f, *t, *ttt, *t4, *ff, *fff;
1858 WORD moveup, numzero, outspace;
1859 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1860 if ( *args != ARGRANGE ) {
1861 MLOCK(ErrorMessageLock);
1862 MesPrint("Illegal range encountered in RunImplode");
1863 MUNLOCK(ErrorMessageLock);
1864 Terminate(-1);
1865 }
1866 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1867 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1868 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1869/*
1870 Get the proper range in forward direction and the number of arguments
1871*/
1872 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1873 else { num1 = arg1; num2 = arg2; }
1874 if ( num1 > totarg || num2 > totarg ) return(0);
1875/*
1876 We need, for the most general case 4 spots for each:
1877 x,pow,coef,sign
1878 Hence we put these in the workspace above the term after tstop
1879*/
1880 n = 1; f = fun+FUNHEAD;
1881 while ( n < num1 ) {
1882 if ( f >= tstop ) return(0);
1883 NEXTARG(f);
1884 n++;
1885 }
1886 ff = f;
1887/*
1888 We are now at the first argument to be done
1889 Go through the terms and test their validity.
1890 If one of them doesn't conform to the rules we don't do anything.
1891 The terms to be done are put in special notation after the function.
1892 Notation: numsymbol, power, |coef|, sign
1893 If numsymbol is negative there is no symbol.
1894 We do it this way because otherwise stepping backwards (as in range=(4,1))
1895 would be very difficult.
1896*/
1897 tt = tstop;
1898 while ( n <= num2 ) {
1899 if ( f >= tstop ) return(0);
1900 if ( *f == -SNUMBER ) { *tt++ = -1; *tt++ = 0;
1901 if ( f[1] < 0 ) { *tt++ = -f[1]; *tt++ = -1; }
1902 else { *tt++ = f[1]; *tt++ = 1; }
1903 f += 2;
1904 }
1905 else if ( *f == -SYMBOL ) { *tt++ = f[1]; *tt++ = 1; *tt++ = 1; *tt++ = 1; f += 2; }
1906 else if ( *f < 0 ) return(0);
1907 else {
1908 if ( *f != ( f[ARGHEAD]+ARGHEAD ) ) return(0); /* Not a single term */
1909 t = f + *f - 1;
1910 i1 = ABS(*t);
1911 if ( ( i1 > 3 ) || ( t[-1] != 1 ) ) return(0); /* Not an integer or too big */
1912 if ( (UWORD)(t[-2]) > MAXPOSITIVE4 ) return(0); /* number too big */
1913 if ( f[ARGHEAD] == i1+1 ) { /* numerical which is fine */
1914 *tt++ = -1; *tt++ = 0; *tt++ = t[-2];
1915 if ( *t < 0 ) { *tt++ = -1; }
1916 else { *tt++ = 1; }
1917 }
1918 else if ( ( f[ARGHEAD+1] != SYMBOL )
1919 || ( f[ARGHEAD+2] != 4 )
1920 || ( ( f+ARGHEAD+1+f[ARGHEAD+2] ) < ( t-i1 ) ) ) return(0);
1921 /* not a single symbol with a coefficient */
1922 else {
1923 *tt++ = f[ARGHEAD+3];
1924 *tt++ = f[ARGHEAD+4];
1925 *tt++ = t[-2];
1926 if ( *t < 0 ) { *tt++ = -1; }
1927 else { *tt++ = 1; }
1928 }
1929 f += *f;
1930 }
1931 n++;
1932 }
1933 fff = f;
1934/*
1935 At this point we can do the implosion.
1936 Requirement: no coefficient shall take more than one word.
1937 (a stricter requirement may be needed to keep the explosion contained)
1938*/
1939 if ( arg1 > arg2 ) {
1940/*
1941 Work backward.
1942*/
1943 t = tt - 4; numzero = 0;
1944 while ( t >= tstop ) {
1945 if ( t[2] == 0 ) numzero++;
1946 else {
1947 if ( numzero > 0 ) {
1948 t[2] += numzero;
1949 t4 = t+4;
1950 ttt = t4 + 4*numzero;
1951 while ( ttt < tt ) *t4++ = *ttt++;
1952 tt -= 4*numzero;
1953 numzero = 0;
1954 }
1955 }
1956 t -= 4;
1957 }
1958 }
1959 else {
1960 t = tstop;
1961 numzero = 0; ttt = t;
1962 while ( t < tt ) {
1963 if ( t[2] == 0 ) numzero++;
1964 else {
1965 if ( numzero > 0 ) {
1966 t[2] += numzero;
1967 t4 = t;
1968 while ( t4 < tt ) *ttt++ = *t4++;
1969 tt -= 4*numzero;
1970 t -= 4*numzero;
1971 ttt = t + 4;
1972 numzero = 0;
1973 }
1974 else {
1975 ttt = t + 4;
1976 }
1977 }
1978 t += 4;
1979 }
1980/*
1981 We may have numzero > 0 at the end. We leave them.
1982 Output space is currently from tstop to tt
1983*/
1984 }
1985/*
1986 Now we compute the real output space needed
1987*/
1988 t = tstop; outspace = 0;
1989 while ( t < tt ) {
1990 if ( t[0] == -1 ) {
1991 if ( t[2] > MAXPOSITIVE4 ) { return(0); /* Number too big */ }
1992 outspace += 2;
1993 }
1994 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) { outspace += 2; }
1995 else { outspace += 8 + ARGHEAD; }
1996 t += 4;
1997 }
1998 if ( outspace < (fff-ff) ) {
1999 t = tstop;
2000 while ( t < tt ) {
2001 if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
2002 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
2003 *ff++ = -SYMBOL; *ff++ = t[0];
2004 }
2005 else {
2006 *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
2007 *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
2008 *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
2009 }
2010 t += 4;
2011 }
2012 while ( fff < tstop ) *ff++ = *fff++;
2013 fun[1] = ff - fun;
2014 }
2015 else if ( outspace > (fff-ff) ) {
2016/*
2017 Move the answer up by the required amount.
2018 Move the tail to its new location
2019 Move in things as for outspace == (fff-ff)
2020*/
2021 moveup = outspace-(fff-ff);
2022 ttt = tt + moveup;
2023 t = tt;
2024 while ( t > fff ) *--ttt = *--t;
2025 tt += moveup; tstop += moveup;
2026 fff += moveup;
2027 fun[1] += moveup;
2028 goto moveinto;
2029 }
2030 else {
2031moveinto:
2032 t = tstop;
2033 while ( t < tt ) {
2034 if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
2035 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
2036 *ff++ = -SYMBOL; *ff++ = t[0];
2037 }
2038 else {
2039 *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
2040 *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
2041 *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
2042 }
2043 t += 4;
2044 }
2045 }
2046 return(0);
2047}
2048
2049/*
2050 #] RunImplode :
2051 #[ RunExplode :
2052*/
2053
2054int RunExplode(PHEAD WORD *fun, WORD *args)
2055{
2056 WORD arg1, arg2, num1, num2, *tt, *tstop, totarg, *tonew, *newfun;
2057 WORD *ff, *f;
2058 int reverse = 0, iarg, i, numzero;
2059 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
2060 if ( *args != ARGRANGE ) {
2061 MLOCK(ErrorMessageLock);
2062 MesPrint("Illegal range encountered in RunExplode");
2063 MUNLOCK(ErrorMessageLock);
2064 Terminate(-1);
2065 }
2066 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2067 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2068 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2069/*
2070 Get the proper range in forward direction and the number of arguments
2071*/
2072 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; reverse = 1; }
2073 else { num1 = arg1; num2 = arg2; }
2074 if ( num1 > totarg || num2 > totarg ) return(0);
2075 if ( tstop + AM.MaxTer > AT.WorkTop ) goto OverWork;
2076/*
2077 We will make the new function after the old one in the workspace
2078 Find the first argument
2079*/
2080 tonew = newfun = tstop;
2081 ff = fun + FUNHEAD; iarg = 0;
2082 while ( ff < tstop ) {
2083 iarg++;
2084 if ( iarg == num1 ) {
2085 i = ff - fun; f = fun;
2086 NCOPY(tonew,f,i)
2087 break;
2088 }
2089 NEXTARG(ff)
2090 }
2091/*
2092 We have reached the first argument to be done
2093*/
2094 while ( iarg <= num2 ) {
2095 if ( *ff == -SYMBOL || ( *ff == -SNUMBER && ff[1] == 0 ) )
2096 { *tonew++ = *ff++; *tonew++ = *ff++; }
2097 else if ( *ff == -SNUMBER ) {
2098 numzero = ABS(ff[1])-1;
2099 if ( reverse ) {
2100 *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
2101 while ( numzero > 0 ) {
2102 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2103 }
2104 }
2105 else {
2106 while ( numzero > 0 ) {
2107 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2108 }
2109 *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
2110 }
2111 ff += 2;
2112 }
2113 else if ( *ff < 0 ) { return(0); }
2114 else {
2115 if ( *ff != ARGHEAD+8 || ff[ARGHEAD] != 8
2116 || ff[ARGHEAD+1] != SYMBOL || ABS(ff[ARGHEAD+7]) != 3
2117 || ff[ARGHEAD+6] != 1 ) return(0);
2118 numzero = ff[ARGHEAD+5];
2119 if ( numzero >= MAXPOSITIVE4 ) return(0);
2120 numzero--;
2121 if ( reverse ) {
2122 if ( ff[ARGHEAD+7] > 0 ) { *tonew++ = -SNUMBER; *tonew++ = 1; }
2123 else {
2124 *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
2125 *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = ff[ARGHEAD+3];
2126 *tonew++ = ff[ARGHEAD+4]; *tonew++ = 1; *tonew++ = 1;
2127 *tonew++ = -3;
2128 }
2129 while ( numzero > 0 ) {
2130 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2131 }
2132 }
2133 else {
2134 while ( numzero > 0 ) {
2135 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2136 }
2137 *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
2138 *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = 4;
2139 *tonew++ = ff[ARGHEAD+3]; *tonew++ = ff[ARGHEAD+4];
2140 *tonew++ = 1; *tonew++ = 1;
2141 if ( ff[ARGHEAD+7] > 0 ) *tonew++ = 3;
2142 else *tonew++ = -3;
2143 }
2144 ff += *ff;
2145 }
2146 if ( tonew > AT.WorkTop ) goto OverWork;
2147 iarg++;
2148 }
2149/*
2150 Copy the tail, settle the size and copy the whole thing back.
2151*/
2152 while ( ff < tstop ) *tonew++ = *ff++;
2153 i = newfun[1] = tonew-newfun;
2154 NCOPY(fun,newfun,i)
2155 return(0);
2156OverWork:;
2157 MLOCK(ErrorMessageLock);
2158 MesWork();
2159 MUNLOCK(ErrorMessageLock);
2160 return(-1);
2161}
2162
2163/*
2164 #] RunExplode :
2165 #[ RunPermute :
2166*/
2167
2168int RunPermute(PHEAD WORD *fun, WORD *args, WORD *info)
2169{
2170 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, *infostop;
2171 WORD *in, *iw, withdollar;
2172 DOLLARS d;
2173 if ( *args != ARGRANGE ) {
2174 MLOCK(ErrorMessageLock);
2175 MesPrint("Illegal range encountered in RunPermute");
2176 MUNLOCK(ErrorMessageLock);
2177 Terminate(-1);
2178 }
2179 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2180 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2181 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2182 arg1 = 1; arg2 = totarg;
2183/*
2184 We need to:
2185 1: get pointers to the arguments
2186 2: permute the pointers
2187 3: copy the arguments to safe territory in the new order
2188 4: copy this new order back in situ.
2189*/
2190 num = arg2-arg1+1;
2191 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2192 f = fun+FUNHEAD; n = 1; i = 0;
2193 while ( n < arg1 ) { n++; NEXTARG(f) }
2194 f1 = f;
2195 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2196/*
2197 Now the permutations
2198*/
2199 info++;
2200 while ( *info ) {
2201 infostop = info + *info;
2202 info++;
2203 if ( *info > totarg ) return(0);
2204/*
2205 Now we have a look whether there are dollar variables to be expanded
2206 We also shift out all values that are out of range.
2207*/
2208 withdollar = 0; in = info;
2209 while ( in < infostop ) {
2210 if ( *in < 0 ) { /* Dollar variable -(number+1) */
2211 d = Dollars - *in - 1;
2212#ifdef WITHPTHREADS
2213 {
2214 int nummodopt, dtype = -1, numdollar = -*in-1;
2215 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2216 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2217 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2218 }
2219 if ( nummodopt < NumModOptdollars ) {
2220 dtype = ModOptdollars[nummodopt].type;
2221 if ( DollarLocalCopy(dtype) ) {
2222 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2223 }
2224 else {
2225 LOCK(d->pthreadslock);
2226 }
2227 }
2228 }
2229 }
2230#endif
2231 if ( ( d->type == DOLNUMBER || d->type == DOLTERMS )
2232 && d->where[0] == 4 && d->where[4] == 0 ) {
2233 if ( d->where[3] < 0 || d->where[2] != 1 || d->where[1] > totarg ) return(0);
2234 }
2235 else if ( d->type == DOLWILDARGS ) {
2236 iw = d->where+1;
2237 while ( *iw ) {
2238 if ( *iw == -SNUMBER ) {
2239 if ( iw[1] <= 0 || iw[1] > totarg ) return(0);
2240 }
2241 else goto IllType;
2242 iw += 2;
2243 }
2244 }
2245 else {
2246IllType:
2247 MLOCK(ErrorMessageLock);
2248 MesPrint("Illegal type of $-variable in RunPermute");
2249 MUNLOCK(ErrorMessageLock);
2250 Terminate(-1);
2251 }
2252 withdollar++;
2253 }
2254 else if ( *in > totarg ) return(0);
2255 in++;
2256 }
2257 if ( withdollar ) { /* We need some space for a copy */
2258 WORD *incopy, *tocopy;
2259 incopy = TermMalloc("RunPermute");
2260 tocopy = incopy+1; in = info;
2261 while ( in < infostop ) {
2262 if ( *in < 0 ) {
2263 d = Dollars - *in - 1;
2264#ifdef WITHPTHREADS
2265 {
2266 int nummodopt, dtype = -1, numdollar = -*in-1;
2267 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2268 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2269 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2270 }
2271 if ( nummodopt < NumModOptdollars ) {
2272 dtype = ModOptdollars[nummodopt].type;
2273 if ( DollarLocalCopy(dtype) ) {
2274 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2275 }
2276 else {
2277 LOCK(d->pthreadslock);
2278 }
2279 }
2280 }
2281 }
2282#endif
2283 if ( d->type == DOLNUMBER || d->type == DOLTERMS ) {
2284 *tocopy++ = d->where[1] - 1;
2285 }
2286 else if ( d->type == DOLWILDARGS ) {
2287 iw = d->where+1;
2288 while ( *iw ) {
2289 *tocopy++ = iw[1] - 1;
2290 iw += 2;
2291 }
2292 }
2293 in++;
2294 }
2295 else *tocopy++ = *in++;
2296 }
2297 *tocopy = 0;
2298 *incopy = tocopy - incopy;
2299 in = incopy+1;
2300 tt = AT.pWorkSpace[AT.pWorkPointer+*in];
2301 in++;
2302 while ( in < tocopy ) {
2303 if ( *in > totarg ) return(0);
2304 AT.pWorkSpace[AT.pWorkPointer+in[-1]] = AT.pWorkSpace[AT.pWorkPointer+*in];
2305 in++;
2306 }
2307 AT.pWorkSpace[AT.pWorkPointer+in[-1]] = tt;
2308 TermFree(incopy,"RunPermute");
2309 info = infostop;
2310 }
2311 else {
2312 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2313 info++;
2314 while ( info < infostop ) {
2315 if ( *info > totarg ) return(0);
2316 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2317 info++;
2318 }
2319 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2320 }
2321 }
2322/*
2323 info++;
2324 while ( *info ) {
2325 infostop = info + *info;
2326 info++;
2327 if ( *info > totarg ) return(0);
2328 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2329 info++;
2330 while ( info < infostop ) {
2331 if ( *info > totarg ) return(0);
2332 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2333 info++;
2334 }
2335 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2336 }
2337*/
2338/*
2339 And the final cleanup
2340*/
2341 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2342 f2 = tstop;
2343 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2344 i = f2 - tstop;
2345 NCOPY(f1,tstop,i)
2346 }
2347 else { /* tensors */
2348 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop-tt;
2349 arg1 = 1; arg2 = totarg;
2350 num = arg2-arg1+1;
2351 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2352 f = fun+FUNHEAD; n = 1; i = 0;
2353 while ( n < arg1 ) { n++; f++; }
2354 f1 = f;
2355 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2356/*
2357 Now the permutations
2358*/
2359 info++;
2360 while ( *info ) {
2361 infostop = info + *info;
2362 info++;
2363 if ( *info > totarg ) return(0);
2364 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2365 info++;
2366 while ( info < infostop ) {
2367 if ( *info > totarg ) return(0);
2368 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2369 info++;
2370 }
2371 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2372 }
2373/*
2374 And the final cleanup
2375*/
2376 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2377 f2 = tstop;
2378 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++= *f++; }
2379 i = f2 - tstop;
2380 NCOPY(f1,tstop,i)
2381 }
2382 return(0);
2383OverWork:;
2384 MLOCK(ErrorMessageLock);
2385 MesWork();
2386 MUNLOCK(ErrorMessageLock);
2387 return(-1);
2388}
2389
2390/*
2391 #] RunPermute :
2392 #[ RunReverse :
2393*/
2394
2395int RunReverse(PHEAD WORD *fun, WORD *args)
2396{
2397 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, i1, i2;
2398 if ( *args != ARGRANGE ) {
2399 MLOCK(ErrorMessageLock);
2400 MesPrint("Illegal range encountered in RunReverse");
2401 MUNLOCK(ErrorMessageLock);
2402 Terminate(-1);
2403 }
2404 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2405 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2406 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2407 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2408/*
2409 We need to:
2410 1: get pointers to the arguments
2411 2: reverse the order of the pointers
2412 3: copy the arguments to safe territory in the new order
2413 4: copy this new order back in situ.
2414*/
2415 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2416 if ( arg2 > totarg ) return(0);
2417
2418 num = arg2-arg1+1;
2419 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2420 f = fun+FUNHEAD; n = 1; i = 0;
2421 while ( n < arg1 ) { n++; NEXTARG(f) }
2422 f1 = f;
2423 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2424 i1 = i-1; i2 = 0;
2425 while ( i1 > i2 ) {
2426 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2427 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2428 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2429 i1--; i2++;
2430 }
2431 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2432 f2 = tstop;
2433 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2434 i = f2 - tstop;
2435 NCOPY(f1,tstop,i)
2436 }
2437 else { /* Tensors */
2438 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2439 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2440/*
2441 We need to:
2442 1: get pointers to the arguments
2443 2: reverse the order of the pointers
2444 3: copy the arguments to safe territory in the new order
2445 4: copy this new order back in situ.
2446*/
2447 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2448 if ( arg2 > totarg ) return(0);
2449
2450 num = arg2-arg1+1;
2451 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2452 f = fun+FUNHEAD; n = 1; i = 0;
2453 while ( n < arg1 ) { n++; f++; }
2454 f1 = f;
2455 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2456 i1 = i-1; i2 = 0;
2457 while ( i1 > i2 ) {
2458 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2459 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2460 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2461 i1--; i2++;
2462 }
2463 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2464 f2 = tstop;
2465 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2466 i = f2 - tstop;
2467 NCOPY(f1,tstop,i)
2468 }
2469 return(0);
2470OverWork:;
2471 MLOCK(ErrorMessageLock);
2472 MesWork();
2473 MUNLOCK(ErrorMessageLock);
2474 return(-1);
2475}
2476
2477/*
2478 #] RunReverse :
2479 #[ RunDedup :
2480*/
2481
2482int RunDedup(PHEAD WORD *fun, WORD *args)
2483{
2484 WORD *tt, totarg, *tstop, arg1, arg2, n, i, j,k, *f, *f1, *f2, *fd, *fstart;
2485 if ( *args != ARGRANGE ) {
2486 MLOCK(ErrorMessageLock);
2487 MesPrint("Illegal range encountered in RunDedup");
2488 MUNLOCK(ErrorMessageLock);
2489 Terminate(-1);
2490 }
2491 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2492 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2493 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2494 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2495
2496 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2497 if ( arg2 > totarg ) return(0);
2498
2499 f = fun+FUNHEAD; n = 1;
2500 while ( n < arg1 ) { n++; NEXTARG(f) }
2501 f1 = f; // fast forward to first element in range
2502 i = 0; // new argument count
2503 fstart = f1;
2504
2505 for (; n <= arg2; n++ ) {
2506 f2 = fstart;
2507 for ( j = 0; j < i; j++ ) { // check all previous terms
2508 fd = f2;
2509 NEXTARG(fd)
2510 for ( k = 0; k < fd-f2; k++ ) // byte comparison of args
2511 if ( f2[k] != f[k] ) break;
2512
2513 if ( k == fd-f2 ) break; // duplicate arg
2514 f2 = fd;
2515 }
2516
2517 if ( j == i ) {
2518 // unique factor, copy in situ
2519 COPY1ARG(f1,f)
2520 i++;
2521 } else {
2522 NEXTARG(f)
2523 }
2524 }
2525
2526 // move the terms from after the range
2527 for (j = n; j <= totarg; j++) {
2528 COPY1ARG(f1,f)
2529 }
2530
2531 fun[1] = f1 - fun; // resize function
2532 }
2533 else { /* Tensors */
2534 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2535 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2536
2537 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2538 if ( arg2 > totarg ) return(0);
2539
2540 f = fun+FUNHEAD;
2541 i = arg1; // new argument count
2542 n = i;
2543
2544 for (; n <= arg2; n++ ) {
2545 for ( j = arg1; j < i; j++ ) { // check all previous terms
2546 if ( f[n-1] == f[j-1] ) break; // duplicate arg
2547 }
2548
2549 if ( j == i ) {
2550 // unique factor, copy in situ
2551 f[i-1] = f[n-1];
2552 i++;
2553 }
2554 }
2555
2556 // move the terms from after the range
2557 for (j = n; j <= totarg; j++, i++) {
2558 f[i-1] = f[j-1];
2559 }
2560
2561 fun[1] = f + i - 1 - fun; // resize function
2562 }
2563 return(0);
2564}
2565
2566/*
2567 #] RunDedup :
2568 #[ RunCycle :
2569*/
2570
2571int RunCycle(PHEAD WORD *fun, WORD *args, WORD *info)
2572{
2573 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, j, *f, *f1, *f2, x, ncyc, cc;
2574 if ( *args != ARGRANGE ) {
2575 MLOCK(ErrorMessageLock);
2576 MesPrint("Illegal range encountered in RunCycle");
2577 MUNLOCK(ErrorMessageLock);
2578 Terminate(-1);
2579 }
2580 ncyc = info[1];
2581 if ( ncyc >= MAXPOSITIVE2 ) { /* $ variable */
2582 ncyc -= MAXPOSITIVE2;
2583 if ( ncyc >= MAXPOSITIVE4 ) {
2584 ncyc -= MAXPOSITIVE4; /* -$ */
2585 cc = -1;
2586 }
2587 else cc = 1;
2588 ncyc = DolToNumber(BHEAD ncyc);
2589 if ( AN.ErrorInDollar ) {
2590 MesPrint(" Error in Dollar variable in transform,cycle()=$");
2591 return(-1);
2592 }
2593 if ( ncyc >= MAXPOSITIVE4 || ncyc <= -MAXPOSITIVE4 ) {
2594 MesPrint(" Illegal value from Dollar variable in transform,cycle()=$");
2595 return(-1);
2596 }
2597 ncyc *= cc;
2598 }
2599 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2600 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2601 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2602 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2603 if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2604 if ( arg2 > totarg ) return(0);
2605/*
2606 We need to:
2607 1: get pointers to the arguments
2608 2: cycle the pointers
2609 3: copy the arguments to safe territory in the new order
2610 4: copy this new order back in situ.
2611*/
2612 num = arg2-arg1+1;
2613 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2614 f = fun+FUNHEAD; n = 1; i = 0;
2615 while ( n < arg1 ) { n++; NEXTARG(f) }
2616 f1 = f;
2617 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2618/*
2619 Now the cycle(s). First minimize the number of cycles.
2620*/
2621 x = ncyc;
2622 if ( x >= i ) {
2623 x %= i;
2624 if ( x > i/2 ) x -= i;
2625 }
2626 else if ( x <= -i ) {
2627 x = -((-x) % i);
2628 if ( x <= -i/2 ) x += i;
2629 }
2630 while ( x ) {
2631 if ( x > 0 ) {
2632 tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2633 for ( j = i-1; j > 0; j-- )
2634 AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2635 AT.pWorkSpace[AT.pWorkPointer] = tt;
2636 x--;
2637 }
2638 else {
2639 tt = AT.pWorkSpace[AT.pWorkPointer];
2640 for ( j = 1; j < i; j++ )
2641 AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2642 AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2643 x++;
2644 }
2645 }
2646/*
2647 And the final cleanup
2648*/
2649 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2650 f2 = tstop;
2651 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2652 i = f2 - tstop;
2653 NCOPY(f1,tstop,i)
2654 }
2655 else { /* Tensors */
2656 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2657 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2658 if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2659 if ( arg2 > totarg ) return(0);
2660/*
2661 We need to:
2662 1: get pointers to the arguments
2663 2: cycle the pointers
2664 3: copy the arguments to safe territory in the new order
2665 4: copy this new order back in situ.
2666*/
2667 num = arg2-arg1+1;
2668 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2669 f = fun+FUNHEAD; n = 1; i = 0;
2670 while ( n < arg1 ) { n++; f++; }
2671 f1 = f;
2672 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2673/*
2674 Now the cycle(s). First minimize the number of cycles.
2675*/
2676 x = ncyc;
2677 if ( x >= i ) {
2678 x %= i;
2679 if ( x > i/2 ) x -= i;
2680 }
2681 else if ( x <= -i ) {
2682 x = -((-x) % i);
2683 if ( x <= -i/2 ) x += i;
2684 }
2685 while ( x ) {
2686 if ( x > 0 ) {
2687 tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2688 for ( j = i-1; j > 0; j-- )
2689 AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2690 AT.pWorkSpace[AT.pWorkPointer] = tt;
2691 x--;
2692 }
2693 else {
2694 tt = AT.pWorkSpace[AT.pWorkPointer];
2695 for ( j = 1; j < i; j++ )
2696 AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2697 AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2698 x++;
2699 }
2700 }
2701/*
2702 And the final cleanup
2703*/
2704 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2705 f2 = tstop;
2706 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2707 i = f2 - tstop;
2708 NCOPY(f1,tstop,i)
2709 }
2710 return(0);
2711OverWork:;
2712 MLOCK(ErrorMessageLock);
2713 MesWork();
2714 MUNLOCK(ErrorMessageLock);
2715 return(-1);
2716}
2717
2718/*
2719 #] RunCycle :
2720 #[ RunAddArg :
2721*/
2722
2723int RunAddArg(PHEAD WORD *fun, WORD *args)
2724{
2725 WORD *tt, totarg, *tstop, arg1, arg2, n, num, *f, *f1, *f2;
2726 WORD scribble[10+ARGHEAD];
2727 LONG space;
2728 if ( *args != ARGRANGE ) {
2729 MLOCK(ErrorMessageLock);
2730 MesPrint("Illegal range encountered in RunAddArg");
2731 MUNLOCK(ErrorMessageLock);
2732 Terminate(-1);
2733 }
2734 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2735 MLOCK(ErrorMessageLock);
2736 MesPrint("Illegal attempt to add arguments of a tensor in AddArg");
2737 MUNLOCK(ErrorMessageLock);
2738 Terminate(-1);
2739 }
2740 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2741 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2742 /* ignore functions with no arguments */
2743 if ( totarg == 0 ) return(0);
2744 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2745/*
2746 We need to:
2747 1: establish that we actually need to add something
2748 2: start a sort
2749 3: if needed, convert arguments to long arguments
2750 4: send (terms in) argument to StoreTerm
2751 5: EndSort and copy the result back into the function
2752 Note that the function is in the workspace, above the term and no
2753 relevant information is trailing it.
2754*/
2755 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2756 if ( arg2 > totarg ) return(0);
2757 num = arg2-arg1+1;
2758 if ( num == 1 ) return(0);
2759 f = fun+FUNHEAD; n = 1;
2760 while ( n < arg1 ) { n++; NEXTARG(f) }
2761 f1 = f;
2762 NewSort(BHEAD0);
2763 while ( n <= arg2 ) {
2764 if ( *f > 0 ) {
2765 f2 = f + *f; f += ARGHEAD;
2766 while ( f < f2 ) { StoreTerm(BHEAD f); f += *f; }
2767 }
2768 else if ( *f == -SNUMBER && f[1] == 0 ) {
2769 f+= 2;
2770 }
2771 else {
2772 ToGeneral(f,scribble,1);
2773 StoreTerm(BHEAD scribble);
2774 NEXTARG(f);
2775 }
2776 n++;
2777 }
2778 if ( EndSort(BHEAD tstop+ARGHEAD,1) < 0 ) return(-1);
2779 num = 0;
2780 f2 = tstop+ARGHEAD;
2781 while ( *f2 ) { f2 += *f2; num++; }
2782 *tstop = f2-tstop;
2783 for ( n = 1; n < ARGHEAD; n++ ) tstop[n] = 0;
2784 if ( num == 1 && ToFast(tstop,tstop) == 1 ) {
2785 f2 = tstop; NEXTARG(f2);
2786 }
2787 if ( *tstop == ARGHEAD ) {
2788 *tstop = -SNUMBER; tstop[1] = 0;
2789 f2 = tstop+2;
2790 }
2791/*
2792 Copy the trailing arguments after the new argument, then copy the whole back.
2793*/
2794 while ( f < tstop ) *f2++ = *f++;
2795 while ( f < f2 ) *f1++ = *f++;
2796 space = f1 - fun;
2797 if ( (space+8)*sizeof(WORD) > (UWORD)AM.MaxTer ) {
2798 MLOCK(ErrorMessageLock);
2799 MesWork();
2800 MUNLOCK(ErrorMessageLock);
2801 return(-1);
2802 }
2803 fun[1] = (WORD)space;
2804 return(0);
2805}
2806
2807/*
2808 #] RunAddArg :
2809 #[ RunMulArg :
2810*/
2811
2812int RunMulArg(PHEAD WORD *fun, WORD *args)
2813{
2814 WORD *t, totarg, *tstop, arg1, arg2, n, *f, nb, *m, i, *w;
2815 WORD *scratch, argbuf[20], argsize, *where, *newterm;
2816 LONG oldcpointer_pos;
2817 CBUF *C = cbuf + AT.ebufnum;
2818 if ( *args != ARGRANGE ) {
2819 MLOCK(ErrorMessageLock);
2820 MesPrint("Illegal range encountered in RunMulArg");
2821 MUNLOCK(ErrorMessageLock);
2822 Terminate(-1);
2823 }
2824 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2825 MLOCK(ErrorMessageLock);
2826 MesPrint("Illegal attempt to multiply arguments of a tensor in MulArg");
2827 MUNLOCK(ErrorMessageLock);
2828 Terminate(-1);
2829 }
2830 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2831 while ( t < tstop ) { totarg++; NEXTARG(t); }
2832 /* ignore functions with no arguments */
2833 if ( totarg == 0 ) return(0);
2834 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2835 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2836 if ( arg1 > totarg ) return(0);
2837 if ( arg2 < 1 ) return(0);
2838 if ( arg1 < 1 ) arg1 = 1;
2839 if ( arg2 > totarg ) arg2 = totarg;
2840 if ( arg1 == arg2 ) return(0);
2841/*
2842 Now we move the arguments to a compiler buffer
2843 Then we create a term in the workspace that is the product of
2844 subexpression pointers to the objects in the compiler buffer.
2845 Next we let Generator work out that term.
2846 Finally we pick up the results from EndSort and put it in the function.
2847*/
2848 f = fun+FUNHEAD; n = 1;
2849 while ( n < arg1 ) { n++; NEXTARG(f) }
2850 t = f;
2851 if ( fun >= AT.WorkSpace && fun < AT.WorkTop ) {
2852 if ( AT.WorkPointer < fun+fun[1] ) AT.WorkPointer = fun+fun[1];
2853 }
2854 scratch = AT.WorkPointer;
2855 w = scratch+1;
2856 oldcpointer_pos = C->Pointer-C->Buffer;
2857 nb = C->numrhs;
2858 while ( n <= arg2 ) {
2859 if ( *t > 0 ) {
2860 argsize = *t - ARGHEAD; where = t + ARGHEAD; t += *t;
2861 }
2862 else if ( *t <= -FUNCTION ) {
2863 argbuf[0] = FUNHEAD+4; argbuf[1] = -*t++; argbuf[2] = FUNHEAD;
2864 for ( i = 2; i < FUNHEAD; i++ ) argbuf[i+1] = 0;
2865 argbuf[FUNHEAD+1] = 1;
2866 argbuf[FUNHEAD+2] = 1;
2867 argbuf[FUNHEAD+3] = 3;
2868 argsize = argbuf[0];
2869 where = argbuf;
2870 }
2871 else if ( *t == -SYMBOL ) {
2872 argbuf[0] = 8; argbuf[1] = SYMBOL; argbuf[2] = 4;
2873 argbuf[3] = t[1]; argbuf[4] = 1;
2874 argbuf[5] = 1; argbuf[6] = 1; argbuf[7] = 3;
2875 argsize = 8; t += 2;
2876 where = argbuf;
2877 }
2878 else if ( *t == -VECTOR || *t == -MINVECTOR ) {
2879 argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2880 argbuf[3] = t[1];
2881 argbuf[4] = 1; argbuf[5] = 1;
2882 if ( *t == -MINVECTOR ) argbuf[6] = -3;
2883 else argbuf[6] = 3;
2884 argsize = 7; t += 2;
2885 where = argbuf;
2886 }
2887 else if ( *t == -INDEX ) {
2888 argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2889 argbuf[3] = t[1];
2890 argbuf[4] = 1; argbuf[5] = 1; argbuf[6] = 3;
2891 argsize = 7; t += 2;
2892 where = argbuf;
2893 }
2894 else if ( *t == -SNUMBER ) {
2895 if ( t[1] < 0 ) {
2896 argbuf[0] = 4; argbuf[1] = -t[1]; argbuf[2] = 1; argbuf[3] = -3;
2897 }
2898 else {
2899 argbuf[0] = 4; argbuf[1] = t[1]; argbuf[2] = 1; argbuf[3] = 3;
2900 }
2901 argsize = 4; t += 2;
2902 where = argbuf;
2903 }
2904 else {
2905 /* unreachable */
2906 return(1);
2907 }
2908/*
2909 Now add the argbuf to AT.ebufnum
2910*/
2911 m = AddRHS(AT.ebufnum,1);
2912 while ( (m + argsize + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,17);
2913 for ( i = 0; i < argsize; i++ ) m[i] = where[i];
2914 m[i] = 0;
2915 C->Pointer = m + i + 1;
2916 n++;
2917 *w++ = SUBEXPRESSION; *w++ = SUBEXPSIZE; *w++ = C->numrhs; *w++ = 1;
2918 *w++ = AT.ebufnum; FILLSUB(w);
2919 }
2920 *w++ = 1; *w++ = 1; *w++ = 3;
2921 *scratch = w-scratch;
2922 AT.WorkPointer = w;
2923 NewSort(BHEAD0);
2924 Generator(BHEAD scratch,AR.Cnumlhs);
2925 newterm = AT.WorkPointer;
2926 EndSort(BHEAD newterm+ARGHEAD,1);
2927 C->Pointer = C->Buffer+oldcpointer_pos;
2928 C->numrhs = nb;
2929 w = newterm+ARGHEAD; while ( *w ) w += *w;
2930 *newterm = w-newterm; newterm[1] = 0;
2931 if ( ToFast(newterm,newterm) ) {
2932 if ( *newterm <= -FUNCTION ) w = newterm+1;
2933 else w = newterm+2;
2934 }
2935 while ( t < tstop ) *w++ = *t++;
2936 i = w - newterm;
2937 t = newterm; NCOPY(f,t,i);
2938 fun[1] = f-fun;
2939 AT.WorkPointer = scratch;
2940 if ( AT.WorkPointer > AT.WorkSpace && AT.WorkPointer < f ) AT.WorkPointer = f;
2941 return(0);
2942}
2943
2944/*
2945 #] RunMulArg :
2946 #[ RunIsLyndon :
2947
2948 Determines whether the range constitutes a Lyndon word.
2949 The two cases of ordering are distinguished by the order of
2950 the numbers of the arguments in the range.
2951*/
2952
2953int RunIsLyndon(PHEAD WORD *fun, WORD *args, int par)
2954{
2955 WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, n, i;
2956/* WORD *f1; */
2957 WORD sign, i1, i2, retval;
2958 if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2959 if ( *args != ARGRANGE ) {
2960 MLOCK(ErrorMessageLock);
2961 MesPrint("Illegal range encountered in RunIsLyndon");
2962 MUNLOCK(ErrorMessageLock);
2963 Terminate(-1);
2964 }
2965 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2966 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2967 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2968 if ( arg1 > totarg || arg2 > totarg ) return(-1);
2969/*
2970 Now make a list of the relevant arguments.
2971*/
2972 if ( arg1 == arg2 ) return(1);
2973 if ( arg2 < arg1 ) { /* greater, rather than smaller */
2974 arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2975 }
2976 else sign = 0;
2977
2978 num = arg2-arg1+1;
2979 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2980 f = fun+FUNHEAD; n = 1; i = 0;
2981 while ( n < arg1 ) { n++; NEXTARG(f) }
2982/* f1 = f; */
2983 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2984/*
2985 If sign == 1 we should alter the order of the pointers first
2986*/
2987 if ( sign ) {
2988 i1 = i-1; i2 = 0;
2989 while ( i1 > i2 ) {
2990 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2991 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2992 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2993 i1--; i2++;
2994 }
2995 }
2996/*
2997 The argument range is from f1 to f and the num pointers to the arguments
2998 are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2999*/
3000 for ( i1 = 1; i1 < num; i1++ ) {
3001 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
3002 AT.pWorkSpace[AT.pWorkPointer]);
3003 if ( retval > 0 ) continue;
3004 if ( retval < 0 ) return(0);
3005 for ( i2 = 1; i2 < num; i2++ ) {
3006 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
3007 AT.pWorkSpace[AT.pWorkPointer+i2]);
3008 if ( retval < 0 ) return(0);
3009 if ( retval > 0 ) goto nexti1;
3010 }
3011/*
3012 If we come here the sequence is not unique.
3013*/
3014 return(0);
3015nexti1:;
3016 }
3017 return(1);
3018}
3019
3020/*
3021 #] RunIsLyndon :
3022 #[ RunToLyndon :
3023
3024 Determines whether the range constitutes a Lyndon word.
3025 If not, we rotate it to a Lyndon word. If this is not possible
3026 we return the noLyndon condition.
3027 The two cases of ordering are distinguished by the order of
3028 the numbers of the arguments in the range.
3029*/
3030
3031WORD RunToLyndon(PHEAD WORD *fun, WORD *args, int par)
3032{
3033 WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, *f1, *f2, n, i;
3034 WORD sign, i1, i2, retval, unique;
3035 if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
3036 if ( *args != ARGRANGE ) {
3037 MLOCK(ErrorMessageLock);
3038 MesPrint("Illegal range encountered in RunToLyndon");
3039 MUNLOCK(ErrorMessageLock);
3040 Terminate(-1);
3041 }
3042 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3043 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3044 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3045 if ( arg1 > totarg || arg2 > totarg ) return(-1);
3046/*
3047 Now make a list of the relevant arguments.
3048*/
3049 if ( arg1 == arg2 ) return(1);
3050 if ( arg2 < arg1 ) { /* greater, rather than smaller */
3051 arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
3052 }
3053 else sign = 0;
3054
3055 num = arg2-arg1+1;
3056 WantAddPointers((2*num)); /* Guarantees the presence of enough pointers */
3057 f = fun+FUNHEAD; n = 1; i = 0;
3058 while ( n < arg1 ) { n++; NEXTARG(f) }
3059 f1 = f;
3060 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
3061/*
3062 If sign == 1 we should alter the order of the pointers first
3063*/
3064 if ( sign ) {
3065 i1 = i-1; i2 = 0;
3066 while ( i1 > i2 ) {
3067 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3068 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3069 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3070 i1--; i2++;
3071 }
3072 }
3073/*
3074 The argument range is from f1 to f and the num pointers to the arguments
3075 are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
3076*/
3077 unique = 1;
3078 for ( i1 = 1; i1 < num; i1++ ) {
3079 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
3080 AT.pWorkSpace[AT.pWorkPointer]);
3081 if ( retval > 0 ) continue;
3082 if ( retval < 0 ) {
3083Rotate:;
3084/*
3085 Rotate so that i1 becomes the zero element. Then start again.
3086*/
3087 for ( i2 = 0; i2 < num; i2++ ) {
3088 AT.pWorkSpace[AT.pWorkPointer+num+i2] =
3089 AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num];
3090 }
3091 for ( i2 = 0; i2 < num; i2++ ) {
3092 AT.pWorkSpace[AT.pWorkPointer+i2] =
3093 AT.pWorkSpace[AT.pWorkPointer+i2+num];
3094 }
3095 i1 = 0;
3096 goto nexti1;
3097 }
3098 for ( i2 = 1; i2 < num; i2++ ) {
3099 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
3100 AT.pWorkSpace[AT.pWorkPointer+i2]);
3101 if ( retval < 0 ) goto Rotate;
3102 if ( retval > 0 ) goto nexti1;
3103 }
3104/*
3105 If we come here the sequence is not unique.
3106*/
3107 unique = 0;
3108nexti1:;
3109 }
3110 if ( sign ) {
3111 i1 = i-1; i2 = 0;
3112 while ( i1 > i2 ) {
3113 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3114 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3115 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3116 i1--; i2++;
3117 }
3118 }
3119/*
3120 Now rewrite the arguments into the proper order
3121*/
3122 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
3123 f2 = tstop;
3124 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
3125 i = f2 - tstop;
3126 NCOPY(f1,tstop,i)
3127/*
3128 The return value indicates whether we have a Lyndon word
3129*/
3130 return(unique);
3131OverWork:;
3132 MLOCK(ErrorMessageLock);
3133 MesWork();
3134 MUNLOCK(ErrorMessageLock);
3135 return(-2);
3136}
3137
3138/*
3139 #] RunToLyndon :
3140 #[ RunDropArg :
3141*/
3142
3143int RunDropArg(PHEAD WORD *fun, WORD *args)
3144{
3145 WORD *t, *tstop, *f, totarg, arg1, arg2, n;
3146
3147 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3148 while ( t < tstop ) { totarg++; NEXTARG(t); }
3149 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3150 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3151 if ( arg1 > totarg ) return(0);
3152 if ( arg2 < 1 ) return(0);
3153 if ( arg1 < 1 ) arg1 = 1;
3154 if ( arg2 > totarg ) arg2 = totarg;
3155 f = fun+FUNHEAD; n = 1;
3156 while ( n < arg1 ) { n++; NEXTARG(f) }
3157 t = f;
3158 while ( n <= arg2 ) { n++; NEXTARG(t) }
3159 while ( t < tstop ) *f++ = *t++;
3160 fun[1] = f-fun;
3161 return(0);
3162}
3163
3164/*
3165 #] RunDropArg :
3166 #[ RunSelectArg :
3167*/
3168
3169int RunSelectArg(PHEAD WORD *fun, WORD *args)
3170{
3171 WORD *t, *tstop, *f, *tt, totarg, arg1, arg2, n;
3172
3173 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3174 while ( t < tstop ) { totarg++; NEXTARG(t); }
3175 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3176 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3177 if ( arg1 > totarg ) return(0);
3178 if ( arg2 < 1 ) return(0);
3179 if ( arg1 < 1 ) arg1 = 1;
3180 if ( arg2 > totarg ) arg2 = totarg;
3181 f = fun+FUNHEAD; n = 1; t = f;
3182 while ( n < arg1 ) { n++; NEXTARG(t) }
3183 while ( n <= arg2 ) {
3184 tt = t; NEXTARG(tt)
3185 while ( t < tt ) *f++ = *t++;
3186 n++;
3187 }
3188 fun[1] = f-fun;
3189 return(0);
3190}
3191
3192/*
3193 #] RunSelectArg :
3194 #[ RunZtoHArg :
3195*/
3196
3197int RunZtoHArg(PHEAD WORD *fun, WORD *args)
3198{
3199 WORD *tt, totarg, *tstop, arg1, arg2, n, i, *f, *f1;
3200 int sign = 0;
3201 WORD *t, *t1, *t2, *t3;
3202 if ( *args != ARGRANGE ) {
3203 MLOCK(ErrorMessageLock);
3204 MesPrint("Illegal range encountered in RunZtoHArg.");
3205 MUNLOCK(ErrorMessageLock);
3206 Terminate(-1);
3207 }
3208 if ( functions[fun[0]-FUNCTION].spec != 0 ) {
3209 MLOCK(ErrorMessageLock);
3210 MesPrint("The ZtoH transformation can only be executed on regular functions with nonzero integer arguments.");
3211 MUNLOCK(ErrorMessageLock);
3212 Terminate(-1);
3213 }
3214 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3215 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3216 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3217/*
3218 Check the arguments. Should be -SNUMBER x!=0
3219*/
3220 f = fun+FUNHEAD; n = 1;
3221 while ( n < arg1 ) { n++; NEXTARG(f) }
3222 f1 = f;
3223 for ( i = arg1; i <= arg2; i++, f += 2 ) {
3224 if ( *f != -SNUMBER || f[1] == 0 ) return(-1);
3225 }
3226/*
3227 Now we need a copy.
3228*/
3229 t = f1; t1 = t2 = tt = TermMalloc("RunZtoHArg");
3230 while ( t < f ) { *t1++ = *t++; *t1++ = *t++; }
3231 t = f1;
3232 while ( t2 < t1 ) {
3233 t += 2;
3234 if ( t2[1] < 0 ) {
3235 t3 = t;
3236 while ( t3 < f ) { t3[1] = -t3[1]; t3 += 2; }
3237 }
3238 t2 += 2;
3239 }
3240 TermFree(tt,"RunZtoHArg");
3241/*
3242 Now the overall sign.
3243*/
3244 while ( f1 < f ) { if ( f1[1] < 0 ) sign = 1-sign; f1 += 2; }
3245 return(sign);
3246}
3247
3248/*
3249 #] RunZtoHArg :
3250 #[ RunHtoZArg :
3251*/
3252
3253int RunHtoZArg(PHEAD WORD *fun, WORD *args)
3254{
3255 WORD *tt, totarg, *tstop, arg1, arg2, n, i, *f, *f1, *f2;
3256 int sign = 0;
3257 WORD *t, *t1, *t2;
3258 if ( *args != ARGRANGE ) {
3259 MLOCK(ErrorMessageLock);
3260 MesPrint("Illegal range encountered in RunZtoHArg.");
3261 MUNLOCK(ErrorMessageLock);
3262 Terminate(-1);
3263 }
3264 if ( functions[fun[0]-FUNCTION].spec != 0 ) {
3265 MLOCK(ErrorMessageLock);
3266 MesPrint("The HtoZ transformation can only be executed on regular functions with nonzero integer arguments.");
3267 MUNLOCK(ErrorMessageLock);
3268 Terminate(-1);
3269 }
3270 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3271 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3272 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3273/*
3274 Check the arguments. Should be -SNUMBER x!=0
3275*/
3276 f = fun+FUNHEAD; n = 1;
3277 while ( n < arg1 ) { n++; NEXTARG(f) }
3278 f2 = f1 = f;
3279 for ( i = arg1; i <= arg2; i++, f += 2 ) {
3280 if ( *f != -SNUMBER || f[1] == 0 ) return(-1);
3281 }
3282/*
3283 First the overall sign.
3284*/
3285 while ( f2 < f ) { if ( f2[1] < 0 ) sign = 1-sign; f2 += 2; }
3286/*
3287 Now we need a copy.
3288*/
3289 t = f1; t1 = tt = TermMalloc("RunHtoZArg");
3290 while ( t < f ) { *t1++ = *t++; *t1++ = *t++; }
3291/*
3292 Now the transformation.
3293*/
3294 t = f1; t2 = tt + 2;
3295 while ( t2 < t1 ) {
3296 t += 2;
3297 if ( t2[-1] < 0 ) t[1] = -t[1];
3298 t2 += 2;
3299 }
3300 TermFree(tt,"RunHtoZArg");
3301 return(sign);
3302}
3303
3304/*
3305 #] RunHtoZArg :
3306 #[ TestArgNum :
3307
3308 Looks whether argument n is contained in any of the ranges
3309 specified in args. Args contains objects of the types
3310 ALLARGS
3311 NUMARG,num
3312 ARGRANGE,num1,num2
3313 The object MAKEARGS,num1,num2 is skipped
3314 Any other object terminates the range specifications.
3315
3316 Currently only ARGRANGE is used (10-may-2016)
3317*/
3318
3319int TestArgNum(int n, int totarg, WORD *args)
3320{
3321 GETIDENTITY
3322 WORD x1, x2;
3323 for(;;) {
3324 switch ( *args ) {
3325 case ALLARGS:
3326 return(1);
3327 case NUMARG:
3328 if ( n == args[1] ) return(1);
3329 if ( args[1] >= MAXPOSITIVE4 ) {
3330 x1 = args[1]-MAXPOSITIVE4;
3331 if ( totarg-x1 == n ) return(1);
3332 }
3333 args += 2;
3334 break;
3335 case ARGRANGE:
3336 if ( args[1] >= MAXPOSITIVE2 ) {
3337 x1 = args[1] - MAXPOSITIVE2;
3338 if ( x1 > MAXPOSITIVE4 ) {
3339 x1 = x1 - MAXPOSITIVE4;
3340 x1 = DolToNumber(BHEAD x1);
3341 x1 = totarg - x1;
3342 }
3343 else {
3344 x1 = DolToNumber(BHEAD x1);
3345 }
3346 }
3347 else if ( args[1] >= MAXPOSITIVE4 ) {
3348 x1 = totarg-(args[1]-MAXPOSITIVE4);
3349 }
3350 else x1 = args[1];
3351 if ( args[2] >= MAXPOSITIVE2 ) {
3352 x2 = args[2] - MAXPOSITIVE2;
3353 if ( x2 > MAXPOSITIVE4 ) {
3354 x2 = x2 - MAXPOSITIVE4;
3355 x2 = DolToNumber(BHEAD x2);
3356 x2 = totarg - x2;
3357 }
3358 else {
3359 x2 = DolToNumber(BHEAD x2);
3360 }
3361 }
3362 else if ( args[2] >= MAXPOSITIVE4 ) {
3363 x2 = totarg-(args[2]-MAXPOSITIVE4);
3364 }
3365 else x2 = args[2];
3366 if ( x1 >= x2 ) {
3367 if ( n >= x2 && n <= x1 ) return(1);
3368 }
3369 else {
3370 if ( n >= x1 && n <= x2 ) return(1);
3371 }
3372 args += 3;
3373 break;
3374 case MAKEARGS:
3375 args += 3;
3376 break;
3377 default:
3378 return(0);
3379 }
3380 }
3381}
3382
3383/*
3384 #] TestArgNum :
3385 #[ PutArgInScratch :
3386*/
3387
3388WORD PutArgInScratch(WORD *arg,UWORD *scrat)
3389{
3390 WORD size, *t, i;
3391 if ( *arg == -SNUMBER ) {
3392 scrat[0] = ABS(arg[1]);
3393 if ( arg[1] < 0 ) size = -1;
3394 else size = 1;
3395 }
3396 else {
3397 t = arg+*arg-1;
3398 if ( *t < 0 ) { i = ((-*t)-1)/2; size = -i; }
3399 else { i = ( *t -1)/2; size = i; }
3400 t = arg+ARGHEAD+1;
3401 NCOPY(scrat,t,i);
3402 }
3403 return(size);
3404}
3405
3406/*
3407 #] PutArgInScratch :
3408 #[ ReadRange :
3409
3410 Comes in at the bracket and leaves at the = sign
3411 Ranges can be:
3412 #1,#2 with # numbers. If the second is smaller than the
3413 first we work it backwards.
3414 first,#2 or #2,first
3415 #1,last or last,#1
3416 first,last or last,first
3417 First is represented by 1. Last is represented by MAXPOSITIVE4.
3418
3419 par = 0: we need the = after.
3420 par = 1: we need a , or '\0' after.
3421 par = 2: we need a :
3422*/
3423
3424UBYTE *ReadRange(UBYTE *s, WORD *out, int par)
3425{
3426 UBYTE *in = s, *ss, c;
3427 LONG x1, x2;
3428
3429 SKIPBRA3(in)
3430 if ( par == 0 && in[1] != '=' ) {
3431 MesPrint("&A range in this type of transform statement should be followed by an = sign");
3432 return(0);
3433 }
3434 else if ( par == 1 && in[1] != ',' && in[1] != '\0' ) {
3435 MesPrint("&A range in this type of transform statement should be followed by a comma or end-of-statement");
3436 return(0);
3437 }
3438 else if ( par == 2 && in[1] != ':' ) {
3439 MesPrint("&A range in this type of transform statement should be followed by a :");
3440 return(0);
3441 }
3442 s++;
3443 if ( FG.cTable[*s] == 0 ) {
3444 ss = s; while ( FG.cTable[*s] == 0 ) s++;
3445 c = *s; *s = 0;
3446 if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3447 *s = c;
3448 x1 = 1;
3449 }
3450 else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3451 *s = c;
3452 if ( c == '-' ) {
3453 s++;
3454 if ( *s == '$' ) {
3455 s++; ss = s;
3456 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3457 c = *s; *s = 0;
3458 if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3459 *s = c;
3460 x1 += MAXPOSITIVE2;
3461 }
3462 else {
3463 x1 = 0;
3464 while ( *s >= '0' && *s <= '9' ) {
3465 x1 = 10*x1 + *s++ - '0';
3466 if ( x1 >= MAXPOSITIVE4 ) {
3467 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3468 return(0);
3469 }
3470 }
3471 }
3472 x1 += MAXPOSITIVE4;
3473 }
3474 else x1 = MAXPOSITIVE4;
3475 }
3476 else {
3477 MesPrint("&Illegal keyword inside range specification");
3478 return(0);
3479 }
3480 }
3481 else if ( FG.cTable[*s] == 1 ) {
3482 x1 = 0;
3483 while ( *s >= '0' && *s <= '9' ) {
3484 x1 = x1*10 + *s++ - '0';
3485 if ( x1 >= MAXPOSITIVE4 ) {
3486 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3487 return(0);
3488 }
3489 }
3490 }
3491 else if ( *s == '$' ) {
3492 s++; ss = s;
3493 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3494 c = *s; *s = 0;
3495 if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3496 *s = c;
3497 x1 += MAXPOSITIVE2;
3498 }
3499 else {
3500 MesPrint("&Illegal character in range specification");
3501 return(0);
3502 }
3503 if ( *s != ',' ) {
3504 MesPrint("&A range is two indicators, separated by a comma or blank");
3505 return(0);
3506 }
3507 s++;
3508 if ( FG.cTable[*s] == 0 ) {
3509 ss = s; while ( FG.cTable[*s] == 0 ) s++;
3510 c = *s; *s = 0;
3511 if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3512 *s = c;
3513 x2 = 1;
3514 }
3515 else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3516 *s = c;
3517 if ( c == '-' ) {
3518 s++;
3519 if ( *s == '$' ) {
3520 s++; ss = s;
3521 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3522 c = *s; *s = 0;
3523 if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3524 *s = c;
3525 x2 += MAXPOSITIVE2;
3526 }
3527 else {
3528 x2 = 0;
3529 while ( *s >= '0' && *s <= '9' ) {
3530 x2 = 10*x2 + *s++ - '0';
3531 if ( x2 >= MAXPOSITIVE4 ) {
3532 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3533 return(0);
3534 }
3535 }
3536 }
3537 x2 += MAXPOSITIVE4;
3538 }
3539 else x2 = MAXPOSITIVE4;
3540 }
3541 else {
3542 MesPrint("&Illegal keyword inside range specification");
3543 return(0);
3544 }
3545 }
3546 else if ( FG.cTable[*s] == 1 ) {
3547 x2 = 0;
3548 while ( *s >= '0' && *s <= '9' ) {
3549 x2 = x2*10 + *s++ - '0';
3550 if ( x2 >= MAXPOSITIVE4 ) {
3551 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3552 return(0);
3553 }
3554 }
3555 }
3556 else if ( *s == '$' ) {
3557 s++; ss = s;
3558 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3559 c = *s; *s = 0;
3560 if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3561 *s = c;
3562 x2 += MAXPOSITIVE2;
3563 }
3564 else {
3565 MesPrint("&Illegal character in range specification");
3566 return(0);
3567 }
3568 if ( s < in ) {
3569 MesPrint("&A range is two indicators, separated by a comma or blank between parentheses");
3570 return(0);
3571 }
3572 out[0] = x1; out[1] = x2;
3573 return(in+1);
3574Error:
3575 MesPrint("&Undefined variable $%s in range",ss);
3576 return(0);
3577}
3578
3579/*
3580 #] ReadRange :
3581 #[ FindRange :
3582*/
3583
3584int FindRange(PHEAD WORD *args, WORD *arg1, WORD *arg2, WORD totarg)
3585{
3586 WORD n[2], fromlast, i;
3587 for ( i = 0; i < 2; i++ ) {
3588 n[i] = args[i+1];
3589 fromlast = 0;
3590 if ( n[i] >= MAXPOSITIVE2 ) { /* This is a dollar variable */
3591 n[i] -= MAXPOSITIVE2;
3592 if ( n[i] >= MAXPOSITIVE4 ) {
3593 fromlast = 1;
3594 n[i] -= MAXPOSITIVE4; /* Now we have the number of the dollar variable */
3595 }
3596 n[i] = DolToNumber(BHEAD n[i]);
3597 if ( AN.ErrorInDollar ) {
3598 MLOCK(ErrorMessageLock);
3599 MesPrint("Illegal $ value in range while executing transform statement.");
3600 MUNLOCK(ErrorMessageLock);
3601 return(-1);
3602 }
3603 if ( fromlast ) n[i] = totarg-n[i];
3604 }
3605 else if ( n[i] >= MAXPOSITIVE4 ) { n[i] = totarg-(n[i]-MAXPOSITIVE4); }
3606 if ( n[i] <= 0 ) {
3607 MLOCK(ErrorMessageLock);
3608 MesPrint("Illegal non-positive value in range (%d) while executing transform statement.", i+1);
3609 MUNLOCK(ErrorMessageLock);
3610 return(-1);
3611 }
3612 }
3613 *arg1 = n[0];
3614 *arg2 = n[1];
3615 return(0);
3616}
3617
3618/*
3619 #] FindRange :
3620 #] Transform :
3621*/
SkipAName
UBYTE * SkipAName(UBYTE *s)
Definition compiler.c:443
AddNtoL
int AddNtoL(int n, WORD *array)
Definition comtool.c:284
AddRHS
WORD * AddRHS(int num, int type)
Definition comtool.c:210
DoubleCbuffer
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition comtool.c:143
EndSort
LONG EndSort(PHEAD WORD *, int)
Definition sort.c:488
Generator
int Generator(PHEAD WORD *, WORD)
Definition proces.c:3272
LowerSortLevel
void LowerSortLevel(void)
Definition sort.c:4731
StoreTerm
int StoreTerm(PHEAD WORD *)
Definition sort.c:4311
NewSort
int NewSort(PHEAD0)
Definition sort.c:397
CbUf::Top
WORD * Top
Definition structs.h:972
CbUf::Buffer
WORD * Buffer
Definition structs.h:971
CbUf::Pointer
WORD * Pointer
Definition structs.h:973
Generated by doxygen 1.9.8