FORM  4.1
transform.c
Go to the documentation of this file.
1 
5 /* #[ License : */
6 /*
7  * Copyright (C) 1984-2013 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  Cycle(argfirst,arglast)=+/-num
57  IsLyndon(argfirst,arglast)=(yes,no)
58  ToLyndon(argfirst,arglast)=(yes,no)
59  In replace the extra information is
60  a replace_() without the name of the replace_ function.
61  This can be as in (0,1,1,0) or (xarg_,1-xarg_) to indicate
62  a symbolic argument or (x,y,y,x) to exchange x and y, etc.
63  In Encode and Decode argfirst is the most significant 'word' and
64  arglast is the least significant 'word'.
65  Note that we need to introduce the generic symbolic arguments xarg_,
66  parg_, iarg_ and farg_.
67  Examples:
68  Transform,{H,E}
69  ,Replace(1:`WEIGHT')=(0,1,1,0)
70  ,Encode(1:`WEIGHT')=base(2);
71  Transform,{H,E}
72  ,Decode(1:`WEIGHT')=base(3)
73  ,Replace(1:`WEIGHT')=(2,-1,1,0,0,1);
74  Others that can be added:
75  symmetrize?
76 
77  #] Intro :
78  #[ CoTransform :
79 */
80 
81 static WORD tranarray[10] = { SUBEXPRESSION, SUBEXPSIZE, 0, 1, 0, 0, 0, 0, 0, 0 };
82 
83 int CoTransform(UBYTE *in)
84 {
85  GETIDENTITY
86  UBYTE *s = in, c, *ss, *Tempbuf;
87  WORD number, type, num, i, *work = AT.WorkPointer+2, *wp, range[2], one = 1;
88  WORD numdol, *wstart;
89  int error = 0, irhs;
90  LONG x;
91  while ( *in == ',' ) in++;
92  num = 0; wp = work + 1;
93 /*
94  #[ Sets :
95 
96  First the set specification(s). No sets means all functions (dangerous!)
97 */
98  for(;;) {
99  if ( *in == '{' ) {
100  s = in+1;
101  SKIPBRA2(in)
102  number = DoTempSet(s,in);
103  in++;
104  if ( *in != ',' ) {
105  c = in[1]; in[1] = 0;
106  MesPrint("& %s: A set in a transform statement should be followed by a comma",s);
107  in[1] = c; in++;
108  if ( error == 0 ) error = 1;
109  }
110  }
111  else if ( *in == '[' || FG.cTable[*in] == 0 ) {
112  s = in;
113  in = SkipAName(in);
114  if ( *in != ',' ) break;
115  c = *in; *in = 0;
116  type = GetName(AC.varnames,s,&number,NOAUTO);
117  if ( type == CFUNCTION ) { number += MAXVARIABLES + FUNCTION; }
118  else if ( type != CSET ) {
119  MesPrint("& %s: A transform statement starts with sets of functions",s);
120  if ( error == 0 ) error = 1;
121  }
122  *in++ = c;
123  }
124  else {
125  MesPrint("&Illegal syntax in Transform statement",s);
126  if ( error == 0 ) error = 1;
127  return(error);
128  }
129  if ( number >= 0 ) {
130  if ( number < MAXVARIABLES ) {
131 /*
132  Check that this is a set of functions
133 */
134  if ( Sets[number].type != CFUNCTION ) {
135  MesPrint("&A set in a transform statement should be a set of functions");
136  if ( error == 0 ) error = 1;
137  }
138  }
139  }
140  else if ( error == 0 ) error = 1;
141 /*
142  Now write the number to the right place
143 */
144  *wp++ = number;
145  num++;
146  while ( *in == ',' ) in++;
147  }
148  *work = wp - work;
149  work = wp; wp++;
150 /*
151  #] Sets :
152 
153  Now we should loop over the various transformations
154 */
155  while ( *s ) {
156  in = s;
157  if ( FG.cTable[*in] != 0 ) {
158  MesPrint("&Illegal character in Transform statement");
159  if ( error == 0 ) error = 1;
160  return(error);
161  }
162  in = SkipAName(in);
163  if ( *in == '>' || *in == '<' ) in++;
164  ss = in;
165  c = *ss; *ss = 0;
166  if ( c != '(' ) {
167  MesPrint("&Illegal syntax in specifying a transformation inside a Transform statement");
168  if ( error == 0 ) error = 1;
169  return(error);
170  }
171 /*
172  #[ replace :
173 */
174  if ( StrICmp(s,(UBYTE *)"replace") == 0 ) {
175 /*
176  Subkeys: (,,,) as in replace_(,,,)
177  The idea here is to read the subkeys as the argument
178  of a replace_ function.
179  We put the whole together as in the multiply statement (which
180  could just be a replace_(....)) and compile it.
181  Then we expand the tree with Generator and check the complete
182  expression for legality.
183 */
184  type = REPLACEARG;
185 doreplace:
186  *ss = c;
187  if ( ( in = ReadRange(in,range,0) ) == 0 ) {
188  if ( error == 0 ) error = 1;
189  return(error);
190  }
191  in++;
192 /*
193  We have replace(#,#)=(...), and we want dum_(...) (DUMFUN)
194  to send to the compiler. The pointer is after the '=';
195 */
196  s = in;
197  if ( *s != '(' ) {
198  MesPrint("&");
199  if ( error == 0 ) error = 1;
200  return(error);
201  }
202  SKIPBRA3(in);
203  if ( *in != ')' ) {
204  MesPrint("&");
205  if ( error == 0 ) error = 1;
206  return(error);
207  }
208  in++;
209  if ( *in != ',' && *in != '\0' ) {
210  MesPrint("&");
211  if ( error == 0 ) error = 1;
212  return(error);
213  }
214  i = in - s;
215  ss = Tempbuf = (UBYTE *)Malloc1(i+5,"CoTransform/replace");
216  *ss++ = 'd'; *ss++ = 'u'; *ss++ = 'm'; *ss++ = '_';
217  NCOPY(ss,s,i)
218  *ss++ = 0;
219  AC.ProtoType = tranarray;
220  tranarray[4] = AC.cbufnum;
221  irhs = CompileAlgebra(Tempbuf,RHSIDE,AC.ProtoType);
222  M_free(Tempbuf,"CoTransform/replace");
223  if ( irhs < 0 ) {
224  if ( error == 0 ) error = 1;
225  return(error);
226  }
227  tranarray[2] = irhs;
228 /*
229  The result of the compilation goes through Generator during
230  execution, because that takes care of $-variables.
231  This is why we could not use replace_ and had to use dum_.
232 */
233  *wp++ = ARGRANGE;
234  *wp++ = range[0];
235  *wp++ = range[1];
236  *wp++ = type;
237  *wp++ = SUBEXPSIZE+4;
238  for ( i = 0; i < SUBEXPSIZE; i++ ) *wp++ = tranarray[i];
239  *wp++ = 1;
240  *wp++ = 1;
241  *wp++ = 3;
242  *work = wp-work;
243  work = wp; *wp++ = 0;
244  s = in;
245  }
246 /*
247  #] replace :
248  #[ encode/decode :
249 */
250  else if ( StrICmp(s,(UBYTE *)"decode" ) == 0 ) {
251  type = DECODEARG;
252  goto doencode;
253  }
254  else if ( StrICmp(s,(UBYTE *)"encode" ) == 0 ) {
255  type = ENCODEARG;
256 doencode: *ss = c;
257  if ( ( in = ReadRange(in,range,2) ) == 0 ) {
258  if ( error == 0 ) error = 1;
259  return(error);
260  }
261  in++;
262  s = in; while ( FG.cTable[*in] == 0 ) in++;
263  c = *in; *in = 0;
264 /*
265  Subkeys: base=# or base=$var
266 */
267  if ( StrICmp(s,(UBYTE *)"base") == 0 ) {
268  *in = c;
269  if ( *in != '=' ) {
270  MesPrint("&Illegal base specification in encode/decode transformation");
271  if ( error == 0 ) error = 1;
272  return(error);
273  }
274  in++;
275  if ( *in == '$' ) {
276  in++; ss = in;
277  in = SkipAName(in);
278  c = *in; *in = 0;
279  if ( GetName(AC.dollarnames,ss,&numdol,NOAUTO) != CDOLLAR ) {
280  MesPrint("&%s is undefined",ss-1);
281  numdol = AddDollar(ss,DOLINDEX,&one,1);
282  return(1);
283  }
284  *in = c;
285  x = -numdol;
286  }
287  else {
288  x = 0;
289  while ( FG.cTable[*in] == 1 ) {
290  x = 10*x + *in++ - '0';
291  if ( x > MAXPOSITIVE2 ) {
292 illsize: MesPrint("&Illegal value for base in encode/decode transformation");
293  if ( error == 0 ) error = 1;
294  return(error);
295  }
296  }
297  if ( x <= 1 ) goto illsize;
298  }
299  if ( *in != ',' && *in != '\0' ) {
300  MesPrint("&Illegal termination of transformation");
301  if ( error == 0 ) error = 1;
302  return(error);
303  }
304  }
305  else {
306  MesPrint("&Illegal option in encode/decode transformation");
307  if ( error == 0 ) error = 1;
308  return(error);
309  }
310 /*
311  Now we can put the whole statement together
312  We have the set(s) in work up to wp and the range in range.
313  The base is in x and the type tells whether it is encode or decode.
314 */
315  *wp++ = ARGRANGE;
316  *wp++ = range[0];
317  *wp++ = range[1];
318  *wp++ = type;
319  *wp++ = 4;
320  *wp++ = BASECODE;
321  *wp++ = (WORD)x;
322  *work = wp-work;
323  work = wp; *wp++ = 0;
324  s = in;
325  }
326 /*
327  #] encode/decode :
328  #[ implode :
329 */
330  else if ( StrICmp(s,(UBYTE *)"implode") == 0
331  || StrICmp(s,(UBYTE *)"tosumnotation") == 0 ) {
332 /*
333  Subkeys: ?
334 */
335  type = IMPLODEARG;
336  *ss = c;
337  if ( ( in = ReadRange(in,range,1) ) == 0 ) {
338  if ( error == 0 ) error = 1;
339  return(error);
340  }
341  *wp++ = ARGRANGE;
342  *wp++ = range[0];
343  *wp++ = range[1];
344  *wp++ = type;
345  *work = wp-work;
346  work = wp; *wp++ = 0;
347  s = in;
348  }
349 /*
350  #] implode :
351  #[ explode :
352 */
353  else if ( StrICmp(s,(UBYTE *)"explode") == 0
354  || StrICmp(s,(UBYTE *)"tointegralnotation") == 0 ) {
355 /*
356  Subkeys: ?
357 */
358  type = EXPLODEARG;
359  *ss = c;
360  if ( ( in = ReadRange(in,range,1) ) == 0 ) {
361  if ( error == 0 ) error = 1;
362  return(error);
363  }
364  *wp++ = ARGRANGE;
365  *wp++ = range[0];
366  *wp++ = range[1];
367  *wp++ = type;
368  *work = wp-work;
369  work = wp; *wp++ = 0;
370  s = in;
371  }
372 /*
373  #] explode :
374  #[ permute :
375 */
376  else if ( StrICmp(s,(UBYTE *)"permute") == 0 ) {
377  type = PERMUTEARG;
378  *ss = c;
379  *wp++ = ARGRANGE;
380  *wp++ = 1;
381  *wp++ = MAXPOSITIVE2;
382  *wp++ = type;
383 /*
384  Now a sequence of cycles
385 */
386  do {
387  wstart = wp; wp++;
388  do {
389  x = 0; in++;
390  while ( FG.cTable[*in] == 1 ) {
391  x = 10*x + *in++ - '0';
392  if ( x > MAXPOSITIVE2 ) {
393  MesPrint("&value in permute transformation too large");
394  if ( error == 0 ) error = 1;
395  return(error);
396  }
397  }
398  if ( x == 0 ) {
399  MesPrint("&value 0 in permute transformation not allowed");
400  if ( error == 0 ) error = 1;
401  return(error);
402  }
403  *wp++ = (WORD)x-1;
404  } while ( *in == ',' );
405  if ( *in != ')' ) {
406  MesPrint("&Illegal syntax in permute transformation");
407  if ( error == 0 ) error = 1;
408  return(error);
409  }
410  in++;
411  if ( *in != ',' && *in != '(' && *in != '\0' ) {
412  MesPrint("&Illegal ending in permute transformation");
413  if ( error == 0 ) error = 1;
414  return(error);
415  }
416  *wstart = wp-wstart;
417  if ( *wstart == 1 ) wstart--;
418  } while ( *in == '(' );
419  *work = wp-work;
420  work = wp; *wp++ = 0;
421  s = in;
422  }
423 /*
424  #] permute :
425  #[ reverse :
426 */
427  else if ( StrICmp(s,(UBYTE *)"reverse") == 0 ) {
428  type = REVERSEARG;
429  *ss = c;
430  if ( ( in = ReadRange(in,range,1) ) == 0 ) {
431  if ( error == 0 ) error = 1;
432  return(error);
433  }
434  *wp++ = ARGRANGE;
435  *wp++ = range[0];
436  *wp++ = range[1];
437  *wp++ = type;
438  *work = wp-work;
439  work = wp; *wp++ = 0;
440  s = in;
441  }
442 /*
443  #] reverse :
444  #[ cycle :
445 */
446  else if ( StrICmp(s,(UBYTE *)"cycle") == 0 ) {
447  type = CYCLEARG;
448  *ss = c;
449  if ( ( in = ReadRange(in,range,0) ) == 0 ) {
450  if ( error == 0 ) error = 1;
451  return(error);
452  }
453  *wp++ = ARGRANGE;
454  *wp++ = range[0];
455  *wp++ = range[1];
456  *wp++ = type;
457 /*
458  Now a sequence of cycles
459 */
460  in++;
461  if ( *in == '+' ) {
462  }
463  else if ( *in == '-' ) {
464  one = -1;
465  }
466  else {
467  MesPrint("&Cycle in a Transform statement should be followed by =+/-number");
468  if ( error == 0 ) error = 1;
469  return(error);
470  }
471  in++; x = 0;
472  while ( FG.cTable[*in] == 1 ) {
473  x = 10*x + *in++ - '0';
474  if ( x > MAXPOSITIVE2 ) {
475  MesPrint("&Number in cycle in a Transform statement too big");
476  if ( error == 0 ) error = 1;
477  return(error);
478  }
479  }
480  *wp++ = x*one;
481  *work = wp-work;
482  work = wp; *wp++ = 0;
483  s = in;
484  }
485 /*
486  #] cycle :
487  #[ islyndon/tolyndon :
488 */
489  else if ( StrICmp(s,(UBYTE *)"islyndon" ) == 0 ) {
490  type = ISLYNDON;
491  goto doreplace;
492  }
493  else if ( StrICmp(s,(UBYTE *)"islyndon<" ) == 0 ) {
494  type = ISLYNDON;
495  goto doreplace;
496  }
497  else if ( StrICmp(s,(UBYTE *)"islyndon+" ) == 0 ) {
498  type = ISLYNDON;
499  goto doreplace;
500  }
501  else if ( StrICmp(s,(UBYTE *)"islyndon>" ) == 0 ) {
502  type = ISLYNDONR;
503  goto doreplace;
504  }
505  else if ( StrICmp(s,(UBYTE *)"islyndon-" ) == 0 ) {
506  type = ISLYNDONR;
507  goto doreplace;
508  }
509  else if ( StrICmp(s,(UBYTE *)"tolyndon" ) == 0 ) {
510  type = TOLYNDON;
511  goto doreplace;
512  }
513  else if ( StrICmp(s,(UBYTE *)"tolyndon<" ) == 0 ) {
514  type = TOLYNDON;
515  goto doreplace;
516  }
517  else if ( StrICmp(s,(UBYTE *)"tolyndon+" ) == 0 ) {
518  type = TOLYNDON;
519  goto doreplace;
520  }
521  else if ( StrICmp(s,(UBYTE *)"tolyndon>" ) == 0 ) {
522  type = TOLYNDONR;
523  goto doreplace;
524  }
525  else if ( StrICmp(s,(UBYTE *)"tolyndon-" ) == 0 ) {
526  type = TOLYNDONR;
527  goto doreplace;
528  }
529 /*
530  #] islyndon/tolyndon :
531 */
532  else {
533  MesPrint("&Unknown transformation inside a Transform statement: %s",s);
534  *ss = c;
535  if ( error == 0 ) error = 1;
536  return(error);
537  }
538  while ( *s == ',') s++;
539  }
540  AT.WorkPointer[0] = TYPETRANSFORM;
541  AT.WorkPointer[1] = i = wp - AT.WorkPointer;
542  AddNtoL(i,AT.WorkPointer);
543  return(error);
544 }
545 
546 /*
547  #] CoTransform :
548  #[ RunTransform :
549 
550  Executes the transform statement.
551  This routine hunts down the functions and sends them to the various
552  action routines.
553  params: size,#set1,...,#setn, transformations
554 
555 */
556 
557 WORD RunTransform(PHEAD WORD *term, WORD *params)
558 {
559  WORD *t, *tstop, *w, *m, *out, *in, *tt, retval;
560  WORD *fun, *args, *info, *infoend, *onetransform, *funs, *endfun;
561  WORD *thearg = 0, *iterm, *newterm, *nt, *oldwork = AT.WorkPointer;
562  int i;
563  out = tstop = term + *term;
564  tstop -= ABS(tstop[-1]);
565  in = term;
566  t = term + 1;
567  while ( t < tstop ) {
568  endfun = onetransform = params + *params;
569  funs = params + 1;
570  if ( *t < FUNCTION ) {}
571  else if ( funs == endfun ) { /* we do all functions */
572 hit:;
573  while ( in < t ) *out++ = *in++;
574  tt = t + t[1]; fun = out;
575  while ( in < tt ) *out++ = *in++;
576  do {
577  args = onetransform + 1;
578  info = args; while ( *info <= MAXRANGEINDICATOR ) {
579  if ( *info == ALLARGS ) info++;
580  else if ( *info == NUMARG ) info += 2;
581  else if ( *info == ARGRANGE ) info += 3;
582  else if ( *info == MAKEARGS ) info += 3;
583  }
584  switch ( *info ) {
585  case REPLACEARG:
586  if ( RunReplace(BHEAD fun,args,info) ) goto abo;
587  out = fun + fun[1];
588  break;
589  case ENCODEARG:
590  if ( RunEncode(BHEAD fun,args,info) ) goto abo;
591  out = fun + fun[1];
592  break;
593  case DECODEARG:
594  if ( RunDecode(BHEAD fun,args,info) ) goto abo;
595  out = fun + fun[1];
596  break;
597  case IMPLODEARG:
598  if ( RunImplode(fun,args) ) goto abo;
599  out = fun + fun[1];
600  break;
601  case EXPLODEARG:
602  if ( RunExplode(BHEAD fun,args) ) goto abo;
603  out = fun + fun[1];
604  break;
605  case PERMUTEARG:
606  if ( RunPermute(BHEAD fun,args,info) ) goto abo;
607  out = fun + fun[1];
608  break;
609  case REVERSEARG:
610  if ( RunReverse(BHEAD fun,args) ) goto abo;
611  out = fun + fun[1];
612  break;
613  case CYCLEARG:
614  if ( RunCycle(BHEAD fun,args,info) ) goto abo;
615  out = fun + fun[1];
616  break;
617  case ISLYNDON:
618  if ( ( retval = RunIsLyndon(BHEAD fun,args,1) ) < -1 ) goto abo;
619  goto returnvalues;
620  break;
621  case ISLYNDONR:
622  if ( ( retval = RunIsLyndon(BHEAD fun,args,-1) ) < -1 ) goto abo;
623  goto returnvalues;
624  break;
625  case TOLYNDON:
626  if ( ( retval = RunToLyndon(BHEAD fun,args,1) ) < -1 ) goto abo;
627  goto returnvalues;
628  break;
629  case TOLYNDONR:
630  if ( ( retval = RunToLyndon(BHEAD fun,args,-1) ) < -1 ) goto abo;
631 returnvalues:;
632  out = fun + fun[1];
633  if ( retval == -1 ) break;
634 /*
635  Work out the yes/no stuff
636 */
637  AT.WorkPointer += 2*AM.MaxTer;
638  if ( AT.WorkPointer > AT.WorkTop ) {
639  MLOCK(ErrorMessageLock);
640  MesWork();
641  MUNLOCK(ErrorMessageLock);
642  return(-1);
643  }
644  iterm = AT.WorkPointer;
645  info++;
646  for ( i = 0; i < *info; i++ ) iterm[i] = info[i];
647  AT.WorkPointer = iterm + *iterm;
648  AR.Eside = LHSIDEX;
649  NewSort(BHEAD0);
650  if ( Generator(BHEAD iterm,AR.Cnumlhs) ) {
651  LowerSortLevel();
652  AT.WorkPointer = oldwork;
653  return(-1);
654  }
655  newterm = AT.WorkPointer;
656  if ( EndSort(BHEAD newterm,0) < 0 ) {}
657  if ( ( *newterm && *(newterm+*newterm) != 0 ) || *newterm == 0 ) {
658  MLOCK(ErrorMessageLock);
659  MesPrint("&yes/no information in islyndon/tolyndon does not evaluate into a single term");
660  MUNLOCK(ErrorMessageLock);
661  return(-1);
662  }
663  AR.Eside = RHSIDE;
664  i = *newterm; tt = iterm; nt = newterm;
665  NCOPY(tt,nt,i);
666  AT.WorkPointer = iterm + *iterm;
667  info = iterm + 1;
668  infoend = info+info[1];
669  info += FUNHEAD;
670 
671  if ( retval == 0 ) {
672 /*
673  Need second argument (=no)
674 */
675  if ( info >= infoend ) {
676 abortlyndon:;
677  MLOCK(ErrorMessageLock);
678  MesPrint("There should be a yes and a no argument in islyndon/tolyndon");
679  MUNLOCK(ErrorMessageLock);
680  Terminate(-1);
681  }
682  NEXTARG(info)
683  if ( info >= infoend ) goto abortlyndon;
684  thearg = info;
685  }
686  else if ( retval == 1 ) {
687 /*
688  Need first argument (=yes)
689 */
690  if ( info >= infoend ) goto abortlyndon;
691  thearg = info;
692  NEXTARG(info)
693  if ( info >= infoend ) goto abortlyndon;
694  }
695  NEXTARG(info)
696  if ( info < infoend ) goto abortlyndon;
697 /*
698  The argument in thearg needs to be copied
699  We did not pull it through generator to guarantee
700  that it is a single argument.
701  The easiest way is to let the routine Normalize
702  do the job and put everything in an exponent function
703  with the power one.
704 */
705  if ( *thearg == -SNUMBER && thearg[1] == 0 ) {
706  *term = 0; return(0);
707  }
708  if ( *thearg == -SNUMBER && thearg[1] == 1 ) { }
709  else {
710  fun = out;
711  *out++ = EXPONENT; out++; *out++ = 1; FILLFUN3(out);
712  COPY1ARG(out,thearg);
713  *out++ = -SNUMBER; *out++ = 1;
714  fun[1] = out-fun;
715  }
716  break;
717  default:
718  MLOCK(ErrorMessageLock);
719  MesPrint("Irregular code in execution of transform statement");
720  MUNLOCK(ErrorMessageLock);
721  Terminate(-1);
722  }
723  onetransform += *onetransform;
724  } while ( *onetransform );
725  }
726  else {
727  while ( funs < endfun ) { /* sum over sets */
728  if ( *funs > MAXVARIABLES ) {
729  if ( *t == *funs-MAXVARIABLES ) goto hit;
730  }
731  else {
732  w = SetElements + Sets[*funs].first;
733  m = SetElements + Sets[*funs].last;
734  while ( w < m ) { /* sum over set elements */
735  if ( *w == *t ) goto hit;
736  w++;
737  }
738  }
739  funs++;
740  }
741  }
742  t += t[1];
743  }
744  tt = term + *term; while ( in < tt ) *out++ = *in++;
745  *tt = i = out - tt;
746 /*
747  Now copy the whole thing back
748 */
749  NCOPY(term,tt,i)
750  return(0);
751 abo:
752  MLOCK(ErrorMessageLock);
753  MesCall("RunTransform");
754  MUNLOCK(ErrorMessageLock);
755  return(-1);
756 }
757 
758 /*
759  #] RunTransform :
760  #[ RunEncode :
761 
762  The info is given by
763  ENCODEARG,size,BASECODE,num
764  and possibly more codes to follow.
765  Only one range is allowed and for now, it should be fully numerical
766  If the range is in reverse order, we need to either revert it
767  first or work with an array of pointers.
768 */
769 
770 WORD RunEncode(PHEAD WORD *fun, WORD *args, WORD *info)
771 {
772  WORD base, *f, *funstop, *fun1, *t, size1, size2, size3, *arg;
773  int num, num1, num2, n, i, i1, i2;
774  UWORD *scrat1, *scrat2, *scrat3;
775  WORD *tt, *tstop, totarg, arg1, arg2;
776  if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
777  if ( *args != ARGRANGE ) {
778  MLOCK(ErrorMessageLock);
779  MesPrint("Illegal range encountered in RunEncode");
780  MUNLOCK(ErrorMessageLock);
781  Terminate(-1);
782  }
783  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
784  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
785  arg1 = args[1];
786  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
787  arg2 = args[2];
788  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
789  if ( arg1 > totarg || arg2 > totarg ) return(0);
790 
791  if ( info[2] == BASECODE ) {
792  base = info[3];
793  if ( base <= 0 ) { /* is a dollar variable */
794  i1 = -base;
795  base = DolToNumber(BHEAD i1);
796  if ( AN.ErrorInDollar || base < 2 ) {
797  MLOCK(ErrorMessageLock);
798  MesPrint("$%s does not have a number value > 1 in base/encode/transform statement in module %l",
799  DOLLARNAME(Dollars,i1),AC.CModule);
800  MUNLOCK(ErrorMessageLock);
801  Terminate(-1);
802  }
803  }
804 /*
805  Compute number of pointers needed and make sure there is space
806 */
807  if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
808  else { num1 = arg1; num2 = arg2; }
809  num = num2-num1+1;
810  WantAddPointers(num);
811 /*
812  Collect the pointers in pWorkSpace
813 */
814  n = 1; funstop = fun+fun[1]; f = fun+FUNHEAD;
815  while ( n < num1 ) {
816  if ( f >= funstop ) return(0);
817  NEXTARG(f);
818  n++;
819  }
820  fun1 = f; i = 0;
821  while ( n <= num2 ) {
822  if ( f >= funstop ) return(0);
823  if ( *f != -SNUMBER ) {
824  if ( *f < 0 ) return(0);
825  t = f + *f - 1;
826  i1 = ABS(*t);
827  if ( (*f-i1) != (ARGHEAD+1) ) return(0); /* Not numerical */
828  i1 = (i1-1)/2 - 1;
829  t--;
830  while ( i1 > 0 ) {
831  if ( *t != 0 ) return(0); /* Not an integer */
832  t--; i1--;
833  }
834  }
835  AT.pWorkSpace[AT.pWorkPointer+i] = f;
836  i++;
837  NEXTARG(f);
838  n++;
839  }
840 /*
841  f points now to after the arguments; fun1 at the first.
842  Now check whether we need to revert the order
843 */
844  if ( arg1 > arg2 ) {
845  i1 = 0; i2 = i-1;
846  while ( i1 < i2 ) {
847  t = AT.pWorkSpace[AT.pWorkPointer+i1];
848  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
849  AT.pWorkSpace[AT.pWorkPointer+i2] = t;
850  i1++; i2--;
851  }
852  }
853 /*
854  Now we can put the thing together.
855  x = arg1;
856  x = base*x+arg2
857  x = base*x+arg3 etc.
858  We need three scratch arrays for long integers
859  (see NumberMalloc in tools.c).
860 */
861  scrat1 = NumberMalloc("RunEncode");
862  scrat2 = NumberMalloc("RunEncode");
863  scrat3 = NumberMalloc("RunEncode");
864  arg = AT.pWorkSpace[AT.pWorkPointer];
865  size1 = PutArgInScratch(arg,scrat1);
866  i--;
867  while ( i > 0 ) {
868  if ( MulLong(scrat1,size1,(UWORD *)(&base),1,scrat2,&size2) ) {
869  NumberFree(scrat3,"RunEncode");
870  NumberFree(scrat2,"RunEncode");
871  NumberFree(scrat1,"RunEncode");
872  goto CalledFrom;
873  }
874  NEXTARG(arg);
875  size3 = PutArgInScratch(arg,scrat3);
876  if ( AddLong(scrat2,size2,scrat3,size3,scrat1,&size1) ) {
877  NumberFree(scrat3,"RunEncode");
878  NumberFree(scrat2,"RunEncode");
879  NumberFree(scrat1,"RunEncode");
880  goto CalledFrom;
881  }
882  i--;
883  }
884 /*
885  Now put the output in place. There are two cases, one being much
886  faster than the other. Hence we program both.
887  Fast: it fits inside the old location.
888  Slow: it does not.
889  The total space is f-fun1
890 */
891  if ( size1 == 0 ) { /* Fits! */
892  *fun1++ = -SNUMBER; *fun1++ = 0;
893  while ( f < funstop ) *fun1++ = *f++;
894  fun[1] = funstop-fun;
895  }
896  else if ( size1 == 1 && scrat1[0] <= MAXPOSITIVE ) { /* Fits! */
897  *fun1++ = -SNUMBER; *fun1++ = scrat1[0];
898  while ( f < funstop ) *fun1++ = *f++;
899  fun[1] = fun1-fun;
900  }
901  else if ( size1 == -1 && scrat1[0] <= MAXPOSITIVE+1 ) { /* Fits! */
902  *fun1++ = -SNUMBER;
903  if ( scrat1[0] < MAXPOSITIVE ) *fun1++ = scrat1[0];
904  else *fun1++ = (WORD)(MAXPOSITIVE+1);
905  while ( f < funstop ) *fun1++ = *f++;
906  fun[1] = fun1-fun;
907  }
908  else if ( ABS(size1)*2+2+ARGHEAD <= f-fun1 ) { /* Fits! */
909  if ( size1 < 0 ) { size2 = size1*2-1; size1 = -size1; size3 = -size2; }
910  else { size2 = 2*size1+1; size3 = size2; }
911  *fun1++ = size3+ARGHEAD+1;
912  *fun1++ = 0; FILLARG(fun1);
913  *fun1++ = size3+1;
914  for ( i = 0; i < size1; i++ ) *fun1++ = scrat1[i];
915  *fun1++ = 1;
916  for ( i = 1; i < size1; i++ ) *fun1++ = 0;
917  *fun1++ = size2;
918  while ( f < funstop ) *fun1++ = *f++;
919  fun[1] = fun1-fun;
920  }
921  else { /* Does not fit */
922  t = funstop;
923  if ( size1 < 0 ) { size2 = size1*2-1; size1 = -size1; size3 = -size2; }
924  else { size2 = 2*size1+1; size3 = size2; }
925  *t++ = size3+ARGHEAD+1;
926  *t++ = 0; FILLARG(t);
927  *t++ = size3+1;
928  for ( i = 0; i < size1; i++ ) *t++ = scrat1[i];
929  *t++ = 1;
930  for ( i = 1; i < size1; i++ ) *t++ = 0;
931  *t++ = size2;
932  while ( f < funstop ) *t++ = *f++;
933  f = funstop;
934  while ( f < t ) *fun1++ = *f++;
935  fun[1] = fun1-fun;
936  }
937  NumberFree(scrat3,"RunEncode");
938  NumberFree(scrat2,"RunEncode");
939  NumberFree(scrat1,"RunEncode");
940  }
941  else {
942  MLOCK(ErrorMessageLock);
943  MesPrint("Unimplemented type of encoding encountered in RunEncode");
944  MUNLOCK(ErrorMessageLock);
945  Terminate(-1);
946  }
947  return(0);
948 CalledFrom:
949  MLOCK(ErrorMessageLock);
950  MesCall("RunEncode");
951  MUNLOCK(ErrorMessageLock);
952  return(-1);
953 }
954 
955 /*
956  #] RunEncode :
957  #[ RunDecode :
958 */
959 
960 WORD RunDecode(PHEAD WORD *fun, WORD *args, WORD *info)
961 {
962  WORD base, num, num1, num2, n, *f, *funstop, *fun1, size1, size2, size3, *t;
963  WORD i1, i2, i, sig;
964  UWORD *scrat1, *scrat2, *scrat3;
965  WORD *tt, *tstop, totarg, arg1, arg2;
966  if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
967  if ( *args != ARGRANGE ) {
968  MLOCK(ErrorMessageLock);
969  MesPrint("Illegal range encountered in RunDecode");
970  MUNLOCK(ErrorMessageLock);
971  Terminate(-1);
972  }
973  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
974  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
975  arg1 = args[1];
976  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
977  arg2 = args[2];
978  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
979  if ( arg1 > totarg && arg2 > totarg ) return(0);
980  if ( info[2] == BASECODE ) {
981  base = info[3];
982  if ( base <= 0 ) { /* is a dollar variable */
983  i1 = -base;
984  base = DolToNumber(BHEAD i1);
985  if ( AN.ErrorInDollar || base < 2 ) {
986  MLOCK(ErrorMessageLock);
987  MesPrint("$%s does not have a number value > 1 in base/decode/transform statement in module %l",
988  DOLLARNAME(Dollars,i1),AC.CModule);
989  MUNLOCK(ErrorMessageLock);
990  Terminate(-1);
991  }
992  }
993 /*
994  Compute number of output arguments needed
995 */
996  if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
997  else { num1 = arg1; num2 = arg2; }
998  num = num2-num1+1;
999  if ( num <= 1 ) return(0);
1000 /*
1001  Find argument num1
1002 */
1003  funstop = fun + fun[1];
1004  f = fun + FUNHEAD; n = 1;
1005  while ( f < funstop ) {
1006  if ( n == num1 ) break;
1007  NEXTARG(f); n++;
1008  }
1009  if ( f >= funstop ) return(0); /* not enough arguments */
1010 /*
1011  Check that f is integer
1012 */
1013  if ( *f == -SNUMBER ) {}
1014  else if ( *f < 0 ) return(0);
1015  else {
1016  t = f + *f - 1;
1017  i1 = ABS(*t);
1018  if ( (*f-i1) != (ARGHEAD+1) ) return(0); /* Not numerical */
1019  i1 = (i1-1)/2 - 1;
1020  t--;
1021  while ( i1 > 0 ) {
1022  if ( *t != 0 ) return(0); /* Not an integer */
1023  t--; i1--;
1024  }
1025  }
1026  fun1 = f;
1027 /*
1028  The argument that should be decoded is in fun1
1029  We have to copy it to scratch
1030 */
1031  scrat1 = NumberMalloc("RunEncode");
1032  scrat2 = NumberMalloc("RunEncode");
1033  scrat3 = NumberMalloc("RunEncode");
1034  size1 = PutArgInScratch(fun1,scrat1);
1035  if ( size1 < 0 ) { sig = -1; size1 = -size1; }
1036  else sig = 1;
1037 /*
1038  We can check first whether this number can be decoded
1039 */
1040  scrat2[0] = base; size2 = 1;
1041  if ( RaisPow(BHEAD scrat2,&size2,num) ) {
1042  NumberFree(scrat3,"RunEncode");
1043  NumberFree(scrat2,"RunEncode");
1044  NumberFree(scrat1,"RunEncode");
1045  goto CalledFrom;
1046  }
1047  if ( BigLong(scrat1,size1,scrat2,size2) >= 0 ) { /* Number too big */
1048  NumberFree(scrat3,"RunEncode");
1049  NumberFree(scrat2,"RunEncode");
1050  NumberFree(scrat1,"RunEncode");
1051  return(0);
1052  }
1053 /*
1054  We need num*2 spaces
1055 */
1056  if ( *fun1 > num*2 ) { /* shrink space */
1057  t = fun1 + 2*num; f = fun1 + *fun1;
1058  while ( f < funstop ) *t++ = *f++;
1059  fun[1] = t - fun;
1060  }
1061  else if ( *fun1 < num*2 ) { /* case includes -SNUMBER */
1062  if ( *fun1 < 0 ) { /* expand space from -SNUMBER */
1063  fun[1] += (num-1)*2;
1064  t = funstop + (num-1)*2;
1065  }
1066  else { /* expand space from general argument */
1067  fun[1] += 2*num - *fun1;
1068  t = funstop +2*num - *fun1;
1069  }
1070  f = funstop;
1071  while ( f > fun1 ) *--t = *--f;
1072  }
1073 /*
1074  Now there is space for num -SNUMBER arguments filled from the top.
1075 */
1076  for ( i = num-1; i >= 0; i-- ) {
1077  DivLong(scrat1,size1,(UWORD *)(&base),1,scrat2,&size2,scrat3,&size3);
1078  fun1[2*i] = -SNUMBER;
1079  if ( size3 == 0 ) fun1[2*i+1] = 0;
1080  else fun1[2*i+1] = (WORD)(scrat3[0])*sig;
1081  for ( i1 = 0; i1 < size2; i1++ ) scrat1[i1] = scrat2[i1];
1082  size1 = size2;
1083  }
1084  if ( size2 != 0 ) {
1085  MLOCK(ErrorMessageLock);
1086  MesPrint("RunDecode: number to be decoded is too big");
1087  MUNLOCK(ErrorMessageLock);
1088  NumberFree(scrat3,"RunEncode");
1089  NumberFree(scrat2,"RunEncode");
1090  NumberFree(scrat1,"RunEncode");
1091  goto CalledFrom;
1092  }
1093 /*
1094  Now check whether we should change the order of the arguments
1095 */
1096  if ( arg1 > arg2 ) {
1097  i1 = 1; i2 = 2*num-1;
1098  while ( i2 > i1 ) {
1099  i = fun1[i1]; fun1[i1] = fun1[i2]; fun1[i2] = i;
1100  i1 += 2; i2 -= 2;
1101  }
1102  }
1103  NumberFree(scrat3,"RunEncode");
1104  NumberFree(scrat2,"RunEncode");
1105  NumberFree(scrat1,"RunEncode");
1106  }
1107  else {
1108  MLOCK(ErrorMessageLock);
1109  MesPrint("Unimplemented type of encoding encountered in RunDecode");
1110  MUNLOCK(ErrorMessageLock);
1111  Terminate(-1);
1112  }
1113  return(0);
1114 CalledFrom:
1115  MLOCK(ErrorMessageLock);
1116  MesCall("RunDecode");
1117  MUNLOCK(ErrorMessageLock);
1118  return(-1);
1119 }
1120 
1121 /*
1122  #] RunDecode :
1123  #[ RunReplace :
1124 
1125  Gets the function, passes the arguments and looks whether they
1126  need to be treated. If so, the exact treatment is found in info.
1127  The info is given as if it is a function of type REPLACEMENT but
1128  its name is REPLACEARG (which is NOT a function).
1129  It is performed on the arguments.
1130  The output is at first written after fun and in the end overwrites fun.
1131 */
1132 
1133 WORD RunReplace(PHEAD WORD *fun, WORD *args, WORD *info)
1134 {
1135  int n = 0, i, dirty = 0, totarg, nfix, nwild, ngeneral;
1136  WORD *t, *tt, *u, *tstop, *info1, *infoend, *oldwork = AT.WorkPointer;
1137  WORD *term, *newterm, *nt, *term1, *term2;
1138  WORD wild[4], mask, *term3, *term4;
1139  WORD n1, n2;
1140  info++;
1141  t = fun; tstop = fun + fun[1]; u = tstop;
1142  for ( i = 0; i < FUNHEAD; i++ ) *u++ = *t++;
1143  tt = t;
1144  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1145  totarg = 0;
1146  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1147  }
1148  else {
1149  totarg = tstop - tt;
1150  }
1151 /*
1152  Now get the info through Generator to bring it to standard form.
1153  info points at a single term that should be sent to Generator.
1154 
1155  We want to put the information in the WorkSpace but fun etc lies there
1156  already. This means that we have to move the WorkPointer quite high up.
1157 */
1158  AT.WorkPointer += 2*AM.MaxTer;
1159  if ( AT.WorkPointer > AT.WorkTop ) {
1160  MLOCK(ErrorMessageLock);
1161  MesWork();
1162  MUNLOCK(ErrorMessageLock);
1163  return(-1);
1164  }
1165  term = AT.WorkPointer;
1166  for ( i = 0; i < *info; i++ ) term[i] = info[i];
1167  AT.WorkPointer = term + *term;
1168  AR.Eside = LHSIDEX;
1169  NewSort(BHEAD0);
1170  if ( Generator(BHEAD term,AR.Cnumlhs) ) {
1171  LowerSortLevel();
1172  AT.WorkPointer = oldwork;
1173  return(-1);
1174  }
1175  newterm = AT.WorkPointer;
1176  if ( EndSort(BHEAD newterm,0) < 0 ) {}
1177  if ( ( *newterm && *(newterm+*newterm) != 0 ) || *newterm == 0 ) {
1178  MLOCK(ErrorMessageLock);
1179  MesPrint("&information in replace transformation does not evaluate into a single term");
1180  MUNLOCK(ErrorMessageLock);
1181  return(-1);
1182  }
1183  AR.Eside = RHSIDE;
1184  i = *newterm; tt = term; nt = newterm;
1185  NCOPY(tt,nt,i);
1186  AT.WorkPointer = term + *term;
1187  info = term + 1;
1188 
1189  term1 = term + *term;
1190  term2 = term1+1;
1191  *term2++ = REPLACEMENT;
1192  term2++; FILLFUN(term2)
1193 /*
1194  First we count the different types of objects
1195 */
1196  infoend = info + info[1];
1197  info1 = info + FUNHEAD;
1198  nfix = nwild = ngeneral = 0;
1199  while ( info1 < infoend ) {
1200  if ( *info1 == -SNUMBER ) {
1201  nfix++;
1202  info1 += 2; NEXTARG(info1)
1203  }
1204  else if ( *info1 <= -FUNCTION ) {
1205  if ( *info1 == -WILDARGFUN ) {
1206  nwild++;
1207  info1++; NEXTARG(info1)
1208  }
1209  else {
1210  *term2++ = *info1++; COPY1ARG(term2,info1)
1211  ngeneral++;
1212  }
1213  }
1214  else if ( *info1 == -INDEX ) {
1215  if ( info1[1] == WILDARGINDEX + AM.OffsetIndex ) {
1216  nwild++;
1217  info1 += 2; NEXTARG(info1)
1218  }
1219  else {
1220  *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1221  ngeneral++;
1222  }
1223  }
1224  else if ( *info1 == -SYMBOL ) {
1225  if ( info1[1] == WILDARGSYMBOL ) {
1226  nwild++;
1227  info1 += 2; NEXTARG(info1)
1228  }
1229  else {
1230  *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1231  ngeneral++;
1232  }
1233  }
1234  else if ( *info1 == -MINVECTOR || *info1 == -VECTOR ) {
1235  if ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) {
1236  nwild++;
1237  info1 += 2; NEXTARG(info1)
1238  }
1239  else {
1240  *term2++ = *info1++; *term2++ = *info1++; COPY1ARG(term2,info1)
1241  ngeneral++;
1242  }
1243  }
1244  else {
1245  MLOCK(ErrorMessageLock);
1246  MesPrint("&irregular code found in replace transformation (RunReplace)");
1247  MUNLOCK(ErrorMessageLock);
1248  Terminate(-1);
1249  }
1250  }
1251  AT.WorkPointer = term2;
1252  *term1 = term2 - term1;
1253  term1[2] = *term1 - 1;
1254 /*
1255  And now stepping through the arguments
1256 */
1257  while ( t < tstop ) {
1258  n++; /* The number of the argument. Now check whether we need it */
1259  if ( TestArgNum(n,totarg,args) == 0 ) {
1260  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1261  if ( *t <= -FUNCTION ) { *u++ = *t++; }
1262  else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1263  else { i = *t; NCOPY(u,t,i) }
1264  }
1265  else *u++ = *t++;
1266  continue;
1267  }
1268 /*
1269  Here we have in info effectively a replace_ function, but with
1270  additionally the possibility of integer arguments. We treat those first
1271  and for the rest we have to do some pattern matching.
1272  Note that the compilation routine should check that there is an
1273  even number of arguments in the replace function.
1274 
1275  First we go for number -> something
1276 */
1277  if ( nfix > 0 ) {
1278  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1279  if ( *t == -SNUMBER ) {
1280  info1 = info + FUNHEAD;
1281  while ( info1 < infoend ) {
1282  if ( *info1 == -SNUMBER ) {
1283  if ( info1[1] == t[1] ) {
1284  if ( info1[2] == -SNUMBER ) {
1285  *u++ = -SNUMBER; *u++ = info1[3];
1286  info1 += 4;
1287  }
1288  else {
1289  info1 += 2;
1290  if ( info1[0] <= -FUNCTION ) i = 1;
1291  else if ( info1[0] < 0 ) i = 2;
1292  else i = *info1;
1293  NCOPY(u,info1,i)
1294  }
1295  t += 2; goto nextt;
1296  }
1297  info1 += 2;
1298  NEXTARG(info1);
1299  }
1300  else {
1301  NEXTARG(info1);
1302  NEXTARG(info1);
1303  }
1304  }
1305  }
1306  }
1307  else { /* Tensor */
1308  if ( *t < AM.OffsetIndex && *t >= 0 ) {
1309  info1 = info + FUNHEAD;
1310  while ( info1 < infoend ) {
1311  if ( ( *info1 == -SNUMBER ) && ( info1[1] == *t )
1312  && ( ( ( info1[2] == -SNUMBER ) && ( info1[3] >= 0 )
1313  && ( info1[3] < AM.OffsetIndex ) )
1314  || ( info1[2] == -INDEX || info1[2] == -VECTOR
1315  || info1[2] == -MINVECTOR ) ) ) {
1316  *u++ = info1[3];
1317  info1 += 4;
1318  t++; goto nextt;
1319  }
1320  else {
1321  NEXTARG(info1);
1322  NEXTARG(info1);
1323  }
1324  }
1325  }
1326  }
1327  }
1328 /*
1329  First we try to catch those elements that have an exact match
1330  in the traditional replace_ part.
1331  This means that *t should be less than zero and match an entry
1332  in the replace_ function that we prepared.
1333 */
1334  if ( ngeneral > 0 ) {
1335  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1336  if ( *t < 0 ) {
1337  term3 = term1 + *term1;
1338  term4 = term1 + FUNHEAD;
1339  while ( term4 < term3 ) {
1340  if ( *term4 == *t && ( *t <= -FUNCTION ||
1341  ( t[1] == term4[1] ) ) ) break;
1342  NEXTARG(term4)
1343  }
1344  if ( term4 < term3 ) goto dothisnow;
1345  }
1346  }
1347  else {
1348  term3 = term1 + *term1;
1349  term4 = term1 + FUNHEAD;
1350  while ( term4 < term3 ) {
1351  if ( ( term4[1] == *t ) &&
1352  ( ( *term4 == -INDEX || *term4 == -VECTOR ||
1353  ( *term4 == -SYMBOL && term4[1] < AM.OffsetIndex
1354  && term4[1] >= 0 ) ) ) ) break;
1355  NEXTARG(term4)
1356  }
1357  if ( term4 < term3 ) goto dothisnow;
1358  }
1359  }
1360 /*
1361  First we eliminate the fixed arguments and make a 'new info'
1362  If there is anything left we can continue.
1363  Now we look for whole argument wildcards (arg_, parg_, iarg_ or farg_)
1364 */
1365  if ( nwild > 0 ) {
1366 /*
1367  If we have f(a)*replace_(xarg_,b(xarg_)) this gives f(b(a))
1368  In testing the wildcard we have CheckWild do the work.
1369  This means that we have to set op the special variables
1370  (AT.WildMask,AN.WildValue,AN.NumWild)
1371 
1372 */
1373  wild[1] = 4;
1374  info1 = info + FUNHEAD;
1375  while ( info1 < infoend ) {
1376  if ( *info1 == -SYMBOL && info1[1] == WILDARGSYMBOL
1377  && ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) ) {
1378  wild[0] = SYMTOSUB;
1379  wild[2] = WILDARGSYMBOL;
1380  wild[3] = 0;
1381  AN.WildValue = wild;
1382  AT.WildMask = &mask;
1383  mask = 0;
1384  AN.NumWild = 1;
1385  if ( *t == -SYMBOL || ( *t > 0 && CheckWild(BHEAD WILDARGSYMBOL,SYMTOSUB,1,t) == 0 ) ) {
1386 /*
1387  We put the part in replace in a function and make
1388  a replace_(xarg_,(t argument)).
1389 */
1390  n1 = SYMBOL; n2 = WILDARGSYMBOL;
1391  info1 += 2;
1392 getthisone:;
1393  term3 = term2+1;
1394  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1395  *term3++ = DUMFUN; term3++; FILLFUN(term3)
1396  COPY1ARG(term3,info1)
1397  }
1398  else {
1399  *term3++ = fun[0]; term3++; FILLFUN(term3)
1400  *term3++ = *info1;
1401  }
1402  term2[2] = term3 - term2 - 1;
1403  tt = term3;
1404  *term3++ = REPLACEMENT;
1405  term3++; FILLFUN(term3)
1406  *term3++ = -n1;
1407  if ( n1 < FUNCTION ) *term3++ = n2;
1408  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1409  term4 = t;
1410  COPY1ARG(term3,term4)
1411  }
1412  else {
1413  *term3++ = *t;
1414  }
1415  tt[1] = term3 - tt;
1416  *term3++ = 1; *term3++ = 1; *term3++ = 3;
1417  *term2 = term3 - term2;
1418 
1419  AT.WorkPointer = term3;
1420  NewSort(BHEAD0);
1421  if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1422  LowerSortLevel();
1423  AT.WorkPointer = oldwork;
1424  return(-1);
1425  }
1426  term4 = AT.WorkPointer;
1427  if ( EndSort(BHEAD term4,0) < 0 ) {}
1428  if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1429  MLOCK(ErrorMessageLock);
1430  MesPrint("&information in replace transformation does not evaluate into a single term");
1431  MUNLOCK(ErrorMessageLock);
1432  return(-1);
1433  }
1434 /*
1435  Now we can copy the new function argument to the output u
1436 */
1437  i = term4[2]-FUNHEAD;
1438  term3 = term4+FUNHEAD+1;
1439  NCOPY(u,term3,i)
1440  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1441  NEXTARG(t)
1442  }
1443  else t++;
1444  AT.WorkPointer = term2;
1445 
1446  goto nextt;
1447  }
1448  info1 += 2; NEXTARG(info1)
1449  }
1450  else if ( ( *info1 == -INDEX )
1451  && ( info[1] == WILDARGINDEX + AM.OffsetIndex ) ) {
1452  wild[0] = INDTOSUB;
1453  wild[2] = WILDARGINDEX+AM.OffsetIndex;
1454  wild[3] = 0;
1455  AN.WildValue = wild;
1456  AT.WildMask = &mask;
1457  mask = 0;
1458  AN.NumWild = 1;
1459  if ( ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION )
1460  || ( *t == -INDEX || ( *t > 0 && CheckWild(BHEAD WILDARGINDEX,INDTOSUB,1,t) == 0 ) ) ) {
1461 /*
1462  We put the part in replace in a function and make
1463  a replace_(xarg_,(t argument)).
1464 */
1465  n1 = INDEX; n2 = WILDARGINDEX+AM.OffsetIndex;
1466  info1 += 2;
1467  goto getthisone;
1468  }
1469  info1 += 2; NEXTARG(info1)
1470  }
1471  else if ( ( *info1 == -VECTOR )
1472  && ( info1[1] == WILDARGVECTOR + AM.OffsetVector ) ) {
1473  wild[0] = VECTOSUB;
1474  wild[2] = WILDARGVECTOR+AM.OffsetVector;
1475  wild[3] = 0;
1476  AN.WildValue = wild;
1477  AT.WildMask = &mask;
1478  mask = 0;
1479  AN.NumWild = 1;
1480  if ( functions[fun[0]-FUNCTION].spec == TENSORFUNCTION ) {
1481  if ( *t < MINSPEC ) {
1482  n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1483  info1 += 2;
1484  goto getthisone;
1485  }
1486  }
1487  else if ( *t == -VECTOR || *t == -MINVECTOR ||
1488  ( *t > 0 && CheckWild(BHEAD WILDARGVECTOR,VECTOSUB,1,t) == 0 ) ) {
1489 /*
1490  We put the part in replace in a function and make
1491  a replace_(xarg_,(t argument)).
1492 */
1493  n1 = VECTOR; n2 = WILDARGVECTOR+AM.OffsetVector;
1494  info1 += 2;
1495  goto getthisone;
1496  }
1497  info1 += 2; NEXTARG(info1)
1498  }
1499  else if ( *info1 == -WILDARGFUN ) {
1500  wild[0] = FUNTOFUN;
1501  wild[2] = WILDARGFUN;
1502  wild[3] = 0;
1503  AN.WildValue = wild;
1504  AT.WildMask = &mask;
1505  mask = 0;
1506  AN.NumWild = 1;
1507  if ( *t <= -FUNCTION || ( *t > 0 && CheckWild(BHEAD WILDARGFUN,FUNTOFUN,1,t) == 0 ) ) {
1508 /*
1509  We put the part in replace in a function and make
1510  a replace_(xarg_,(t argument)).
1511 */
1512  n2 = n1 = -WILDARGFUN; /* n2 is to keep the compiler quiet */
1513  info1++;
1514  goto getthisone;
1515  }
1516  info1++; NEXTARG(info1)
1517  }
1518  else {
1519  NEXTARG(info1) NEXTARG(info1)
1520  }
1521  }
1522  }
1523  if ( ngeneral > 0 ) {
1524 /*
1525  They are all in a replace_ function.
1526  Compose the whole thing into a term with replace_()*dum_(arg)
1527  which will be given to Generator.
1528  If we have f(a(x))*replace_(x,b) this gives f(a(b))
1529 */
1530 dothisnow:;
1531  term3 = term2; term4 = term1; i = *term1;
1532  NCOPY(term3,term4,i)
1533  term4 = term3;
1534  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1535  *term3++ = DUMFUN; term3++; FILLFUN(term3);
1536  tt = t;
1537  COPY1ARG(term3,tt)
1538  }
1539  else {
1540  *term3++ = fun[0]; term3++; FILLFUN(term3); *term3++ = *t;
1541  }
1542  term4[1] = term3-term4;
1543  *term3++ = 1; *term3++ = 1; *term3++ = 3;
1544  *term2 = term3-term2;
1545  AT.WorkPointer = term3;
1546  NewSort(BHEAD0);
1547  if ( Generator(BHEAD term2,AR.Cnumlhs) ) {
1548  LowerSortLevel();
1549  AT.WorkPointer = oldwork;
1550  return(-1);
1551  }
1552  term4 = AT.WorkPointer;
1553  if ( EndSort(BHEAD term4,0) < 0 ) {}
1554  if ( ( *term4 && *(term4+*term4) != 0 ) || *term4 == 0 ) {
1555  MLOCK(ErrorMessageLock);
1556  MesPrint("&information in replace transformation does not evaluate into a single term");
1557  MUNLOCK(ErrorMessageLock);
1558  return(-1);
1559  }
1560 /*
1561  Now we can copy the new function argument to the output u
1562 */
1563  i = term4[2]-FUNHEAD;
1564  term3 = term4+FUNHEAD+1;
1565  NCOPY(u,term3,i)
1566  NEXTARG(t)
1567  AT.WorkPointer = term2;
1568 
1569  goto nextt;
1570  }
1571 
1572 /*
1573  No catch. Copy the argument and continue.
1574 */
1575  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1576  if ( *t <= -FUNCTION ) { *u++ = *t++; }
1577  else if ( *t < 0 ) { *u++ = *t++; *u++ = *t++; }
1578  else { i = *t; NCOPY(u,t,i) }
1579  }
1580  else {
1581  *u++ = *t++;
1582  }
1583 nextt:;
1584  }
1585  i = u - tstop; tstop[1] = i; tstop[2] = dirty;
1586  t = fun; u = tstop; NCOPY(t,u,i)
1587  AT.WorkPointer = oldwork;
1588  return(0);
1589 }
1590 
1591 /*
1592  #] RunReplace :
1593  #[ RunImplode :
1594 
1595  Note that we restrict ourselves to short integers and/or single symbols
1596 */
1597 
1598 WORD RunImplode(WORD *fun, WORD *args)
1599 {
1600  WORD *tt, *tstop, totarg, arg1, arg2, num1, num2, i, i1, n;
1601  WORD *f, *t, *ttt, *t4, *ff, *fff;
1602  WORD moveup, numzero, outspace;
1603  if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1604  if ( *args != ARGRANGE ) {
1605  MLOCK(ErrorMessageLock);
1606  MesPrint("Illegal range encountered in RunImplode");
1607  MUNLOCK(ErrorMessageLock);
1608  Terminate(-1);
1609  }
1610  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1611  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1612  arg1 = args[1];
1613  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
1614  arg2 = args[2];
1615  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
1616 /*
1617  Get the proper range in forward direction and the number of arguments
1618 */
1619  if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; }
1620  else { num1 = arg1; num2 = arg2; }
1621  if ( num1 > totarg || num2 > totarg ) return(0);
1622 /*
1623  We need, for the most general case 4 spots for each:
1624  x,pow,coef,sign
1625  Hence we put these in the workspace above the term after tstop
1626 */
1627  n = 1; f = fun+FUNHEAD;
1628  while ( n < num1 ) {
1629  if ( f >= tstop ) return(0);
1630  NEXTARG(f);
1631  n++;
1632  }
1633  ff = f;
1634 /*
1635  We are now at the first argument to be done
1636  Go through the terms and test their validity.
1637  If one of them doesn't conform to the rules we don't do anything.
1638  The terms to be done are put in special notation after the function.
1639  Notation: numsymbol, power, |coef|, sign
1640  If numsymbol is negative there is no symbol.
1641  We do it this way because otherwise stepping backwards (as in range=(4,1))
1642  would be very difficult.
1643 */
1644  tt = tstop; i = 0;
1645  while ( n <= num2 ) {
1646  if ( f >= tstop ) return(0);
1647  if ( *f == -SNUMBER ) { *tt++ = -1; *tt++ = 0;
1648  if ( f[1] < 0 ) { *tt++ = -f[1]; *tt++ = -1; }
1649  else { *tt++ = f[1]; *tt++ = 1; }
1650  f += 2;
1651  }
1652  else if ( *f == -SYMBOL ) { *tt++ = f[1]; *tt++ = 1; *tt++ = 1; *tt++ = 1; f += 2; }
1653  else if ( *f < 0 ) return(0);
1654  else {
1655  if ( *f != ( f[ARGHEAD]+ARGHEAD ) ) return(0); /* Not a single term */
1656  t = f + *f - 1;
1657  i1 = ABS(*t);
1658  if ( ( i1 > 3 ) || ( t[-1] != 1 ) ) return(0); /* Not an integer or too big */
1659  if ( (UWORD)(t[-2]) > MAXPOSITIVE2 ) return(0); /* number too big */
1660  if ( f[ARGHEAD] == i1+1 ) { /* numerical which is fine */
1661  *tt++ = -1; *tt++ = 0; *tt++ = t[-2];
1662  if ( *t < 0 ) { *tt++ = -1; }
1663  else { *tt++ = 1; }
1664  }
1665  else if ( ( f[ARGHEAD+1] != SYMBOL )
1666  || ( f[ARGHEAD+2] != 4 )
1667  || ( ( f+ARGHEAD+1+f[ARGHEAD+2] ) < ( t-i1 ) ) ) return(0);
1668  /* not a single symbol with a coefficient */
1669  else {
1670  *tt++ = f[ARGHEAD+3];
1671  *tt++ = f[ARGHEAD+4];
1672  *tt++ = t[-2];
1673  if ( *t < 0 ) { *tt++ = -1; }
1674  else { *tt++ = 1; }
1675  }
1676  f += *f;
1677  }
1678  i++; n++;
1679  }
1680  fff = f;
1681 /*
1682  At this point we can do the implosion.
1683  Requirement: no coefficient shall take more than one word.
1684  (a stricter requirement may be needed to keep the explosion contained)
1685 */
1686  if ( arg1 > arg2 ) {
1687 /*
1688  Work backward.
1689 */
1690  t = tt - 4; numzero = 0;
1691  while ( t >= tstop ) {
1692  if ( t[2] == 0 ) numzero++;
1693  else {
1694  if ( numzero > 0 ) {
1695  t[2] += numzero;
1696  t4 = t+4;
1697  ttt = t4 + 4*numzero;
1698  while ( ttt < tt ) *t4++ = *ttt++;
1699  tt -= 4*numzero;
1700  numzero = 0;
1701  }
1702  }
1703  t -= 4;
1704  }
1705  }
1706  else {
1707  t = tstop;
1708  numzero = 0; ttt = t;
1709  while ( t < tt ) {
1710  if ( t[2] == 0 ) numzero++;
1711  else {
1712  if ( numzero > 0 ) {
1713  t[2] += numzero;
1714  t4 = t;
1715  while ( t4 < tt ) *ttt++ = *t4++;
1716  tt -= 4*numzero;
1717  t -= 4*numzero;
1718  ttt = t + 4;
1719  numzero = 0;
1720  }
1721  else {
1722  ttt = t + 4;
1723  }
1724  }
1725  t += 4;
1726  }
1727 /*
1728  We may have numzero > 0 at the end. We leave them.
1729  Output space is currently from tstop to tt
1730 */
1731  }
1732 /*
1733  Now we compute the real output space needed
1734 */
1735  t = tstop; outspace = 0;
1736  while ( t < tt ) {
1737  if ( t[0] == -1 ) {
1738  if ( t[2] > MAXPOSITIVE2 ) { return(0); /* Number too big */ }
1739  outspace += 2;
1740  }
1741  else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) { outspace += 2; }
1742  else { outspace += 8 + ARGHEAD; }
1743  t += 4;
1744  }
1745  if ( outspace < (fff-ff) ) {
1746  t = tstop;
1747  while ( t < tt ) {
1748  if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
1749  else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
1750  *ff++ = -SYMBOL; *ff++ = t[0];
1751  }
1752  else {
1753  *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
1754  *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
1755  *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
1756  }
1757  t += 4;
1758  }
1759  while ( fff < tstop ) *ff++ = *fff++;
1760  fun[1] = ff - fun;
1761  }
1762  else if ( outspace > (fff-ff) ) {
1763 /*
1764  Move the answer up by the required amount.
1765  Move the tail to its new location
1766  Move in things as for outspace == (fff-ff)
1767 */
1768  moveup = outspace-(fff-ff);
1769  ttt = tt + moveup;
1770  t = tt;
1771  while ( t > fff ) *--ttt = *--t;
1772  tt += moveup; tstop += moveup;
1773  fff += moveup;
1774  fun[1] += moveup;
1775  goto moveinto;
1776  }
1777  else {
1778 moveinto:
1779  t = tstop;
1780  while ( t < tt ) {
1781  if ( t[0] == -1 ) { *ff++ = -SNUMBER; *ff++ = t[2]*t[3]; }
1782  else if ( t[1] == 1 && t[2] == 1 && t[3] == 1 ) {
1783  *ff++ = -SYMBOL; *ff++ = t[0];
1784  }
1785  else {
1786  *ff++ = 8+ARGHEAD; *ff++ = 0; FILLARG(ff);
1787  *ff++ = 8; *ff++ = SYMBOL; *ff++ = 4; *ff++ = t[0]; *ff++ = t[1];
1788  *ff++ = t[2]; *ff++ = 1; *ff++ = t[3] > 0 ? 3: -3;
1789  }
1790  t += 4;
1791  }
1792  }
1793  return(0);
1794 }
1795 
1796 /*
1797  #] RunImplode :
1798  #[ RunExplode :
1799 */
1800 
1801 WORD RunExplode(PHEAD WORD *fun, WORD *args)
1802 {
1803  WORD arg1, arg2, num1, num2, *tt, *tstop, totarg, *tonew, *newfun;
1804  WORD *ff, *f;
1805  int reverse = 0, iarg, i, numzero;
1806  if ( functions[fun[0]-FUNCTION].spec != 0 ) return(0);
1807  if ( *args != ARGRANGE ) {
1808  MLOCK(ErrorMessageLock);
1809  MesPrint("Illegal range encountered in RunExplode");
1810  MUNLOCK(ErrorMessageLock);
1811  Terminate(-1);
1812  }
1813  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1814  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1815  arg1 = args[1];
1816  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
1817  arg2 = args[2];
1818  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
1819 /*
1820  Get the proper range in forward direction and the number of arguments
1821 */
1822  if ( arg1 > arg2 ) { num1 = arg2; num2 = arg1; reverse = 1; }
1823  else { num1 = arg1; num2 = arg2; }
1824  if ( num1 > totarg || num2 > totarg ) return(0);
1825  if ( tstop + AM.MaxTer > AT.WorkTop ) goto OverWork;
1826 /*
1827  We will make the new function after the old one in the workspace
1828  Find the first argument
1829 */
1830  tonew = newfun = tstop;
1831  ff = fun + FUNHEAD; iarg = 0;
1832  while ( ff < tstop ) {
1833  iarg++;
1834  if ( iarg == num1 ) {
1835  i = ff - fun; f = fun;
1836  NCOPY(tonew,f,i)
1837  break;
1838  }
1839  NEXTARG(ff)
1840  }
1841 /*
1842  We have reached the first argument to be done
1843 */
1844  while ( iarg <= num2 ) {
1845  if ( *ff == -SYMBOL ) { *tonew++ = *ff++; *tonew++ = *ff++; }
1846  else if ( *ff == -SNUMBER ) {
1847  numzero = ABS(ff[1])-1;
1848  if ( reverse ) {
1849  *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
1850  while ( numzero > 0 ) {
1851  *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
1852  }
1853  }
1854  else {
1855  while ( numzero > 0 ) {
1856  *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
1857  }
1858  *tonew++ = -SNUMBER; *tonew++ = ff[1] < 0 ? -1: 1;
1859  }
1860  ff += 2;
1861  }
1862  else if ( *ff < 0 ) { return(0); }
1863  else {
1864  if ( *ff != ARGHEAD+8 || ff[ARGHEAD] != 8
1865  || ff[ARGHEAD+1] != SYMBOL || ABS(ff[ARGHEAD+7]) != 3
1866  || ff[ARGHEAD+6] != 1 ) return(0);
1867  numzero = ff[ARGHEAD+5];
1868  if ( numzero >= MAXPOSITIVE2 ) return(0);
1869  numzero--;
1870  if ( reverse ) {
1871  if ( ff[ARGHEAD+7] > 0 ) { *tonew++ = -SNUMBER; *tonew++ = 1; }
1872  else {
1873  *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
1874  *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = ff[ARGHEAD+3];
1875  *tonew++ = ff[ARGHEAD+4]; *tonew++ = 1; *tonew++ = 1;
1876  *tonew++ = -3;
1877  }
1878  while ( numzero > 0 ) {
1879  *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
1880  }
1881  }
1882  else {
1883  while ( numzero > 0 ) {
1884  *tonew++ = -SNUMBER; *tonew++ = 0; numzero--;
1885  }
1886  if ( ff[ARGHEAD+7] > 0 ) { *tonew++ = -SNUMBER; *tonew++ = 1; }
1887  else {
1888  *tonew++ = ARGHEAD+8; *tonew++ = 0; FILLARG(tonew)
1889  *tonew++ = 8; *tonew++ = SYMBOL; *tonew++ = ff[ARGHEAD+3];
1890  *tonew++ = ff[ARGHEAD+4]; *tonew++ = 1; *tonew++ = 1;
1891  *tonew++ = -3;
1892  }
1893  }
1894  ff += *ff;
1895  }
1896  if ( tonew > AT.WorkTop ) goto OverWork;
1897  iarg++;
1898  }
1899 /*
1900  Copy the tail, settle the size and copy the whole thing back.
1901 */
1902  while ( ff < tstop ) *tonew++ = *ff++;
1903  i = newfun[1] = tonew-newfun;
1904  NCOPY(fun,newfun,i)
1905  return(0);
1906 OverWork:;
1907  MLOCK(ErrorMessageLock);
1908  MesWork();
1909  MUNLOCK(ErrorMessageLock);
1910  return(-1);
1911 }
1912 
1913 /*
1914  #] RunExplode :
1915  #[ RunPermute :
1916 */
1917 
1918 WORD RunPermute(PHEAD WORD *fun, WORD *args, WORD *info)
1919 {
1920  WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, *infostop;
1921  if ( *args != ARGRANGE ) {
1922  MLOCK(ErrorMessageLock);
1923  MesPrint("Illegal range encountered in RunPermute");
1924  MUNLOCK(ErrorMessageLock);
1925  Terminate(-1);
1926  }
1927  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
1928  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
1929  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
1930  arg1 = 1; arg2 = totarg;
1931 /*
1932  We need to:
1933  1: get pointers to the arguments
1934  2: permute the pointers
1935  3: copy the arguments to safe territory in the new order
1936  4: copy this new order back in situ.
1937 */
1938  num = arg2-arg1+1;
1939  WantAddPointers(num); /* Guarantees the presence of enough pointers */
1940  f = fun+FUNHEAD; n = 1; i = 0;
1941  while ( n < arg1 ) { n++; NEXTARG(f) }
1942  f1 = f;
1943  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
1944 /*
1945  Now the permutations
1946 */
1947  info++;
1948  while ( *info ) {
1949  infostop = info + *info;
1950  info++;
1951  if ( *info > totarg ) return(0);
1952  tt = AT.pWorkSpace[AT.pWorkPointer+*info];
1953  info++;
1954  while ( info < infostop ) {
1955  if ( *info > totarg ) return(0);
1956  AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
1957  info++;
1958  }
1959  AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
1960  }
1961 /*
1962  And the final cleanup
1963 */
1964  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
1965  f2 = tstop;
1966  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
1967  i = f2 - tstop;
1968  NCOPY(f1,tstop,i)
1969  }
1970  else { /* tensors */
1971  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop-tt;
1972  arg1 = 1; arg2 = totarg;
1973  num = arg2-arg1+1;
1974  WantAddPointers(num); /* Guarantees the presence of enough pointers */
1975  f = fun+FUNHEAD; n = 1; i = 0;
1976  while ( n < arg1 ) { n++; f++; }
1977  f1 = f;
1978  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
1979 /*
1980  Now the permutations
1981 */
1982  info++;
1983  while ( *info ) {
1984  infostop = info + *info;
1985  info++;
1986  if ( *info > totarg ) return(0);
1987  tt = AT.pWorkSpace[AT.pWorkPointer+*info];
1988  info++;
1989  while ( info < infostop ) {
1990  if ( *info > totarg ) return(0);
1991  AT.pWorkSpace[AT.pWorkPointer+info[-1]] = AT.pWorkSpace[AT.pWorkPointer+*info];
1992  info++;
1993  }
1994  AT.pWorkSpace[AT.pWorkPointer+info[-1]] = tt;
1995  }
1996 /*
1997  And the final cleanup
1998 */
1999  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2000  f2 = tstop;
2001  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++= *f++; }
2002  i = f2 - tstop;
2003  NCOPY(f1,tstop,i)
2004  }
2005  return(0);
2006 OverWork:;
2007  MLOCK(ErrorMessageLock);
2008  MesWork();
2009  MUNLOCK(ErrorMessageLock);
2010  return(-1);
2011 }
2012 
2013 /*
2014  #] RunPermute :
2015  #[ RunReverse :
2016 */
2017 
2018 WORD RunReverse(PHEAD WORD *fun, WORD *args)
2019 {
2020  WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, *f, *f1, *f2, i1, i2;
2021  if ( *args != ARGRANGE ) {
2022  MLOCK(ErrorMessageLock);
2023  MesPrint("Illegal range encountered in RunReverse");
2024  MUNLOCK(ErrorMessageLock);
2025  Terminate(-1);
2026  }
2027  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2028  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2029  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2030  arg1 = args[1];
2031  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
2032  arg2 = args[2];
2033  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
2034 /*
2035  We need to:
2036  1: get pointers to the arguments
2037  2: reverse the order of the pointers
2038  3: copy the arguments to safe territory in the new order
2039  4: copy this new order back in situ.
2040 */
2041  if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2042  if ( arg2 > totarg ) return(0);
2043 
2044  num = arg2-arg1+1;
2045  WantAddPointers(num); /* Guarantees the presence of enough pointers */
2046  f = fun+FUNHEAD; n = 1; i = 0;
2047  while ( n < arg1 ) { n++; NEXTARG(f) }
2048  f1 = f;
2049  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2050  i1 = i-1; i2 = 0;
2051  while ( i1 > i2 ) {
2052  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2053  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2054  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2055  i1--; i2++;
2056  }
2057  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2058  f2 = tstop;
2059  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2060  i = f2 - tstop;
2061  NCOPY(f1,tstop,i)
2062  }
2063  else { /* Tensors */
2064  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2065  arg1 = args[1];
2066  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
2067  arg2 = args[2];
2068  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
2069 /*
2070  We need to:
2071  1: get pointers to the arguments
2072  2: reverse the order of the pointers
2073  3: copy the arguments to safe territory in the new order
2074  4: copy this new order back in situ.
2075 */
2076  if ( arg2 < arg1 ) { n = arg1; arg1 = arg2; arg2 = n; }
2077  if ( arg2 > totarg ) return(0);
2078 
2079  num = arg2-arg1+1;
2080  WantAddPointers(num); /* Guarantees the presence of enough pointers */
2081  f = fun+FUNHEAD; n = 1; i = 0;
2082  while ( n < arg1 ) { n++; f++; }
2083  f1 = f;
2084  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2085  i1 = i-1; i2 = 0;
2086  while ( i1 > i2 ) {
2087  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2088  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2089  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2090  i1--; i2++;
2091  }
2092  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2093  f2 = tstop;
2094  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2095  i = f2 - tstop;
2096  NCOPY(f1,tstop,i)
2097  }
2098  return(0);
2099 OverWork:;
2100  MLOCK(ErrorMessageLock);
2101  MesWork();
2102  MUNLOCK(ErrorMessageLock);
2103  return(-1);
2104 }
2105 
2106 /*
2107  #] RunReverse :
2108  #[ RunCycle :
2109 */
2110 
2111 WORD RunCycle(PHEAD WORD *fun, WORD *args, WORD *info)
2112 {
2113  WORD *tt, totarg, *tstop, arg1, arg2, n, num, i, j, *f, *f1, *f2, x;
2114  if ( *args != ARGRANGE ) {
2115  MLOCK(ErrorMessageLock);
2116  MesPrint("Illegal range encountered in RunCycle");
2117  MUNLOCK(ErrorMessageLock);
2118  Terminate(-1);
2119  }
2120  if ( functions[fun[0]-FUNCTION].spec != TENSORFUNCTION ) {
2121  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2122  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2123  arg1 = args[1]; arg2 = args[2];
2124  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
2125  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
2126  if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2127  if ( arg2 > totarg ) return(0);
2128 /*
2129  We need to:
2130  1: get pointers to the arguments
2131  2: cycle the pointers
2132  3: copy the arguments to safe territory in the new order
2133  4: copy this new order back in situ.
2134 */
2135  num = arg2-arg1+1;
2136  WantAddPointers(num); /* Guarantees the presence of enough pointers */
2137  f = fun+FUNHEAD; n = 1; i = 0;
2138  while ( n < arg1 ) { n++; NEXTARG(f) }
2139  f1 = f;
2140  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2141 /*
2142  Now the cycle(s). First minimize the number of cycles.
2143 */
2144  info++;
2145  x = *info;
2146  if ( x >= i ) {
2147  x %= i;
2148  if ( x > i/2 ) x -= i;
2149  }
2150  else if ( x <= -i ) {
2151  x = -((-x) % i);
2152  if ( x <= -i/2 ) x += i;
2153  }
2154  while ( x ) {
2155  if ( x > 0 ) {
2156  tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2157  for ( j = i-1; j > 0; j-- )
2158  AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2159  AT.pWorkSpace[AT.pWorkPointer] = tt;
2160  x--;
2161  }
2162  else {
2163  tt = AT.pWorkSpace[AT.pWorkPointer];
2164  for ( j = 1; j < i; j++ )
2165  AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2166  AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2167  x++;
2168  }
2169  }
2170 /*
2171  And the final cleanup
2172 */
2173  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2174  f2 = tstop;
2175  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2176  i = f2 - tstop;
2177  NCOPY(f1,tstop,i)
2178  }
2179  else { /* Tensors */
2180  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = tstop - tt;
2181  arg1 = args[1]; arg2 = args[2];
2182  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
2183  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
2184  if ( arg1 > arg2 ) { n = arg1; arg1 = arg2; arg2 = n; }
2185  if ( arg2 > totarg ) return(0);
2186 /*
2187  We need to:
2188  1: get pointers to the arguments
2189  2: cycle the pointers
2190  3: copy the arguments to safe territory in the new order
2191  4: copy this new order back in situ.
2192 */
2193  num = arg2-arg1+1;
2194  WantAddPointers(num); /* Guarantees the presence of enough pointers */
2195  f = fun+FUNHEAD; n = 1; i = 0;
2196  while ( n < arg1 ) { n++; f++; }
2197  f1 = f;
2198  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; f++; }
2199 /*
2200  Now the cycle(s). First minimize the number of cycles.
2201 */
2202  info++;
2203  x = *info;
2204  if ( x >= i ) {
2205  x %= i;
2206  if ( x > i/2 ) x -= i;
2207  }
2208  else if ( x <= -i ) {
2209  x = -((-x) % i);
2210  if ( x <= -i/2 ) x += i;
2211  }
2212  while ( x ) {
2213  if ( x > 0 ) {
2214  tt = AT.pWorkSpace[AT.pWorkPointer+i-1];
2215  for ( j = i-1; j > 0; j-- )
2216  AT.pWorkSpace[AT.pWorkPointer+j] = AT.pWorkSpace[AT.pWorkPointer+j-1];
2217  AT.pWorkSpace[AT.pWorkPointer] = tt;
2218  x--;
2219  }
2220  else {
2221  tt = AT.pWorkSpace[AT.pWorkPointer];
2222  for ( j = 1; j < i; j++ )
2223  AT.pWorkSpace[AT.pWorkPointer+j-1] = AT.pWorkSpace[AT.pWorkPointer+j];
2224  AT.pWorkSpace[AT.pWorkPointer+j-1] = tt;
2225  x++;
2226  }
2227  }
2228 /*
2229  And the final cleanup
2230 */
2231  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2232  f2 = tstop;
2233  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; *f2++ = *f++; }
2234  i = f2 - tstop;
2235  NCOPY(f1,tstop,i)
2236  }
2237  return(0);
2238 OverWork:;
2239  MLOCK(ErrorMessageLock);
2240  MesWork();
2241  MUNLOCK(ErrorMessageLock);
2242  return(-1);
2243 }
2244 
2245 /*
2246  #] RunCycle :
2247  #[ RunIsLyndon :
2248 
2249  Determines whether the range constitutes a Lyndon word.
2250  The two cases of ordering are distinguised by the order of
2251  the numbers of the arguments in the range.
2252 */
2253 
2254 WORD RunIsLyndon(PHEAD WORD *fun, WORD *args, int par)
2255 {
2256  WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, n, i;
2257 /* WORD *f1; */
2258  WORD sign, i1, i2, retval;
2259  if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2260  if ( *args != ARGRANGE ) {
2261  MLOCK(ErrorMessageLock);
2262  MesPrint("Illegal range encountered in RunIsLyndon");
2263  MUNLOCK(ErrorMessageLock);
2264  Terminate(-1);
2265  }
2266  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2267  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2268  arg1 = args[1];
2269  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
2270  arg2 = args[2];
2271  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
2272  if ( arg1 > totarg || arg2 > totarg ) return(-1);
2273 /*
2274  Now make a list of the relevant arguments.
2275 */
2276  if ( arg1 == arg2 ) return(1);
2277  if ( arg2 < arg1 ) { /* greater, rather than smaller */
2278  arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2279  }
2280  else sign = 0;
2281 
2282  num = arg2-arg1+1;
2283  WantAddPointers(num); /* Guarantees the presence of enough pointers */
2284  f = fun+FUNHEAD; n = 1; i = 0;
2285  while ( n < arg1 ) { n++; NEXTARG(f) }
2286 /* f1 = f; */
2287  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2288 /*
2289  If sign == 1 we should alter the order of the pointers first
2290 */
2291  if ( sign ) {
2292  i1 = i-1; i2 = 0;
2293  while ( i1 > i2 ) {
2294  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2295  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2296  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2297  i1--; i2++;
2298  }
2299  }
2300 /*
2301  The argument range is from f1 to f and the num pointers to the arguments
2302  are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2303 */
2304  for ( i1 = 1; i1 < num; i1++ ) {
2305  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
2306  AT.pWorkSpace[AT.pWorkPointer]);
2307  if ( retval > 0 ) continue;
2308  if ( retval < 0 ) return(0);
2309  for ( i2 = 1; i2 < num; i2++ ) {
2310  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
2311  AT.pWorkSpace[AT.pWorkPointer+i2]);
2312  if ( retval < 0 ) return(0);
2313  if ( retval > 0 ) goto nexti1;
2314  }
2315 /*
2316  If we come here the sequence is not unique.
2317 */
2318  return(0);
2319 nexti1:;
2320  }
2321  return(1);
2322 }
2323 
2324 /*
2325  #] RunIsLyndon :
2326  #[ RunToLyndon :
2327 
2328  Determines whether the range constitutes a Lyndon word.
2329  If not, we rotate it to a Lyndon word. If this is not possible
2330  we return the noLyndon condition.
2331  The two cases of ordering are distinguised by the order of
2332  the numbers of the arguments in the range.
2333 */
2334 
2335 WORD RunToLyndon(PHEAD WORD *fun, WORD *args, int par)
2336 {
2337  WORD *tt, totarg, *tstop, arg1, arg2, arg, num, *f, *f1, *f2, n, i;
2338  WORD sign, i1, i2, retval, unique;
2339  if ( fun[0] <= GAMMASEVEN && fun[0] >= GAMMA ) return(0);
2340  if ( *args != ARGRANGE ) {
2341  MLOCK(ErrorMessageLock);
2342  MesPrint("Illegal range encountered in RunToLyndon");
2343  MUNLOCK(ErrorMessageLock);
2344  Terminate(-1);
2345  }
2346  tt = fun+FUNHEAD; tstop = fun+fun[1]; totarg = 0;
2347  while ( tt < tstop ) { totarg++; NEXTARG(tt); }
2348  arg1 = args[1];
2349  if ( arg1 >= MAXPOSITIVE2 ) { arg1 = totarg-(arg1-MAXPOSITIVE2); }
2350  arg2 = args[2];
2351  if ( arg2 >= MAXPOSITIVE2 ) { arg2 = totarg-(arg2-MAXPOSITIVE2); }
2352  if ( arg1 > totarg || arg2 > totarg ) return(-1);
2353 /*
2354  Now make a list of the relevant arguments.
2355 */
2356  if ( arg1 == arg2 ) return(1);
2357  if ( arg2 < arg1 ) { /* greater, rather than smaller */
2358  arg = arg1; arg1 = arg2; arg2 = arg; sign = 1;
2359  }
2360  else sign = 0;
2361 
2362  num = arg2-arg1+1;
2363  WantAddPointers((2*num)); /* Guarantees the presence of enough pointers */
2364  f = fun+FUNHEAD; n = 1; i = 0;
2365  while ( n < arg1 ) { n++; NEXTARG(f) }
2366  f1 = f;
2367  while ( n <= arg2 ) { AT.pWorkSpace[AT.pWorkPointer+i++] = f; n++; NEXTARG(f) }
2368 /*
2369  If sign == 1 we should alter the order of the pointers first
2370 */
2371  if ( sign ) {
2372  i1 = i-1; i2 = 0;
2373  while ( i1 > i2 ) {
2374  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2375  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2376  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2377  i1--; i2++;
2378  }
2379  }
2380 /*
2381  The argument range is from f1 to f and the num pointers to the arguments
2382  are in AT.pWorkSpace[AT.pWorkPointer] to AT.pWorkSpace[AT.pWorkPointer+num-1]
2383 */
2384  unique = 1;
2385  for ( i1 = 1; i1 < num; i1++ ) {
2386  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+i1],
2387  AT.pWorkSpace[AT.pWorkPointer]);
2388  if ( retval > 0 ) continue;
2389  if ( retval < 0 ) {
2390 Rotate:;
2391 /*
2392  Rotate so that i1 becomes the zero element. Then start again.
2393 */
2394  for ( i2 = 0; i2 < num; i2++ ) {
2395  AT.pWorkSpace[AT.pWorkPointer+num+i2] =
2396  AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num];
2397  }
2398  for ( i2 = 0; i2 < num; i2++ ) {
2399  AT.pWorkSpace[AT.pWorkPointer+i2] =
2400  AT.pWorkSpace[AT.pWorkPointer+i2+num];
2401  }
2402  i1 = 0;
2403  goto nexti1;
2404  }
2405  for ( i2 = 1; i2 < num; i2++ ) {
2406  retval = par * CompArg(AT.pWorkSpace[AT.pWorkPointer+(i1+i2)%num],
2407  AT.pWorkSpace[AT.pWorkPointer+i2]);
2408  if ( retval < 0 ) goto Rotate;
2409  if ( retval > 0 ) goto nexti1;
2410  }
2411 /*
2412  If we come here the sequence is not unique.
2413 */
2414  unique = 0;
2415 nexti1:;
2416  }
2417  if ( sign ) {
2418  i1 = i-1; i2 = 0;
2419  while ( i1 > i2 ) {
2420  tt = AT.pWorkSpace[AT.pWorkPointer+i1];
2421  AT.pWorkSpace[AT.pWorkPointer+i1] = AT.pWorkSpace[AT.pWorkPointer+i2];
2422  AT.pWorkSpace[AT.pWorkPointer+i2] = tt;
2423  i1--; i2++;
2424  }
2425  }
2426 /*
2427  Now rewrite the arguments into the proper order
2428 */
2429  if ( tstop+(f-f1) > AT.WorkTop ) goto OverWork;
2430  f2 = tstop;
2431  for ( i = 0; i < num; i++ ) { f = AT.pWorkSpace[AT.pWorkPointer+i]; COPY1ARG(f2,f) }
2432  i = f2 - tstop;
2433  NCOPY(f1,tstop,i)
2434 /*
2435  The return value indicates whether we have a Lyndon word
2436 */
2437  return(unique);
2438 OverWork:;
2439  MLOCK(ErrorMessageLock);
2440  MesWork();
2441  MUNLOCK(ErrorMessageLock);
2442  return(-2);
2443 }
2444 
2445 /*
2446  #] RunToLyndon :
2447  #[ TestArgNum :
2448 
2449  Looks whether argument n is contained in any of the ranges
2450  specified in args. Args contains objects of the types
2451  ALLARGS
2452  NUMARG,num
2453  ARGRANGE,num1,num2
2454  The object MAKEARGS,num1,num2 is skipped
2455  Any other object terminates the range specifications.
2456 */
2457 
2458 int TestArgNum(int n, int totarg, WORD *args)
2459 {
2460  WORD x1, x2;
2461  for(;;) {
2462  switch ( *args ) {
2463  case ALLARGS:
2464  return(1);
2465  case NUMARG:
2466  if ( n == args[1] ) return(1);
2467  if ( args[1] >= MAXPOSITIVE2 ) {
2468  x1 = args[1]-MAXPOSITIVE2;
2469  if ( totarg-x1 == n ) return(1);
2470  }
2471  args += 2;
2472  break;
2473  case ARGRANGE:
2474  if ( args[1] >= MAXPOSITIVE2 ) {
2475  x1 = totarg-(args[1]-MAXPOSITIVE2);
2476  }
2477  else x1 = args[1];
2478  if ( args[2] >= MAXPOSITIVE2 ) {
2479  x2 = totarg-(args[2]-MAXPOSITIVE2);
2480  }
2481  else x2 = args[2];
2482  if ( x1 >= x2 ) {
2483  if ( n >= x2 && n <= x1 ) return(1);
2484  }
2485  else {
2486  if ( n >= x1 && n <= x2 ) return(1);
2487  }
2488  args += 3;
2489  break;
2490  case MAKEARGS:
2491  args += 3;
2492  break;
2493  default:
2494  return(0);
2495  }
2496  }
2497 }
2498 
2499 /*
2500  #] TestArgNum :
2501  #[ PutArgInScratch :
2502 */
2503 
2504 WORD PutArgInScratch(WORD *arg,UWORD *scrat)
2505 {
2506  WORD size, *t, i;
2507  if ( *arg == -SNUMBER ) {
2508  scrat[0] = ABS(arg[1]);
2509  if ( arg[1] < 0 ) size = -1;
2510  else size = 1;
2511  }
2512  else {
2513  t = arg+*arg-1;
2514  if ( *t < 0 ) { i = ((-*t)-1)/2; size = -i; }
2515  else { i = ( *t -1)/2; size = i; }
2516  t = arg+ARGHEAD+1;
2517  NCOPY(scrat,t,i);
2518  }
2519  return(size);
2520 }
2521 
2522 /*
2523  #] PutArgInScratch :
2524  #[ ReadRange :
2525 
2526  Comes in at the bracket and leaves at the = sign
2527  Ranges can be:
2528  #1,#2 with # numbers. If the second is smaller than the
2529  first we work it backwards.
2530  first,#2 or #2,first
2531  #1,last or last,#1
2532  first,last or last,first
2533  First is represented by 1. Last is represented by MAXPOSITIVE2.
2534 
2535  par = 0: we need the = after.
2536  par = 1: we need a , or '\0' after.
2537  par = 2: we need a :
2538 */
2539 
2540 UBYTE *ReadRange(UBYTE *s, WORD *out, int par)
2541 {
2542  UBYTE *in = s, *ss, c;
2543  LONG x1, x2;
2544 
2545  SKIPBRA3(in)
2546  if ( par == 0 && in[1] != '=' ) {
2547  MesPrint("&A range in this type of transform statement should be followed by a = sign");
2548  return(0);
2549  }
2550  else if ( par == 1 && in[1] != ',' && in[1] != '\0' ) {
2551  MesPrint("&A range in this type of transform statement should be followed by a comma or end-of-statement");
2552  return(0);
2553  }
2554  else if ( par == 2 && in[1] != ':' ) {
2555  MesPrint("&A range in this type of transform statement should be followed by a :");
2556  return(0);
2557  }
2558  s++;
2559  if ( FG.cTable[*s] == 0 ) {
2560  ss = s; while ( FG.cTable[*s] == 0 ) s++;
2561  c = *s; *s = 0;
2562  if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
2563  *s = c;
2564  x1 = 1;
2565  }
2566  else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
2567  *s = c;
2568  if ( c == '-' ) {
2569  s++; x1 = 0;
2570  while ( *s >= '0' && *s <= '9' ) {
2571  x1 = 10*x1 + *s++ - '0';
2572  if ( x1 >= MAXPOSITIVE2 ) {
2573  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE2);
2574  return(0);
2575  }
2576  }
2577  x1 += MAXPOSITIVE2;
2578  }
2579  else x1 = MAXPOSITIVE2;
2580  }
2581  else {
2582  MesPrint("&Illegal keyword inside range specification");
2583  return(0);
2584  }
2585  }
2586  else if ( FG.cTable[*s] == 1 ) {
2587  x1 = 0;
2588  while ( *s >= '0' && *s <= '9' ) {
2589  x1 = x1*10 + *s++ - '0';
2590  if ( x1 >= MAXPOSITIVE2 ) {
2591  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE2);
2592  return(0);
2593  }
2594  }
2595  }
2596  else {
2597  MesPrint("&Illegal character in range specification");
2598  return(0);
2599  }
2600  if ( *s != ',' ) {
2601  MesPrint("&A range is two indicators, separated by a comma or blank");
2602  return(0);
2603  }
2604  s++;
2605  if ( FG.cTable[*s] == 0 ) {
2606  ss = s; while ( FG.cTable[*s] == 0 ) s++;
2607  c = *s; *s = 0;
2608  if ( StrICmp(ss,(UBYTE *)"first") == 0 ) {
2609  *s = c;
2610  x2 = 1;
2611  }
2612  else if ( StrICmp(ss,(UBYTE *)"last") == 0 ) {
2613  *s = c;
2614  if ( c == '-' ) {
2615  s++; x2 = 0;
2616  while ( *s >= '0' && *s <= '9' ) {
2617  x2 = 10*x2 + *s++ - '0';
2618  if ( x2 >= MAXPOSITIVE2 ) {
2619  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE2);
2620  return(0);
2621  }
2622  }
2623  x2 += MAXPOSITIVE2;
2624  }
2625  else x2 = MAXPOSITIVE2;
2626  }
2627  else {
2628  MesPrint("&Illegal keyword inside range specification");
2629  return(0);
2630  }
2631  }
2632  else if ( FG.cTable[*s] == 1 ) {
2633  x2 = 0;
2634  while ( *s >= '0' && *s <= '9' ) {
2635  x2 = x2*10 + *s++ - '0';
2636  if ( x2 >= MAXPOSITIVE2 ) {
2637  MesPrint("&Fixed range indicator bigger than %l",(LONG)MAXPOSITIVE2);
2638  return(0);
2639  }
2640  }
2641  }
2642  else {
2643  MesPrint("&Illegal character in range specification");
2644  return(0);
2645  }
2646  if ( s < in ) {
2647  MesPrint("&A range is two indicators, separated by a comma or blank between parentheses");
2648  return(0);
2649  }
2650  out[0] = x1; out[1] = x2;
2651  return(in+1);
2652 }
2653 
2654 /*
2655  #] ReadRange :
2656  #] Transform :
2657 */
2658 
#define PHEAD
Definition: ftypes.h:56
VOID LowerSortLevel()
Definition: sort.c:4435
WORD NewSort(PHEAD0)
Definition: sort.c:553
WORD Generator(PHEAD WORD *, WORD)
Definition: proces.c:2865
LONG EndSort(PHEAD WORD *, int)
Definition: sort.c:632