FORM  4.2
transform.c
Go to the documentation of this file.
1 
5 /* #[ License : */
6 /*
7  * Copyright (C) 1984-2017 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 
85 static WORD tranarray[10] = { SUBEXPRESSION, SUBEXPSIZE, 0, 1, 0, 0, 0, 0, 0, 0 };
86 
87 int 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;
189 doreplace:
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;
260 doencode: *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 ) {
296 illsize: 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 
689 WORD 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 */
704 hit:;
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;
775 returnvalues:;
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) ) {
795  LowerSortLevel();
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 ) {
820 abortlyndon:;
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);
903 abo:
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 
922 WORD 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);
1097 CalledFrom:
1098  MLOCK(ErrorMessageLock);
1099  MesCall("RunEncode");
1100  MUNLOCK(ErrorMessageLock);
1101  return(-1);
1102 }
1103 
1104 /*
1105  #] RunEncode :
1106  #[ RunDecode :
1107 */
1108 
1109 WORD 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);
1260 CalledFrom:
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 
1279 WORD 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) ) {
1317  LowerSortLevel();
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;
1548 getthisone:;
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) ) {
1578  LowerSortLevel();
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 */
1687 dothisnow:;
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) ) {
1705  LowerSortLevel();
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  }
1741 nextt:;
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 
1757 WORD 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 {
1935 moveinto:
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 
1958 WORD 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);
2060 OverWork:;
2061  MLOCK(ErrorMessageLock);
2062  MesWork();
2063  MUNLOCK(ErrorMessageLock);
2064  return(-1);
2065 }
2066 
2067 /*
2068  #] RunExplode :
2069  #[ RunPermute :
2070 */
2071 
2072 WORD 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 {
2150 IllType:
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);
2287 OverWork:;
2288  MLOCK(ErrorMessageLock);
2289  MesWork();
2290  MUNLOCK(ErrorMessageLock);
2291  return(-1);
2292 }
2293 
2294 /*
2295  #] RunPermute :
2296  #[ RunReverse :
2297 */
2298 
2299 WORD 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);
2374 OverWork:;
2375  MLOCK(ErrorMessageLock);
2376  MesWork();
2377  MUNLOCK(ErrorMessageLock);
2378  return(-1);
2379 }
2380 
2381 /*
2382  #] RunReverse :
2383  #[ RunDedup :
2384 */
2385 
2386 WORD 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 
2475 WORD 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);
2615 OverWork:;
2616  MLOCK(ErrorMessageLock);
2617  MesWork();
2618  MUNLOCK(ErrorMessageLock);
2619  return(-1);
2620 }
2621 
2622 /*
2623  #] RunCycle :
2624  #[ RunAddArg :
2625 */
2626 
2627 WORD 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 /*
2690  Copy the trailing arguments after the new argument, then copy the whole back.
2691 */
2692  while ( f < tstop ) *f2++ = *f++;
2693  while ( f < f2 ) *f1++ = *f++;
2694  space = f1 - fun;
2695  if ( (space+8)*sizeof(WORD) > (UWORD)AM.MaxTer ) {
2696  MLOCK(ErrorMessageLock);
2697  MesWork();
2698  MUNLOCK(ErrorMessageLock);
2699  return(-1);
2700  }
2701  fun[1] = (WORD)space;
2702  return(0);
2703 }
2704 
2705 /*
2706  #] RunAddArg :
2707  #[ RunMulArg :
2708 */
2709 
2710 WORD RunMulArg(PHEAD WORD *fun, WORD *args)
2711 {
2712  WORD *t, totarg, *tstop, arg1, arg2, n, *f, nb, *m, i, *w;
2713  WORD *scratch, argbuf[20], argsize, *where, *newterm;
2714  LONG oldcpointer_pos;
2715  CBUF *C = cbuf + AT.ebufnum;
2716  if ( *args != ARGRANGE ) {
2717  MLOCK(ErrorMessageLock);
2718  MesPrint("Illegal range encountered in RunMulArg");
2719  MUNLOCK(ErrorMessageLock);
2720  Terminate(-1);
2721  }
2722  if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
2723  MLOCK(ErrorMessageLock);
2724  MesPrint("Illegal attempt to multiply arguments of a tensor in MulArg");
2725  MUNLOCK(ErrorMessageLock);
2726  Terminate(-1);
2727  }
2728  t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2729  while ( t < tstop ) { totarg++; NEXTARG(t); }
2730  if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2731  if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2732  if ( arg1 > totarg ) return(0);
2733  if ( arg2 < 1 ) return(0);
2734  if ( arg1 < 1 ) arg1 = 1;
2735  if ( arg2 > totarg ) arg2 = totarg;
2736  if ( arg1 == arg2 ) return(0);
2737 /*
2738  Now we move the arguments to a compiler buffer
2739  Then we create a term in the workspace that is the product of
2740  subexpression pointers to the objects in the compiler buffer.
2741  Next we let Generator work out that term.
2742  Finally we pick up the results from EndSort and put it in the function.
2743 */
2744  f = fun+FUNHEAD; n = 1;
2745  while ( n < arg1 ) { n++; NEXTARG(f) }
2746  t = f;
2747  if ( fun >= AT.WorkSpace && fun < AT.WorkTop ) {
2748  if ( AT.WorkPointer < fun+fun[1] ) AT.WorkPointer = fun+fun[1];
2749  }
2750  scratch = AT.WorkPointer;
2751  w = scratch+1;
2752  oldcpointer_pos = C->Pointer-C->Buffer;
2753  nb = C->numrhs;
2754  while ( n <= arg2 ) {
2755  if ( *t > 0 ) {
2756  argsize = *t - ARGHEAD; where = t + ARGHEAD; t += *t;
2757  }
2758  else if ( *t <= -FUNCTION ) {
2759  argbuf[0] = FUNHEAD+4; argbuf[1] = -*t++; argbuf[2] = FUNHEAD;
2760  for ( i = 2; i < FUNHEAD; i++ ) argbuf[i+1] = 0;
2761  argbuf[FUNHEAD+1] = 1;
2762  argbuf[FUNHEAD+2] = 1;
2763  argbuf[FUNHEAD+3] = 3;
2764  argsize = argbuf[0];
2765  where = argbuf;
2766  }
2767  else if ( *t == -SYMBOL ) {
2768  argbuf[0] = 8; argbuf[1] = SYMBOL; argbuf[2] = 4;
2769  argbuf[3] = t[1]; argbuf[4] = 1;
2770  argbuf[5] = 1; argbuf[6] = 1; argbuf[7] = 3;
2771  argsize = 8; t += 2;
2772  where = argbuf;
2773  }
2774  else if ( *t == -VECTOR || *t == -MINVECTOR ) {
2775  argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2776  argbuf[3] = t[1];
2777  argbuf[4] = 1; argbuf[5] = 1;
2778  if ( *t == -MINVECTOR ) argbuf[6] = -3;
2779  else argbuf[6] = 3;
2780  argsize = 7; t += 2;
2781  where = argbuf;
2782  }
2783  else if ( *t == -INDEX ) {
2784  argbuf[0] = 7; argbuf[1] = INDEX; argbuf[2] = 3;
2785  argbuf[3] = t[1];
2786  argbuf[4] = 1; argbuf[5] = 1; argbuf[6] = 3;
2787  argsize = 7; t += 2;
2788  where = argbuf;
2789  }
2790  else if ( *t == -SNUMBER ) {
2791  if ( t[1] < 0 ) {
2792  argbuf[0] = 4; argbuf[1] = -t[1]; argbuf[2] = 1; argbuf[3] = -3;
2793  }
2794  else {
2795  argbuf[0] = 4; argbuf[1] = t[1]; argbuf[2] = 1; argbuf[3] = 3;
2796  }
2797  argsize = 4; t += 2;
2798  where = argbuf;
2799  }
2800  else {
2801  /* unreachable */
2802  return(1);
2803  }
2804 /*
2805  Now add the argbuf to AT.ebufnum
2806 */
2807  m = AddRHS(AT.ebufnum,1);
2808  while ( (m + argsize + 10) > C->Top ) m = DoubleCbuffer(AT.ebufnum,m,17);
2809  for ( i = 0; i < argsize; i++ ) m[i] = where[i];
2810  m[i] = 0;
2811  C->Pointer = m + i + 1;
2812  n++;
2813  *w++ = SUBEXPRESSION; *w++ = SUBEXPSIZE; *w++ = C->numrhs; *w++ = 1;
2814  *w++ = AT.ebufnum; FILLSUB(w);
2815  }
2816  *w++ = 1; *w++ = 1; *w++ = 3;
2817  *scratch = w-scratch;
2818  AT.WorkPointer = w;
2819  NewSort(BHEAD0);
2820  Generator(BHEAD scratch,AR.Cnumlhs);
2821  newterm = AT.WorkPointer;
2822  EndSort(BHEAD newterm+ARGHEAD,0);
2823  C->Pointer = C->Buffer+oldcpointer_pos;
2824  C->numrhs = nb;
2825  w = newterm+ARGHEAD; while ( *w ) w += *w;
2826  *newterm = w-newterm; newterm[1] = 0;
2827  if ( ToFast(newterm,newterm) ) {
2828  if ( *newterm <= -FUNCTION ) w = newterm+1;
2829  else w = newterm+2;
2830  }
2831  while ( t < tstop ) *w++ = *t++;
2832  i = w - newterm;
2833  t = newterm; NCOPY(f,t,i);
2834  fun[1] = f-fun;
2835  AT.WorkPointer = scratch;
2836  if ( AT.WorkPointer > AT.WorkSpace && AT.WorkPointer < f ) AT.WorkPointer = f;
2837  return(0);
2838 }
2839 
2840 /*
2841  #] RunMulArg :
2842  #[ RunIsLyndon :
2843 
2844  Determines whether the range constitutes a Lyndon word.
2845  The two cases of ordering are distinguised by the order of
2846  the numbers of the arguments in the range.
2847 */
2848 
2849 WORD RunIsLyndon(PHEAD WORD *fun, WORD *args, int par)
2850 {
2851  WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, n, i;
2852 /* WORD *f1; */
2853  WORD sign, i1, i2, retval;
2854  if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2855  if ( *args != ARGRANGE ) {
2856  MLOCK(ErrorMessageLock);
2857  MesPrint("Illegal range encountered in RunIsLyndon");
2858  MUNLOCK(ErrorMessageLock);
2859  Terminate(-1);
2860  }
2861  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2862  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2863  if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2864  if ( arg1 > totarg || arg2 > totarg ) return(-1);
2865 /*
2866  Now make a list of the relevant arguments.
2867 */
2868  if ( arg1 == arg2 ) return(1);
2869  if ( arg2 < arg1 ) { /* greater, rather than smaller */
2870  arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2871  }
2872  else sign = 0;
2873 
2874  num = arg2-arg1+1;
2875  WantAddPointers(num); /* Guarantees the presence of enough pointers */
2876  f = fun+FUNHEAD; n = 1; i = 0;
2877  while ( n < arg1 ) { n++; NEXTARG(f) }
2878 /* f1 = f; */
2879  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2880 /*
2881  If sign == 1 we should alter the order of the pointers first
2882 */
2883  if ( sign ) {
2884  i1 = i-1; i2 = 0;
2885  while ( i1 > i2 ) {
2886  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2887  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2888  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2889  i1--; i2++;
2890  }
2891  }
2892 /*
2893  The argument range is from f1 to f and the num pointers to the arguments
2894  are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2895 */
2896  for ( i1 = 1; i1 < num; i1++ ) {
2897  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
2898  AT.pWorkSpace[AT.pWorkPointer]);
2899  if ( retval > 0 ) continue;
2900  if ( retval < 0 ) return(0);
2901  for ( i2 = 1; i2 < num; i2++ ) {
2902  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
2903  AT.pWorkSpace[AT.pWorkPointer+i2]);
2904  if ( retval < 0 ) return(0);
2905  if ( retval > 0 ) goto nexti1;
2906  }
2907 /*
2908  If we come here the sequence is not unique.
2909 */
2910  return(0);
2911 nexti1:;
2912  }
2913  return(1);
2914 }
2915 
2916 /*
2917  #] RunIsLyndon :
2918  #[ RunToLyndon :
2919 
2920  Determines whether the range constitutes a Lyndon word.
2921  If not, we rotate it to a Lyndon word. If this is not possible
2922  we return the noLyndon condition.
2923  The two cases of ordering are distinguised by the order of
2924  the numbers of the arguments in the range.
2925 */
2926 
2927 WORD RunToLyndon(PHEAD WORD *fun, WORD *args, int par)
2928 {
2929  WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, *f1, *f2, n, i;
2930  WORD sign, i1, i2, retval, unique;
2931  if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2932  if ( *args != ARGRANGE ) {
2933  MLOCK(ErrorMessageLock);
2934  MesPrint("Illegal range encountered in RunToLyndon");
2935  MUNLOCK(ErrorMessageLock);
2936  Terminate(-1);
2937  }
2938  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2939  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2940  if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
2941  if ( arg1 > totarg || arg2 > totarg ) return(-1);
2942 /*
2943  Now make a list of the relevant arguments.
2944 */
2945  if ( arg1 == arg2 ) return(1);
2946  if ( arg2 < arg1 ) { /* greater, rather than smaller */
2947  arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2948  }
2949  else sign = 0;
2950 
2951  num = arg2-arg1+1;
2952  WantAddPointers((2*num)); /* Guarantees the presence of enough pointers */
2953  f = fun+FUNHEAD; n = 1; i = 0;
2954  while ( n < arg1 ) { n++; NEXTARG(f) }
2955  f1 = f;
2956  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2957 /*
2958  If sign == 1 we should alter the order of the pointers first
2959 */
2960  if ( sign ) {
2961  i1 = i-1; i2 = 0;
2962  while ( i1 > i2 ) {
2963  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2964  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2965  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2966  i1--; i2++;
2967  }
2968  }
2969 /*
2970  The argument range is from f1 to f and the num pointers to the arguments
2971  are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2972 */
2973  unique = 1;
2974  for ( i1 = 1; i1 < num; i1++ ) {
2975  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
2976  AT.pWorkSpace[AT.pWorkPointer]);
2977  if ( retval > 0 ) continue;
2978  if ( retval < 0 ) {
2979 Rotate:;
2980 /*
2981  Rotate so that i1 becomes the zero element. Then start again.
2982 */
2983  for ( i2 = 0; i2 < num; i2++ ) {
2984  AT.pWorkSpace[AT.pWorkPointer+num+i2] =
2985  AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num];
2986  }
2987  for ( i2 = 0; i2 < num; i2++ ) {
2988  AT.pWorkSpace[AT.pWorkPointer+i2] =
2989  AT.pWorkSpace[AT.pWorkPointer+i2+num];
2990  }
2991  i1 = 0;
2992  goto nexti1;
2993  }
2994  for ( i2 = 1; i2 < num; i2++ ) {
2995  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
2996  AT.pWorkSpace[AT.pWorkPointer+i2]);
2997  if ( retval < 0 ) goto Rotate;
2998  if ( retval > 0 ) goto nexti1;
2999  }
3000 /*
3001  If we come here the sequence is not unique.
3002 */
3003  unique = 0;
3004 nexti1:;
3005  }
3006  if ( sign ) {
3007  i1 = i-1; i2 = 0;
3008  while ( i1 > i2 ) {
3009  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
3010  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
3011  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
3012  i1--; i2++;
3013  }
3014  }
3015 /*
3016  Now rewrite the arguments into the proper order
3017 */
3018  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
3019  f2 = tstop;
3020  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
3021  i = f2 - tstop;
3022  NCOPY(f1,tstop,i)
3023 /*
3024  The return value indicates whether we have a Lyndon word
3025 */
3026  return(unique);
3027 OverWork:;
3028  MLOCK(ErrorMessageLock);
3029  MesWork();
3030  MUNLOCK(ErrorMessageLock);
3031  return(-2);
3032 }
3033 
3034 /*
3035  #] RunToLyndon :
3036  #[ RunDropArg :
3037 */
3038 
3039 WORD RunDropArg(PHEAD WORD *fun, WORD *args)
3040 {
3041  WORD *t, *tstop, *f, totarg, arg1, arg2, n;
3042 
3043  t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3044  while ( t < tstop ) { totarg++; NEXTARG(t); }
3045  if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3046  if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3047  if ( arg1 > totarg ) return(0);
3048  if ( arg2 < 1 ) return(0);
3049  if ( arg1 < 1 ) arg1 = 1;
3050  if ( arg2 > totarg ) arg2 = totarg;
3051  f = fun+FUNHEAD; n = 1;
3052  while ( n < arg1 ) { n++; NEXTARG(f) }
3053  t = f;
3054  while ( n <= arg2 ) { n++; NEXTARG(t) }
3055  while ( t < tstop ) *f++ = *t++;
3056  fun[1] = f-fun;
3057  return(0);
3058 }
3059 
3060 /*
3061  #] RunDropArg :
3062  #[ RunSelectArg :
3063 */
3064 
3065 WORD RunSelectArg(PHEAD WORD *fun, WORD *args)
3066 {
3067  WORD *t, *tstop, *f, *tt, totarg, arg1, arg2, n;
3068 
3069  t = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
3070  while ( t < tstop ) { totarg++; NEXTARG(t); }
3071  if ( FindRange(BHEAD args,&arg1,&arg2,totarg) ) return(-1);
3072  if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
3073  if ( arg1 > totarg ) return(0);
3074  if ( arg2 < 1 ) return(0);
3075  if ( arg1 < 1 ) arg1 = 1;
3076  if ( arg2 > totarg ) arg2 = totarg;
3077  f = fun+FUNHEAD; n = 1; t = f;
3078  while ( n < arg1 ) { n++; NEXTARG(t) }
3079  while ( n <= arg2 ) {
3080  tt = t; NEXTARG(tt)
3081  while ( t < tt ) *f++ = *t++;
3082  n++;
3083  }
3084  fun[1] = f-fun;
3085  return(0);
3086 }
3087 
3088 /*
3089  #] RunSelectArg :
3090  #[ TestArgNum :
3091 
3092  Looks whether argument n is contained in any of the ranges
3093  specified in args. Args contains objects of the types
3094  ALLARGS
3095  NUMARG,num
3096  ARGRANGE,num1,num2
3097  The object MAKEARGS,num1,num2 is skipped
3098  Any other object terminates the range specifications.
3099 
3100  Currently only ARGRANGE is used (10-may-2016)
3101 */
3102 
3103 int TestArgNum(int n, int totarg, WORD *args)
3104 {
3105  GETIDENTITY
3106  WORD x1, x2;
3107  for(;;) {
3108  switch ( *args ) {
3109  case ALLARGS:
3110  return(1);
3111  case NUMARG:
3112  if ( n == args[1] ) return(1);
3113  if ( args[1] >= MAXPOSITIVE4 ) {
3114  x1 = args[1]-MAXPOSITIVE4;
3115  if ( totarg-x1 == n ) return(1);
3116  }
3117  args += 2;
3118  break;
3119  case ARGRANGE:
3120  if ( args[1] >= MAXPOSITIVE2 ) {
3121  x1 = args[1] - MAXPOSITIVE2;
3122  if ( x1 > MAXPOSITIVE4 ) {
3123  x1 = x1 - MAXPOSITIVE4;
3124  x1 = DolToNumber(BHEAD x1);
3125  x1 = totarg - x1;
3126  }
3127  else {
3128  x1 = DolToNumber(BHEAD x1);
3129  }
3130  }
3131  else if ( args[1] >= MAXPOSITIVE4 ) {
3132  x1 = totarg-(args[1]-MAXPOSITIVE4);
3133  }
3134  else x1 = args[1];
3135  if ( args[2] >= MAXPOSITIVE2 ) {
3136  x2 = args[2] - MAXPOSITIVE2;
3137  if ( x2 > MAXPOSITIVE4 ) {
3138  x2 = x2 - MAXPOSITIVE4;
3139  x2 = DolToNumber(BHEAD x2);
3140  x2 = totarg - x2;
3141  }
3142  else {
3143  x2 = DolToNumber(BHEAD x2);
3144  }
3145  }
3146  else if ( args[2] >= MAXPOSITIVE4 ) {
3147  x2 = totarg-(args[2]-MAXPOSITIVE4);
3148  }
3149  else x2 = args[2];
3150  if ( x1 >= x2 ) {
3151  if ( n >= x2 && n <= x1 ) return(1);
3152  }
3153  else {
3154  if ( n >= x1 && n <= x2 ) return(1);
3155  }
3156  args += 3;
3157  break;
3158  case MAKEARGS:
3159  args += 3;
3160  break;
3161  default:
3162  return(0);
3163  }
3164  }
3165 }
3166 
3167 /*
3168  #] TestArgNum :
3169  #[ PutArgInScratch :
3170 */
3171 
3172 WORD PutArgInScratch(WORD *arg,UWORD *scrat)
3173 {
3174  WORD size, *t, i;
3175  if ( *arg == -SNUMBER ) {
3176  scrat[0] = ABS(arg[1]);
3177  if ( arg[1] < 0 ) size = -1;
3178  else size = 1;
3179  }
3180  else {
3181  t = arg+*arg-1;
3182  if ( *t < 0 ) { i = ((-*t)-1)/2; size = -i; }
3183  else { i = ( *t -1)/2; size = i; }
3184  t = arg+ARGHEAD+1;
3185  NCOPY(scrat,t,i);
3186  }
3187  return(size);
3188 }
3189 
3190 /*
3191  #] PutArgInScratch :
3192  #[ ReadRange :
3193 
3194  Comes in at the bracket and leaves at the = sign
3195  Ranges can be:
3196  #1,#2 with # numbers. If the second is smaller than the
3197  first we work it backwards.
3198  first,#2 or #2,first
3199  #1,last or last,#1
3200  first,last or last,first
3201  First is represented by 1. Last is represented by MAXPOSITIVE4.
3202 
3203  par = 0: we need the = after.
3204  par = 1: we need a , or '\0' after.
3205  par = 2: we need a :
3206 */
3207 
3208 UBYTE *ReadRange(UBYTE *s, WORD *out, int par)
3209 {
3210  UBYTE *in = s, *ss, c;
3211  LONG x1, x2;
3212 
3213  SKIPBRA3(in)
3214  if ( par == 0 && in[1] != '=' ) {
3215  MesPrint("&A range in this type of transform statement should be followed by an = sign");
3216  return(0);
3217  }
3218  else if ( par == 1 && in[1] != ',' && in[1] != '\0' ) {
3219  MesPrint("&A range in this type of transform statement should be followed by a comma or end-of-statement");
3220  return(0);
3221  }
3222  else if ( par == 2 && in[1] != ':' ) {
3223  MesPrint("&A range in this type of transform statement should be followed by a :");
3224  return(0);
3225  }
3226  s++;
3227  if ( FG.cTable[*s] == 0 ) {
3228  ss = s; while ( FG.cTable[*s] == 0 ) s++;
3229  c = *s; *s = 0;
3230  if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3231  *s = c;
3232  x1 = 1;
3233  }
3234  else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3235  *s = c;
3236  if ( c == '-' ) {
3237  s++;
3238  if ( *s == '$' ) {
3239  s++; ss = s;
3240  while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3241  c = *s; *s = 0;
3242  if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3243  *s = c;
3244  x1 += MAXPOSITIVE2;
3245  }
3246  else {
3247  x1 = 0;
3248  while ( *s >= '0' && *s <= '9' ) {
3249  x1 = 10*x1 + *s++ - '0';
3250  if ( x1 >= MAXPOSITIVE4 ) {
3251  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3252  return(0);
3253  }
3254  }
3255  }
3256  x1 += MAXPOSITIVE4;
3257  }
3258  else x1 = MAXPOSITIVE4;
3259  }
3260  else {
3261  MesPrint("&Illegal keyword inside range specification");
3262  return(0);
3263  }
3264  }
3265  else if ( FG.cTable[*s] == 1 ) {
3266  x1 = 0;
3267  while ( *s >= '0' && *s <= '9' ) {
3268  x1 = x1*10 + *s++ - '0';
3269  if ( x1 >= MAXPOSITIVE4 ) {
3270  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3271  return(0);
3272  }
3273  }
3274  }
3275  else if ( *s == '$' ) {
3276  s++; ss = s;
3277  while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3278  c = *s; *s = 0;
3279  if ( ( x1 = GetDollar(ss) ) < 0 ) goto Error;
3280  *s = c;
3281  x1 += MAXPOSITIVE2;
3282  }
3283  else {
3284  MesPrint("&Illegal character in range specification");
3285  return(0);
3286  }
3287  if ( *s != ',' ) {
3288  MesPrint("&A range is two indicators, separated by a comma or blank");
3289  return(0);
3290  }
3291  s++;
3292  if ( FG.cTable[*s] == 0 ) {
3293  ss = s; while ( FG.cTable[*s] == 0 ) s++;
3294  c = *s; *s = 0;
3295  if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
3296  *s = c;
3297  x2 = 1;
3298  }
3299  else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
3300  *s = c;
3301  if ( c == '-' ) {
3302  s++;
3303  if ( *s == '$' ) {
3304  s++; ss = s;
3305  while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3306  c = *s; *s = 0;
3307  if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3308  *s = c;
3309  x2 += MAXPOSITIVE2;
3310  }
3311  else {
3312  x2 = 0;
3313  while ( *s >= '0' && *s <= '9' ) {
3314  x2 = 10*x2 + *s++ - '0';
3315  if ( x2 >= MAXPOSITIVE4 ) {
3316  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3317  return(0);
3318  }
3319  }
3320  }
3321  x2 += MAXPOSITIVE4;
3322  }
3323  else x2 = MAXPOSITIVE4;
3324  }
3325  else {
3326  MesPrint("&Illegal keyword inside range specification");
3327  return(0);
3328  }
3329  }
3330  else if ( FG.cTable[*s] == 1 ) {
3331  x2 = 0;
3332  while ( *s >= '0' && *s <= '9' ) {
3333  x2 = x2*10 + *s++ - '0';
3334  if ( x2 >= MAXPOSITIVE4 ) {
3335  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE4);
3336  return(0);
3337  }
3338  }
3339  }
3340  else if ( *s == '$' ) {
3341  s++; ss = s;
3342  while ( FG.cTable[*s] == 0 || FG.cTable[*s] == 1 ) s++;
3343  c = *s; *s = 0;
3344  if ( ( x2 = GetDollar(ss) ) < 0 ) goto Error;
3345  *s = c;
3346  x2 += MAXPOSITIVE2;
3347  }
3348  else {
3349  MesPrint("&Illegal character in range specification");
3350  return(0);
3351  }
3352  if ( s < in ) {
3353  MesPrint("&A range is two indicators, separated by a comma or blank between parentheses");
3354  return(0);
3355  }
3356  out[0] = x1; out[1] = x2;
3357  return(in+1);
3358 Error:
3359  MesPrint("&Undefined variable $%s in range",ss);
3360  return(0);
3361 }
3362 
3363 /*
3364  #] ReadRange :
3365  #[ FindRange :
3366 */
3367 
3368 int FindRange(PHEAD WORD *args, WORD *arg1, WORD *arg2, WORD totarg)
3369 {
3370  WORD n[2], fromlast, i;
3371  for ( i = 0; i < 2; i++ ) {
3372  n[i] = args[i+1];
3373  fromlast = 0;
3374  if ( n[i] >= MAXPOSITIVE2 ) { /* This is a dollar variable */
3375  n[i] -= MAXPOSITIVE2;
3376  if ( n[i] >= MAXPOSITIVE4 ) {
3377  fromlast = 1;
3378  n[i] -= MAXPOSITIVE4; /* Now we have the number of the dollar variable */
3379  }
3380  n[i] = DolToNumber(BHEAD n[i]);
3381  if ( AN.ErrorInDollar ) goto Error;
3382  if ( fromlast ) n[i] = totarg-n[i];
3383  }
3384  else if ( n[i] >= MAXPOSITIVE4 ) { n[i] = totarg-(n[i]-MAXPOSITIVE4); }
3385  if ( n[i] <= 0 ) goto Error;
3386  }
3387  *arg1 = n[0];
3388  *arg2 = n[1];
3389  return(0);
3390 Error:
3391  MLOCK(ErrorMessageLock);
3392  MesPrint("Illegal $ value in range while executing transform statement.");
3393  MUNLOCK(ErrorMessageLock);
3394  return(-1);
3395 }
3396 
3397 /*
3398  #] FindRange :
3399  #] Transform :
3400 */
#define PHEAD
Definition: ftypes.h:56
WORD * DoubleCbuffer(int num, WORD *w, int par)
Definition: comtool.c:143
Definition: structs.h:921
WORD * Pointer
Definition: structs.h:924
WORD StoreTerm(PHEAD WORD *)
Definition: sort.c:4246
int AddNtoL(int n, WORD *array)
Definition: comtool.c:288
VOID LowerSortLevel()
Definition: sort.c:4610
WORD * Buffer
Definition: structs.h:922
WORD NewSort(PHEAD0)
Definition: sort.c:589
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:3034
WORD * Top
Definition: structs.h:923
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:675
WORD * AddRHS(int num, int type)
Definition: comtool.c:214