FORM v5.0.1-33-gdf7fc94
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)
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 AT.WildMask = &mask;
1630 mask = 0;
1631 AN.NumWild = 1;
1632 if ( *t == -SYMBOL || ( *t > 0 && CheckWild(BHEAD WILDARGSYMBOL,SYMTOSUB,1,t) == 0 )
1633 || doanyway ) {
1634/*
1635 We put the part in replace in a function and make
1636 a replace_(xarg_,(t argument)).
1637*/
1638 n1 = SYMBOL; n2 = WILDARGSYMBOL;
1639 info1 += 2;
1640getthisone:;
1641 term3 = term2+1;
1642 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1643 *term3++ = DUMFUN; term3++; FILLFUN(term3)
1644 COPY1ARG(term3,info1)
1645 }
1646 else {
1647 *term3++ = fun[0]; term3++; FILLFUN(term3)
1648 *term3++ = *info1;
1649 }
1650 term2[2] = term3 - term2 - 1;
1651 tt = term3;
1652 *term3++ = REPLACEMENT;
1653 term3++; FILLFUN(term3)
1654 *term3++ = -n1;
1655 if ( n1 < FUNCTION ) *term3++ = n2;
1656 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1657 term4 = t;
1658 COPY1ARG(term3,term4)
1659 }
1660 else {
1661 *term3++ = *t;
1662 }
1663 tt[1] = term3 - tt;
1664 *term3++ = 1; *term3++ = 1; *term3++ = 3;
1665 *term2 = term3 - term2;
1666
1667 AT.WorkPointer = term3;
1668 NewSort(BHEAD0);
1669 if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1670 LowerSortLevel();
1671 AT.WorkPointer = oldwork;
1672 AT.WildMask = oldmask;
1673 return(-1);
1674 }
1675 term4 = AT.WorkPointer;
1676 if ( EndSort(BHEAD term4,1) < 0 ) {}
1677 if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1678 MLOCK(ErrorMessageLock);
1679 MesPrint("&information in replace transformation does not evaluate into a single term");
1680 MUNLOCK(ErrorMessageLock);
1681 return(-1);
1682 }
1683/*
1684 Now we can copy the new function argument to the output u
1685*/
1686 i = term4[2]-FUNHEAD;
1687 term3 = term4+FUNHEAD+1;
1688 NCOPY(u,term3,i)
1689 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1690 NEXTARG(t)
1691 }
1692 else t++;
1693 AT.WorkPointer = term2;
1694
1695 goto nextt;
1696 }
1697 info1 += 2; NEXTARG(info1)
1698 }
1699 else if ( ( *info1 == -INDEX )
1700 && ( info[1] == WILDARGINDEX + AM.OffsetIndex ) ) {
1701 wild[0] = INDTOSUB;
1702 wild[2] = WILDARGINDEX+AM.OffsetIndex;
1703 wild[3] = 0;
1704 AN.WildValue = wild;
1705 AT.WildMask = &mask;
1706 mask = 0;
1707 AN.NumWild = 1;
1708 if ( ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION )
1709 || ( *t == -INDEX || ( *t > 0 && CheckWild(BHEAD WILDARGINDEX,INDTOSUB,1,t) == 0 ) ) ) {
1710/*
1711 We put the part in replace in a function and make
1712 a replace_(xarg_,(t argument)).
1713*/
1714 n1 = INDEX; n2 = WILDARGINDEX+AM.OffsetIndex;
1715 info1 += 2;
1716 goto getthisone;
1717 }
1718 info1 += 2; NEXTARG(info1)
1719 }
1720 else if ( ( *info1 == -VECTOR )
1721 && ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) ) {
1722 wild[0] = VECTOSUB;
1723 wild[2] = WILDARGVECTOR+AM.OffsetVector;
1724 wild[3] = 0;
1725 AN.WildValue = wild;
1726 AT.WildMask = &mask;
1727 mask = 0;
1728 AN.NumWild = 1;
1729 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
1730 if ( *t < MINSPEC ) {
1731 n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1732 info1 += 2;
1733 goto getthisone;
1734 }
1735 }
1736 else if ( *t == -VECTOR || *t == -MINVECTOR ||
1737 ( *t > 0 && CheckWild(BHEAD WILDARGVECTOR,VECTOSUB,1,t) == 0 ) ) {
1738/*
1739 We put the part in replace in a function and make
1740 a replace_(xarg_,(t argument)).
1741*/
1742 n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1743 info1 += 2;
1744 goto getthisone;
1745 }
1746 info1 += 2; NEXTARG(info1)
1747 }
1748 else if ( *info1 == -WILDARGFUN ) {
1749 wild[0] = FUNTOFUN;
1750 wild[2] = WILDARGFUN;
1751 wild[3] = 0;
1752 AN.WildValue = wild;
1753 AT.WildMask = &mask;
1754 mask = 0;
1755 AN.NumWild = 1;
1756 if ( *t <= -FUNCTION || ( *t > 0 && CheckWild(BHEAD WILDARGFUN,FUNTOFUN,1,t) == 0 ) ) {
1757/*
1758 We put the part in replace in a function and make
1759 a replace_(xarg_,(t argument)).
1760*/
1761 n2 = n1 = -WILDARGFUN; /* n2 is to keep the compiler quiet */
1762 info1++;
1763 goto getthisone;
1764 }
1765 info1++; NEXTARG(info1)
1766 }
1767 else {
1768 NEXTARG(info1) NEXTARG(info1)
1769 }
1770 }
1771 }
1772 if ( ngeneral > 0 ) {
1773/*
1774 They are all in a replace_ function.
1775 Compose the whole thing into a term with replace_()*dum_(arg)
1776 which will be given to Generator.
1777 If we have f(a(x))*replace_(x,b) this gives f(a(b))
1778*/
1779dothisnow:;
1780 term3 = term2; term4 = term1; i = *term1;
1781 NCOPY(term3,term4,i)
1782 term4 = term3;
1783 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1784 *term3++ = DUMFUN; term3++; FILLFUN(term3);
1785 tt = t;
1786 COPY1ARG(term3,tt)
1787 }
1788 else {
1789 *term3++ = fun[0]; term3++; FILLFUN(term3); *term3++ = *t;
1790 }
1791 term4[1] = term3-term4;
1792 *term3++ = 1; *term3++ = 1; *term3++ = 3;
1793 *term2 = term3-term2;
1794 AT.WorkPointer = term3;
1795 NewSort(BHEAD0);
1796 if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1797 LowerSortLevel();
1798 AT.WorkPointer = oldwork;
1799 AT.WildMask = oldmask;
1800 return(-1);
1801 }
1802 term4 = AT.WorkPointer;
1803 if ( EndSort(BHEAD term4,1) < 0 ) {}
1804 if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1805 MLOCK(ErrorMessageLock);
1806 MesPrint("&information in replace transformation does not evaluate into a single term");
1807 MUNLOCK(ErrorMessageLock);
1808 return(-1);
1809 }
1810/*
1811 Now we can copy the new function argument to the output u
1812*/
1813 i = term4[2]-FUNHEAD;
1814 term3 = term4+FUNHEAD+1;
1815 NCOPY(u,term3,i)
1816 NEXTARG(t)
1817 AT.WorkPointer = term2;
1818
1819 goto nextt;
1820 }
1821
1822/*
1823 No catch. Copy the argument and continue.
1824*/
1825 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1826 if ( *t <= -FUNCTION ) { *u++ = *t++; }
1827 else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1828 else { i = *t; NCOPY(u,t,i) }
1829 }
1830 else {
1831 *u++ = *t++;
1832 }
1833nextt:;
1834 }
1835 i = u - tstop; tstop[1] = i; tstop[2] = dirty;
1836 t = fun; u = tstop; NCOPY(t,u,i)
1837 AT.WorkPointer = oldwork;
1838 AT.WildMask = oldmask;
1839 return(0);
1840}
1841
1842/*
1843 #] RunReplace :
1844 #[ RunImplode :
1845
1846 Note that we restrict ourselves to short integers and/or single symbols
1847*/
1848
1849int RunImplode(WORD *fun, WORD *args)
1850{
1851 GETIDENTITY
1852 WORD *tt, *tstop, totarg, arg1, arg2, num1, num2, i1, n;
1853 WORD *f, *t, *ttt, *t4, *ff, *fff;
1854 WORD moveup, numzero, outspace;
1855 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1856 if ( *args != ARGRANGE ) {
1857 MLOCK(ErrorMessageLock);
1858 MesPrint("Illegal range encountered in RunImplode");
1859 MUNLOCK(ErrorMessageLock);
1860 Terminate(-1);
1861 }
1862 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1863 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1864 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1865/*
1866 Get the proper range in forward direction and the number of arguments
1867*/
1868 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1869 else { num1 = arg1; num2 = arg2; }
1870 if ( num1 > totarg || num2 > totarg ) return(0);
1871/*
1872 We need, for the most general case 4 spots for each:
1873 x,pow,coef,sign
1874 Hence we put these in the workspace above the term after tstop
1875*/
1876 n = 1; f = fun+FUNHEAD;
1877 while ( n < num1 ) {
1878 if ( f >= tstop ) return(0);
1879 NEXTARG(f);
1880 n++;
1881 }
1882 ff = f;
1883/*
1884 We are now at the first argument to be done
1885 Go through the terms and test their validity.
1886 If one of them doesn't conform to the rules we don't do anything.
1887 The terms to be done are put in special notation after the function.
1888 Notation: numsymbol, power, |coef|, sign
1889 If numsymbol is negative there is no symbol.
1890 We do it this way because otherwise stepping backwards (as in range=(4,1))
1891 would be very difficult.
1892*/
1893 tt = tstop;
1894 while ( n <= num2 ) {
1895 if ( f >= tstop ) return(0);
1896 if ( *f == -SNUMBER ) { *tt++ = -1; *tt++ = 0;
1897 if ( f[1] < 0 ) { *tt++ = -f[1]; *tt++ = -1; }
1898 else { *tt++ = f[1]; *tt++ = 1; }
1899 f += 2;
1900 }
1901 else if ( *f == -SYMBOL ) { *tt++ = f[1]; *tt++ = 1; *tt++ = 1; *tt++ = 1; f += 2; }
1902 else if ( *f < 0 ) return(0);
1903 else {
1904 if ( *f != ( f[ARGHEAD]+ARGHEAD ) ) return(0); /* Not a single term */
1905 t = f + *f - 1;
1906 i1 = ABS(*t);
1907 if ( ( i1 > 3 ) || ( t[-1] != 1 ) ) return(0); /* Not an integer or too big */
1908 if ( (UWORD)(t[-2]) > MAXPOSITIVE4 ) return(0); /* number too big */
1909 if ( f[ARGHEAD] == i1+1 ) { /* numerical which is fine */
1910 *tt++ = -1; *tt++ = 0; *tt++ = t[-2];
1911 if ( *t < 0 ) { *tt++ = -1; }
1912 else { *tt++ = 1; }
1913 }
1914 else if ( ( f[ARGHEAD+1] != SYMBOL )
1915 || ( f[ARGHEAD+2] != 4 )
1916 || ( ( f+ARGHEAD+1+f[ARGHEAD+2] ) < ( t-i1 ) ) ) return(0);
1917 /* not a single symbol with a coefficient */
1918 else {
1919 *tt++ = f[ARGHEAD+3];
1920 *tt++ = f[ARGHEAD+4];
1921 *tt++ = t[-2];
1922 if ( *t < 0 ) { *tt++ = -1; }
1923 else { *tt++ = 1; }
1924 }
1925 f += *f;
1926 }
1927 n++;
1928 }
1929 fff = f;
1930/*
1931 At this point we can do the implosion.
1932 Requirement: no coefficient shall take more than one word.
1933 (a stricter requirement may be needed to keep the explosion contained)
1934*/
1935 if ( arg1 > arg2 ) {
1936/*
1937 Work backward.
1938*/
1939 t = tt - 4; numzero = 0;
1940 while ( t >= tstop ) {
1941 if ( t[2] == 0 ) numzero++;
1942 else {
1943 if ( numzero > 0 ) {
1944 t[2] += numzero;
1945 t4 = t+4;
1946 ttt = t4 + 4*numzero;
1947 while ( ttt < tt ) *t4++ = *ttt++;
1948 tt -= 4*numzero;
1949 numzero = 0;
1950 }
1951 }
1952 t -= 4;
1953 }
1954 }
1955 else {
1956 t = tstop;
1957 numzero = 0; ttt = t;
1958 while ( t < tt ) {
1959 if ( t[2] == 0 ) numzero++;
1960 else {
1961 if ( numzero > 0 ) {
1962 t[2] += numzero;
1963 t4 = t;
1964 while ( t4 < tt ) *ttt++ = *t4++;
1965 tt -= 4*numzero;
1966 t -= 4*numzero;
1967 ttt = t + 4;
1968 numzero = 0;
1969 }
1970 else {
1971 ttt = t + 4;
1972 }
1973 }
1974 t += 4;
1975 }
1976/*
1977 We may have numzero > 0 at the end. We leave them.
1978 Output space is currently from tstop to tt
1979*/
1980 }
1981/*
1982 Now we compute the real output space needed
1983*/
1984 t = tstop; outspace = 0;
1985 while ( t < tt ) {
1986 if ( t[0] == -1 ) {
1987 if ( t[2] > MAXPOSITIVE4 ) { return(0); /* Number too big */ }
1988 outspace += 2;
1989 }
1990 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) { outspace += 2; }
1991 else { outspace += 8 + ARGHEAD; }
1992 t += 4;
1993 }
1994 if ( outspace < (fff-ff) ) {
1995 t = tstop;
1996 while ( t < tt ) {
1997 if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
1998 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
1999 *ff++ = -SYMBOL; *ff++ = t[0];
2000 }
2001 else {
2002 *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
2003 *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
2004 *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
2005 }
2006 t += 4;
2007 }
2008 while ( fff < tstop ) *ff++ = *fff++;
2009 fun[1] = ff - fun;
2010 }
2011 else if ( outspace > (fff-ff) ) {
2012/*
2013 Move the answer up by the required amount.
2014 Move the tail to its new location
2015 Move in things as for outspace == (fff-ff)
2016*/
2017 moveup = outspace-(fff-ff);
2018 ttt = tt + moveup;
2019 t = tt;
2020 while ( t > fff ) *--ttt = *--t;
2021 tt += moveup; tstop += moveup;
2022 fff += moveup;
2023 fun[1] += moveup;
2024 goto moveinto;
2025 }
2026 else {
2027moveinto:
2028 t = tstop;
2029 while ( t < tt ) {
2030 if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
2031 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
2032 *ff++ = -SYMBOL; *ff++ = t[0];
2033 }
2034 else {
2035 *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
2036 *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
2037 *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
2038 }
2039 t += 4;
2040 }
2041 }
2042 return(0);
2043}
2044
2045/*
2046 #] RunImplode :
2047 #[ RunExplode :
2048*/
2049
2050int RunExplode(PHEAD WORD *fun, WORD *args)
2051{
2052 WORD arg1, arg2, num1, num2, *tt, *tstop, totarg, *tonew, *newfun;
2053 WORD *ff, *f;
2054 int reverse = 0, iarg, i, numzero;
2055 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
2056 if ( *args != ARGRANGE ) {
2057 MLOCK(ErrorMessageLock);
2058 MesPrint("Illegal range encountered in RunExplode");
2059 MUNLOCK(ErrorMessageLock);
2060 Terminate(-1);
2061 }
2062 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2063 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2064 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2065/*
2066 Get the proper range in forward direction and the number of arguments
2067*/
2068 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; reverse = 1; }
2069 else { num1 = arg1; num2 = arg2; }
2070 if ( num1 > totarg || num2 > totarg ) return(0);
2071 if ( tstop + AM.MaxTer > AT.WorkTop ) goto OverWork;
2072/*
2073 We will make the new function after the old one in the workspace
2074 Find the first argument
2075*/
2076 tonew = newfun = tstop;
2077 ff = fun + FUNHEAD; iarg = 0;
2078 while ( ff < tstop ) {
2079 iarg++;
2080 if ( iarg == num1 ) {
2081 i = ff - fun; f = fun;
2082 NCOPY(tonew,f,i)
2083 break;
2084 }
2085 NEXTARG(ff)
2086 }
2087/*
2088 We have reached the first argument to be done
2089*/
2090 while ( iarg <= num2 ) {
2091 if ( *ff == -SYMBOL || ( *ff == -SNUMBER && ff[1] == 0 ) )
2092 { *tonew++ = *ff++; *tonew++ = *ff++; }
2093 else if ( *ff == -SNUMBER ) {
2094 numzero = ABS(ff[1])-1;
2095 if ( reverse ) {
2096 *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
2097 while ( numzero > 0 ) {
2098 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2099 }
2100 }
2101 else {
2102 while ( numzero > 0 ) {
2103 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2104 }
2105 *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
2106 }
2107 ff += 2;
2108 }
2109 else if ( *ff < 0 ) { return(0); }
2110 else {
2111 if ( *ff != ARGHEAD+8 || ff[ARGHEAD] != 8
2112 || ff[ARGHEAD+1] != SYMBOL || ABS(ff[ARGHEAD+7]) != 3
2113 || ff[ARGHEAD+6] != 1 ) return(0);
2114 numzero = ff[ARGHEAD+5];
2115 if ( numzero >= MAXPOSITIVE4 ) return(0);
2116 numzero--;
2117 if ( reverse ) {
2118 if ( ff[ARGHEAD+7] > 0 ) { *tonew++ = -SNUMBER; *tonew++ = 1; }
2119 else {
2120 *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
2121 *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = ff[ARGHEAD+3];
2122 *tonew++ = ff[ARGHEAD+4]; *tonew++ = 1; *tonew++ = 1;
2123 *tonew++ = -3;
2124 }
2125 while ( numzero > 0 ) {
2126 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2127 }
2128 }
2129 else {
2130 while ( numzero > 0 ) {
2131 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2132 }
2133 *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
2134 *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = 4;
2135 *tonew++ = ff[ARGHEAD+3]; *tonew++ = ff[ARGHEAD+4];
2136 *tonew++ = 1; *tonew++ = 1;
2137 if ( ff[ARGHEAD+7] > 0 ) *tonew++ = 3;
2138 else *tonew++ = -3;
2139 }
2140 ff += *ff;
2141 }
2142 if ( tonew > AT.WorkTop ) goto OverWork;
2143 iarg++;
2144 }
2145/*
2146 Copy the tail, settle the size and copy the whole thing back.
2147*/
2148 while ( ff < tstop ) *tonew++ = *ff++;
2149 i = newfun[1] = tonew-newfun;
2150 NCOPY(fun,newfun,i)
2151 return(0);
2152OverWork:;
2153 MLOCK(ErrorMessageLock);
2154 MesWork();
2155 MUNLOCK(ErrorMessageLock);
2156 return(-1);
2157}
2158
2159/*
2160 #] RunExplode :
2161 #[ RunPermute :
2162*/
2163
2164int RunPermute(PHEAD WORD *fun, WORD *args, WORD *info)
2165{
2166 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, *infostop;
2167 WORD *in, *iw, withdollar;
2168 DOLLARS d;
2169 if ( *args != ARGRANGE ) {
2170 MLOCK(ErrorMessageLock);
2171 MesPrint("Illegal range encountered in RunPermute");
2172 MUNLOCK(ErrorMessageLock);
2173 Terminate(-1);
2174 }
2175 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2176 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2177 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2178 arg1 = 1; arg2 = totarg;
2179/*
2180 We need to:
2181 1: get pointers to the arguments
2182 2: permute the pointers
2183 3: copy the arguments to safe territory in the new order
2184 4: copy this new order back in situ.
2185*/
2186 num = arg2-arg1+1;
2187 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2188 f = fun+FUNHEAD; n = 1; i = 0;
2189 while ( n < arg1 ) { n++; NEXTARG(f) }
2190 f1 = f;
2191 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2192/*
2193 Now the permutations
2194*/
2195 info++;
2196 while ( *info ) {
2197 infostop = info + *info;
2198 info++;
2199 if ( *info > totarg ) return(0);
2200/*
2201 Now we have a look whether there are dollar variables to be expanded
2202 We also shift out all values that are out of range.
2203*/
2204 withdollar = 0; in = info;
2205 while ( in < infostop ) {
2206 if ( *in < 0 ) { /* Dollar variable -(number+1) */
2207 d = Dollars - *in - 1;
2208#ifdef WITHPTHREADS
2209 {
2210 int nummodopt, dtype = -1, numdollar = -*in-1;
2211 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2212 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2213 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2214 }
2215 if ( nummodopt < NumModOptdollars ) {
2216 dtype = ModOptdollars[nummodopt].type;
2217 if ( DollarLocalCopy(dtype) ) {
2218 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2219 }
2220 else {
2221 LOCK(d->pthreadslock);
2222 }
2223 }
2224 }
2225 }
2226#endif
2227 if ( ( d->type == DOLNUMBER || d->type == DOLTERMS )
2228 && d->where[0] == 4 && d->where[4] == 0 ) {
2229 if ( d->where[3] < 0 || d->where[2] != 1 || d->where[1] > totarg ) return(0);
2230 }
2231 else if ( d->type == DOLWILDARGS ) {
2232 iw = d->where+1;
2233 while ( *iw ) {
2234 if ( *iw == -SNUMBER ) {
2235 if ( iw[1] <= 0 || iw[1] > totarg ) return(0);
2236 }
2237 else goto IllType;
2238 iw += 2;
2239 }
2240 }
2241 else {
2242IllType:
2243 MLOCK(ErrorMessageLock);
2244 MesPrint("Illegal type of $-variable in RunPermute");
2245 MUNLOCK(ErrorMessageLock);
2246 Terminate(-1);
2247 }
2248 withdollar++;
2249 }
2250 else if ( *in > totarg ) return(0);
2251 in++;
2252 }
2253 if ( withdollar ) { /* We need some space for a copy */
2254 WORD *incopy, *tocopy;
2255 incopy = TermMalloc("RunPermute");
2256 tocopy = incopy+1; in = info;
2257 while ( in < infostop ) {
2258 if ( *in < 0 ) {
2259 d = Dollars - *in - 1;
2260#ifdef WITHPTHREADS
2261 {
2262 int nummodopt, dtype = -1, numdollar = -*in-1;
2263 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2264 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2265 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2266 }
2267 if ( nummodopt < NumModOptdollars ) {
2268 dtype = ModOptdollars[nummodopt].type;
2269 if ( DollarLocalCopy(dtype) ) {
2270 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2271 }
2272 else {
2273 LOCK(d->pthreadslock);
2274 }
2275 }
2276 }
2277 }
2278#endif
2279 if ( d->type == DOLNUMBER || d->type == DOLTERMS ) {
2280 *tocopy++ = d->where[1] - 1;
2281 }
2282 else if ( d->type == DOLWILDARGS ) {
2283 iw = d->where+1;
2284 while ( *iw ) {
2285 *tocopy++ = iw[1] - 1;
2286 iw += 2;
2287 }
2288 }
2289 in++;
2290 }
2291 else *tocopy++ = *in++;
2292 }
2293 *tocopy = 0;
2294 *incopy = tocopy - incopy;
2295 in = incopy+1;
2296 tt = AT.pWorkSpace[AT.pWorkPointer+*in];
2297 in++;
2298 while ( in < tocopy ) {
2299 if ( *in > totarg ) return(0);
2300 AT.pWorkSpace[AT.pWorkPointer+in[-1]] = AT.pWorkSpace[AT.pWorkPointer+*in];
2301 in++;
2302 }
2303 AT.pWorkSpace[AT.pWorkPointer+in[-1]] = tt;
2304 TermFree(incopy,"RunPermute");
2305 info = infostop;
2306 }
2307 else {
2308 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2309 info++;
2310 while ( info < infostop ) {
2311 if ( *info > totarg ) return(0);
2312 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2313 info++;
2314 }
2315 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2316 }
2317 }
2318/*
2319 info++;
2320 while ( *info ) {
2321 infostop = info + *info;
2322 info++;
2323 if ( *info > totarg ) return(0);
2324 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2325 info++;
2326 while ( info < infostop ) {
2327 if ( *info > totarg ) return(0);
2328 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2329 info++;
2330 }
2331 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2332 }
2333*/
2334/*
2335 And the final cleanup
2336*/
2337 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2338 f2 = tstop;
2339 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2340 i = f2 - tstop;
2341 NCOPY(f1,tstop,i)
2342 }
2343 else { /* tensors */
2344 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop-tt;
2345 arg1 = 1; arg2 = totarg;
2346 num = arg2-arg1+1;
2347 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2348 f = fun+FUNHEAD; n = 1; i = 0;
2349 while ( n < arg1 ) { n++; f++; }
2350 f1 = f;
2351 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2352/*
2353 Now the permutations
2354*/
2355 info++;
2356 while ( *info ) {
2357 infostop = info + *info;
2358 info++;
2359 if ( *info > totarg ) return(0);
2360 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2361 info++;
2362 while ( info < infostop ) {
2363 if ( *info > totarg ) return(0);
2364 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2365 info++;
2366 }
2367 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2368 }
2369/*
2370 And the final cleanup
2371*/
2372 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2373 f2 = tstop;
2374 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++= *f++; }
2375 i = f2 - tstop;
2376 NCOPY(f1,tstop,i)
2377 }
2378 return(0);
2379OverWork:;
2380 MLOCK(ErrorMessageLock);
2381 MesWork();
2382 MUNLOCK(ErrorMessageLock);
2383 return(-1);
2384}
2385
2386/*
2387 #] RunPermute :
2388 #[ RunReverse :
2389*/
2390
2391int RunReverse(PHEAD WORD *fun, WORD *args)
2392{
2393 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, i1, i2;
2394 if ( *args != ARGRANGE ) {
2395 MLOCK(ErrorMessageLock);
2396 MesPrint("Illegal range encountered in RunReverse");
2397 MUNLOCK(ErrorMessageLock);
2398 Terminate(-1);
2399 }
2400 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2401 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2402 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2403 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2404/*
2405 We need to:
2406 1: get pointers to the arguments
2407 2: reverse the order of the pointers
2408 3: copy the arguments to safe territory in the new order
2409 4: copy this new order back in situ.
2410*/
2411 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2412 if ( arg2 > totarg ) return(0);
2413
2414 num = arg2-arg1+1;
2415 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2416 f = fun+FUNHEAD; n = 1; i = 0;
2417 while ( n < arg1 ) { n++; NEXTARG(f) }
2418 f1 = f;
2419 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2420 i1 = i-1; i2 = 0;
2421 while ( i1 > i2 ) {
2422 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2423 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2424 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2425 i1--; i2++;
2426 }
2427 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2428 f2 = tstop;
2429 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2430 i = f2 - tstop;
2431 NCOPY(f1,tstop,i)
2432 }
2433 else { /* Tensors */
2434 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2435 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2436/*
2437 We need to:
2438 1: get pointers to the arguments
2439 2: reverse the order of the pointers
2440 3: copy the arguments to safe territory in the new order
2441 4: copy this new order back in situ.
2442*/
2443 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2444 if ( arg2 > totarg ) return(0);
2445
2446 num = arg2-arg1+1;
2447 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2448 f = fun+FUNHEAD; n = 1; i = 0;
2449 while ( n < arg1 ) { n++; f++; }
2450 f1 = f;
2451 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2452 i1 = i-1; i2 = 0;
2453 while ( i1 > i2 ) {
2454 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2455 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2456 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2457 i1--; i2++;
2458 }
2459 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2460 f2 = tstop;
2461 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2462 i = f2 - tstop;
2463 NCOPY(f1,tstop,i)
2464 }
2465 return(0);
2466OverWork:;
2467 MLOCK(ErrorMessageLock);
2468 MesWork();
2469 MUNLOCK(ErrorMessageLock);
2470 return(-1);
2471}
2472
2473/*
2474 #] RunReverse :
2475 #[ RunDedup :
2476*/
2477
2478int RunDedup(PHEAD WORD *fun, WORD *args)
2479{
2480 WORD *tt, totarg, *tstop, arg1, arg2, n, i, j,k, *f, *f1, *f2, *fd, *fstart;
2481 if ( *args != ARGRANGE ) {
2482 MLOCK(ErrorMessageLock);
2483 MesPrint("Illegal range encountered in RunDedup");
2484 MUNLOCK(ErrorMessageLock);
2485 Terminate(-1);
2486 }
2487 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2488 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2489 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2490 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2491
2492 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2493 if ( arg2 > totarg ) return(0);
2494
2495 f = fun+FUNHEAD; n = 1;
2496 while ( n < arg1 ) { n++; NEXTARG(f) }
2497 f1 = f; // fast forward to first element in range
2498 i = 0; // new argument count
2499 fstart = f1;
2500
2501 for (; n <= arg2; n++ ) {
2502 f2 = fstart;
2503 for ( j = 0; j < i; j++ ) { // check all previous terms
2504 fd = f2;
2505 NEXTARG(fd)
2506 for ( k = 0; k < fd-f2; k++ ) // byte comparison of args
2507 if ( f2[k] != f[k] ) break;
2508
2509 if ( k == fd-f2 ) break; // duplicate arg
2510 f2 = fd;
2511 }
2512
2513 if ( j == i ) {
2514 // unique factor, copy in situ
2515 COPY1ARG(f1,f)
2516 i++;
2517 } else {
2518 NEXTARG(f)
2519 }
2520 }
2521
2522 // move the terms from after the range
2523 for (j = n; j <= totarg; j++) {
2524 COPY1ARG(f1,f)
2525 }
2526
2527 fun[1] = f1 - fun; // resize function
2528 }
2529 else { /* Tensors */
2530 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2531 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2532
2533 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2534 if ( arg2 > totarg ) return(0);
2535
2536 f = fun+FUNHEAD;
2537 i = arg1; // new argument count
2538 n = i;
2539
2540 for (; n <= arg2; n++ ) {
2541 for ( j = arg1; j < i; j++ ) { // check all previous terms
2542 if ( f[n-1] == f[j-1] ) break; // duplicate arg
2543 }
2544
2545 if ( j == i ) {
2546 // unique factor, copy in situ
2547 f[i-1] = f[n-1];
2548 i++;
2549 }
2550 }
2551
2552 // move the terms from after the range
2553 for (j = n; j <= totarg; j++, i++) {
2554 f[i-1] = f[j-1];
2555 }
2556
2557 fun[1] = f + i - 1 - fun; // resize function
2558 }
2559 return(0);
2560}
2561
2562/*
2563 #] RunDedup :
2564 #[ RunCycle :
2565*/
2566
2567int RunCycle(PHEAD WORD *fun, WORD *args, WORD *info)
2568{
2569 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, j, *f, *f1, *f2, x, ncyc, cc;
2570 if ( *args != ARGRANGE ) {
2571 MLOCK(ErrorMessageLock);
2572 MesPrint("Illegal range encountered in RunCycle");
2573 MUNLOCK(ErrorMessageLock);
2574 Terminate(-1);
2575 }
2576 ncyc = info[1];
2577 if ( ncyc >= MAXPOSITIVE2 ) { /* $ variable */
2578 ncyc -= MAXPOSITIVE2;
2579 if ( ncyc >= MAXPOSITIVE4 ) {
2580 ncyc -= MAXPOSITIVE4; /* -$ */
2581 cc = -1;
2582 }
2583 else cc = 1;
2584 ncyc = DolToNumber(BHEAD ncyc);
2585 if ( AN.ErrorInDollar ) {
2586 MesPrint(" Error in Dollar variable in transform,cycle()=$");
2587 return(-1);
2588 }
2589 if ( ncyc >= MAXPOSITIVE4 || ncyc <= -MAXPOSITIVE4 ) {
2590 MesPrint(" Illegal value from Dollar variable in transform,cycle()=$");
2591 return(-1);
2592 }
2593 ncyc *= cc;
2594 }
2595 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2596 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2597 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2598 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2599 if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2600 if ( arg2 > totarg ) return(0);
2601/*
2602 We need to:
2603 1: get pointers to the arguments
2604 2: cycle the pointers
2605 3: copy the arguments to safe territory in the new order
2606 4: copy this new order back in situ.
2607*/
2608 num = arg2-arg1+1;
2609 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2610 f = fun+FUNHEAD; n = 1; i = 0;
2611 while ( n < arg1 ) { n++; NEXTARG(f) }
2612 f1 = f;
2613 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2614/*
2615 Now the cycle(s). First minimize the number of cycles.
2616*/
2617 x = ncyc;
2618 if ( x >= i ) {
2619 x %= i;
2620 if ( x > i/2 ) x -= i;
2621 }
2622 else if ( x <= -i ) {
2623 x = -((-x) % i);
2624 if ( x <= -i/2 ) x += i;
2625 }
2626 while ( x ) {
2627 if ( x > 0 ) {
2628 tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2629 for ( j = i-1; j > 0; j-- )
2630 AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2631 AT.pWorkSpace[AT.pWorkPointer] = tt;
2632 x--;
2633 }
2634 else {
2635 tt = AT.pWorkSpace[AT.pWorkPointer];
2636 for ( j = 1; j < i; j++ )
2637 AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2638 AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2639 x++;
2640 }
2641 }
2642/*
2643 And the final cleanup
2644*/
2645 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2646 f2 = tstop;
2647 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2648 i = f2 - tstop;
2649 NCOPY(f1,tstop,i)
2650 }
2651 else { /* Tensors */
2652 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2653 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2654 if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2655 if ( arg2 > totarg ) return(0);
2656/*
2657 We need to:
2658 1: get pointers to the arguments
2659 2: cycle the pointers
2660 3: copy the arguments to safe territory in the new order
2661 4: copy this new order back in situ.
2662*/
2663 num = arg2-arg1+1;
2664 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2665 f = fun+FUNHEAD; n = 1; i = 0;
2666 while ( n < arg1 ) { n++; f++; }
2667 f1 = f;
2668 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2669/*
2670 Now the cycle(s). First minimize the number of cycles.
2671*/
2672 x = ncyc;
2673 if ( x >= i ) {
2674 x %= i;
2675 if ( x > i/2 ) x -= i;
2676 }
2677 else if ( x <= -i ) {
2678 x = -((-x) % i);
2679 if ( x <= -i/2 ) x += i;
2680 }
2681 while ( x ) {
2682 if ( x > 0 ) {
2683 tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2684 for ( j = i-1; j > 0; j-- )
2685 AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2686 AT.pWorkSpace[AT.pWorkPointer] = tt;
2687 x--;
2688 }
2689 else {
2690 tt = AT.pWorkSpace[AT.pWorkPointer];
2691 for ( j = 1; j < i; j++ )
2692 AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2693 AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2694 x++;
2695 }
2696 }
2697/*
2698 And the final cleanup
2699*/
2700 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2701 f2 = tstop;
2702 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2703 i = f2 - tstop;
2704 NCOPY(f1,tstop,i)
2705 }
2706 return(0);
2707OverWork:;
2708 MLOCK(ErrorMessageLock);
2709 MesWork();
2710 MUNLOCK(ErrorMessageLock);
2711 return(-1);
2712}
2713
2714/*
2715 #] RunCycle :
2716 #[ RunAddArg :
2717*/
2718
2719int RunAddArg(PHEAD WORD *fun, WORD *args)
2720{
2721 WORD *tt, totarg, *tstop, arg1, arg2, n, num, *f, *f1, *f2;
2722 WORD scribble[10+ARGHEAD];
2723 LONG space;
2724 if ( *args != ARGRANGE ) {
2725 MLOCK(ErrorMessageLock);
2726 MesPrint("Illegal range encountered in RunAddArg");
2727 MUNLOCK(ErrorMessageLock);
2728 Terminate(-1);
2729 }
2730 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2731 MLOCK(ErrorMessageLock);
2732 MesPrint("Illegal attempt to add arguments of a tensor in AddArg");
2733 MUNLOCK(ErrorMessageLock);
2734 Terminate(-1);
2735 }
2736 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2737 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2738 /* ignore functions with no arguments */
2739 if ( totarg == 0 ) return(0);
2740 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2741/*
2742 We need to:
2743 1: establish that we actually need to add something
2744 2: start a sort
2745 3: if needed, convert arguments to long arguments
2746 4: send (terms in) argument to StoreTerm
2747 5: EndSort and copy the result back into the function
2748 Note that the function is in the workspace, above the term and no
2749 relevant information is trailing it.
2750*/
2751 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2752 if ( arg2 > totarg ) return(0);
2753 num = arg2-arg1+1;
2754 if ( num == 1 ) return(0);
2755 f = fun+FUNHEAD; n = 1;
2756 while ( n < arg1 ) { n++; NEXTARG(f) }
2757 f1 = f;
2758 NewSort(BHEAD0);
2759 while ( n <= arg2 ) {
2760 if ( *f > 0 ) {
2761 f2 = f + *f; f += ARGHEAD;
2762 while ( f < f2 ) { StoreTerm(BHEAD f); f += *f; }
2763 }
2764 else if ( *f == -SNUMBER && f[1] == 0 ) {
2765 f+= 2;
2766 }
2767 else {
2768 ToGeneral(f,scribble,1);
2769 StoreTerm(BHEAD scribble);
2770 NEXTARG(f);
2771 }
2772 n++;
2773 }
2774 if ( EndSort(BHEAD tstop+ARGHEAD,1) < 0 ) return(-1);
2775 num = 0;
2776 f2 = tstop+ARGHEAD;
2777 while ( *f2 ) { f2 += *f2; num++; }
2778 *tstop = f2-tstop;
2779 for ( n = 1; n < ARGHEAD; n++ ) tstop[n] = 0;
2780 if ( num == 1 && ToFast(tstop,tstop) == 1 ) {
2781 f2 = tstop; NEXTARG(f2);
2782 }
2783 if ( *tstop == ARGHEAD ) {
2784 *tstop = -SNUMBER; tstop[1] = 0;
2785 f2 = tstop+2;
2786 }
2787/*
2788 Copy the trailing arguments after the new argument, then copy the whole back.
2789*/
2790 while ( f < tstop ) *f2++ = *f++;
2791 while ( f < f2 ) *f1++ = *f++;
2792 space = f1 - fun;
2793 if ( (space+8)*sizeof(WORD) > (UWORD)AM.MaxTer ) {
2794 MLOCK(ErrorMessageLock);
2795 MesWork();
2796 MUNLOCK(ErrorMessageLock);
2797 return(-1);
2798 }
2799 fun[1] = (WORD)space;
2800 return(0);
2801}
2802
2803/*
2804 #] RunAddArg :
2805 #[ RunMulArg :
2806*/
2807
2808int RunMulArg(PHEAD WORD *fun, WORD *args)
2809{
2810 WORD *t, totarg, *tstop, arg1, arg2, n, *f, nb, *m, i, *w;
2811 WORD *scratch, argbuf[20], argsize, *where, *newterm;
2812 LONG oldcpointer_pos;
2813 CBUF *C = cbuf + AT.ebufnum;
2814 if ( *args != ARGRANGE ) {
2815 MLOCK(ErrorMessageLock);
2816 MesPrint("Illegal range encountered in RunMulArg");
2817 MUNLOCK(ErrorMessageLock);
2818 Terminate(-1);
2819 }
2820 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2821 MLOCK(ErrorMessageLock);
2822 MesPrint("Illegal attempt to multiply arguments of a tensor in MulArg");
2823 MUNLOCK(ErrorMessageLock);
2824 Terminate(-1);
2825 }
2826 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2827 while ( t < tstop ) { totarg++; NEXTARG(t); }
2828 /* ignore functions with no arguments */
2829 if ( totarg == 0 ) return(0);
2830 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2831 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2832 if ( arg1 > totarg ) return(0);
2833 if ( arg2 < 1 ) return(0);
2834 if ( arg1 < 1 ) arg1 = 1;
2835 if ( arg2 > totarg ) arg2 = totarg;
2836 if ( arg1 == arg2 ) return(0);
2837/*
2838 Now we move the arguments to a compiler buffer
2839 Then we create a term in the workspace that is the product of
2840 subexpression pointers to the objects in the compiler buffer.
2841 Next we let Generator work out that term.
2842 Finally we pick up the results from EndSort and put it in the function.
2843*/
2844 f = fun+FUNHEAD; n = 1;
2845 while ( n < arg1 ) { n++; NEXTARG(f) }
2846 t = f;
2847 if ( fun >= AT.WorkSpace && fun < AT.WorkTop ) {
2848 if ( AT.WorkPointer < fun+fun[1] ) AT.WorkPointer = fun+fun[1];
2849 }
2850 scratch = AT.WorkPointer;
2851 w = scratch+1;
2852 oldcpointer_pos = C->Pointer-C->Buffer;
2853 nb = C->numrhs;
2854 while ( n <= arg2 ) {
2855 if ( *t > 0 ) {
2856 argsize = *t - ARGHEAD; where = t + ARGHEAD; t += *t;
2857 }
2858 else if ( *t <= -FUNCTION ) {
2859 argbuf[0] = FUNHEAD+4; argbuf[1] = -*t++; argbuf[2] = FUNHEAD;
2860 for ( i = 2; i < FUNHEAD; i++ ) argbuf[i+1] = 0;
2861 argbuf[FUNHEAD+1] = 1;
2862 argbuf[FUNHEAD+2] = 1;
2863 argbuf[FUNHEAD+3] = 3;
2864 argsize = argbuf[0];
2865 where = argbuf;
2866 }
2867 else if ( *t == -SYMBOL ) {
2868 argbuf[0] = 8; argbuf[1] = SYMBOL; argbuf[2] = 4;
2869 argbuf[3] = t[1]; argbuf[4] = 1;
2870 argbuf[5] = 1; argbuf[6] = 1; argbuf[7] = 3;
2871 argsize = 8; t += 2;
2872 where = argbuf;
2873 }
2874 else if ( *t == -VECTOR || *t == -MINVECTOR ) {
2875 argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2876 argbuf[3] = t[1];
2877 argbuf[4] = 1; argbuf[5] = 1;
2878 if ( *t == -MINVECTOR ) argbuf[6] = -3;
2879 else argbuf[6] = 3;
2880 argsize = 7; t += 2;
2881 where = argbuf;
2882 }
2883 else if ( *t == -INDEX ) {
2884 argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2885 argbuf[3] = t[1];
2886 argbuf[4] = 1; argbuf[5] = 1; argbuf[6] = 3;
2887 argsize = 7; t += 2;
2888 where = argbuf;
2889 }
2890 else if ( *t == -SNUMBER ) {
2891 if ( t[1] < 0 ) {
2892 argbuf[0] = 4; argbuf[1] = -t[1]; argbuf[2] = 1; argbuf[3] = -3;
2893 }
2894 else {
2895 argbuf[0] = 4; argbuf[1] = t[1]; argbuf[2] = 1; argbuf[3] = 3;
2896 }
2897 argsize = 4; t += 2;
2898 where = argbuf;
2899 }
2900 else {
2901 /* unreachable */
2902 return(1);
2903 }
2904/*
2905 Now add the argbuf to AT.ebufnum
2906*/
2907 m = AddRHS(AT.ebufnum,1);
2908 while ( (m + argsize + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,17);
2909 for ( i = 0; i < argsize; i++ ) m[i] = where[i];
2910 m[i] = 0;
2911 C->Pointer = m + i + 1;
2912 n++;
2913 *w++ = SUBEXPRESSION; *w++ = SUBEXPSIZE; *w++ = C->numrhs; *w++ = 1;
2914 *w++ = AT.ebufnum; FILLSUB(w);
2915 }
2916 *w++ = 1; *w++ = 1; *w++ = 3;
2917 *scratch = w-scratch;
2918 AT.WorkPointer = w;
2919 NewSort(BHEAD0);
2920 Generator(BHEAD scratch,AR.Cnumlhs);
2921 newterm = AT.WorkPointer;
2922 EndSort(BHEAD newterm+ARGHEAD,1);
2923 C->Pointer = C->Buffer+oldcpointer_pos;
2924 C->numrhs = nb;
2925 w = newterm+ARGHEAD; while ( *w ) w += *w;
2926 *newterm = w-newterm; newterm[1] = 0;
2927 if ( ToFast(newterm,newterm) ) {
2928 if ( *newterm <= -FUNCTION ) w = newterm+1;
2929 else w = newterm+2;
2930 }
2931 while ( t < tstop ) *w++ = *t++;
2932 i = w - newterm;
2933 t = newterm; NCOPY(f,t,i);
2934 fun[1] = f-fun;
2935 AT.WorkPointer = scratch;
2936 if ( AT.WorkPointer > AT.WorkSpace && AT.WorkPointer < f ) AT.WorkPointer = f;
2937 return(0);
2938}
2939
2940/*
2941 #] RunMulArg :
2942 #[ RunIsLyndon :
2943
2944 Determines whether the range constitutes a Lyndon word.
2945 The two cases of ordering are distinguished by the order of
2946 the numbers of the arguments in the range.
2947*/
2948
2949int RunIsLyndon(PHEAD WORD *fun, WORD *args, int par)
2950{
2951 WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, n, i;
2952/* WORD *f1; */
2953 WORD sign, i1, i2, retval;
2954 if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2955 if ( *args != ARGRANGE ) {
2956 MLOCK(ErrorMessageLock);
2957 MesPrint("Illegal range encountered in RunIsLyndon");
2958 MUNLOCK(ErrorMessageLock);
2959 Terminate(-1);
2960 }
2961 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2962 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2963 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2964 if ( arg1 > totarg || arg2 > totarg ) return(-1);
2965/*
2966 Now make a list of the relevant arguments.
2967*/
2968 if ( arg1 == arg2 ) return(1);
2969 if ( arg2 < arg1 ) { /* greater, rather than smaller */
2970 arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2971 }
2972 else sign = 0;
2973
2974 num = arg2-arg1+1;
2975 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2976 f = fun+FUNHEAD; n = 1; i = 0;
2977 while ( n < arg1 ) { n++; NEXTARG(f) }
2978/* f1 = f; */
2979 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2980/*
2981 If sign == 1 we should alter the order of the pointers first
2982*/
2983 if ( sign ) {
2984 i1 = i-1; i2 = 0;
2985 while ( i1 > i2 ) {
2986 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2987 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2988 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2989 i1--; i2++;
2990 }
2991 }
2992/*
2993 The argument range is from f1 to f and the num pointers to the arguments
2994 are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2995*/
2996 for ( i1 = 1; i1 < num; i1++ ) {
2997 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
2998 AT.pWorkSpace[AT.pWorkPointer]);
2999 if ( retval > 0 ) continue;
3000 if ( retval < 0 ) return(0);
3001 for ( i2 = 1; i2 < num; i2++ ) {
3002 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
3003 AT.pWorkSpace[AT.pWorkPointer+i2]);
3004 if ( retval < 0 ) return(0);
3005 if ( retval > 0 ) goto nexti1;
3006 }
3007/*
3008 If we come here the sequence is not unique.
3009*/
3010 return(0);
3011nexti1:;
3012 }
3013 return(1);
3014}
3015
3016/*
3017 #] RunIsLyndon :
3018 #[ RunToLyndon :
3019
3020 Determines whether the range constitutes a Lyndon word.
3021 If not, we rotate it to a Lyndon word. If this is not possible
3022 we return the noLyndon condition.
3023 The two cases of ordering are distinguished by the order of
3024 the numbers of the arguments in the range.
3025*/
3026
3027WORD RunToLyndon(PHEAD WORD *fun, WORD *args, int par)
3028{
3029 WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, *f1, *f2, n, i;
3030 WORD sign, i1, i2, retval, unique;
3031 if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
3032 if ( *args != ARGRANGE ) {
3033 MLOCK(ErrorMessageLock);
3034 MesPrint("Illegal range encountered in RunToLyndon");
3035 MUNLOCK(ErrorMessageLock);
3036 Terminate(-1);
3037 }
3038 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3039 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3040 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3041 if ( arg1 > totarg || arg2 > totarg ) return(-1);
3042/*
3043 Now make a list of the relevant arguments.
3044*/
3045 if ( arg1 == arg2 ) return(1);
3046 if ( arg2 < arg1 ) { /* greater, rather than smaller */
3047 arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
3048 }
3049 else sign = 0;
3050
3051 num = arg2-arg1+1;
3052 WantAddPointers((2*num)); /* Guarantees the presence of enough pointers */
3053 f = fun+FUNHEAD; n = 1; i = 0;
3054 while ( n < arg1 ) { n++; NEXTARG(f) }
3055 f1 = f;
3056 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
3057/*
3058 If sign == 1 we should alter the order of the pointers first
3059*/
3060 if ( sign ) {
3061 i1 = i-1; i2 = 0;
3062 while ( i1 > i2 ) {
3063 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3064 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3065 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3066 i1--; i2++;
3067 }
3068 }
3069/*
3070 The argument range is from f1 to f and the num pointers to the arguments
3071 are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
3072*/
3073 unique = 1;
3074 for ( i1 = 1; i1 < num; i1++ ) {
3075 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
3076 AT.pWorkSpace[AT.pWorkPointer]);
3077 if ( retval > 0 ) continue;
3078 if ( retval < 0 ) {
3079Rotate:;
3080/*
3081 Rotate so that i1 becomes the zero element. Then start again.
3082*/
3083 for ( i2 = 0; i2 < num; i2++ ) {
3084 AT.pWorkSpace[AT.pWorkPointer+num+i2] =
3085 AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num];
3086 }
3087 for ( i2 = 0; i2 < num; i2++ ) {
3088 AT.pWorkSpace[AT.pWorkPointer+i2] =
3089 AT.pWorkSpace[AT.pWorkPointer+i2+num];
3090 }
3091 i1 = 0;
3092 goto nexti1;
3093 }
3094 for ( i2 = 1; i2 < num; i2++ ) {
3095 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
3096 AT.pWorkSpace[AT.pWorkPointer+i2]);
3097 if ( retval < 0 ) goto Rotate;
3098 if ( retval > 0 ) goto nexti1;
3099 }
3100/*
3101 If we come here the sequence is not unique.
3102*/
3103 unique = 0;
3104nexti1:;
3105 }
3106 if ( sign ) {
3107 i1 = i-1; i2 = 0;
3108 while ( i1 > i2 ) {
3109 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3110 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3111 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3112 i1--; i2++;
3113 }
3114 }
3115/*
3116 Now rewrite the arguments into the proper order
3117*/
3118 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
3119 f2 = tstop;
3120 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
3121 i = f2 - tstop;
3122 NCOPY(f1,tstop,i)
3123/*
3124 The return value indicates whether we have a Lyndon word
3125*/
3126 return(unique);
3127OverWork:;
3128 MLOCK(ErrorMessageLock);
3129 MesWork();
3130 MUNLOCK(ErrorMessageLock);
3131 return(-2);
3132}
3133
3134/*
3135 #] RunToLyndon :
3136 #[ RunDropArg :
3137*/
3138
3139int RunDropArg(PHEAD WORD *fun, WORD *args)
3140{
3141 WORD *t, *tstop, *f, totarg, arg1, arg2, n;
3142
3143 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3144 while ( t < tstop ) { totarg++; NEXTARG(t); }
3145 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3146 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3147 if ( arg1 > totarg ) return(0);
3148 if ( arg2 < 1 ) return(0);
3149 if ( arg1 < 1 ) arg1 = 1;
3150 if ( arg2 > totarg ) arg2 = totarg;
3151 f = fun+FUNHEAD; n = 1;
3152 while ( n < arg1 ) { n++; NEXTARG(f) }
3153 t = f;
3154 while ( n <= arg2 ) { n++; NEXTARG(t) }
3155 while ( t < tstop ) *f++ = *t++;
3156 fun[1] = f-fun;
3157 return(0);
3158}
3159
3160/*
3161 #] RunDropArg :
3162 #[ RunSelectArg :
3163*/
3164
3165int RunSelectArg(PHEAD WORD *fun, WORD *args)
3166{
3167 WORD *t, *tstop, *f, *tt, totarg, arg1, arg2, n;
3168
3169 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3170 while ( t < tstop ) { totarg++; NEXTARG(t); }
3171 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3172 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3173 if ( arg1 > totarg ) return(0);
3174 if ( arg2 < 1 ) return(0);
3175 if ( arg1 < 1 ) arg1 = 1;
3176 if ( arg2 > totarg ) arg2 = totarg;
3177 f = fun+FUNHEAD; n = 1; t = f;
3178 while ( n < arg1 ) { n++; NEXTARG(t) }
3179 while ( n <= arg2 ) {
3180 tt = t; NEXTARG(tt)
3181 while ( t < tt ) *f++ = *t++;
3182 n++;
3183 }
3184 fun[1] = f-fun;
3185 return(0);
3186}
3187
3188/*
3189 #] RunSelectArg :
3190 #[ RunZtoHArg :
3191*/
3192
3193int RunZtoHArg(PHEAD WORD *fun, WORD *args)
3194{
3195 WORD *tt, totarg, *tstop, arg1, arg2, n, i, *f, *f1;
3196 int sign = 0;
3197 WORD *t, *t1, *t2, *t3;
3198 if ( *args != ARGRANGE ) {
3199 MLOCK(ErrorMessageLock);
3200 MesPrint("Illegal range encountered in RunZtoHArg.");
3201 MUNLOCK(ErrorMessageLock);
3202 Terminate(-1);
3203 }
3204 if ( functions[fun[0]-FUNCTION].spec != 0 ) {
3205 MLOCK(ErrorMessageLock);
3206 MesPrint("The ZtoH transformation can only be executed on regular functions with nonzero integer arguments.");
3207 MUNLOCK(ErrorMessageLock);
3208 Terminate(-1);
3209 }
3210 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3211 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3212 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3213/*
3214 Check the arguments. Should be -SNUMBER x!=0
3215*/
3216 f = fun+FUNHEAD; n = 1;
3217 while ( n < arg1 ) { n++; NEXTARG(f) }
3218 f1 = f;
3219 for ( i = arg1; i <= arg2; i++, f += 2 ) {
3220 if ( *f != -SNUMBER || f[1] == 0 ) return(-1);
3221 }
3222/*
3223 Now we need a copy.
3224*/
3225 t = f1; t1 = t2 = tt = TermMalloc("RunZtoHArg");
3226 while ( t < f ) { *t1++ = *t++; *t1++ = *t++; }
3227 t = f1;
3228 while ( t2 < t1 ) {
3229 t += 2;
3230 if ( t2[1] < 0 ) {
3231 t3 = t;
3232 while ( t3 < f ) { t3[1] = -t3[1]; t3 += 2; }
3233 }
3234 t2 += 2;
3235 }
3236 TermFree(tt,"RunZtoHArg");
3237/*
3238 Now the overall sign.
3239*/
3240 while ( f1 < f ) { if ( f1[1] < 0 ) sign = 1-sign; f1 += 2; }
3241 return(sign);
3242}
3243
3244/*
3245 #] RunZtoHArg :
3246 #[ RunHtoZArg :
3247*/
3248
3249int RunHtoZArg(PHEAD WORD *fun, WORD *args)
3250{
3251 WORD *tt, totarg, *tstop, arg1, arg2, n, i, *f, *f1, *f2;
3252 int sign = 0;
3253 WORD *t, *t1, *t2;
3254 if ( *args != ARGRANGE ) {
3255 MLOCK(ErrorMessageLock);
3256 MesPrint("Illegal range encountered in RunZtoHArg.");
3257 MUNLOCK(ErrorMessageLock);
3258 Terminate(-1);
3259 }
3260 if ( functions[fun[0]-FUNCTION].spec != 0 ) {
3261 MLOCK(ErrorMessageLock);
3262 MesPrint("The HtoZ transformation can only be executed on regular functions with nonzero integer arguments.");
3263 MUNLOCK(ErrorMessageLock);
3264 Terminate(-1);
3265 }
3266 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3267 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3268 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3269/*
3270 Check the arguments. Should be -SNUMBER x!=0
3271*/
3272 f = fun+FUNHEAD; n = 1;
3273 while ( n < arg1 ) { n++; NEXTARG(f) }
3274 f2 = f1 = f;
3275 for ( i = arg1; i <= arg2; i++, f += 2 ) {
3276 if ( *f != -SNUMBER || f[1] == 0 ) return(-1);
3277 }
3278/*
3279 First the overall sign.
3280*/
3281 while ( f2 < f ) { if ( f2[1] < 0 ) sign = 1-sign; f2 += 2; }
3282/*
3283 Now we need a copy.
3284*/
3285 t = f1; t1 = tt = TermMalloc("RunHtoZArg");
3286 while ( t < f ) { *t1++ = *t++; *t1++ = *t++; }
3287/*
3288 Now the transformation.
3289*/
3290 t = f1; t2 = tt + 2;
3291 while ( t2 < t1 ) {
3292 t += 2;
3293 if ( t2[-1] < 0 ) t[1] = -t[1];
3294 t2 += 2;
3295 }
3296 TermFree(tt,"RunHtoZArg");
3297 return(sign);
3298}
3299
3300/*
3301 #] RunHtoZArg :
3302 #[ TestArgNum :
3303
3304 Looks whether argument n is contained in any of the ranges
3305 specified in args. Args contains objects of the types
3306 ALLARGS
3307 NUMARG,num
3308 ARGRANGE,num1,num2
3309 The object MAKEARGS,num1,num2 is skipped
3310 Any other object terminates the range specifications.
3311
3312 Currently only ARGRANGE is used (10-may-2016)
3313*/
3314
3315int TestArgNum(int n, int totarg, WORD *args)
3316{
3317 GETIDENTITY
3318 WORD x1, x2;
3319 for(;;) {
3320 switch ( *args ) {
3321 case ALLARGS:
3322 return(1);
3323 case NUMARG:
3324 if ( n == args[1] ) return(1);
3325 if ( args[1] >= MAXPOSITIVE4 ) {
3326 x1 = args[1]-MAXPOSITIVE4;
3327 if ( totarg-x1 == n ) return(1);
3328 }
3329 args += 2;
3330 break;
3331 case ARGRANGE:
3332 if ( args[1] >= MAXPOSITIVE2 ) {
3333 x1 = args[1] - MAXPOSITIVE2;
3334 if ( x1 > MAXPOSITIVE4 ) {
3335 x1 = x1 - MAXPOSITIVE4;
3336 x1 = DolToNumber(BHEAD x1);
3337 x1 = totarg - x1;
3338 }
3339 else {
3340 x1 = DolToNumber(BHEAD x1);
3341 }
3342 }
3343 else if ( args[1] >= MAXPOSITIVE4 ) {
3344 x1 = totarg-(args[1]-MAXPOSITIVE4);
3345 }
3346 else x1 = args[1];
3347 if ( args[2] >= MAXPOSITIVE2 ) {
3348 x2 = args[2] - MAXPOSITIVE2;
3349 if ( x2 > MAXPOSITIVE4 ) {
3350 x2 = x2 - MAXPOSITIVE4;
3351 x2 = DolToNumber(BHEAD x2);
3352 x2 = totarg - x2;
3353 }
3354 else {
3355 x2 = DolToNumber(BHEAD x2);
3356 }
3357 }
3358 else if ( args[2] >= MAXPOSITIVE4 ) {
3359 x2 = totarg-(args[2]-MAXPOSITIVE4);
3360 }
3361 else x2 = args[2];
3362 if ( x1 >= x2 ) {
3363 if ( n >= x2 && n <= x1 ) return(1);
3364 }
3365 else {
3366 if ( n >= x1 && n <= x2 ) return(1);
3367 }
3368 args += 3;
3369 break;
3370 case MAKEARGS:
3371 args += 3;
3372 break;
3373 default:
3374 return(0);
3375 }
3376 }
3377}
3378
3379/*
3380 #] TestArgNum :
3381 #[ PutArgInScratch :
3382*/
3383
3384WORD PutArgInScratch(WORD *arg,UWORD *scrat)
3385{
3386 WORD size, *t, i;
3387 if ( *arg == -SNUMBER ) {
3388 scrat[0] = ABS(arg[1]);
3389 if ( arg[1] < 0 ) size = -1;
3390 else size = 1;
3391 }
3392 else {
3393 t = arg+*arg-1;
3394 if ( *t < 0 ) { i = ((-*t)-1)/2; size = -i; }
3395 else { i = ( *t -1)/2; size = i; }
3396 t = arg+ARGHEAD+1;
3397 NCOPY(scrat,t,i);
3398 }
3399 return(size);
3400}
3401
3402/*
3403 #] PutArgInScratch :
3404 #[ ReadRange :
3405
3406 Comes in at the bracket and leaves at the = sign
3407 Ranges can be:
3408 #1,#2 with # numbers. If the second is smaller than the
3409 first we work it backwards.
3410 first,#2 or #2,first
3411 #1,last or last,#1
3412 first,last or last,first
3413 First is represented by 1. Last is represented by MAXPOSITIVE4.
3414
3415 par = 0: we need the = after.
3416 par = 1: we need a , or '\0' after.
3417 par = 2: we need a :
3418*/
3419
3420UBYTE *ReadRange(UBYTE *s, WORD *out, int par)
3421{
3422 UBYTE *in = s, *ss, c;
3423 LONG x1, x2;
3424
3425 SKIPBRA3(in)
3426 if ( par == 0 && in[1] != '=' ) {
3427 MesPrint("&A range in this type of transform statement should be followed by an = sign");
3428 return(0);
3429 }
3430 else if ( par == 1 && in[1] != ',' && in[1] != '\0' ) {
3431 MesPrint("&A range in this type of transform statement should be followed by a comma or end-of-statement");
3432 return(0);
3433 }
3434 else if ( par == 2 && in[1] != ':' ) {
3435 MesPrint("&A range in this type of transform statement should be followed by a :");
3436 return(0);
3437 }
3438 s++;
3439 if ( FG.cTable[*s] == 0 ) {
3440 ss = s; while ( FG.cTable[*s] == 0 ) s++;
3441 c = *s; *s = 0;
3442 if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3443 *s = c;
3444 x1 = 1;
3445 }
3446 else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3447 *s = c;
3448 if ( c == '-' ) {
3449 s++;
3450 if ( *s == '$' ) {
3451 s++; ss = s;
3452 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3453 c = *s; *s = 0;
3454 if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3455 *s = c;
3456 x1 += MAXPOSITIVE2;
3457 }
3458 else {
3459 x1 = 0;
3460 while ( *s >= '0' && *s <= '9' ) {
3461 x1 = 10*x1 + *s++ - '0';
3462 if ( x1 >= MAXPOSITIVE4 ) {
3463 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3464 return(0);
3465 }
3466 }
3467 }
3468 x1 += MAXPOSITIVE4;
3469 }
3470 else x1 = MAXPOSITIVE4;
3471 }
3472 else {
3473 MesPrint("&Illegal keyword inside range specification");
3474 return(0);
3475 }
3476 }
3477 else if ( FG.cTable[*s] == 1 ) {
3478 x1 = 0;
3479 while ( *s >= '0' && *s <= '9' ) {
3480 x1 = x1*10 + *s++ - '0';
3481 if ( x1 >= MAXPOSITIVE4 ) {
3482 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3483 return(0);
3484 }
3485 }
3486 }
3487 else if ( *s == '$' ) {
3488 s++; ss = s;
3489 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3490 c = *s; *s = 0;
3491 if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3492 *s = c;
3493 x1 += MAXPOSITIVE2;
3494 }
3495 else {
3496 MesPrint("&Illegal character in range specification");
3497 return(0);
3498 }
3499 if ( *s != ',' ) {
3500 MesPrint("&A range is two indicators, separated by a comma or blank");
3501 return(0);
3502 }
3503 s++;
3504 if ( FG.cTable[*s] == 0 ) {
3505 ss = s; while ( FG.cTable[*s] == 0 ) s++;
3506 c = *s; *s = 0;
3507 if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3508 *s = c;
3509 x2 = 1;
3510 }
3511 else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3512 *s = c;
3513 if ( c == '-' ) {
3514 s++;
3515 if ( *s == '$' ) {
3516 s++; ss = s;
3517 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3518 c = *s; *s = 0;
3519 if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3520 *s = c;
3521 x2 += MAXPOSITIVE2;
3522 }
3523 else {
3524 x2 = 0;
3525 while ( *s >= '0' && *s <= '9' ) {
3526 x2 = 10*x2 + *s++ - '0';
3527 if ( x2 >= MAXPOSITIVE4 ) {
3528 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3529 return(0);
3530 }
3531 }
3532 }
3533 x2 += MAXPOSITIVE4;
3534 }
3535 else x2 = MAXPOSITIVE4;
3536 }
3537 else {
3538 MesPrint("&Illegal keyword inside range specification");
3539 return(0);
3540 }
3541 }
3542 else if ( FG.cTable[*s] == 1 ) {
3543 x2 = 0;
3544 while ( *s >= '0' && *s <= '9' ) {
3545 x2 = x2*10 + *s++ - '0';
3546 if ( x2 >= MAXPOSITIVE4 ) {
3547 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3548 return(0);
3549 }
3550 }
3551 }
3552 else if ( *s == '$' ) {
3553 s++; ss = s;
3554 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3555 c = *s; *s = 0;
3556 if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3557 *s = c;
3558 x2 += MAXPOSITIVE2;
3559 }
3560 else {
3561 MesPrint("&Illegal character in range specification");
3562 return(0);
3563 }
3564 if ( s < in ) {
3565 MesPrint("&A range is two indicators, separated by a comma or blank between parentheses");
3566 return(0);
3567 }
3568 out[0] = x1; out[1] = x2;
3569 return(in+1);
3570Error:
3571 MesPrint("&Undefined variable $%s in range",ss);
3572 return(0);
3573}
3574
3575/*
3576 #] ReadRange :
3577 #[ FindRange :
3578*/
3579
3580int FindRange(PHEAD WORD *args, WORD *arg1, WORD *arg2, WORD totarg)
3581{
3582 WORD n[2], fromlast, i;
3583 for ( i = 0; i < 2; i++ ) {
3584 n[i] = args[i+1];
3585 fromlast = 0;
3586 if ( n[i] >= MAXPOSITIVE2 ) { /* This is a dollar variable */
3587 n[i] -= MAXPOSITIVE2;
3588 if ( n[i] >= MAXPOSITIVE4 ) {
3589 fromlast = 1;
3590 n[i] -= MAXPOSITIVE4; /* Now we have the number of the dollar variable */
3591 }
3592 n[i] = DolToNumber(BHEAD n[i]);
3593 if ( AN.ErrorInDollar ) {
3594 MLOCK(ErrorMessageLock);
3595 MesPrint("Illegal $ value in range while executing transform statement.");
3596 MUNLOCK(ErrorMessageLock);
3597 return(-1);
3598 }
3599 if ( fromlast ) n[i] = totarg-n[i];
3600 }
3601 else if ( n[i] >= MAXPOSITIVE4 ) { n[i] = totarg-(n[i]-MAXPOSITIVE4); }
3602 if ( n[i] <= 0 ) {
3603 MLOCK(ErrorMessageLock);
3604 MesPrint("Illegal non-positive value in range (%d) while executing transform statement.", i+1);
3605 MUNLOCK(ErrorMessageLock);
3606 return(-1);
3607 }
3608 }
3609 *arg1 = n[0];
3610 *arg2 = n[1];
3611 return(0);
3612}
3613
3614/*
3615 #] FindRange :
3616 #] Transform :
3617*/
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:3275
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