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