FORM v5.0.0-35-g6318119
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 MLOCK(ErrorMessageLock);
951 MesPrint("Irregular code in execution of transform statement");
952 MUNLOCK(ErrorMessageLock);
953 Terminate(-1);
954 }
955 onetransform += *onetransform;
956 } while ( *onetransform );
957 }
958 else {
959 while ( funs < endfun ) { /* sum over sets */
960 if ( *funs > MAXVARIABLES ) {
961 if ( *t == *funs-MAXVARIABLES ) goto hit;
962 }
963 else {
964 w = SetElements + Sets[*funs].first;
965 m = SetElements + Sets[*funs].last;
966 while ( w < m ) { /* sum over set elements */
967 if ( *w == *t ) goto hit;
968 w++;
969 }
970 }
971 funs++;
972 }
973 }
974#ifdef WITHFLOAT
975next:
976#endif
977 t += t[1];
978 }
979 tt = term + *term; while ( in < tt ) *out++ = *in++;
980 if ( sign == -1 ) out[-1] = -out[-1];
981 *tt = i = out - tt;
982/*
983 Now copy the whole thing back
984*/
985 NCOPY(term,tt,i)
986 return(0);
987abo:
988 MLOCK(ErrorMessageLock);
989 MesCall("RunTransform");
990 MUNLOCK(ErrorMessageLock);
991 return(-1);
992}
993
994/*
995 #] RunTransform :
996 #[ RunEncode :
997
998 The info is given by
999 ENCODEARG,size,BASECODE,num
1000 and possibly more codes to follow.
1001 Only one range is allowed and for now, it should be fully numerical
1002 If the range is in reverse order, we need to either revert it
1003 first or work with an array of pointers.
1004*/
1005
1006int RunEncode(PHEAD WORD *fun, WORD *args, WORD *info)
1007{
1008 WORD base, *f, *funstop, *fun1, *t, size1, size2, size3, *arg;
1009 int num, num1, num2, n, i, i1, i2;
1010 UWORD *scrat1, *scrat2, *scrat3;
1011 WORD *tt, *tstop, totarg, arg1, arg2;
1012 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1013 if ( *args != ARGRANGE ) {
1014 MLOCK(ErrorMessageLock);
1015 MesPrint("Illegal range encountered in RunEncode");
1016 MUNLOCK(ErrorMessageLock);
1017 Terminate(-1);
1018 }
1019 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1020 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1021 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1022 if ( arg1 > totarg || arg2 > totarg ) return(0);
1023
1024 if ( info[2] == BASECODE ) {
1025 base = info[3];
1026 if ( base <= 0 ) { /* is a dollar variable */
1027 i1 = -base;
1028 base = DolToNumber(BHEAD i1);
1029 if ( AN.ErrorInDollar || base < 2 ) {
1030 MLOCK(ErrorMessageLock);
1031 MesPrint("$%s does not have a number value > 1 in base/encode/transform statement in module %l",
1032 DOLLARNAME(Dollars,i1),AC.CModule);
1033 MUNLOCK(ErrorMessageLock);
1034 Terminate(-1);
1035 }
1036 }
1037/*
1038 Compute number of pointers needed and make sure there is space
1039*/
1040 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1041 else { num1 = arg1; num2 = arg2; }
1042 num = num2-num1+1;
1043 WantAddPointers(num);
1044/*
1045 Collect the pointers in pWorkSpace
1046*/
1047 n = 1; funstop = fun+fun[1]; f = fun+FUNHEAD;
1048 while ( n < num1 ) {
1049 if ( f >= funstop ) return(0);
1050 NEXTARG(f);
1051 n++;
1052 }
1053 fun1 = f; i = 0;
1054 while ( n <= num2 ) {
1055 if ( f >= funstop ) return(0);
1056 if ( *f != -SNUMBER ) {
1057 if ( *f < 0 ) return(0);
1058 t = f + *f - 1;
1059 i1 = ABS(*t);
1060 if ( (*f-i1) != (ARGHEAD+1) ) return(0); /* Not numerical */
1061 i1 = (i1-1)/2 - 1;
1062 t--;
1063 while ( i1 > 0 ) {
1064 if ( *t != 0 ) return(0); /* Not an integer */
1065 t--; i1--;
1066 }
1067 }
1068 AT.pWorkSpace[AT.pWorkPointer+i] = f;
1069 i++;
1070 NEXTARG(f);
1071 n++;
1072 }
1073/*
1074 f points now to after the arguments; fun1 at the first.
1075 Now check whether we need to revert the order
1076*/
1077 if ( arg1 > arg2 ) {
1078 i1 = 0; i2 = i-1;
1079 while ( i1 < i2 ) {
1080 t = AT.pWorkSpace[AT.pWorkPointer+i1];
1081 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
1082 AT.pWorkSpace[AT.pWorkPointer+i2] = t;
1083 i1++; i2--;
1084 }
1085 }
1086/*
1087 Now we can put the thing together.
1088 x = arg1;
1089 x = base*x+arg2
1090 x = base*x+arg3 etc.
1091 We need three scratch arrays for long integers
1092 (see NumberMalloc in tools.c).
1093*/
1094 scrat1 = NumberMalloc("RunEncode");
1095 scrat2 = NumberMalloc("RunEncode");
1096 scrat3 = NumberMalloc("RunEncode");
1097 arg = AT.pWorkSpace[AT.pWorkPointer];
1098 size1 = PutArgInScratch(arg,scrat1);
1099 i--;
1100 while ( i > 0 ) {
1101 if ( MulLong(scrat1,size1,(UWORD *)(&base),1,scrat2,&size2) ) {
1102 NumberFree(scrat3,"RunEncode");
1103 NumberFree(scrat2,"RunEncode");
1104 NumberFree(scrat1,"RunEncode");
1105 goto CalledFrom;
1106 }
1107 NEXTARG(arg);
1108 size3 = PutArgInScratch(arg,scrat3);
1109 if ( AddLong(scrat2,size2,scrat3,size3,scrat1,&size1) ) {
1110 NumberFree(scrat3,"RunEncode");
1111 NumberFree(scrat2,"RunEncode");
1112 NumberFree(scrat1,"RunEncode");
1113 goto CalledFrom;
1114 }
1115 i--;
1116 }
1117/*
1118 Now put the output in place. There are two cases, one being much
1119 faster than the other. Hence we program both.
1120 Fast: it fits inside the old location.
1121 Slow: it does not.
1122 The total space is f-fun1
1123*/
1124 if ( size1 == 0 ) { /* Fits! */
1125 *fun1++ = -SNUMBER; *fun1++ = 0;
1126 while ( f < funstop ) *fun1++ = *f++;
1127 fun[1] = funstop-fun;
1128 }
1129 else if ( size1 == 1 && scrat1[0] <= MAXPOSITIVE ) { /* Fits! */
1130 *fun1++ = -SNUMBER; *fun1++ = scrat1[0];
1131 while ( f < funstop ) *fun1++ = *f++;
1132 fun[1] = fun1-fun;
1133 }
1134 else if ( size1 == -1 && scrat1[0] <= MAXPOSITIVE+1 ) { /* Fits! */
1135 *fun1++ = -SNUMBER;
1136 if ( scrat1[0] < MAXPOSITIVE ) *fun1++ = scrat1[0];
1137 else *fun1++ = (WORD)(MAXPOSITIVE+1);
1138 while ( f < funstop ) *fun1++ = *f++;
1139 fun[1] = fun1-fun;
1140 }
1141 else if ( ABS(size1)*2+2+ARGHEAD <= f-fun1 ) { /* Fits! */
1142 if ( size1 < 0 ) { size2 = size1*2-1; size1 = -size1; size3 = -size2; }
1143 else { size2 = 2*size1+1; size3 = size2; }
1144 *fun1++ = size3+ARGHEAD+1;
1145 *fun1++ = 0; FILLARG(fun1);
1146 *fun1++ = size3+1;
1147 for ( i = 0; i < size1; i++ ) *fun1++ = scrat1[i];
1148 *fun1++ = 1;
1149 for ( i = 1; i < size1; i++ ) *fun1++ = 0;
1150 *fun1++ = size2;
1151 while ( f < funstop ) *fun1++ = *f++;
1152 fun[1] = fun1-fun;
1153 }
1154 else { /* Does not fit */
1155 t = funstop;
1156 if ( size1 < 0 ) { size2 = size1*2-1; size1 = -size1; size3 = -size2; }
1157 else { size2 = 2*size1+1; size3 = size2; }
1158 *t++ = size3+ARGHEAD+1;
1159 *t++ = 0; FILLARG(t);
1160 *t++ = size3+1;
1161 for ( i = 0; i < size1; i++ ) *t++ = scrat1[i];
1162 *t++ = 1;
1163 for ( i = 1; i < size1; i++ ) *t++ = 0;
1164 *t++ = size2;
1165 while ( f < funstop ) *t++ = *f++;
1166 f = funstop;
1167 while ( f < t ) *fun1++ = *f++;
1168 fun[1] = fun1-fun;
1169 }
1170 NumberFree(scrat3,"RunEncode");
1171 NumberFree(scrat2,"RunEncode");
1172 NumberFree(scrat1,"RunEncode");
1173 }
1174 else {
1175 MLOCK(ErrorMessageLock);
1176 MesPrint("Unimplemented type of encoding encountered in RunEncode");
1177 MUNLOCK(ErrorMessageLock);
1178 Terminate(-1);
1179 }
1180 return(0);
1181CalledFrom:
1182 MLOCK(ErrorMessageLock);
1183 MesCall("RunEncode");
1184 MUNLOCK(ErrorMessageLock);
1185 return(-1);
1186}
1187
1188/*
1189 #] RunEncode :
1190 #[ RunDecode :
1191*/
1192
1193int RunDecode(PHEAD WORD *fun, WORD *args, WORD *info)
1194{
1195 WORD base, num, num1, num2, n, *f, *funstop, *fun1, size1, size2, size3, *t;
1196 WORD i1, i2, i, sig;
1197 UWORD *scrat1, *scrat2, *scrat3;
1198 WORD *tt, *tstop, totarg, arg1, arg2;
1199 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1200 if ( *args != ARGRANGE ) {
1201 MLOCK(ErrorMessageLock);
1202 MesPrint("Illegal range encountered in RunDecode");
1203 MUNLOCK(ErrorMessageLock);
1204 Terminate(-1);
1205 }
1206 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1207 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1208 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1209 if ( arg1 > totarg && arg2 > totarg ) return(0);
1210 if ( info[2] == BASECODE ) {
1211 base = info[3];
1212 if ( base <= 0 ) { /* is a dollar variable */
1213 i1 = -base;
1214 base = DolToNumber(BHEAD i1);
1215 if ( AN.ErrorInDollar || base < 2 ) {
1216 MLOCK(ErrorMessageLock);
1217 MesPrint("$%s does not have a number value > 1 in base/decode/transform statement in module %l",
1218 DOLLARNAME(Dollars,i1),AC.CModule);
1219 MUNLOCK(ErrorMessageLock);
1220 Terminate(-1);
1221 }
1222 }
1223/*
1224 Compute number of output arguments needed
1225*/
1226 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1227 else { num1 = arg1; num2 = arg2; }
1228 num = num2-num1+1;
1229 if ( num <= 1 ) return(0);
1230/*
1231 Find argument num1
1232*/
1233 funstop = fun + fun[1];
1234 f = fun + FUNHEAD; n = 1;
1235 while ( f < funstop ) {
1236 if ( n == num1 ) break;
1237 NEXTARG(f); n++;
1238 }
1239 if ( f >= funstop ) return(0); /* not enough arguments */
1240/*
1241 Check that f is integer
1242*/
1243 if ( *f == -SNUMBER ) {}
1244 else if ( *f < 0 ) return(0);
1245 else {
1246 t = f + *f - 1;
1247 i1 = ABS(*t);
1248 if ( (*f-i1) != (ARGHEAD+1) ) return(0); /* Not numerical */
1249 i1 = (i1-1)/2 - 1;
1250 t--;
1251 while ( i1 > 0 ) {
1252 if ( *t != 0 ) return(0); /* Not an integer */
1253 t--; i1--;
1254 }
1255 }
1256 fun1 = f;
1257/*
1258 The argument that should be decoded is in fun1
1259 We have to copy it to scratch
1260*/
1261 scrat1 = NumberMalloc("RunEncode");
1262 scrat2 = NumberMalloc("RunEncode");
1263 scrat3 = NumberMalloc("RunEncode");
1264 size1 = PutArgInScratch(fun1,scrat1);
1265 if ( size1 < 0 ) { sig = -1; size1 = -size1; }
1266 else sig = 1;
1267/*
1268 We can check first whether this number can be decoded
1269*/
1270 scrat2[0] = base; size2 = 1;
1271 if ( RaisPow(BHEAD scrat2,&size2,num) ) {
1272 NumberFree(scrat3,"RunEncode");
1273 NumberFree(scrat2,"RunEncode");
1274 NumberFree(scrat1,"RunEncode");
1275 goto CalledFrom;
1276 }
1277 if ( BigLong(scrat1,size1,scrat2,size2) >= 0 ) { /* Number too big */
1278 NumberFree(scrat3,"RunEncode");
1279 NumberFree(scrat2,"RunEncode");
1280 NumberFree(scrat1,"RunEncode");
1281 return(0);
1282 }
1283/*
1284 We need num*2 spaces
1285*/
1286 if ( *fun1 > num*2 ) { /* shrink space */
1287 t = fun1 + 2*num; f = fun1 + *fun1;
1288 while ( f < funstop ) *t++ = *f++;
1289 fun[1] = t - fun;
1290 }
1291 else if ( *fun1 < num*2 ) { /* case includes -SNUMBER */
1292 if ( *fun1 < 0 ) { /* expand space from -SNUMBER */
1293 fun[1] += (num-1)*2;
1294 t = funstop + (num-1)*2;
1295 }
1296 else { /* expand space from general argument */
1297 fun[1] += 2*num - *fun1;
1298 t = funstop +2*num - *fun1;
1299 }
1300 f = funstop;
1301 while ( f > fun1 ) *--t = *--f;
1302 }
1303/*
1304 Now there is space for num -SNUMBER arguments filled from the top.
1305*/
1306 for ( i = num-1; i >= 0; i-- ) {
1307 DivLong(scrat1,size1,(UWORD *)(&base),1,scrat2,&size2,scrat3,&size3);
1308 fun1[2*i] = -SNUMBER;
1309 if ( size3 == 0 ) fun1[2*i+1] = 0;
1310 else fun1[2*i+1] = (WORD)(scrat3[0])*sig;
1311 for ( i1 = 0; i1 < size2; i1++ ) scrat1[i1] = scrat2[i1];
1312 size1 = size2;
1313 }
1314 if ( size2 != 0 ) {
1315 MLOCK(ErrorMessageLock);
1316 MesPrint("RunDecode: number to be decoded is too big");
1317 MUNLOCK(ErrorMessageLock);
1318 NumberFree(scrat3,"RunEncode");
1319 NumberFree(scrat2,"RunEncode");
1320 NumberFree(scrat1,"RunEncode");
1321 goto CalledFrom;
1322 }
1323/*
1324 Now check whether we should change the order of the arguments
1325*/
1326 if ( arg1 > arg2 ) {
1327 i1 = 1; i2 = 2*num-1;
1328 while ( i2 > i1 ) {
1329 i = fun1[i1]; fun1[i1] = fun1[i2]; fun1[i2] = i;
1330 i1 += 2; i2 -= 2;
1331 }
1332 }
1333 NumberFree(scrat3,"RunEncode");
1334 NumberFree(scrat2,"RunEncode");
1335 NumberFree(scrat1,"RunEncode");
1336 }
1337 else {
1338 MLOCK(ErrorMessageLock);
1339 MesPrint("Unimplemented type of encoding encountered in RunDecode");
1340 MUNLOCK(ErrorMessageLock);
1341 Terminate(-1);
1342 }
1343 return(0);
1344CalledFrom:
1345 MLOCK(ErrorMessageLock);
1346 MesCall("RunDecode");
1347 MUNLOCK(ErrorMessageLock);
1348 return(-1);
1349}
1350
1351/*
1352 #] RunDecode :
1353 #[ RunReplace :
1354
1355 Gets the function, passes the arguments and looks whether they
1356 need to be treated. If so, the exact treatment is found in info.
1357 The info is given as if it is a function of type REPLACEMENT but
1358 its name is REPLACEARG (which is NOT a function).
1359 It is performed on the arguments.
1360 The output is at first written after fun and in the end overwrites fun.
1361*/
1362
1363int RunReplace(PHEAD WORD *fun, WORD *args, WORD *info)
1364{
1365 int n = 0, i, dirty = 0, totarg, nfix, nwild, ngeneral;
1366 WORD *t, *tt, *u, *tstop, *info1, *infoend, *oldwork = AT.WorkPointer;
1367 WORD *term, *newterm, *nt, *term1, *term2;
1368 WORD wild[4], mask, *term3, *term4, *oldmask = AT.WildMask;
1369 WORD n1, n2, doanyway;
1370 info++;
1371 t = fun; tstop = fun + fun[1]; u = tstop;
1372 for ( i = 0; i < FUNHEAD; i++ ) *u++ = *t++;
1373 tt = t;
1374 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1375 totarg = 0;
1376 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1377 }
1378 else {
1379 totarg = tstop - tt;
1380 }
1381/*
1382 Now get the info through Generator to bring it to standard form.
1383 info points at a single term that should be sent to Generator.
1384
1385 We want to put the information in the WorkSpace but fun etc lies there
1386 already. This means that we have to move the WorkPointer quite high up.
1387*/
1388 AT.WorkPointer += 2*AM.MaxTer;
1389 if ( AT.WorkPointer > AT.WorkTop ) {
1390 MLOCK(ErrorMessageLock);
1391 MesWork();
1392 MUNLOCK(ErrorMessageLock);
1393 return(-1);
1394 }
1395 term = AT.WorkPointer;
1396 for ( i = 0; i < *info; i++ ) term[i] = info[i];
1397 AT.WorkPointer = term + *term;
1398 AR.Eside = LHSIDEX;
1399 NewSort(BHEAD0);
1400 if ( Generator(BHEAD term,AR.Cnumlhs) ) {
1401 LowerSortLevel();
1402 AT.WorkPointer = oldwork;
1403 return(-1);
1404 }
1405 newterm = AT.WorkPointer;
1406 if ( EndSort(BHEAD newterm,1) < 0 ) {}
1407 if ( ( *newterm && *(newterm+*newterm) != 0 ) || *newterm == 0 ) {
1408 MLOCK(ErrorMessageLock);
1409 MesPrint("&information in replace transformation does not evaluate into a single term");
1410 MUNLOCK(ErrorMessageLock);
1411 return(-1);
1412 }
1413 AR.Eside = RHSIDE;
1414 i = *newterm; tt = term; nt = newterm;
1415 NCOPY(tt,nt,i);
1416 AT.WorkPointer = term + *term;
1417 info = term + 1;
1418
1419 term1 = term + *term;
1420 term2 = term1+1;
1421 *term2++ = REPLACEMENT;
1422 term2++; FILLFUN(term2)
1423/*
1424 First we count the different types of objects
1425*/
1426 infoend = info + info[1];
1427 info1 = info + FUNHEAD;
1428 nfix = nwild = ngeneral = 0;
1429 while ( info1 < infoend ) {
1430 if ( *info1 == -SNUMBER ) {
1431 nfix++;
1432 info1 += 2; NEXTARG(info1)
1433 }
1434 else if ( *info1 <= -FUNCTION ) {
1435 if ( *info1 == -WILDARGFUN ) {
1436 nwild++;
1437 info1++; NEXTARG(info1)
1438 }
1439 else {
1440 *term2++ = *info1++; COPY1ARG(term2,info1)
1441 ngeneral++;
1442 }
1443 }
1444 else if ( *info1 == -INDEX ) {
1445 if ( info1[1] == WILDARGINDEX + AM.OffsetIndex ) {
1446 nwild++;
1447 info1 += 2; NEXTARG(info1)
1448 }
1449 else {
1450 *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1451 ngeneral++;
1452 }
1453 }
1454 else if ( *info1 == -SYMBOL ) {
1455 if ( info1[1] == WILDARGSYMBOL ) {
1456 nwild++;
1457 info1 += 2; NEXTARG(info1)
1458 }
1459 else {
1460 *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1461 ngeneral++;
1462 }
1463 }
1464 else if ( *info1 == -MINVECTOR || *info1 == -VECTOR ) {
1465 if ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) {
1466 nwild++;
1467 info1 += 2; NEXTARG(info1)
1468 }
1469 else {
1470 *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1471 ngeneral++;
1472 }
1473 }
1474 else {
1475 MLOCK(ErrorMessageLock);
1476 MesPrint("&irregular code found in replace transformation (RunReplace)");
1477 MUNLOCK(ErrorMessageLock);
1478 Terminate(-1);
1479 }
1480 }
1481 AT.WorkPointer = term2;
1482 *term1 = term2 - term1;
1483 term1[2] = *term1 - 1;
1484/*
1485 And now stepping through the arguments
1486*/
1487 while ( t < tstop ) {
1488 n++; /* The number of the argument. Now check whether we need it */
1489 if ( TestArgNum(n,totarg,args) == 0 ) {
1490 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1491 if ( *t <= -FUNCTION ) { *u++ = *t++; }
1492 else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1493 else { i = *t; NCOPY(u,t,i) }
1494 }
1495 else *u++ = *t++;
1496 continue;
1497 }
1498/*
1499 Here we have in info effectively a replace_ function, but with
1500 additionally the possibility of integer arguments. We treat those first
1501 and for the rest we have to do some pattern matching.
1502 Note that the compilation routine should check that there is an
1503 even number of arguments in the replace function.
1504
1505 First we go for number -> something
1506*/
1507 doanyway = 0;
1508 if ( nfix > 0 ) {
1509 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1510 if ( *t == -SNUMBER ) {
1511 info1 = info + FUNHEAD;
1512 while ( info1 < infoend ) {
1513 if ( *info1 == -SNUMBER ) {
1514 if ( info1[1] == t[1] ) {
1515 if ( info1[2] == -SNUMBER ) {
1516 *u++ = -SNUMBER; *u++ = info1[3];
1517 info1 += 4;
1518 }
1519 else {
1520 info1 += 2;
1521 if ( info1[0] <= -FUNCTION ) i = 1;
1522 else if ( info1[0] < 0 ) i = 2;
1523 else i = *info1;
1524 NCOPY(u,info1,i)
1525 }
1526 t += 2; goto nextt;
1527 }
1528 info1 += 2;
1529 NEXTARG(info1);
1530 }
1531 else {
1532 NEXTARG(info1);
1533 NEXTARG(info1);
1534 }
1535 }
1536/*
1537 Here we had no match in the style of 1->2. It could however
1538 be that xarg_ does something
1539*/
1540 doanyway = 1; n2 = t[1];
1541 }
1542 }
1543 else { /* Tensor */
1544 if ( *t < AM.OffsetIndex && *t >= 0 ) {
1545 info1 = info + FUNHEAD;
1546 while ( info1 < infoend ) {
1547 if ( ( *info1 == -SNUMBER ) && ( info1[1] == *t )
1548 && ( ( ( info1[2] == -SNUMBER ) && ( info1[3] >= 0 )
1549 && ( info1[3] < AM.OffsetIndex ) )
1550 || ( info1[2] == -INDEX || info1[2] == -VECTOR
1551 || info1[2] == -MINVECTOR ) ) ) {
1552 *u++ = info1[3];
1553 info1 += 4;
1554 t++; goto nextt;
1555 }
1556 else {
1557 NEXTARG(info1);
1558 NEXTARG(info1);
1559 }
1560 }
1561 }
1562 }
1563 }
1564 else if ( *t == -SNUMBER ) {
1565 doanyway = 1; n2 = t[1];
1566 }
1567/*
1568 First we try to catch those elements that have an exact match
1569 in the traditional replace_ part.
1570 This means that *t should be less than zero and match an entry
1571 in the replace_ function that we prepared.
1572*/
1573 if ( ngeneral > 0 ) {
1574 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1575 if ( *t < 0 ) {
1576 term3 = term1 + *term1;
1577 term4 = term1 + FUNHEAD;
1578 while ( term4 < term3 ) {
1579 if ( *term4 == *t && ( *t <= -FUNCTION ||
1580 ( t[1] == term4[1] ) ) ) break;
1581 NEXTARG(term4)
1582 }
1583 if ( term4 < term3 ) goto dothisnow;
1584 }
1585 }
1586 else {
1587 term3 = term1 + *term1;
1588 term4 = term1 + FUNHEAD;
1589 while ( term4 < term3 ) {
1590 if ( ( term4[1] == *t ) &&
1591 ( ( *term4 == -INDEX || *term4 == -VECTOR ||
1592 ( *term4 == -SYMBOL && term4[1] < AM.OffsetIndex
1593 && term4[1] >= 0 ) ) ) ) break;
1594 NEXTARG(term4)
1595 }
1596 if ( term4 < term3 ) goto dothisnow;
1597 }
1598 }
1599/*
1600 First we eliminate the fixed arguments and make a 'new info'
1601 If there is anything left we can continue.
1602 Now we look for whole argument wildcards (arg_, parg_, iarg_ or farg_)
1603*/
1604 if ( nwild > 0 ) {
1605/*
1606 If we have f(a)*replace_(xarg_,b(xarg_)) this gives f(b(a))
1607 In testing the wildcard we have CheckWild do the work.
1608 This means that we have to set op the special variables
1609 (AT.WildMask,AN.WildValue,AN.NumWild)
1610
1611*/
1612 wild[1] = 4;
1613 info1 = info + FUNHEAD;
1614 while ( info1 < infoend ) {
1615 if ( *info1 == -SYMBOL && info1[1] == WILDARGSYMBOL
1616 && ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) ) {
1617 wild[0] = SYMTOSUB;
1618 wild[2] = WILDARGSYMBOL;
1619 wild[3] = 0;
1620 AN.WildValue = wild;
1621 AT.WildMask = &mask;
1622 mask = 0;
1623 AN.NumWild = 1;
1624 if ( *t == -SYMBOL || ( *t > 0 && CheckWild(BHEAD WILDARGSYMBOL,SYMTOSUB,1,t) == 0 )
1625 || doanyway ) {
1626/*
1627 We put the part in replace in a function and make
1628 a replace_(xarg_,(t argument)).
1629*/
1630 n1 = SYMBOL; n2 = WILDARGSYMBOL;
1631 info1 += 2;
1632getthisone:;
1633 term3 = term2+1;
1634 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1635 *term3++ = DUMFUN; term3++; FILLFUN(term3)
1636 COPY1ARG(term3,info1)
1637 }
1638 else {
1639 *term3++ = fun[0]; term3++; FILLFUN(term3)
1640 *term3++ = *info1;
1641 }
1642 term2[2] = term3 - term2 - 1;
1643 tt = term3;
1644 *term3++ = REPLACEMENT;
1645 term3++; FILLFUN(term3)
1646 *term3++ = -n1;
1647 if ( n1 < FUNCTION ) *term3++ = n2;
1648 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1649 term4 = t;
1650 COPY1ARG(term3,term4)
1651 }
1652 else {
1653 *term3++ = *t;
1654 }
1655 tt[1] = term3 - tt;
1656 *term3++ = 1; *term3++ = 1; *term3++ = 3;
1657 *term2 = term3 - term2;
1658
1659 AT.WorkPointer = term3;
1660 NewSort(BHEAD0);
1661 if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1662 LowerSortLevel();
1663 AT.WorkPointer = oldwork;
1664 AT.WildMask = oldmask;
1665 return(-1);
1666 }
1667 term4 = AT.WorkPointer;
1668 if ( EndSort(BHEAD term4,1) < 0 ) {}
1669 if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1670 MLOCK(ErrorMessageLock);
1671 MesPrint("&information in replace transformation does not evaluate into a single term");
1672 MUNLOCK(ErrorMessageLock);
1673 return(-1);
1674 }
1675/*
1676 Now we can copy the new function argument to the output u
1677*/
1678 i = term4[2]-FUNHEAD;
1679 term3 = term4+FUNHEAD+1;
1680 NCOPY(u,term3,i)
1681 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1682 NEXTARG(t)
1683 }
1684 else t++;
1685 AT.WorkPointer = term2;
1686
1687 goto nextt;
1688 }
1689 info1 += 2; NEXTARG(info1)
1690 }
1691 else if ( ( *info1 == -INDEX )
1692 && ( info[1] == WILDARGINDEX + AM.OffsetIndex ) ) {
1693 wild[0] = INDTOSUB;
1694 wild[2] = WILDARGINDEX+AM.OffsetIndex;
1695 wild[3] = 0;
1696 AN.WildValue = wild;
1697 AT.WildMask = &mask;
1698 mask = 0;
1699 AN.NumWild = 1;
1700 if ( ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION )
1701 || ( *t == -INDEX || ( *t > 0 && CheckWild(BHEAD WILDARGINDEX,INDTOSUB,1,t) == 0 ) ) ) {
1702/*
1703 We put the part in replace in a function and make
1704 a replace_(xarg_,(t argument)).
1705*/
1706 n1 = INDEX; n2 = WILDARGINDEX+AM.OffsetIndex;
1707 info1 += 2;
1708 goto getthisone;
1709 }
1710 info1 += 2; NEXTARG(info1)
1711 }
1712 else if ( ( *info1 == -VECTOR )
1713 && ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) ) {
1714 wild[0] = VECTOSUB;
1715 wild[2] = WILDARGVECTOR+AM.OffsetVector;
1716 wild[3] = 0;
1717 AN.WildValue = wild;
1718 AT.WildMask = &mask;
1719 mask = 0;
1720 AN.NumWild = 1;
1721 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
1722 if ( *t < MINSPEC ) {
1723 n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1724 info1 += 2;
1725 goto getthisone;
1726 }
1727 }
1728 else if ( *t == -VECTOR || *t == -MINVECTOR ||
1729 ( *t > 0 && CheckWild(BHEAD WILDARGVECTOR,VECTOSUB,1,t) == 0 ) ) {
1730/*
1731 We put the part in replace in a function and make
1732 a replace_(xarg_,(t argument)).
1733*/
1734 n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1735 info1 += 2;
1736 goto getthisone;
1737 }
1738 info1 += 2; NEXTARG(info1)
1739 }
1740 else if ( *info1 == -WILDARGFUN ) {
1741 wild[0] = FUNTOFUN;
1742 wild[2] = WILDARGFUN;
1743 wild[3] = 0;
1744 AN.WildValue = wild;
1745 AT.WildMask = &mask;
1746 mask = 0;
1747 AN.NumWild = 1;
1748 if ( *t <= -FUNCTION || ( *t > 0 && CheckWild(BHEAD WILDARGFUN,FUNTOFUN,1,t) == 0 ) ) {
1749/*
1750 We put the part in replace in a function and make
1751 a replace_(xarg_,(t argument)).
1752*/
1753 n2 = n1 = -WILDARGFUN; /* n2 is to keep the compiler quiet */
1754 info1++;
1755 goto getthisone;
1756 }
1757 info1++; NEXTARG(info1)
1758 }
1759 else {
1760 NEXTARG(info1) NEXTARG(info1)
1761 }
1762 }
1763 }
1764 if ( ngeneral > 0 ) {
1765/*
1766 They are all in a replace_ function.
1767 Compose the whole thing into a term with replace_()*dum_(arg)
1768 which will be given to Generator.
1769 If we have f(a(x))*replace_(x,b) this gives f(a(b))
1770*/
1771dothisnow:;
1772 term3 = term2; term4 = term1; i = *term1;
1773 NCOPY(term3,term4,i)
1774 term4 = term3;
1775 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1776 *term3++ = DUMFUN; term3++; FILLFUN(term3);
1777 tt = t;
1778 COPY1ARG(term3,tt)
1779 }
1780 else {
1781 *term3++ = fun[0]; term3++; FILLFUN(term3); *term3++ = *t;
1782 }
1783 term4[1] = term3-term4;
1784 *term3++ = 1; *term3++ = 1; *term3++ = 3;
1785 *term2 = term3-term2;
1786 AT.WorkPointer = term3;
1787 NewSort(BHEAD0);
1788 if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1789 LowerSortLevel();
1790 AT.WorkPointer = oldwork;
1791 AT.WildMask = oldmask;
1792 return(-1);
1793 }
1794 term4 = AT.WorkPointer;
1795 if ( EndSort(BHEAD term4,1) < 0 ) {}
1796 if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1797 MLOCK(ErrorMessageLock);
1798 MesPrint("&information in replace transformation does not evaluate into a single term");
1799 MUNLOCK(ErrorMessageLock);
1800 return(-1);
1801 }
1802/*
1803 Now we can copy the new function argument to the output u
1804*/
1805 i = term4[2]-FUNHEAD;
1806 term3 = term4+FUNHEAD+1;
1807 NCOPY(u,term3,i)
1808 NEXTARG(t)
1809 AT.WorkPointer = term2;
1810
1811 goto nextt;
1812 }
1813
1814/*
1815 No catch. Copy the argument and continue.
1816*/
1817 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1818 if ( *t <= -FUNCTION ) { *u++ = *t++; }
1819 else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1820 else { i = *t; NCOPY(u,t,i) }
1821 }
1822 else {
1823 *u++ = *t++;
1824 }
1825nextt:;
1826 }
1827 i = u - tstop; tstop[1] = i; tstop[2] = dirty;
1828 t = fun; u = tstop; NCOPY(t,u,i)
1829 AT.WorkPointer = oldwork;
1830 AT.WildMask = oldmask;
1831 return(0);
1832}
1833
1834/*
1835 #] RunReplace :
1836 #[ RunImplode :
1837
1838 Note that we restrict ourselves to short integers and/or single symbols
1839*/
1840
1841int RunImplode(WORD *fun, WORD *args)
1842{
1843 GETIDENTITY
1844 WORD *tt, *tstop, totarg, arg1, arg2, num1, num2, i1, n;
1845 WORD *f, *t, *ttt, *t4, *ff, *fff;
1846 WORD moveup, numzero, outspace;
1847 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1848 if ( *args != ARGRANGE ) {
1849 MLOCK(ErrorMessageLock);
1850 MesPrint("Illegal range encountered in RunImplode");
1851 MUNLOCK(ErrorMessageLock);
1852 Terminate(-1);
1853 }
1854 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1855 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1856 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
1857/*
1858 Get the proper range in forward direction and the number of arguments
1859*/
1860 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1861 else { num1 = arg1; num2 = arg2; }
1862 if ( num1 > totarg || num2 > totarg ) return(0);
1863/*
1864 We need, for the most general case 4 spots for each:
1865 x,pow,coef,sign
1866 Hence we put these in the workspace above the term after tstop
1867*/
1868 n = 1; f = fun+FUNHEAD;
1869 while ( n < num1 ) {
1870 if ( f >= tstop ) return(0);
1871 NEXTARG(f);
1872 n++;
1873 }
1874 ff = f;
1875/*
1876 We are now at the first argument to be done
1877 Go through the terms and test their validity.
1878 If one of them doesn't conform to the rules we don't do anything.
1879 The terms to be done are put in special notation after the function.
1880 Notation: numsymbol, power, |coef|, sign
1881 If numsymbol is negative there is no symbol.
1882 We do it this way because otherwise stepping backwards (as in range=(4,1))
1883 would be very difficult.
1884*/
1885 tt = tstop;
1886 while ( n <= num2 ) {
1887 if ( f >= tstop ) return(0);
1888 if ( *f == -SNUMBER ) { *tt++ = -1; *tt++ = 0;
1889 if ( f[1] < 0 ) { *tt++ = -f[1]; *tt++ = -1; }
1890 else { *tt++ = f[1]; *tt++ = 1; }
1891 f += 2;
1892 }
1893 else if ( *f == -SYMBOL ) { *tt++ = f[1]; *tt++ = 1; *tt++ = 1; *tt++ = 1; f += 2; }
1894 else if ( *f < 0 ) return(0);
1895 else {
1896 if ( *f != ( f[ARGHEAD]+ARGHEAD ) ) return(0); /* Not a single term */
1897 t = f + *f - 1;
1898 i1 = ABS(*t);
1899 if ( ( i1 > 3 ) || ( t[-1] != 1 ) ) return(0); /* Not an integer or too big */
1900 if ( (UWORD)(t[-2]) > MAXPOSITIVE4 ) return(0); /* number too big */
1901 if ( f[ARGHEAD] == i1+1 ) { /* numerical which is fine */
1902 *tt++ = -1; *tt++ = 0; *tt++ = t[-2];
1903 if ( *t < 0 ) { *tt++ = -1; }
1904 else { *tt++ = 1; }
1905 }
1906 else if ( ( f[ARGHEAD+1] != SYMBOL )
1907 || ( f[ARGHEAD+2] != 4 )
1908 || ( ( f+ARGHEAD+1+f[ARGHEAD+2] ) < ( t-i1 ) ) ) return(0);
1909 /* not a single symbol with a coefficient */
1910 else {
1911 *tt++ = f[ARGHEAD+3];
1912 *tt++ = f[ARGHEAD+4];
1913 *tt++ = t[-2];
1914 if ( *t < 0 ) { *tt++ = -1; }
1915 else { *tt++ = 1; }
1916 }
1917 f += *f;
1918 }
1919 n++;
1920 }
1921 fff = f;
1922/*
1923 At this point we can do the implosion.
1924 Requirement: no coefficient shall take more than one word.
1925 (a stricter requirement may be needed to keep the explosion contained)
1926*/
1927 if ( arg1 > arg2 ) {
1928/*
1929 Work backward.
1930*/
1931 t = tt - 4; numzero = 0;
1932 while ( t >= tstop ) {
1933 if ( t[2] == 0 ) numzero++;
1934 else {
1935 if ( numzero > 0 ) {
1936 t[2] += numzero;
1937 t4 = t+4;
1938 ttt = t4 + 4*numzero;
1939 while ( ttt < tt ) *t4++ = *ttt++;
1940 tt -= 4*numzero;
1941 numzero = 0;
1942 }
1943 }
1944 t -= 4;
1945 }
1946 }
1947 else {
1948 t = tstop;
1949 numzero = 0; ttt = t;
1950 while ( t < tt ) {
1951 if ( t[2] == 0 ) numzero++;
1952 else {
1953 if ( numzero > 0 ) {
1954 t[2] += numzero;
1955 t4 = t;
1956 while ( t4 < tt ) *ttt++ = *t4++;
1957 tt -= 4*numzero;
1958 t -= 4*numzero;
1959 ttt = t + 4;
1960 numzero = 0;
1961 }
1962 else {
1963 ttt = t + 4;
1964 }
1965 }
1966 t += 4;
1967 }
1968/*
1969 We may have numzero > 0 at the end. We leave them.
1970 Output space is currently from tstop to tt
1971*/
1972 }
1973/*
1974 Now we compute the real output space needed
1975*/
1976 t = tstop; outspace = 0;
1977 while ( t < tt ) {
1978 if ( t[0] == -1 ) {
1979 if ( t[2] > MAXPOSITIVE4 ) { return(0); /* Number too big */ }
1980 outspace += 2;
1981 }
1982 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) { outspace += 2; }
1983 else { outspace += 8 + ARGHEAD; }
1984 t += 4;
1985 }
1986 if ( outspace < (fff-ff) ) {
1987 t = tstop;
1988 while ( t < tt ) {
1989 if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
1990 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
1991 *ff++ = -SYMBOL; *ff++ = t[0];
1992 }
1993 else {
1994 *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
1995 *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
1996 *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
1997 }
1998 t += 4;
1999 }
2000 while ( fff < tstop ) *ff++ = *fff++;
2001 fun[1] = ff - fun;
2002 }
2003 else if ( outspace > (fff-ff) ) {
2004/*
2005 Move the answer up by the required amount.
2006 Move the tail to its new location
2007 Move in things as for outspace == (fff-ff)
2008*/
2009 moveup = outspace-(fff-ff);
2010 ttt = tt + moveup;
2011 t = tt;
2012 while ( t > fff ) *--ttt = *--t;
2013 tt += moveup; tstop += moveup;
2014 fff += moveup;
2015 fun[1] += moveup;
2016 goto moveinto;
2017 }
2018 else {
2019moveinto:
2020 t = tstop;
2021 while ( t < tt ) {
2022 if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
2023 else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
2024 *ff++ = -SYMBOL; *ff++ = t[0];
2025 }
2026 else {
2027 *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
2028 *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
2029 *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
2030 }
2031 t += 4;
2032 }
2033 }
2034 return(0);
2035}
2036
2037/*
2038 #] RunImplode :
2039 #[ RunExplode :
2040*/
2041
2042int RunExplode(PHEAD WORD *fun, WORD *args)
2043{
2044 WORD arg1, arg2, num1, num2, *tt, *tstop, totarg, *tonew, *newfun;
2045 WORD *ff, *f;
2046 int reverse = 0, iarg, i, numzero;
2047 if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
2048 if ( *args != ARGRANGE ) {
2049 MLOCK(ErrorMessageLock);
2050 MesPrint("Illegal range encountered in RunExplode");
2051 MUNLOCK(ErrorMessageLock);
2052 Terminate(-1);
2053 }
2054 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2055 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2056 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2057/*
2058 Get the proper range in forward direction and the number of arguments
2059*/
2060 if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; reverse = 1; }
2061 else { num1 = arg1; num2 = arg2; }
2062 if ( num1 > totarg || num2 > totarg ) return(0);
2063 if ( tstop + AM.MaxTer > AT.WorkTop ) goto OverWork;
2064/*
2065 We will make the new function after the old one in the workspace
2066 Find the first argument
2067*/
2068 tonew = newfun = tstop;
2069 ff = fun + FUNHEAD; iarg = 0;
2070 while ( ff < tstop ) {
2071 iarg++;
2072 if ( iarg == num1 ) {
2073 i = ff - fun; f = fun;
2074 NCOPY(tonew,f,i)
2075 break;
2076 }
2077 NEXTARG(ff)
2078 }
2079/*
2080 We have reached the first argument to be done
2081*/
2082 while ( iarg <= num2 ) {
2083 if ( *ff == -SYMBOL || ( *ff == -SNUMBER && ff[1] == 0 ) )
2084 { *tonew++ = *ff++; *tonew++ = *ff++; }
2085 else if ( *ff == -SNUMBER ) {
2086 numzero = ABS(ff[1])-1;
2087 if ( reverse ) {
2088 *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
2089 while ( numzero > 0 ) {
2090 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2091 }
2092 }
2093 else {
2094 while ( numzero > 0 ) {
2095 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2096 }
2097 *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
2098 }
2099 ff += 2;
2100 }
2101 else if ( *ff < 0 ) { return(0); }
2102 else {
2103 if ( *ff != ARGHEAD+8 || ff[ARGHEAD] != 8
2104 || ff[ARGHEAD+1] != SYMBOL || ABS(ff[ARGHEAD+7]) != 3
2105 || ff[ARGHEAD+6] != 1 ) return(0);
2106 numzero = ff[ARGHEAD+5];
2107 if ( numzero >= MAXPOSITIVE4 ) return(0);
2108 numzero--;
2109 if ( reverse ) {
2110 if ( ff[ARGHEAD+7] > 0 ) { *tonew++ = -SNUMBER; *tonew++ = 1; }
2111 else {
2112 *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
2113 *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = ff[ARGHEAD+3];
2114 *tonew++ = ff[ARGHEAD+4]; *tonew++ = 1; *tonew++ = 1;
2115 *tonew++ = -3;
2116 }
2117 while ( numzero > 0 ) {
2118 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2119 }
2120 }
2121 else {
2122 while ( numzero > 0 ) {
2123 *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
2124 }
2125 *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
2126 *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = 4;
2127 *tonew++ = ff[ARGHEAD+3]; *tonew++ = ff[ARGHEAD+4];
2128 *tonew++ = 1; *tonew++ = 1;
2129 if ( ff[ARGHEAD+7] > 0 ) *tonew++ = 3;
2130 else *tonew++ = -3;
2131 }
2132 ff += *ff;
2133 }
2134 if ( tonew > AT.WorkTop ) goto OverWork;
2135 iarg++;
2136 }
2137/*
2138 Copy the tail, settle the size and copy the whole thing back.
2139*/
2140 while ( ff < tstop ) *tonew++ = *ff++;
2141 i = newfun[1] = tonew-newfun;
2142 NCOPY(fun,newfun,i)
2143 return(0);
2144OverWork:;
2145 MLOCK(ErrorMessageLock);
2146 MesWork();
2147 MUNLOCK(ErrorMessageLock);
2148 return(-1);
2149}
2150
2151/*
2152 #] RunExplode :
2153 #[ RunPermute :
2154*/
2155
2156int RunPermute(PHEAD WORD *fun, WORD *args, WORD *info)
2157{
2158 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, *infostop;
2159 WORD *in, *iw, withdollar;
2160 DOLLARS d;
2161 if ( *args != ARGRANGE ) {
2162 MLOCK(ErrorMessageLock);
2163 MesPrint("Illegal range encountered in RunPermute");
2164 MUNLOCK(ErrorMessageLock);
2165 Terminate(-1);
2166 }
2167 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2168 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2169 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2170 arg1 = 1; arg2 = totarg;
2171/*
2172 We need to:
2173 1: get pointers to the arguments
2174 2: permute the pointers
2175 3: copy the arguments to safe territory in the new order
2176 4: copy this new order back in situ.
2177*/
2178 num = arg2-arg1+1;
2179 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2180 f = fun+FUNHEAD; n = 1; i = 0;
2181 while ( n < arg1 ) { n++; NEXTARG(f) }
2182 f1 = f;
2183 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2184/*
2185 Now the permutations
2186*/
2187 info++;
2188 while ( *info ) {
2189 infostop = info + *info;
2190 info++;
2191 if ( *info > totarg ) return(0);
2192/*
2193 Now we have a look whether there are dollar variables to be expanded
2194 We also shift out all values that are out of range.
2195*/
2196 withdollar = 0; in = info;
2197 while ( in < infostop ) {
2198 if ( *in < 0 ) { /* Dollar variable -(number+1) */
2199 d = Dollars - *in - 1;
2200#ifdef WITHPTHREADS
2201 {
2202 int nummodopt, dtype = -1, numdollar = -*in-1;
2203 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2204 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2205 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2206 }
2207 if ( nummodopt < NumModOptdollars ) {
2208 dtype = ModOptdollars[nummodopt].type;
2209 if ( dtype == MODLOCAL ) {
2210 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2211 }
2212 else {
2213 LOCK(d->pthreadslock);
2214 }
2215 }
2216 }
2217 }
2218#endif
2219 if ( ( d->type == DOLNUMBER || d->type == DOLTERMS )
2220 && d->where[0] == 4 && d->where[4] == 0 ) {
2221 if ( d->where[3] < 0 || d->where[2] != 1 || d->where[1] > totarg ) return(0);
2222 }
2223 else if ( d->type == DOLWILDARGS ) {
2224 iw = d->where+1;
2225 while ( *iw ) {
2226 if ( *iw == -SNUMBER ) {
2227 if ( iw[1] <= 0 || iw[1] > totarg ) return(0);
2228 }
2229 else goto IllType;
2230 iw += 2;
2231 }
2232 }
2233 else {
2234IllType:
2235 MLOCK(ErrorMessageLock);
2236 MesPrint("Illegal type of $-variable in RunPermute");
2237 MUNLOCK(ErrorMessageLock);
2238 Terminate(-1);
2239 }
2240 withdollar++;
2241 }
2242 else if ( *in > totarg ) return(0);
2243 in++;
2244 }
2245 if ( withdollar ) { /* We need some space for a copy */
2246 WORD *incopy, *tocopy;
2247 incopy = TermMalloc("RunPermute");
2248 tocopy = incopy+1; in = info;
2249 while ( in < infostop ) {
2250 if ( *in < 0 ) {
2251 d = Dollars - *in - 1;
2252#ifdef WITHPTHREADS
2253 {
2254 int nummodopt, dtype = -1, numdollar = -*in-1;
2255 if ( AS.MultiThreaded && ( AC.mparallelflag == PARALLELFLAG ) ) {
2256 for ( nummodopt = 0; nummodopt < NumModOptdollars; nummodopt++ ) {
2257 if ( numdollar == ModOptdollars[nummodopt].number ) break;
2258 }
2259 if ( nummodopt < NumModOptdollars ) {
2260 dtype = ModOptdollars[nummodopt].type;
2261 if ( dtype == MODLOCAL ) {
2262 d = ModOptdollars[nummodopt].dstruct+AT.identity;
2263 }
2264 else {
2265 LOCK(d->pthreadslock);
2266 }
2267 }
2268 }
2269 }
2270#endif
2271 if ( d->type == DOLNUMBER || d->type == DOLTERMS ) {
2272 *tocopy++ = d->where[1] - 1;
2273 }
2274 else if ( d->type == DOLWILDARGS ) {
2275 iw = d->where+1;
2276 while ( *iw ) {
2277 *tocopy++ = iw[1] - 1;
2278 iw += 2;
2279 }
2280 }
2281 in++;
2282 }
2283 else *tocopy++ = *in++;
2284 }
2285 *tocopy = 0;
2286 *incopy = tocopy - incopy;
2287 in = incopy+1;
2288 tt = AT.pWorkSpace[AT.pWorkPointer+*in];
2289 in++;
2290 while ( in < tocopy ) {
2291 if ( *in > totarg ) return(0);
2292 AT.pWorkSpace[AT.pWorkPointer+in[-1]] = AT.pWorkSpace[AT.pWorkPointer+*in];
2293 in++;
2294 }
2295 AT.pWorkSpace[AT.pWorkPointer+in[-1]] = tt;
2296 TermFree(incopy,"RunPermute");
2297 info = infostop;
2298 }
2299 else {
2300 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2301 info++;
2302 while ( info < infostop ) {
2303 if ( *info > totarg ) return(0);
2304 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2305 info++;
2306 }
2307 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2308 }
2309 }
2310/*
2311 info++;
2312 while ( *info ) {
2313 infostop = info + *info;
2314 info++;
2315 if ( *info > totarg ) return(0);
2316 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2317 info++;
2318 while ( info < infostop ) {
2319 if ( *info > totarg ) return(0);
2320 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2321 info++;
2322 }
2323 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2324 }
2325*/
2326/*
2327 And the final cleanup
2328*/
2329 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2330 f2 = tstop;
2331 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2332 i = f2 - tstop;
2333 NCOPY(f1,tstop,i)
2334 }
2335 else { /* tensors */
2336 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop-tt;
2337 arg1 = 1; arg2 = totarg;
2338 num = arg2-arg1+1;
2339 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2340 f = fun+FUNHEAD; n = 1; i = 0;
2341 while ( n < arg1 ) { n++; f++; }
2342 f1 = f;
2343 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2344/*
2345 Now the permutations
2346*/
2347 info++;
2348 while ( *info ) {
2349 infostop = info + *info;
2350 info++;
2351 if ( *info > totarg ) return(0);
2352 tt = AT.pWorkSpace[AT.pWorkPointer+*info];
2353 info++;
2354 while ( info < infostop ) {
2355 if ( *info > totarg ) return(0);
2356 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
2357 info++;
2358 }
2359 AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
2360 }
2361/*
2362 And the final cleanup
2363*/
2364 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2365 f2 = tstop;
2366 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++= *f++; }
2367 i = f2 - tstop;
2368 NCOPY(f1,tstop,i)
2369 }
2370 return(0);
2371OverWork:;
2372 MLOCK(ErrorMessageLock);
2373 MesWork();
2374 MUNLOCK(ErrorMessageLock);
2375 return(-1);
2376}
2377
2378/*
2379 #] RunPermute :
2380 #[ RunReverse :
2381*/
2382
2383int RunReverse(PHEAD WORD *fun, WORD *args)
2384{
2385 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, i1, i2;
2386 if ( *args != ARGRANGE ) {
2387 MLOCK(ErrorMessageLock);
2388 MesPrint("Illegal range encountered in RunReverse");
2389 MUNLOCK(ErrorMessageLock);
2390 Terminate(-1);
2391 }
2392 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2393 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2394 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2395 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2396/*
2397 We need to:
2398 1: get pointers to the arguments
2399 2: reverse the order of the pointers
2400 3: copy the arguments to safe territory in the new order
2401 4: copy this new order back in situ.
2402*/
2403 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2404 if ( arg2 > totarg ) return(0);
2405
2406 num = arg2-arg1+1;
2407 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2408 f = fun+FUNHEAD; n = 1; i = 0;
2409 while ( n < arg1 ) { n++; NEXTARG(f) }
2410 f1 = f;
2411 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2412 i1 = i-1; i2 = 0;
2413 while ( i1 > i2 ) {
2414 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2415 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2416 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2417 i1--; i2++;
2418 }
2419 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2420 f2 = tstop;
2421 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2422 i = f2 - tstop;
2423 NCOPY(f1,tstop,i)
2424 }
2425 else { /* Tensors */
2426 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2427 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2428/*
2429 We need to:
2430 1: get pointers to the arguments
2431 2: reverse the order of the pointers
2432 3: copy the arguments to safe territory in the new order
2433 4: copy this new order back in situ.
2434*/
2435 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2436 if ( arg2 > totarg ) return(0);
2437
2438 num = arg2-arg1+1;
2439 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2440 f = fun+FUNHEAD; n = 1; i = 0;
2441 while ( n < arg1 ) { n++; f++; }
2442 f1 = f;
2443 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2444 i1 = i-1; i2 = 0;
2445 while ( i1 > i2 ) {
2446 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2447 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2448 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2449 i1--; i2++;
2450 }
2451 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2452 f2 = tstop;
2453 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2454 i = f2 - tstop;
2455 NCOPY(f1,tstop,i)
2456 }
2457 return(0);
2458OverWork:;
2459 MLOCK(ErrorMessageLock);
2460 MesWork();
2461 MUNLOCK(ErrorMessageLock);
2462 return(-1);
2463}
2464
2465/*
2466 #] RunReverse :
2467 #[ RunDedup :
2468*/
2469
2470int RunDedup(PHEAD WORD *fun, WORD *args)
2471{
2472 WORD *tt, totarg, *tstop, arg1, arg2, n, i, j,k, *f, *f1, *f2, *fd, *fstart;
2473 if ( *args != ARGRANGE ) {
2474 MLOCK(ErrorMessageLock);
2475 MesPrint("Illegal range encountered in RunDedup");
2476 MUNLOCK(ErrorMessageLock);
2477 Terminate(-1);
2478 }
2479 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2480 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2481 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2482 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2483
2484 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2485 if ( arg2 > totarg ) return(0);
2486
2487 f = fun+FUNHEAD; n = 1;
2488 while ( n < arg1 ) { n++; NEXTARG(f) }
2489 f1 = f; // fast forward to first element in range
2490 i = 0; // new argument count
2491 fstart = f1;
2492
2493 for (; n <= arg2; n++ ) {
2494 f2 = fstart;
2495 for ( j = 0; j < i; j++ ) { // check all previous terms
2496 fd = f2;
2497 NEXTARG(fd)
2498 for ( k = 0; k < fd-f2; k++ ) // byte comparison of args
2499 if ( f2[k] != f[k] ) break;
2500
2501 if ( k == fd-f2 ) break; // duplicate arg
2502 f2 = fd;
2503 }
2504
2505 if ( j == i ) {
2506 // unique factor, copy in situ
2507 COPY1ARG(f1,f)
2508 i++;
2509 } else {
2510 NEXTARG(f)
2511 }
2512 }
2513
2514 // move the terms from after the range
2515 for (j = n; j <= totarg; j++) {
2516 COPY1ARG(f1,f)
2517 }
2518
2519 fun[1] = f1 - fun; // resize function
2520 }
2521 else { /* Tensors */
2522 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2523 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2524
2525 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2526 if ( arg2 > totarg ) return(0);
2527
2528 f = fun+FUNHEAD;
2529 i = arg1; // new argument count
2530 n = i;
2531
2532 for (; n <= arg2; n++ ) {
2533 for ( j = arg1; j < i; j++ ) { // check all previous terms
2534 if ( f[n-1] == f[j-1] ) break; // duplicate arg
2535 }
2536
2537 if ( j == i ) {
2538 // unique factor, copy in situ
2539 f[i-1] = f[n-1];
2540 i++;
2541 }
2542 }
2543
2544 // move the terms from after the range
2545 for (j = n; j <= totarg; j++, i++) {
2546 f[i-1] = f[j-1];
2547 }
2548
2549 fun[1] = f + i - 1 - fun; // resize function
2550 }
2551 return(0);
2552}
2553
2554/*
2555 #] RunDedup :
2556 #[ RunCycle :
2557*/
2558
2559int RunCycle(PHEAD WORD *fun, WORD *args, WORD *info)
2560{
2561 WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, j, *f, *f1, *f2, x, ncyc, cc;
2562 if ( *args != ARGRANGE ) {
2563 MLOCK(ErrorMessageLock);
2564 MesPrint("Illegal range encountered in RunCycle");
2565 MUNLOCK(ErrorMessageLock);
2566 Terminate(-1);
2567 }
2568 ncyc = info[1];
2569 if ( ncyc >= MAXPOSITIVE2 ) { /* $ variable */
2570 ncyc -= MAXPOSITIVE2;
2571 if ( ncyc >= MAXPOSITIVE4 ) {
2572 ncyc -= MAXPOSITIVE4; /* -$ */
2573 cc = -1;
2574 }
2575 else cc = 1;
2576 ncyc = DolToNumber(BHEAD ncyc);
2577 if ( AN.ErrorInDollar ) {
2578 MesPrint(" Error in Dollar variable in transform,cycle()=$");
2579 return(-1);
2580 }
2581 if ( ncyc >= MAXPOSITIVE4 || ncyc <= -MAXPOSITIVE4 ) {
2582 MesPrint(" Illegal value from Dollar variable in transform,cycle()=$");
2583 return(-1);
2584 }
2585 ncyc *= cc;
2586 }
2587 if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2588 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2589 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2590 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2591 if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2592 if ( arg2 > totarg ) return(0);
2593/*
2594 We need to:
2595 1: get pointers to the arguments
2596 2: cycle the pointers
2597 3: copy the arguments to safe territory in the new order
2598 4: copy this new order back in situ.
2599*/
2600 num = arg2-arg1+1;
2601 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2602 f = fun+FUNHEAD; n = 1; i = 0;
2603 while ( n < arg1 ) { n++; NEXTARG(f) }
2604 f1 = f;
2605 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2606/*
2607 Now the cycle(s). First minimize the number of cycles.
2608*/
2609 x = ncyc;
2610 if ( x >= i ) {
2611 x %= i;
2612 if ( x > i/2 ) x -= i;
2613 }
2614 else if ( x <= -i ) {
2615 x = -((-x) % i);
2616 if ( x <= -i/2 ) x += i;
2617 }
2618 while ( x ) {
2619 if ( x > 0 ) {
2620 tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2621 for ( j = i-1; j > 0; j-- )
2622 AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2623 AT.pWorkSpace[AT.pWorkPointer] = tt;
2624 x--;
2625 }
2626 else {
2627 tt = AT.pWorkSpace[AT.pWorkPointer];
2628 for ( j = 1; j < i; j++ )
2629 AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2630 AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2631 x++;
2632 }
2633 }
2634/*
2635 And the final cleanup
2636*/
2637 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2638 f2 = tstop;
2639 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2640 i = f2 - tstop;
2641 NCOPY(f1,tstop,i)
2642 }
2643 else { /* Tensors */
2644 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2645 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2646 if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2647 if ( arg2 > totarg ) return(0);
2648/*
2649 We need to:
2650 1: get pointers to the arguments
2651 2: cycle the pointers
2652 3: copy the arguments to safe territory in the new order
2653 4: copy this new order back in situ.
2654*/
2655 num = arg2-arg1+1;
2656 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2657 f = fun+FUNHEAD; n = 1; i = 0;
2658 while ( n < arg1 ) { n++; f++; }
2659 f1 = f;
2660 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2661/*
2662 Now the cycle(s). First minimize the number of cycles.
2663*/
2664 x = ncyc;
2665 if ( x >= i ) {
2666 x %= i;
2667 if ( x > i/2 ) x -= i;
2668 }
2669 else if ( x <= -i ) {
2670 x = -((-x) % i);
2671 if ( x <= -i/2 ) x += i;
2672 }
2673 while ( x ) {
2674 if ( x > 0 ) {
2675 tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2676 for ( j = i-1; j > 0; j-- )
2677 AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2678 AT.pWorkSpace[AT.pWorkPointer] = tt;
2679 x--;
2680 }
2681 else {
2682 tt = AT.pWorkSpace[AT.pWorkPointer];
2683 for ( j = 1; j < i; j++ )
2684 AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2685 AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2686 x++;
2687 }
2688 }
2689/*
2690 And the final cleanup
2691*/
2692 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2693 f2 = tstop;
2694 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2695 i = f2 - tstop;
2696 NCOPY(f1,tstop,i)
2697 }
2698 return(0);
2699OverWork:;
2700 MLOCK(ErrorMessageLock);
2701 MesWork();
2702 MUNLOCK(ErrorMessageLock);
2703 return(-1);
2704}
2705
2706/*
2707 #] RunCycle :
2708 #[ RunAddArg :
2709*/
2710
2711int RunAddArg(PHEAD WORD *fun, WORD *args)
2712{
2713 WORD *tt, totarg, *tstop, arg1, arg2, n, num, *f, *f1, *f2;
2714 WORD scribble[10+ARGHEAD];
2715 LONG space;
2716 if ( *args != ARGRANGE ) {
2717 MLOCK(ErrorMessageLock);
2718 MesPrint("Illegal range encountered in RunAddArg");
2719 MUNLOCK(ErrorMessageLock);
2720 Terminate(-1);
2721 }
2722 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2723 MLOCK(ErrorMessageLock);
2724 MesPrint("Illegal attempt to add arguments of a tensor in AddArg");
2725 MUNLOCK(ErrorMessageLock);
2726 Terminate(-1);
2727 }
2728 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2729 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2730 /* ignore functions with no arguments */
2731 if ( totarg == 0 ) return(0);
2732 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2733/*
2734 We need to:
2735 1: establish that we actually need to add something
2736 2: start a sort
2737 3: if needed, convert arguments to long arguments
2738 4: send (terms in) argument to StoreTerm
2739 5: EndSort and copy the result back into the function
2740 Note that the function is in the workspace, above the term and no
2741 relevant information is trailing it.
2742*/
2743 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2744 if ( arg2 > totarg ) return(0);
2745 num = arg2-arg1+1;
2746 if ( num == 1 ) return(0);
2747 f = fun+FUNHEAD; n = 1;
2748 while ( n < arg1 ) { n++; NEXTARG(f) }
2749 f1 = f;
2750 NewSort(BHEAD0);
2751 while ( n <= arg2 ) {
2752 if ( *f > 0 ) {
2753 f2 = f + *f; f += ARGHEAD;
2754 while ( f < f2 ) { StoreTerm(BHEAD f); f += *f; }
2755 }
2756 else if ( *f == -SNUMBER && f[1] == 0 ) {
2757 f+= 2;
2758 }
2759 else {
2760 ToGeneral(f,scribble,1);
2761 StoreTerm(BHEAD scribble);
2762 NEXTARG(f);
2763 }
2764 n++;
2765 }
2766 if ( EndSort(BHEAD tstop+ARGHEAD,1) < 0 ) return(-1);
2767 num = 0;
2768 f2 = tstop+ARGHEAD;
2769 while ( *f2 ) { f2 += *f2; num++; }
2770 *tstop = f2-tstop;
2771 for ( n = 1; n < ARGHEAD; n++ ) tstop[n] = 0;
2772 if ( num == 1 && ToFast(tstop,tstop) == 1 ) {
2773 f2 = tstop; NEXTARG(f2);
2774 }
2775 if ( *tstop == ARGHEAD ) {
2776 *tstop = -SNUMBER; tstop[1] = 0;
2777 f2 = tstop+2;
2778 }
2779/*
2780 Copy the trailing arguments after the new argument, then copy the whole back.
2781*/
2782 while ( f < tstop ) *f2++ = *f++;
2783 while ( f < f2 ) *f1++ = *f++;
2784 space = f1 - fun;
2785 if ( (space+8)*sizeof(WORD) > (UWORD)AM.MaxTer ) {
2786 MLOCK(ErrorMessageLock);
2787 MesWork();
2788 MUNLOCK(ErrorMessageLock);
2789 return(-1);
2790 }
2791 fun[1] = (WORD)space;
2792 return(0);
2793}
2794
2795/*
2796 #] RunAddArg :
2797 #[ RunMulArg :
2798*/
2799
2800int RunMulArg(PHEAD WORD *fun, WORD *args)
2801{
2802 WORD *t, totarg, *tstop, arg1, arg2, n, *f, nb, *m, i, *w;
2803 WORD *scratch, argbuf[20], argsize, *where, *newterm;
2804 LONG oldcpointer_pos;
2805 CBUF *C = cbuf + AT.ebufnum;
2806 if ( *args != ARGRANGE ) {
2807 MLOCK(ErrorMessageLock);
2808 MesPrint("Illegal range encountered in RunMulArg");
2809 MUNLOCK(ErrorMessageLock);
2810 Terminate(-1);
2811 }
2812 if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2813 MLOCK(ErrorMessageLock);
2814 MesPrint("Illegal attempt to multiply arguments of a tensor in MulArg");
2815 MUNLOCK(ErrorMessageLock);
2816 Terminate(-1);
2817 }
2818 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2819 while ( t < tstop ) { totarg++; NEXTARG(t); }
2820 /* ignore functions with no arguments */
2821 if ( totarg == 0 ) return(0);
2822 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2823 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2824 if ( arg1 > totarg ) return(0);
2825 if ( arg2 < 1 ) return(0);
2826 if ( arg1 < 1 ) arg1 = 1;
2827 if ( arg2 > totarg ) arg2 = totarg;
2828 if ( arg1 == arg2 ) return(0);
2829/*
2830 Now we move the arguments to a compiler buffer
2831 Then we create a term in the workspace that is the product of
2832 subexpression pointers to the objects in the compiler buffer.
2833 Next we let Generator work out that term.
2834 Finally we pick up the results from EndSort and put it in the function.
2835*/
2836 f = fun+FUNHEAD; n = 1;
2837 while ( n < arg1 ) { n++; NEXTARG(f) }
2838 t = f;
2839 if ( fun >= AT.WorkSpace && fun < AT.WorkTop ) {
2840 if ( AT.WorkPointer < fun+fun[1] ) AT.WorkPointer = fun+fun[1];
2841 }
2842 scratch = AT.WorkPointer;
2843 w = scratch+1;
2844 oldcpointer_pos = C->Pointer-C->Buffer;
2845 nb = C->numrhs;
2846 while ( n <= arg2 ) {
2847 if ( *t > 0 ) {
2848 argsize = *t - ARGHEAD; where = t + ARGHEAD; t += *t;
2849 }
2850 else if ( *t <= -FUNCTION ) {
2851 argbuf[0] = FUNHEAD+4; argbuf[1] = -*t++; argbuf[2] = FUNHEAD;
2852 for ( i = 2; i < FUNHEAD; i++ ) argbuf[i+1] = 0;
2853 argbuf[FUNHEAD+1] = 1;
2854 argbuf[FUNHEAD+2] = 1;
2855 argbuf[FUNHEAD+3] = 3;
2856 argsize = argbuf[0];
2857 where = argbuf;
2858 }
2859 else if ( *t == -SYMBOL ) {
2860 argbuf[0] = 8; argbuf[1] = SYMBOL; argbuf[2] = 4;
2861 argbuf[3] = t[1]; argbuf[4] = 1;
2862 argbuf[5] = 1; argbuf[6] = 1; argbuf[7] = 3;
2863 argsize = 8; t += 2;
2864 where = argbuf;
2865 }
2866 else if ( *t == -VECTOR || *t == -MINVECTOR ) {
2867 argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2868 argbuf[3] = t[1];
2869 argbuf[4] = 1; argbuf[5] = 1;
2870 if ( *t == -MINVECTOR ) argbuf[6] = -3;
2871 else argbuf[6] = 3;
2872 argsize = 7; t += 2;
2873 where = argbuf;
2874 }
2875 else if ( *t == -INDEX ) {
2876 argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2877 argbuf[3] = t[1];
2878 argbuf[4] = 1; argbuf[5] = 1; argbuf[6] = 3;
2879 argsize = 7; t += 2;
2880 where = argbuf;
2881 }
2882 else if ( *t == -SNUMBER ) {
2883 if ( t[1] < 0 ) {
2884 argbuf[0] = 4; argbuf[1] = -t[1]; argbuf[2] = 1; argbuf[3] = -3;
2885 }
2886 else {
2887 argbuf[0] = 4; argbuf[1] = t[1]; argbuf[2] = 1; argbuf[3] = 3;
2888 }
2889 argsize = 4; t += 2;
2890 where = argbuf;
2891 }
2892 else {
2893 /* unreachable */
2894 return(1);
2895 }
2896/*
2897 Now add the argbuf to AT.ebufnum
2898*/
2899 m = AddRHS(AT.ebufnum,1);
2900 while ( (m + argsize + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,17);
2901 for ( i = 0; i < argsize; i++ ) m[i] = where[i];
2902 m[i] = 0;
2903 C->Pointer = m + i + 1;
2904 n++;
2905 *w++ = SUBEXPRESSION; *w++ = SUBEXPSIZE; *w++ = C->numrhs; *w++ = 1;
2906 *w++ = AT.ebufnum; FILLSUB(w);
2907 }
2908 *w++ = 1; *w++ = 1; *w++ = 3;
2909 *scratch = w-scratch;
2910 AT.WorkPointer = w;
2911 NewSort(BHEAD0);
2912 Generator(BHEAD scratch,AR.Cnumlhs);
2913 newterm = AT.WorkPointer;
2914 EndSort(BHEAD newterm+ARGHEAD,1);
2915 C->Pointer = C->Buffer+oldcpointer_pos;
2916 C->numrhs = nb;
2917 w = newterm+ARGHEAD; while ( *w ) w += *w;
2918 *newterm = w-newterm; newterm[1] = 0;
2919 if ( ToFast(newterm,newterm) ) {
2920 if ( *newterm <= -FUNCTION ) w = newterm+1;
2921 else w = newterm+2;
2922 }
2923 while ( t < tstop ) *w++ = *t++;
2924 i = w - newterm;
2925 t = newterm; NCOPY(f,t,i);
2926 fun[1] = f-fun;
2927 AT.WorkPointer = scratch;
2928 if ( AT.WorkPointer > AT.WorkSpace && AT.WorkPointer < f ) AT.WorkPointer = f;
2929 return(0);
2930}
2931
2932/*
2933 #] RunMulArg :
2934 #[ RunIsLyndon :
2935
2936 Determines whether the range constitutes a Lyndon word.
2937 The two cases of ordering are distinguished by the order of
2938 the numbers of the arguments in the range.
2939*/
2940
2941int RunIsLyndon(PHEAD WORD *fun, WORD *args, int par)
2942{
2943 WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, n, i;
2944/* WORD *f1; */
2945 WORD sign, i1, i2, retval;
2946 if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2947 if ( *args != ARGRANGE ) {
2948 MLOCK(ErrorMessageLock);
2949 MesPrint("Illegal range encountered in RunIsLyndon");
2950 MUNLOCK(ErrorMessageLock);
2951 Terminate(-1);
2952 }
2953 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2954 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2955 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2956 if ( arg1 > totarg || arg2 > totarg ) return(-1);
2957/*
2958 Now make a list of the relevant arguments.
2959*/
2960 if ( arg1 == arg2 ) return(1);
2961 if ( arg2 < arg1 ) { /* greater, rather than smaller */
2962 arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2963 }
2964 else sign = 0;
2965
2966 num = arg2-arg1+1;
2967 WantAddPointers(num); /* Guarantees the presence of enough pointers */
2968 f = fun+FUNHEAD; n = 1; i = 0;
2969 while ( n < arg1 ) { n++; NEXTARG(f) }
2970/* f1 = f; */
2971 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2972/*
2973 If sign == 1 we should alter the order of the pointers first
2974*/
2975 if ( sign ) {
2976 i1 = i-1; i2 = 0;
2977 while ( i1 > i2 ) {
2978 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2979 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2980 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2981 i1--; i2++;
2982 }
2983 }
2984/*
2985 The argument range is from f1 to f and the num pointers to the arguments
2986 are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2987*/
2988 for ( i1 = 1; i1 < num; i1++ ) {
2989 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
2990 AT.pWorkSpace[AT.pWorkPointer]);
2991 if ( retval > 0 ) continue;
2992 if ( retval < 0 ) return(0);
2993 for ( i2 = 1; i2 < num; i2++ ) {
2994 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
2995 AT.pWorkSpace[AT.pWorkPointer+i2]);
2996 if ( retval < 0 ) return(0);
2997 if ( retval > 0 ) goto nexti1;
2998 }
2999/*
3000 If we come here the sequence is not unique.
3001*/
3002 return(0);
3003nexti1:;
3004 }
3005 return(1);
3006}
3007
3008/*
3009 #] RunIsLyndon :
3010 #[ RunToLyndon :
3011
3012 Determines whether the range constitutes a Lyndon word.
3013 If not, we rotate it to a Lyndon word. If this is not possible
3014 we return the noLyndon condition.
3015 The two cases of ordering are distinguished by the order of
3016 the numbers of the arguments in the range.
3017*/
3018
3019WORD RunToLyndon(PHEAD WORD *fun, WORD *args, int par)
3020{
3021 WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, *f1, *f2, n, i;
3022 WORD sign, i1, i2, retval, unique;
3023 if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
3024 if ( *args != ARGRANGE ) {
3025 MLOCK(ErrorMessageLock);
3026 MesPrint("Illegal range encountered in RunToLyndon");
3027 MUNLOCK(ErrorMessageLock);
3028 Terminate(-1);
3029 }
3030 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3031 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3032 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3033 if ( arg1 > totarg || arg2 > totarg ) return(-1);
3034/*
3035 Now make a list of the relevant arguments.
3036*/
3037 if ( arg1 == arg2 ) return(1);
3038 if ( arg2 < arg1 ) { /* greater, rather than smaller */
3039 arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
3040 }
3041 else sign = 0;
3042
3043 num = arg2-arg1+1;
3044 WantAddPointers((2*num)); /* Guarantees the presence of enough pointers */
3045 f = fun+FUNHEAD; n = 1; i = 0;
3046 while ( n < arg1 ) { n++; NEXTARG(f) }
3047 f1 = f;
3048 while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
3049/*
3050 If sign == 1 we should alter the order of the pointers first
3051*/
3052 if ( sign ) {
3053 i1 = i-1; i2 = 0;
3054 while ( i1 > i2 ) {
3055 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3056 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3057 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3058 i1--; i2++;
3059 }
3060 }
3061/*
3062 The argument range is from f1 to f and the num pointers to the arguments
3063 are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
3064*/
3065 unique = 1;
3066 for ( i1 = 1; i1 < num; i1++ ) {
3067 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
3068 AT.pWorkSpace[AT.pWorkPointer]);
3069 if ( retval > 0 ) continue;
3070 if ( retval < 0 ) {
3071Rotate:;
3072/*
3073 Rotate so that i1 becomes the zero element. Then start again.
3074*/
3075 for ( i2 = 0; i2 < num; i2++ ) {
3076 AT.pWorkSpace[AT.pWorkPointer+num+i2] =
3077 AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num];
3078 }
3079 for ( i2 = 0; i2 < num; i2++ ) {
3080 AT.pWorkSpace[AT.pWorkPointer+i2] =
3081 AT.pWorkSpace[AT.pWorkPointer+i2+num];
3082 }
3083 i1 = 0;
3084 goto nexti1;
3085 }
3086 for ( i2 = 1; i2 < num; i2++ ) {
3087 retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
3088 AT.pWorkSpace[AT.pWorkPointer+i2]);
3089 if ( retval < 0 ) goto Rotate;
3090 if ( retval > 0 ) goto nexti1;
3091 }
3092/*
3093 If we come here the sequence is not unique.
3094*/
3095 unique = 0;
3096nexti1:;
3097 }
3098 if ( sign ) {
3099 i1 = i-1; i2 = 0;
3100 while ( i1 > i2 ) {
3101 tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3102 AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3103 AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3104 i1--; i2++;
3105 }
3106 }
3107/*
3108 Now rewrite the arguments into the proper order
3109*/
3110 if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
3111 f2 = tstop;
3112 for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
3113 i = f2 - tstop;
3114 NCOPY(f1,tstop,i)
3115/*
3116 The return value indicates whether we have a Lyndon word
3117*/
3118 return(unique);
3119OverWork:;
3120 MLOCK(ErrorMessageLock);
3121 MesWork();
3122 MUNLOCK(ErrorMessageLock);
3123 return(-2);
3124}
3125
3126/*
3127 #] RunToLyndon :
3128 #[ RunDropArg :
3129*/
3130
3131int RunDropArg(PHEAD WORD *fun, WORD *args)
3132{
3133 WORD *t, *tstop, *f, totarg, arg1, arg2, n;
3134
3135 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3136 while ( t < tstop ) { totarg++; NEXTARG(t); }
3137 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3138 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3139 if ( arg1 > totarg ) return(0);
3140 if ( arg2 < 1 ) return(0);
3141 if ( arg1 < 1 ) arg1 = 1;
3142 if ( arg2 > totarg ) arg2 = totarg;
3143 f = fun+FUNHEAD; n = 1;
3144 while ( n < arg1 ) { n++; NEXTARG(f) }
3145 t = f;
3146 while ( n <= arg2 ) { n++; NEXTARG(t) }
3147 while ( t < tstop ) *f++ = *t++;
3148 fun[1] = f-fun;
3149 return(0);
3150}
3151
3152/*
3153 #] RunDropArg :
3154 #[ RunSelectArg :
3155*/
3156
3157int RunSelectArg(PHEAD WORD *fun, WORD *args)
3158{
3159 WORD *t, *tstop, *f, *tt, totarg, arg1, arg2, n;
3160
3161 t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3162 while ( t < tstop ) { totarg++; NEXTARG(t); }
3163 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3164 if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3165 if ( arg1 > totarg ) return(0);
3166 if ( arg2 < 1 ) return(0);
3167 if ( arg1 < 1 ) arg1 = 1;
3168 if ( arg2 > totarg ) arg2 = totarg;
3169 f = fun+FUNHEAD; n = 1; t = f;
3170 while ( n < arg1 ) { n++; NEXTARG(t) }
3171 while ( n <= arg2 ) {
3172 tt = t; NEXTARG(tt)
3173 while ( t < tt ) *f++ = *t++;
3174 n++;
3175 }
3176 fun[1] = f-fun;
3177 return(0);
3178}
3179
3180/*
3181 #] RunSelectArg :
3182 #[ RunZtoHArg :
3183*/
3184
3185int RunZtoHArg(PHEAD WORD *fun, WORD *args)
3186{
3187 WORD *tt, totarg, *tstop, arg1, arg2, n, i, *f, *f1;
3188 int sign = 0;
3189 WORD *t, *t1, *t2, *t3;
3190 if ( *args != ARGRANGE ) {
3191 MLOCK(ErrorMessageLock);
3192 MesPrint("Illegal range encountered in RunZtoHArg.");
3193 MUNLOCK(ErrorMessageLock);
3194 Terminate(-1);
3195 }
3196 if ( functions[fun[0]-FUNCTION].spec != 0 ) {
3197 MLOCK(ErrorMessageLock);
3198 MesPrint("The ZtoH transformation can only be executed on regular functions with nonzero integer arguments.");
3199 MUNLOCK(ErrorMessageLock);
3200 Terminate(-1);
3201 }
3202 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3203 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3204 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3205/*
3206 Check the arguments. Should be -SNUMBER x!=0
3207*/
3208 f = fun+FUNHEAD; n = 1;
3209 while ( n < arg1 ) { n++; NEXTARG(f) }
3210 f1 = f;
3211 for ( i = arg1; i <= arg2; i++, f += 2 ) {
3212 if ( *f != -SNUMBER || f[1] == 0 ) return(-1);
3213 }
3214/*
3215 Now we need a copy.
3216*/
3217 t = f1; t1 = t2 = tt = TermMalloc("RunZtoHArg");
3218 while ( t < f ) { *t1++ = *t++; *t1++ = *t++; }
3219 t = f1;
3220 while ( t2 < t1 ) {
3221 t += 2;
3222 if ( t2[1] < 0 ) {
3223 t3 = t;
3224 while ( t3 < f ) { t3[1] = -t3[1]; t3 += 2; }
3225 }
3226 t2 += 2;
3227 }
3228 TermFree(tt,"RunZtoHArg");
3229/*
3230 Now the overall sign.
3231*/
3232 while ( f1 < f ) { if ( f1[1] < 0 ) sign = 1-sign; f1 += 2; }
3233 return(sign);
3234}
3235
3236/*
3237 #] RunZtoHArg :
3238 #[ RunHtoZArg :
3239*/
3240
3241int RunHtoZArg(PHEAD WORD *fun, WORD *args)
3242{
3243 WORD *tt, totarg, *tstop, arg1, arg2, n, i, *f, *f1, *f2;
3244 int sign = 0;
3245 WORD *t, *t1, *t2;
3246 if ( *args != ARGRANGE ) {
3247 MLOCK(ErrorMessageLock);
3248 MesPrint("Illegal range encountered in RunZtoHArg.");
3249 MUNLOCK(ErrorMessageLock);
3250 Terminate(-1);
3251 }
3252 if ( functions[fun[0]-FUNCTION].spec != 0 ) {
3253 MLOCK(ErrorMessageLock);
3254 MesPrint("The HtoZ transformation can only be executed on regular functions with nonzero integer arguments.");
3255 MUNLOCK(ErrorMessageLock);
3256 Terminate(-1);
3257 }
3258 tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3259 while ( tt < tstop ) { totarg++; NEXTARG(tt); }
3260 if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3261/*
3262 Check the arguments. Should be -SNUMBER x!=0
3263*/
3264 f = fun+FUNHEAD; n = 1;
3265 while ( n < arg1 ) { n++; NEXTARG(f) }
3266 f2 = f1 = f;
3267 for ( i = arg1; i <= arg2; i++, f += 2 ) {
3268 if ( *f != -SNUMBER || f[1] == 0 ) return(-1);
3269 }
3270/*
3271 First the overall sign.
3272*/
3273 while ( f2 < f ) { if ( f2[1] < 0 ) sign = 1-sign; f2 += 2; }
3274/*
3275 Now we need a copy.
3276*/
3277 t = f1; t1 = tt = TermMalloc("RunHtoZArg");
3278 while ( t < f ) { *t1++ = *t++; *t1++ = *t++; }
3279/*
3280 Now the transformation.
3281*/
3282 t = f1; t2 = tt + 2;
3283 while ( t2 < t1 ) {
3284 t += 2;
3285 if ( t2[-1] < 0 ) t[1] = -t[1];
3286 t2 += 2;
3287 }
3288 TermFree(tt,"RunHtoZArg");
3289 return(sign);
3290}
3291
3292/*
3293 #] RunHtoZArg :
3294 #[ TestArgNum :
3295
3296 Looks whether argument n is contained in any of the ranges
3297 specified in args. Args contains objects of the types
3298 ALLARGS
3299 NUMARG,num
3300 ARGRANGE,num1,num2
3301 The object MAKEARGS,num1,num2 is skipped
3302 Any other object terminates the range specifications.
3303
3304 Currently only ARGRANGE is used (10-may-2016)
3305*/
3306
3307int TestArgNum(int n, int totarg, WORD *args)
3308{
3309 GETIDENTITY
3310 WORD x1, x2;
3311 for(;;) {
3312 switch ( *args ) {
3313 case ALLARGS:
3314 return(1);
3315 case NUMARG:
3316 if ( n == args[1] ) return(1);
3317 if ( args[1] >= MAXPOSITIVE4 ) {
3318 x1 = args[1]-MAXPOSITIVE4;
3319 if ( totarg-x1 == n ) return(1);
3320 }
3321 args += 2;
3322 break;
3323 case ARGRANGE:
3324 if ( args[1] >= MAXPOSITIVE2 ) {
3325 x1 = args[1] - MAXPOSITIVE2;
3326 if ( x1 > MAXPOSITIVE4 ) {
3327 x1 = x1 - MAXPOSITIVE4;
3328 x1 = DolToNumber(BHEAD x1);
3329 x1 = totarg - x1;
3330 }
3331 else {
3332 x1 = DolToNumber(BHEAD x1);
3333 }
3334 }
3335 else if ( args[1] >= MAXPOSITIVE4 ) {
3336 x1 = totarg-(args[1]-MAXPOSITIVE4);
3337 }
3338 else x1 = args[1];
3339 if ( args[2] >= MAXPOSITIVE2 ) {
3340 x2 = args[2] - MAXPOSITIVE2;
3341 if ( x2 > MAXPOSITIVE4 ) {
3342 x2 = x2 - MAXPOSITIVE4;
3343 x2 = DolToNumber(BHEAD x2);
3344 x2 = totarg - x2;
3345 }
3346 else {
3347 x2 = DolToNumber(BHEAD x2);
3348 }
3349 }
3350 else if ( args[2] >= MAXPOSITIVE4 ) {
3351 x2 = totarg-(args[2]-MAXPOSITIVE4);
3352 }
3353 else x2 = args[2];
3354 if ( x1 >= x2 ) {
3355 if ( n >= x2 && n <= x1 ) return(1);
3356 }
3357 else {
3358 if ( n >= x1 && n <= x2 ) return(1);
3359 }
3360 args += 3;
3361 break;
3362 case MAKEARGS:
3363 args += 3;
3364 break;
3365 default:
3366 return(0);
3367 }
3368 }
3369}
3370
3371/*
3372 #] TestArgNum :
3373 #[ PutArgInScratch :
3374*/
3375
3376WORD PutArgInScratch(WORD *arg,UWORD *scrat)
3377{
3378 WORD size, *t, i;
3379 if ( *arg == -SNUMBER ) {
3380 scrat[0] = ABS(arg[1]);
3381 if ( arg[1] < 0 ) size = -1;
3382 else size = 1;
3383 }
3384 else {
3385 t = arg+*arg-1;
3386 if ( *t < 0 ) { i = ((-*t)-1)/2; size = -i; }
3387 else { i = ( *t -1)/2; size = i; }
3388 t = arg+ARGHEAD+1;
3389 NCOPY(scrat,t,i);
3390 }
3391 return(size);
3392}
3393
3394/*
3395 #] PutArgInScratch :
3396 #[ ReadRange :
3397
3398 Comes in at the bracket and leaves at the = sign
3399 Ranges can be:
3400 #1,#2 with # numbers. If the second is smaller than the
3401 first we work it backwards.
3402 first,#2 or #2,first
3403 #1,last or last,#1
3404 first,last or last,first
3405 First is represented by 1. Last is represented by MAXPOSITIVE4.
3406
3407 par = 0: we need the = after.
3408 par = 1: we need a , or '\0' after.
3409 par = 2: we need a :
3410*/
3411
3412UBYTE *ReadRange(UBYTE *s, WORD *out, int par)
3413{
3414 UBYTE *in = s, *ss, c;
3415 LONG x1, x2;
3416
3417 SKIPBRA3(in)
3418 if ( par == 0 && in[1] != '=' ) {
3419 MesPrint("&A range in this type of transform statement should be followed by an = sign");
3420 return(0);
3421 }
3422 else if ( par == 1 && in[1] != ',' && in[1] != '\0' ) {
3423 MesPrint("&A range in this type of transform statement should be followed by a comma or end-of-statement");
3424 return(0);
3425 }
3426 else if ( par == 2 && in[1] != ':' ) {
3427 MesPrint("&A range in this type of transform statement should be followed by a :");
3428 return(0);
3429 }
3430 s++;
3431 if ( FG.cTable[*s] == 0 ) {
3432 ss = s; while ( FG.cTable[*s] == 0 ) s++;
3433 c = *s; *s = 0;
3434 if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3435 *s = c;
3436 x1 = 1;
3437 }
3438 else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3439 *s = c;
3440 if ( c == '-' ) {
3441 s++;
3442 if ( *s == '$' ) {
3443 s++; ss = s;
3444 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3445 c = *s; *s = 0;
3446 if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3447 *s = c;
3448 x1 += MAXPOSITIVE2;
3449 }
3450 else {
3451 x1 = 0;
3452 while ( *s >= '0' && *s <= '9' ) {
3453 x1 = 10*x1 + *s++ - '0';
3454 if ( x1 >= MAXPOSITIVE4 ) {
3455 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3456 return(0);
3457 }
3458 }
3459 }
3460 x1 += MAXPOSITIVE4;
3461 }
3462 else x1 = MAXPOSITIVE4;
3463 }
3464 else {
3465 MesPrint("&Illegal keyword inside range specification");
3466 return(0);
3467 }
3468 }
3469 else if ( FG.cTable[*s] == 1 ) {
3470 x1 = 0;
3471 while ( *s >= '0' && *s <= '9' ) {
3472 x1 = x1*10 + *s++ - '0';
3473 if ( x1 >= MAXPOSITIVE4 ) {
3474 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3475 return(0);
3476 }
3477 }
3478 }
3479 else if ( *s == '$' ) {
3480 s++; ss = s;
3481 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3482 c = *s; *s = 0;
3483 if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3484 *s = c;
3485 x1 += MAXPOSITIVE2;
3486 }
3487 else {
3488 MesPrint("&Illegal character in range specification");
3489 return(0);
3490 }
3491 if ( *s != ',' ) {
3492 MesPrint("&A range is two indicators, separated by a comma or blank");
3493 return(0);
3494 }
3495 s++;
3496 if ( FG.cTable[*s] == 0 ) {
3497 ss = s; while ( FG.cTable[*s] == 0 ) s++;
3498 c = *s; *s = 0;
3499 if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3500 *s = c;
3501 x2 = 1;
3502 }
3503 else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3504 *s = c;
3505 if ( c == '-' ) {
3506 s++;
3507 if ( *s == '$' ) {
3508 s++; ss = s;
3509 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3510 c = *s; *s = 0;
3511 if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3512 *s = c;
3513 x2 += MAXPOSITIVE2;
3514 }
3515 else {
3516 x2 = 0;
3517 while ( *s >= '0' && *s <= '9' ) {
3518 x2 = 10*x2 + *s++ - '0';
3519 if ( x2 >= MAXPOSITIVE4 ) {
3520 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3521 return(0);
3522 }
3523 }
3524 }
3525 x2 += MAXPOSITIVE4;
3526 }
3527 else x2 = MAXPOSITIVE4;
3528 }
3529 else {
3530 MesPrint("&Illegal keyword inside range specification");
3531 return(0);
3532 }
3533 }
3534 else if ( FG.cTable[*s] == 1 ) {
3535 x2 = 0;
3536 while ( *s >= '0' && *s <= '9' ) {
3537 x2 = x2*10 + *s++ - '0';
3538 if ( x2 >= MAXPOSITIVE4 ) {
3539 MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3540 return(0);
3541 }
3542 }
3543 }
3544 else if ( *s == '$' ) {
3545 s++; ss = s;
3546 while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3547 c = *s; *s = 0;
3548 if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3549 *s = c;
3550 x2 += MAXPOSITIVE2;
3551 }
3552 else {
3553 MesPrint("&Illegal character in range specification");
3554 return(0);
3555 }
3556 if ( s < in ) {
3557 MesPrint("&A range is two indicators, separated by a comma or blank between parentheses");
3558 return(0);
3559 }
3560 out[0] = x1; out[1] = x2;
3561 return(in+1);
3562Error:
3563 MesPrint("&Undefined variable $%s in range",ss);
3564 return(0);
3565}
3566
3567/*
3568 #] ReadRange :
3569 #[ FindRange :
3570*/
3571
3572int FindRange(PHEAD WORD *args, WORD *arg1, WORD *arg2, WORD totarg)
3573{
3574 WORD n[2], fromlast, i;
3575 for ( i = 0; i < 2; i++ ) {
3576 n[i] = args[i+1];
3577 fromlast = 0;
3578 if ( n[i] >= MAXPOSITIVE2 ) { /* This is a dollar variable */
3579 n[i] -= MAXPOSITIVE2;
3580 if ( n[i] >= MAXPOSITIVE4 ) {
3581 fromlast = 1;
3582 n[i] -= MAXPOSITIVE4; /* Now we have the number of the dollar variable */
3583 }
3584 n[i] = DolToNumber(BHEAD n[i]);
3585 if ( AN.ErrorInDollar ) {
3586 MLOCK(ErrorMessageLock);
3587 MesPrint("Illegal $ value in range while executing transform statement.");
3588 MUNLOCK(ErrorMessageLock);
3589 return(-1);
3590 }
3591 if ( fromlast ) n[i] = totarg-n[i];
3592 }
3593 else if ( n[i] >= MAXPOSITIVE4 ) { n[i] = totarg-(n[i]-MAXPOSITIVE4); }
3594 if ( n[i] <= 0 ) {
3595 MLOCK(ErrorMessageLock);
3596 MesPrint("Illegal non-positive value in range (%d) while executing transform statement.", i+1);
3597 MUNLOCK(ErrorMessageLock);
3598 return(-1);
3599 }
3600 }
3601 *arg1 = n[0];
3602 *arg2 = n[1];
3603 return(0);
3604}
3605
3606/*
3607 #] FindRange :
3608 #] Transform :
3609*/
SkipAName
UBYTE * SkipAName(UBYTE *s)
Definition compiler.c:443
AddNtoL
int AddNtoL(int n, WORD *array)
Definition comtool.c:288
AddRHS
WORD * AddRHS(int num, int type)
Definition comtool.c:214
DoubleCbuffer
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition comtool.c:143
EndSort
LONG EndSort(PHEAD WORD *, int)
Definition sort.c:454
Generator
int Generator(PHEAD WORD *, WORD)
Definition proces.c:3249
LowerSortLevel
void LowerSortLevel(void)
Definition sort.c:4661
StoreTerm
int StoreTerm(PHEAD WORD *)
Definition sort.c:4244
NewSort
int NewSort(PHEAD0)
Definition sort.c:359
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