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