FORM  4.2
sch.c
Go to the documentation of this file.
1 
6 /* #[ License : */
7 /*
8  * Copyright (C) 1984-2017 J.A.M. Vermaseren
9  * When using this file you are requested to refer to the publication
10  * J.A.M.Vermaseren "New features of FORM" math-ph/0010025
11  * This is considered a matter of courtesy as the development was paid
12  * for by FOM the Dutch physics granting agency and we would like to
13  * be able to track its scientific use to convince FOM of its value
14  * for the community.
15  *
16  * This file is part of FORM.
17  *
18  * FORM is free software: you can redistribute it and/or modify it under the
19  * terms of the GNU General Public License as published by the Free Software
20  * Foundation, either version 3 of the License, or (at your option) any later
21  * version.
22  *
23  * FORM is distributed in the hope that it will be useful, but WITHOUT ANY
24  * WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
25  * FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
26  * details.
27  *
28  * You should have received a copy of the GNU General Public License along
29  * with FORM. If not, see <http://www.gnu.org/licenses/>.
30  */
31 /* #] License : */
32 /*
33  #[ Includes : sch.c
34 */
35 
36 #include "form3.h"
37 
38 #ifdef ANSI
39 #include <stdarg.h>
40 #else
41 #ifdef mBSD
42 #include <varargs.h>
43 #else
44 #ifdef VMS
45 #include <varargs.h>
46 #else
47 typedef UBYTE *va_list;
48 #define va_dcl int va_alist;
49 #define va_start(list) list = (UBYTE *) &va_alist
50 #define va_end(list)
51 #define va_arg(list,mode) (((mode *)(list += sizeof(mode)))[-1])
52 #endif
53 #endif
54 #endif
55 
56 static int startinline = 0;
57 static char fcontchar = '&';
58 static int noextralinefeed = 0;
59 static int lowestlevel = 1;
60 
61 /*
62  #] Includes :
63  #[ schryf-Utilities :
64  #[ StrCopy : UBYTE *StrCopy(from,to)
65 */
66 
67 UBYTE *StrCopy(UBYTE *from, UBYTE *to)
68 {
69  while( ( *to++ = *from++ ) != 0 );
70  return(to-1);
71 }
72 
73 /*
74  #] StrCopy :
75  #[ AddToLine : VOID AddToLine(s)
76 
77  Puts the characters of s in the outputline. If the line becomes
78  filled it is written.
79 
80 */
81 
82 VOID AddToLine(UBYTE *s)
83 {
84  UBYTE *Out;
85  LONG num;
86  int i;
87  if ( AO.OutInBuffer ) { AddToDollarBuffer(s); return; }
88  Out = AO.OutFill;
89  while ( *s ) {
90  if ( Out >= AO.OutStop ) {
91  if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90 ) {
92  *Out++ = fcontchar;
93  }
94 #ifdef WITHRETURN
95  *Out++ = CARRIAGERETURN;
96 #endif
97  *Out++ = LINEFEED;
98  AO.FortFirst = 0;
99  num = Out - AO.OutputLine;
100 
101  if ( AC.LogHandle >= 0 ) {
102  if ( WriteFile(AC.LogHandle,AO.OutputLine+startinline
103  ,num-startinline) != (num-startinline) ) {
104 /*
105  We cannot write to an otherwise open log file.
106  The disk could be full of course.
107 */
108 #ifdef DEBUGGER
109  if ( BUG.logfileflag == 0 ) {
110  fprintf(stderr,"Panic: Cannot write to log file! Disk full?\n");
111  BUG.logfileflag = 1;
112  }
113  BUG.eflag = 1; BUG.printflag = 1;
114 #else
115  Terminate(-1);
116 #endif
117  }
118  }
119 
120  if ( ( AO.PrintType & PRINTLFILE ) == 0 ) {
121 #ifdef WITHRETURN
122  if ( num > 1 && AO.OutputLine[num-2] == CARRIAGERETURN ) {
123  AO.OutputLine[num-2] = LINEFEED;
124  num--;
125  }
126 #endif
127  if ( WriteFile(AM.StdOut,AO.OutputLine+startinline
128  ,num-startinline) != (num-startinline) ) {
129 #ifdef DEBUGGER
130  if ( BUG.stdoutflag == 0 ) {
131  fprintf(stderr,"Panic: Cannot write to standard output!\n");
132  BUG.stdoutflag = 1;
133  }
134  BUG.eflag = 1; BUG.printflag = 1;
135 #else
136  Terminate(-1);
137 #endif
138  }
139  }
140  /* thomasr 23/04/09: A continuation line has been started.
141  * In Fortran90 we do not want a space after the initial
142  * '&' character otherwise we might end up with something
143  * like:
144  * ... 2.&
145  * & 0 ...
146  */
147  startinline = 0;
148  for ( i = 0; i < AO.OutSkip; i++ ) AO.OutputLine[i] = ' ';
149  Out = AO.OutputLine + AO.OutSkip;
150  if ( ( AC.OutputMode == FORTRANMODE
151  || AC.OutputMode == PFORTRANMODE ) && AO.OutSkip == 7 ) {
152  /* thomasr 23/04/09: fix leading blank in fortran90 mode */
153  if(AC.IsFortran90 == ISFORTRAN90) {
154  Out[-1] = fcontchar;
155  }
156  else {
157  Out[-2] = fcontchar;
158  Out[-1] = ' ';
159  }
160  }
161  if ( AO.IsBracket ) { *Out++ = ' ';
162  if ( AC.OutputSpaces == NORMALFORMAT ) {
163  *Out++ = ' '; *Out++ = ' '; }
164  }
165  *Out = '\0';
166  if ( AC.OutputMode == FORTRANMODE
167  || ( AC.OutputMode == CMODE && AO.FactorMode == 0 )
168  || AC.OutputMode == PFORTRANMODE )
169  AO.InFbrack++;
170  }
171  *Out++ = *s++;
172  }
173  *Out = '\0';
174  AO.OutFill = Out;
175 }
176 
177 /*
178  #] AddToLine :
179  #[ FiniLine : VOID FiniLine()
180 */
181 
182 VOID FiniLine()
183 {
184  UBYTE *Out;
185  WORD i;
186  LONG num;
187  if ( AO.OutInBuffer ) return;
188  Out = AO.OutFill;
189  while ( Out > AO.OutputLine ) {
190  if ( Out[-1] == ' ' ) Out--;
191  else break;
192  }
193  i = (WORD)(Out-AO.OutputLine);
194  if ( noextralinefeed == 0 ) {
195  if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90
196  && Out > AO.OutputLine ) {
197 /*
198  *Out++ = fcontchar;
199 */
200  }
201 #ifdef WITHRETURN
202  *Out++ = CARRIAGERETURN;
203 #endif
204  *Out++ = LINEFEED;
205  AO.FortFirst = 0;
206  }
207  num = Out - AO.OutputLine;
208 
209  if ( AC.LogHandle >= 0 ) {
210  if ( WriteFile(AC.LogHandle,AO.OutputLine+startinline
211  ,num-startinline) != (num-startinline) ) {
212 #ifdef DEBUGGER
213  if ( BUG.logfileflag == 0 ) {
214  fprintf(stderr,"Panic: Cannot write to log file! Disk full?\n");
215  BUG.logfileflag = 1;
216  }
217  BUG.eflag = 1; BUG.printflag = 1;
218 #else
219  Terminate(-1);
220 #endif
221  }
222  }
223 
224  if ( ( AO.PrintType & PRINTLFILE ) == 0 ) {
225 #ifdef WITHRETURN
226  if ( num > 1 && AO.OutputLine[num-2] == CARRIAGERETURN ) {
227  AO.OutputLine[num-2] = LINEFEED;
228  num--;
229  }
230 #endif
231  if ( WriteFile(AM.StdOut,AO.OutputLine+startinline,
232  num-startinline) != (num-startinline) ) {
233 #ifdef DEBUGGER
234  if ( BUG.stdoutflag == 0 ) {
235  fprintf(stderr,"Panic: Cannot write to standard output!\n");
236  BUG.stdoutflag = 1;
237  }
238  BUG.eflag = 1; BUG.printflag = 1;
239 #else
240  Terminate(-1);
241 #endif
242  }
243  }
244  startinline = 0;
245  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
246  || ( AC.OutputMode == CMODE && AO.FactorMode == 0 ) ) AO.InFbrack++;
247  Out = AO.OutputLine;
248  AO.OutStop = Out + AC.LineLength;
249  i = AO.OutSkip;
250  while ( --i >= 0 ) *Out++ = ' ';
251  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
252  && AO.OutSkip == 7 ) {
253  Out[-2] = fcontchar;
254  Out[-1] = ' ';
255  }
256  AO.OutFill = Out;
257 }
258 
259 /*
260  #] FiniLine :
261  #[ IniLine : VOID IniLine(extrablank)
262 
263  Initializes the output line for the type of output
264 
265 */
266 
267 VOID IniLine(WORD extrablank)
268 {
269  UBYTE *Out;
270  Out = AO.OutputLine;
271  AO.OutStop = Out + AC.LineLength;
272  *Out++ = ' ';
273  *Out++ = ' ';
274  *Out++ = ' ';
275  *Out++ = ' ';
276  *Out++ = ' ';
277  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {
278  *Out++ = fcontchar;
279  AO.OutSkip = 7;
280  }
281  else
282  AO.OutSkip = 6;
283  *Out++ = ' ';
284  while ( extrablank > 0 ) {
285  *Out++ = ' ';
286  extrablank--;
287  }
288  AO.OutFill = Out;
289 }
290 
291 /*
292  #] IniLine :
293  #[ LongToLine : VOID LongToLine(a,na)
294 
295  Puts a Long integer in the output line. If it is only a single
296  word long it is put in the line as a single token.
297  The sign of a is ignored.
298 
299 */
300 
301 static UBYTE *LLscratch = 0;
302 
303 VOID LongToLine(UWORD *a, WORD na)
304 {
305  UBYTE *OutScratch;
306  if ( LLscratch == 0 ) {
307  LLscratch = (UBYTE *)Malloc1(4*(AM.MaxTal*sizeof(WORD)+2)*sizeof(UBYTE),"LongToLine");
308  }
309  OutScratch = LLscratch;
310  if ( na < 0 ) na = -na;
311  if ( na > 1 ) {
312  PrtLong(a,na,OutScratch);
313  if ( AO.NoSpacesInNumbers || AC.OutputMode == REDUCEMODE ) {
314  AO.BlockSpaces = 1;
315  TokenToLine(OutScratch);
316  AO.BlockSpaces = 0;
317  }
318  else {
319  TokenToLine(OutScratch);
320  }
321  }
322  else if ( !na ) TokenToLine((UBYTE *)"0");
323  else TalToLine(*a);
324 }
325 
326 /*
327  #] LongToLine :
328  #[ RatToLine : VOID RatToLine(a,na)
329 
330  Puts a rational number in the output line. The sign is ignored.
331 
332 */
333 
334 static UBYTE *RLscratch = 0;
335 static UWORD *RLscratE = 0;
336 
337 VOID RatToLine(UWORD *a, WORD na)
338 {
339  GETIDENTITY
340  WORD adenom, anumer;
341  if ( na < 0 ) na = -na;
342  if ( AC.OutNumberType == RATIONALMODE ) {
343 /*
344  We need some special provisions for the various Fortran modes.
345  In PFORTRAN we use
346  one if denom = numerator = 1
347  integer if denom = 1
348  (one/integer) if numerator = 1
349  ((one*integer)/integer) in the general case
350 */
351  if ( AC.OutputMode == PFORTRANMODE ) {
352  UnPack(a,na,&adenom,&anumer);
353  if ( na == 1 && a[0] == 1 && a[1] == 1 ) {
354  AddToLine((UBYTE *)"one");
355  return;
356  }
357  if ( adenom == 1 && a[na] == 1 ) {
358  LongToLine(a,anumer);
359  if ( anumer > 1 ) {
360  if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
361  else { AddToLine((UBYTE *)".D0"); }
362  }
363  }
364  else if ( anumer == 1 && a[0] == 1 ) {
365  a += na;
366  AddToLine((UBYTE *)"(one/");
367  LongToLine(a,adenom);
368  if ( adenom > 1 ) {
369  if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
370  else { AddToLine((UBYTE *)".D0"); }
371  }
372  AddToLine((UBYTE *)")");
373  }
374  else {
375  if ( anumer > 1 || adenom > 1 ) {
376  LongToLine(a,anumer);
377  if ( anumer > 1 ) {
378  if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
379  else { AddToLine((UBYTE *)".D0"); }
380  }
381  a += na;
382  AddToLine((UBYTE *)"/");
383  LongToLine(a,adenom);
384  if ( adenom > 1 ) {
385  if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
386  else { AddToLine((UBYTE *)".D0"); }
387  }
388  }
389  else {
390  AddToLine((UBYTE *)"((one*");
391  LongToLine(a,anumer);
392  a += na;
393  AddToLine((UBYTE *)")/");
394  LongToLine(a,adenom);
395  AddToLine((UBYTE *)")");
396  }
397  }
398  }
399  else {
400  UnPack(a,na,&adenom,&anumer);
401  LongToLine(a,anumer);
402  a += na;
403  if ( anumer && !( adenom == 1 && *a == 1 ) ) {
404  if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90 ) {
405  if ( AC.Fortran90Kind ) {
406  AddToLine(AC.Fortran90Kind);
407  AddToLine((UBYTE *)"/");
408  }
409  else {
410  AddToLine((UBYTE *)"./");
411  }
412  }
413  else if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == CMODE ) {
414  if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0/"); }
415  else if ( AO.DoubleFlag == 1 ) { AddToLine((UBYTE *)".D0/"); }
416  else { AddToLine((UBYTE *)"./"); }
417  }
418  else AddToLine((UBYTE *)"/");
419  LongToLine(a,adenom);
420  if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90 ) {
421  if ( AC.Fortran90Kind ) {
422  AddToLine(AC.Fortran90Kind);
423  }
424  else {
425  AddToLine((UBYTE *)".");
426  }
427  }
428  else if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == CMODE ) {
429  if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
430  else if ( AO.DoubleFlag == 1 ) { AddToLine((UBYTE *)".D0"); }
431  else { AddToLine((UBYTE *)"."); }
432  }
433  }
434  else if ( anumer > 1 && ( AC.OutputMode == FORTRANMODE
435  || AC.OutputMode == CMODE ) ) {
436  if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90 ) {
437  if ( AC.Fortran90Kind ) {
438  AddToLine(AC.Fortran90Kind);
439  }
440  else {
441  AddToLine((UBYTE *)".");
442  }
443  }
444  else if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
445  else if ( AO.DoubleFlag == 1 ) { AddToLine((UBYTE *)".D0"); }
446  else { AddToLine((UBYTE *)"."); }
447  }
448  else if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90 ) {
449  if ( AC.Fortran90Kind ) {
450  AddToLine(AC.Fortran90Kind);
451  }
452  else {
453  AddToLine((UBYTE *)".");
454  }
455  }
456  else if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == CMODE )
457  && AO.DoubleFlag ) {
458  if ( anumer == 1 && adenom == 1 && a[0] == 1 ) {}
459  else if ( AO.DoubleFlag == 2 ) { AddToLine((UBYTE *)".Q0"); }
460  else if ( AO.DoubleFlag == 1 ) { AddToLine((UBYTE *)".D0"); }
461  }
462  }
463  }
464  else {
465 /*
466  This is the float mode
467 */
468  UBYTE *OutScratch;
469  WORD exponent = 0, i, ndig, newl;
470  UWORD *c, *den, b = 10, dig[10];
471  UBYTE *o, *out, cc;
472 /*
473  First we have to adjust the numerator and denominator
474 */
475  if ( RLscratch == 0 ) {
476  RLscratch = (UBYTE *)Malloc1(4*(AM.MaxTal+2)*sizeof(UBYTE),"RatToLine");
477  RLscratE = (UWORD *)Malloc1(2*(AM.MaxTal+2)*sizeof(UWORD),"RatToLine");
478  }
479  out = OutScratch = RLscratch;
480  c = RLscratE; for ( i = 0; i < 2*na; i++ ) c[i] = a[i];
481  UnPack(c,na,&adenom,&anumer);
482  while ( BigLong(c,anumer,c+na,adenom) >= 0 ) {
483  Divvy(BHEAD c,&na,&b,1);
484  UnPack(c,na,&adenom,&anumer);
485  exponent++;
486  }
487  while ( BigLong(c,anumer,c+na,adenom) < 0 ) {
488  Mully(BHEAD c,&na,&b,1);
489  UnPack(c,na,&adenom,&anumer);
490  exponent--;
491  }
492 /*
493  Now division will give a number between 1 and 9
494 */
495  den = c + na; i = 1;
496  DivLong(c,anumer,den,adenom,dig,&ndig,c,&newl);
497  *out++ = (UBYTE)(dig[0]+'0'); *out++ = '.';
498  while ( newl && i < AC.OutNumberType ) {
499  Pack(c,&newl,den,adenom);
500  Mully(BHEAD c,&newl,&b,1);
501  na = newl;
502  UnPack(c,na,&adenom,&anumer);
503  den = c + na;
504  DivLong(c,anumer,den,adenom,dig,&ndig,c,&newl);
505  if ( ndig == 0 ) *out++ = '0';
506  else *out++ = (UBYTE)(dig[0]+'0');
507  i++;
508  }
509  *out++ = 'E';
510  if ( exponent < 0 ) { exponent = -exponent; *out++ = '-'; }
511  else { *out++ = '+'; }
512  o = out;
513  do {
514  *out++ = (UBYTE)((exponent % 10)+'0');
515  exponent /= 10;
516  } while ( exponent );
517  *out = 0; out--;
518  while ( o < out ) { cc = *o; *o = *out; *out = cc; o++; out--; }
519  TokenToLine(OutScratch);
520  }
521 }
522 
523 /*
524  #] RatToLine :
525  #[ TalToLine : VOID TalToLine(x)
526 
527  Writes the unsigned number x to the output as a single token.
528  Par indicates the number of leading blanks in the line.
529  This parameter is needed here for the WriteLists routine.
530 
531 */
532 
533 VOID TalToLine(UWORD x)
534 {
535  UBYTE t[BITSINWORD/3+1];
536  UBYTE *s;
537  WORD i = 0, j;
538  s = t;
539  do { *s++ = (UBYTE)((x % 10)+'0'); i++; } while ( ( x /= 10 ) != 0 );
540  *s-- = '\0';
541  j = ( i - 1 ) >> 1;
542  while ( j >= 0 ) {
543  i = t[j]; t[j] = s[-j]; s[-j] = (UBYTE)i; j--;
544  }
545  TokenToLine(t);
546 }
547 
548 /*
549  #] TalToLine :
550  #[ TokenToLine : VOID TokenToLine(s)
551 
552  Puts s in the output buffer. If it doesn't fit the buffer is
553  flushed first. This routine keeps tokens as one unit.
554  Par indicates the number of leading blanks in the line.
555  This parameter is needed here for the WriteLists routine.
556 
557  Remark (27-oct-2007): i and j must be longer than WORD!
558  It can happen that a number is so long that it has more than 2^15 or 2^31
559  digits!
560 */
561 
562 VOID TokenToLine(UBYTE *s)
563 {
564  UBYTE *t, *Out;
565  LONG num, i = 0, j;
566  if ( AO.OutInBuffer ) { AddToDollarBuffer(s); return; }
567  t = s; Out = AO.OutFill;
568  while ( *t++ ) i++;
569  while ( i > 0 ) {
570  if ( ( Out + i ) >= AO.OutStop && ( ( i < ((AC.LineLength-AO.OutSkip)>>1) )
571  || ( (AO.OutStop-Out) < (i>>2) ) ) ) {
572  if ( AC.OutputMode == FORTRANMODE && AC.IsFortran90 == ISFORTRAN90 ) {
573  *Out++ = fcontchar;
574  }
575 #ifdef WITHRETURN
576  *Out++ = CARRIAGERETURN;
577 #endif
578  *Out++ = LINEFEED;
579  AO.FortFirst = 0;
580  num = Out - AO.OutputLine;
581  if ( AC.LogHandle >= 0 ) {
582  if ( WriteFile(AC.LogHandle,AO.OutputLine+startinline,
583  num-startinline) != (num-startinline) ) {
584 #ifdef DEBUGGER
585  if ( BUG.logfileflag == 0 ) {
586  fprintf(stderr,"Panic: Cannot write to log file! Disk full?\n");
587  BUG.logfileflag = 1;
588  }
589  BUG.eflag = 1; BUG.printflag = 1;
590 #else
591  Terminate(-1);
592 #endif
593  }
594  }
595  if ( ( AO.PrintType & PRINTLFILE ) == 0 ) {
596 #ifdef WITHRETURN
597  if ( num > 1 && AO.OutputLine[num-2] == CARRIAGERETURN ) {
598  AO.OutputLine[num-2] = LINEFEED;
599  num--;
600  }
601 #endif
602  if ( WriteFile(AM.StdOut,AO.OutputLine+startinline,
603  num-startinline) != (num-startinline) ) {
604 #ifdef DEBUGGER
605  if ( BUG.stdoutflag == 0 ) {
606  fprintf(stderr,"Panic: Cannot write to standard output!\n");
607  BUG.stdoutflag = 1;
608  }
609  BUG.eflag = 1; BUG.printflag = 1;
610 #else
611  Terminate(-1);
612 #endif
613  }
614  }
615  startinline = 0;
616  Out = AO.OutputLine;
617  if ( AO.BlockSpaces == 0 ) {
618  for ( j = 0; j < AO.OutSkip; j++ ) { *Out++ = ' '; }
619  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) ) {
620  if ( AO.OutSkip == 7 ) {
621  Out[-2] = fcontchar;
622  Out[-1] = ' ';
623  }
624  }
625  }
626 /*
627  Out = AO.OutputLine + AO.OutSkip;
628  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
629  && AO.OutSkip == 7 ) {
630  Out[-2] = fcontchar;
631  Out[-1] = ' ';
632  }
633  else {
634  for ( j = 0; j < AO.OutSkip; j++ ) { AO.OutputLine[j] = ' '; }
635  }
636 */
637  if ( AO.IsBracket ) { *Out++ = ' '; *Out++ = ' '; *Out++ = ' '; }
638  *Out = '\0';
639  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
640  || ( AC.OutputMode == CMODE && AO.FactorMode == 0 ) ) AO.InFbrack++;
641  }
642  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE ) {
643  /* Very long numbers */
644  if ( i > (WORD)(AO.OutStop-Out) ) j = (WORD)(AO.OutStop - Out);
645  else j = i;
646  i -= j;
647  NCOPYB(Out,s,j);
648  }
649  else {
650  if ( i > (WORD)(AO.OutStop-Out) ) j = (WORD)(AO.OutStop - Out - 1);
651  else j = i;
652  i -= j;
653  NCOPYB(Out,s,j);
654  if ( i > 0 ) *Out++ = '\\';
655  }
656  }
657  *Out = '\0';
658  AO.OutFill = Out;
659 }
660 
661 /*
662  #] TokenToLine :
663  #[ CodeToLine : VOID CodeToLine(name,number,mode)
664 
665  Writes a name and possibly its number to output as a single token.
666 
667 */
668 
669 UBYTE *CodeToLine(WORD number, UBYTE *Out)
670 {
671  Out = StrCopy((UBYTE *)"(",Out);
672  Out = NumCopy(number,Out);
673  Out = StrCopy((UBYTE *)")",Out);
674  return(Out);
675 }
676 
677 /*
678  #] CodeToLine :
679  #[ MultiplyToLine :
680 */
681 
682 void MultiplyToLine()
683 {
684  int i;
685  if ( AO.CurrentDictionary > 0 && AO.CurDictSpecials > 0
686  && AO.CurDictSpecials == DICT_DOSPECIALS ) {
687  DICTIONARY *dict = AO.Dictionaries[AO.CurrentDictionary-1];
688 /*
689  Find the star:
690 */
691  for ( i = 0; i < dict->numelements; i++ ) {
692  if ( dict->elements[i]->type != DICT_SPECIALCHARACTER ) continue;
693  if ( (UBYTE)dict->elements[i]->lhs[0] == (UBYTE)('*') ) {
694  TokenToLine((UBYTE *)(dict->elements[i]->rhs));
695  return;
696  }
697  }
698  }
699  TokenToLine((UBYTE *)"*");
700 }
701 
702 /*
703  #] MultiplyToLine :
704  #[ AddArrayIndex :
705 */
706 
707 UBYTE *AddArrayIndex(WORD num,UBYTE *out)
708 {
709  if ( AC.OutputMode == CMODE ) {
710  out = StrCopy((UBYTE *)"[",out);
711  out = NumCopy(num,out);
712  out = StrCopy((UBYTE *)"]",out);
713  }
714  else {
715  out = StrCopy((UBYTE *)"(",out);
716  out = NumCopy(num,out);
717  out = StrCopy((UBYTE *)")",out);
718  }
719  return(out);
720 }
721 
722 /*
723  #] AddArrayIndex :
724  #[ PrtTerms : VOID PrtTerms()
725 */
726 
727 VOID PrtTerms()
728 {
729  UWORD a[2];
730  WORD na;
731  a[0] = (UWORD)AO.NumInBrack;
732  a[1] = (UWORD)(AO.NumInBrack >> BITSINWORD);
733  if ( a[1] ) na = 2;
734  else na = 1;
735  TokenToLine((UBYTE *)" ");
736  LongToLine(a,na);
737  if ( a[0] == 1 && na == 1 ) {
738  TokenToLine((UBYTE *)" term");
739  }
740  else TokenToLine((UBYTE *)" terms");
741  AO.NumInBrack = 0;
742 }
743 
744 /*
745  #] PrtTerms :
746  #[ WrtPower :
747 */
748 
749 UBYTE *WrtPower(UBYTE *Out, WORD Power)
750 {
751  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
752  || AC.OutputMode == REDUCEMODE ) {
753  *Out++ = '*'; *Out++ = '*';
754  }
755  else if ( AC.OutputMode == CMODE ) *Out++ = ',';
756  else *Out++ = '^';
757  if ( Power >= 0 ) {
758  if ( Power < 2*MAXPOWER )
759  Out = NumCopy(Power,Out);
760  else
761  Out = StrCopy(FindSymbol((WORD)((LONG)Power-2*MAXPOWER)),Out);
762 /* Out = StrCopy(VARNAME(symbols,(LONG)Power-2*MAXPOWER),Out); */
763  if ( AC.OutputMode == CMODE ) *Out++ = ')';
764  *Out = 0;
765  }
766  else {
767  if ( ( AC.OutputMode >= FORTRANMODE || AC.OutputMode >= PFORTRANMODE )
768  && AC.OutputMode != CMODE )
769  *Out++ = '(';
770  *Out++ = '-';
771  if ( Power > -2*MAXPOWER )
772  Out = NumCopy(-Power,Out);
773  else
774  Out = StrCopy(FindSymbol((WORD)((LONG)Power-2*MAXPOWER)),Out);
775 /* Out = StrCopy(VARNAME(symbols,(LONG)(-Power)-2*MAXPOWER),Out); */
776  if ( AC.OutputMode >= FORTRANMODE || AC.OutputMode >= PFORTRANMODE ) *Out++ = ')';
777  *Out = 0;
778  }
779  return(Out);
780 }
781 
782 /*
783  #] WrtPower :
784  #[ PrintTime :
785 */
786 
787 void PrintTime()
788 {
789  LONG millitime = TimeCPU(1);
790  WORD timepart = (WORD)(millitime%1000);
791  millitime /= 1000;
792  timepart /= 10;
793  MesPrint("Time = %7l.%2i sec",millitime,timepart);
794 }
795 
796 /*
797  #] PrintTime :
798  #] schryf-Utilities :
799  #[ schryf-Writes :
800  #[ WriteLists : VOID WriteLists()
801 
802  Writes the namelists. If mode > 0 also the internal codes are given.
803 
804 */
805 
806 static UBYTE *symname[] = {
807  (UBYTE *)"(cyclic)",(UBYTE *)"(reversecyclic)"
808  ,(UBYTE *)"(symmetric)",(UBYTE *)"(antisymmetric)" };
809 static UBYTE *rsymname[] = {
810  (UBYTE *)"(-cyclic)",(UBYTE *)"(-reversecyclic)"
811  ,(UBYTE *)"(-symmetric)",(UBYTE *)"(-antisymmetric)" };
812 
813 VOID WriteLists()
814 {
815  GETIDENTITY
816  WORD i, j, k, *skip;
817  int first, startvalue;
818  UBYTE *OutScr, *Out;
819  EXPRESSIONS e;
820  CBUF *C = cbuf+AC.cbufnum;
821  int olddict = AO.CurrentDictionary;
822  skip = &AO.OutSkip;
823  *skip = 0;
824  AO.OutputLine = AO.OutFill = (UBYTE *)AT.WorkPointer;
825  AO.CurrentDictionary = 0;
826  FiniLine();
827  OutScr = (UBYTE *)AT.WorkPointer + ( TOLONG(AT.WorkTop) - TOLONG(AT.WorkPointer) ) /2;
828  if ( AC.CodesFlag || AC.NamesFlag > 1 ) startvalue = 0;
829  else startvalue = FIRSTUSERSYMBOL;
830  if ( ( j = NumSymbols ) > startvalue ) {
831  TokenToLine((UBYTE *)" Symbols");
832  *skip = 3;
833  FiniLine();
834  for ( i = startvalue; i < j; i++ ) {
835  if ( i >= BUILTINSYMBOLS && i < FIRSTUSERSYMBOL ) continue;
836  Out = StrCopy(VARNAME(symbols,i),OutScr);
837  if ( symbols[i].minpower > -MAXPOWER || symbols[i].maxpower < MAXPOWER ) {
838  Out = StrCopy((UBYTE *)"(",Out);
839  if ( symbols[i].minpower > -MAXPOWER )
840  Out = NumCopy(symbols[i].minpower,Out);
841  Out = StrCopy((UBYTE *)":",Out);
842  if ( symbols[i].maxpower < MAXPOWER )
843  Out = NumCopy(symbols[i].maxpower,Out);
844  Out = StrCopy((UBYTE *)")",Out);
845  }
846  if ( ( symbols[i].complex & VARTYPEIMAGINARY ) == VARTYPEIMAGINARY ) {
847  Out = StrCopy((UBYTE *)"#i",Out);
848  }
849  else if ( ( symbols[i].complex & VARTYPECOMPLEX ) == VARTYPECOMPLEX ) {
850  Out = StrCopy((UBYTE *)"#c",Out);
851  }
852  else if ( ( symbols[i].complex & VARTYPEROOTOFUNITY ) == VARTYPEROOTOFUNITY ) {
853  Out = StrCopy((UBYTE *)"#",Out);
854  if ( ( symbols[i].complex & VARTYPEMINUS ) == VARTYPEMINUS ) {
855  Out = StrCopy((UBYTE *)"-",Out);
856  }
857  else {
858  Out = StrCopy((UBYTE *)"+",Out);
859  }
860  Out = NumCopy(symbols[i].maxpower,Out);
861  }
862  if ( AC.CodesFlag ) Out = CodeToLine(i,Out);
863  if ( ( symbols[i].complex & VARTYPECOMPLEX ) == VARTYPECOMPLEX ) i++;
864  StrCopy((UBYTE *)" ",Out);
865  TokenToLine(OutScr);
866  }
867  *skip = 0;
868  FiniLine();
869  }
870  if ( AC.CodesFlag || AC.NamesFlag > 1 ) startvalue = 0;
871  else startvalue = BUILTININDICES;
872  if ( ( j = NumIndices ) > startvalue ) {
873  TokenToLine((UBYTE *)" Indices");
874  *skip = 3;
875  FiniLine();
876  for ( i = startvalue; i < j; i++ ) {
877  Out = StrCopy(FindIndex(i+AM.OffsetIndex),OutScr);
878  Out = StrCopy(VARNAME(indices,i),OutScr);
879  if ( indices[i].dimension >= 0 ) {
880  if ( indices[i].dimension != AC.lDefDim ) {
881  Out = StrCopy((UBYTE *)"=",Out);
882  Out = NumCopy(indices[i].dimension,Out);
883  }
884  }
885  else if ( indices[i].dimension < 0 ) {
886  Out = StrCopy((UBYTE *)"=",Out);
887  Out = StrCopy(VARNAME(symbols,-indices[i].dimension),Out);
888  if ( indices[i].nmin4 < -NMIN4SHIFT ) {
889  Out = StrCopy((UBYTE *)":",Out);
890  Out = StrCopy(VARNAME(symbols,-indices[i].nmin4-NMIN4SHIFT),Out);
891  }
892  }
893  if ( AC.CodesFlag ) Out = CodeToLine(i+AM.OffsetIndex,Out);
894  StrCopy((UBYTE *)" ",Out);
895  TokenToLine(OutScr);
896  }
897  *skip = 0;
898  FiniLine();
899  }
900  if ( AC.CodesFlag || AC.NamesFlag > 1 ) startvalue = 0;
901  else startvalue = BUILTINVECTORS;
902  if ( ( j = NumVectors ) > startvalue ) {
903  TokenToLine((UBYTE *)" Vectors");
904  *skip = 3;
905  FiniLine();
906  for ( i = startvalue; i < j; i++ ) {
907  Out = StrCopy(VARNAME(vectors,i),OutScr);
908  if ( AC.CodesFlag ) Out = CodeToLine(i+AM.OffsetVector,Out);
909  StrCopy((UBYTE *)" ",Out);
910  TokenToLine(OutScr);
911  }
912  *skip = 0;
913  FiniLine();
914  }
915 
916  if ( AC.CodesFlag || AC.NamesFlag > 1 ) startvalue = 0;
917  else startvalue = AM.NumFixedFunctions;
918  for ( k = 0; k < 2; k++ ) {
919  first = 1;
920  j = NumFunctions;
921  for ( i = startvalue; i < j; i++ ) {
922  if ( i > MAXBUILTINFUNCTION-FUNCTION
923  && i < FIRSTUSERFUNCTION-FUNCTION ) continue;
924  if ( ( k == 0 && functions[i].commute )
925  || ( k != 0 && !functions[i].commute ) ) {
926  if ( first ) {
927  TokenToLine((UBYTE *)(FG.FunNam[k]));
928  *skip = 3;
929  FiniLine();
930  first = 0;
931  }
932  Out = StrCopy(VARNAME(functions,i),OutScr);
933  if ( ( functions[i].complex & VARTYPEIMAGINARY ) == VARTYPEIMAGINARY ) {
934  Out = StrCopy((UBYTE *)"#i",Out);
935  }
936  else if ( ( functions[i].complex & VARTYPECOMPLEX ) == VARTYPECOMPLEX ) {
937  Out = StrCopy((UBYTE *)"#c",Out);
938  }
939  if ( functions[i].spec >= TENSORFUNCTION ) {
940  Out = StrCopy((UBYTE *)"(Tensor)",Out);
941  }
942  if ( functions[i].symmetric > 0 ) {
943  if ( ( functions[i].symmetric & REVERSEORDER ) != 0 ) {
944  Out = StrCopy((UBYTE *)(rsymname[(functions[i].symmetric & ~REVERSEORDER)-1]),Out);
945  }
946  else {
947  Out = StrCopy((UBYTE *)(symname[functions[i].symmetric-1]),Out);
948  }
949  }
950  if ( AC.CodesFlag ) Out = CodeToLine(i+FUNCTION,Out);
951  if ( ( functions[i].complex & VARTYPECOMPLEX ) == VARTYPECOMPLEX ) i++;
952  StrCopy((UBYTE *)" ",Out);
953  TokenToLine(OutScr);
954  }
955  }
956  *skip = 0;
957  if ( first == 0 ) FiniLine();
958  }
959  if ( AC.CodesFlag || AC.NamesFlag > 1 ) startvalue = 0;
960  else startvalue = AM.NumFixedSets;
961  if ( ( j = AC.SetList.num ) > startvalue ) {
962  WORD element, LastElement, type, number;
963  TokenToLine((UBYTE *)" Sets");
964  for ( i = startvalue; i < j; i++ ) {
965  *skip = 3;
966  FiniLine();
967  if ( Sets[i].name < 0 ) {
968  Out = StrCopy((UBYTE *)"{}",OutScr);
969  }
970  else {
971  Out = StrCopy(VARNAME(Sets,i),OutScr);
972  }
973  if ( AC.CodesFlag ) Out = CodeToLine(i,Out);
974  StrCopy((UBYTE *)":",Out);
975  TokenToLine(OutScr);
976  if ( i < AM.NumFixedSets ) {
977  TokenToLine((UBYTE *)" ");
978  TokenToLine((UBYTE *)fixedsets[i].description);
979  }
980  else if ( Sets[i].type == CRANGE ) {
981  int iflag = 0;
982  if ( Sets[i].first == 3*MAXPOWER ) {
983  }
984  else if ( Sets[i].first >= MAXPOWER ) {
985  TokenToLine((UBYTE *)"<=");
986  NumCopy(Sets[i].first-2*MAXPOWER,OutScr);
987  TokenToLine(OutScr);
988  iflag = 1;
989  }
990  else {
991  TokenToLine((UBYTE *)"<");
992  NumCopy(Sets[i].first,OutScr);
993  TokenToLine(OutScr);
994  iflag = 1;
995  }
996  if ( Sets[i].last == -3*MAXPOWER ) {
997  }
998  else if ( Sets[i].last <= -MAXPOWER ) {
999  if ( iflag ) TokenToLine((UBYTE *)",");
1000  TokenToLine((UBYTE *)">=");
1001  NumCopy(Sets[i].last+2*MAXPOWER,OutScr);
1002  TokenToLine(OutScr);
1003  }
1004  else {
1005  if ( iflag ) TokenToLine((UBYTE *)",");
1006  TokenToLine((UBYTE *)">");
1007  NumCopy(Sets[i].last,OutScr);
1008  TokenToLine(OutScr);
1009  }
1010  }
1011  else {
1012  element = Sets[i].first;
1013  LastElement = Sets[i].last;
1014  type = Sets[i].type;
1015  do {
1016  TokenToLine((UBYTE *)" ");
1017  number = SetElements[element++];
1018  switch ( type ) {
1019  case CSYMBOL:
1020  if ( number < 0 ) {
1021  StrCopy(VARNAME(symbols,-number),OutScr);
1022  StrCopy((UBYTE *)"?",Out);
1023  TokenToLine(OutScr);
1024  }
1025  else if ( number < MAXPOWER )
1026  TokenToLine(VARNAME(symbols,number));
1027  else {
1028  NumCopy(number-2*MAXPOWER,OutScr);
1029  TokenToLine(OutScr);
1030  }
1031  break;
1032  case CINDEX:
1033  if ( number >= AM.IndDum ) {
1034  Out = StrCopy((UBYTE *)"N",OutScr);
1035  Out = NumCopy(number-(AM.IndDum),Out);
1036  StrCopy((UBYTE *)"_?",Out);
1037  TokenToLine(OutScr);
1038  }
1039  else if ( number >= AM.OffsetIndex + (WORD)WILDMASK ) {
1040  Out = StrCopy(VARNAME(indices,number
1041  -AM.OffsetIndex-WILDMASK),OutScr);
1042  StrCopy((UBYTE *)"?",Out);
1043  TokenToLine(OutScr);
1044  }
1045  else if ( number >= AM.OffsetIndex ) {
1046  TokenToLine(VARNAME(indices,number-AM.OffsetIndex));
1047  }
1048  else {
1049  NumCopy(number,OutScr);
1050  TokenToLine(OutScr);
1051  }
1052  break;
1053  case CVECTOR:
1054  Out = OutScr;
1055  if ( number < AM.OffsetVector ) {
1056  number += WILDMASK;
1057  Out = StrCopy((UBYTE *)"-",Out);
1058  }
1059  if ( number >= AM.OffsetVector + WILDOFFSET ) {
1060  Out = StrCopy(VARNAME(vectors,number
1061  -AM.OffsetVector-WILDOFFSET),Out);
1062  StrCopy((UBYTE *)"?",Out);
1063  }
1064  else {
1065  Out = StrCopy(VARNAME(vectors,number-AM.OffsetVector),Out);
1066  }
1067  TokenToLine(OutScr);
1068  break;
1069  case CFUNCTION:
1070  if ( number >= FUNCTION + (WORD)WILDMASK ) {
1071  Out = StrCopy(VARNAME(functions,number
1072  -FUNCTION-WILDMASK),OutScr);
1073  StrCopy((UBYTE *)"?",Out);
1074  TokenToLine(OutScr);
1075  }
1076  TokenToLine(VARNAME(functions,number-FUNCTION));
1077  break;
1078  default:
1079  NumCopy(number,OutScr);
1080  TokenToLine(OutScr);
1081  break;
1082  }
1083  } while ( element < LastElement );
1084  }
1085  }
1086  *skip = 0;
1087  FiniLine();
1088  }
1089  if ( AS.ExecMode ) {
1090  e = Expressions;
1091  j = NumExpressions;
1092  first = 1;
1093  for ( i = 0; i < j; i++, e++ ) {
1094  if ( e->status >= 0 ) {
1095  if ( first ) {
1096  TokenToLine((UBYTE *)" Expressions");
1097  *skip = 3;
1098  FiniLine();
1099  first = 0;
1100  }
1101  Out = StrCopy(AC.exprnames->namebuffer+e->name,OutScr);
1102  Out = StrCopy((UBYTE *)(FG.ExprStat[e->status]),Out);
1103  if ( AC.CodesFlag ) Out = CodeToLine(i,Out);
1104  StrCopy((UBYTE *)" ",Out);
1105  TokenToLine(OutScr);
1106  }
1107  }
1108  if ( !first ) {
1109  *skip = 0;
1110  FiniLine();
1111  }
1112  }
1113  e = Expressions;
1114  j = NumExpressions;
1115  first = 1;
1116  for ( i = 0; i < j; i++ ) {
1117  if ( e->printflag && ( e->status == LOCALEXPRESSION ||
1118  e->status == GLOBALEXPRESSION || e->status == UNHIDELEXPRESSION
1119  || e->status == UNHIDEGEXPRESSION ) ) {
1120  if ( first ) {
1121  TokenToLine((UBYTE *)" Expressions to be printed");
1122  *skip = 3;
1123  FiniLine();
1124  first = 0;
1125  }
1126  Out = StrCopy(AC.exprnames->namebuffer+e->name,OutScr);
1127  StrCopy((UBYTE *)" ",Out);
1128  TokenToLine(OutScr);
1129  }
1130  e++;
1131  }
1132  if ( !first ) {
1133  *skip = 0;
1134  FiniLine();
1135  }
1136 
1137  if ( AC.CodesFlag || AC.NamesFlag > 1 ) startvalue = 0;
1138  else startvalue = BUILTINDOLLARS;
1139  if ( ( j = NumDollars ) > startvalue ) {
1140  TokenToLine((UBYTE *)" Dollar variables");
1141  *skip = 3;
1142  FiniLine();
1143  for ( i = startvalue; i < j; i++ ) {
1144  Out = StrCopy((UBYTE *)"$", OutScr);
1145  Out = StrCopy(DOLLARNAME(Dollars, i), Out);
1146  if ( AC.CodesFlag ) Out = CodeToLine(i, Out);
1147  StrCopy((UBYTE *)" ", Out);
1148  TokenToLine(OutScr);
1149  }
1150  *skip = 0;
1151  FiniLine();
1152  }
1153 
1154  if ( ( j = NumPotModdollars ) > 0 ) {
1155  TokenToLine((UBYTE *)" Dollar variables to be modified");
1156  *skip = 3;
1157  FiniLine();
1158  for ( i = 0; i < j; i++ ) {
1159  Out = StrCopy((UBYTE *)"$", OutScr);
1160  Out = StrCopy(DOLLARNAME(Dollars, PotModdollars[i]), Out);
1161  for ( k = 0; k < NumModOptdollars; k++ )
1162  if ( ModOptdollars[k].number == PotModdollars[i] ) break;
1163  if ( k < NumModOptdollars ) {
1164  switch ( ModOptdollars[k].type ) {
1165  case MODSUM:
1166  Out = StrCopy((UBYTE *)"(sum)", Out);
1167  break;
1168  case MODMAX:
1169  Out = StrCopy((UBYTE *)"(maximum)", Out);
1170  break;
1171  case MODMIN:
1172  Out = StrCopy((UBYTE *)"(minimum)", Out);
1173  break;
1174  case MODLOCAL:
1175  Out = StrCopy((UBYTE *)"(local)", Out);
1176  break;
1177  default:
1178  Out = StrCopy((UBYTE *)"(?)", Out);
1179  break;
1180  }
1181  }
1182  StrCopy((UBYTE *)" ", Out);
1183  TokenToLine(OutScr);
1184  }
1185  *skip = 0;
1186  FiniLine();
1187  }
1188 
1189  if ( AC.ncmod != 0 ) {
1190  TokenToLine((UBYTE *)"All arithmetic is modulus ");
1191  LongToLine((UWORD *)AC.cmod,ABS(AC.ncmod));
1192  if ( AC.ncmod > 0 ) TokenToLine((UBYTE *)" with powerreduction");
1193  else TokenToLine((UBYTE *)" without powerreduction");
1194  if ( ( AC.modmode & POSNEG ) != 0 ) TokenToLine((UBYTE *)" centered around 0");
1195  else TokenToLine((UBYTE *)" positive numbers only");
1196  FiniLine();
1197  }
1198  if ( AC.lDefDim != 4 ) {
1199  TokenToLine((UBYTE *)"The default dimension is ");
1200  if ( AC.lDefDim >= 0 ) {
1201  NumCopy(AC.lDefDim,OutScr);
1202  TokenToLine(OutScr);
1203  }
1204  else {
1205  TokenToLine(VARNAME(symbols,-AC.lDefDim));
1206  if ( AC.lDefDim4 != -NMIN4SHIFT ) {
1207  TokenToLine((UBYTE *)":");
1208  if ( AC.lDefDim4 >= -NMIN4SHIFT ) {
1209  NumCopy(AC.lDefDim4,OutScr);
1210  TokenToLine(OutScr);
1211  }
1212  else {
1213  TokenToLine(VARNAME(symbols,-AC.lDefDim4-NMIN4SHIFT));
1214  }
1215  }
1216  }
1217  FiniLine();
1218  }
1219  if ( AC.lUnitTrace != 4 ) {
1220  TokenToLine((UBYTE *)"The trace of the unit matrix is ");
1221  if ( AC.lUnitTrace >= 0 ) {
1222  NumCopy(AC.lUnitTrace,OutScr);
1223  TokenToLine(OutScr);
1224  }
1225  else {
1226  TokenToLine(VARNAME(symbols,-AC.lUnitTrace));
1227  }
1228  FiniLine();
1229  }
1230  if ( AO.NumDictionaries > 0 ) {
1231  for ( i = 0; i < AO.NumDictionaries; i++ ) {
1232  WriteDictionary(AO.Dictionaries[i]);
1233  }
1234  if ( olddict > 0 )
1235  MesPrint("\nCurrently dictionary %s is active\n",
1236  AO.Dictionaries[olddict-1]->name);
1237  else
1238  MesPrint("\nCurrently there is no actice dictionary\n");
1239  }
1240  if ( AC.CodesFlag ) {
1241  if ( C->numlhs > 0 ) {
1242  TokenToLine((UBYTE *)" Left Hand Sides:");
1243  AO.OutSkip = 3;
1244  for ( i = 1; i <= C->numlhs; i++ ) {
1245  FiniLine();
1246  skip = C->lhs[i];
1247  j = skip[1];
1248  while ( --j >= 0 ) { TalToLine((UWORD)(*skip++)); TokenToLine((UBYTE *)" "); }
1249  }
1250  AO.OutSkip = 0;
1251  FiniLine();
1252  }
1253  if ( C->numrhs > 0 ) {
1254  TokenToLine((UBYTE *)" Right Hand Sides:");
1255  AO.OutSkip = 3;
1256  for ( i = 1; i <= C->numrhs; i++ ) {
1257  FiniLine();
1258  skip = C->rhs[i];
1259  while ( ( j = skip[0] ) != 0 ) {
1260  while ( --j >= 0 ) { TalToLine((UWORD)(*skip++)); TokenToLine((UBYTE *)" "); }
1261  }
1262  FiniLine();
1263  }
1264  AO.OutSkip = 0;
1265  FiniLine();
1266  }
1267  }
1268  AO.CurrentDictionary = olddict;
1269 }
1270 
1271 /*
1272  #] WriteLists :
1273  #[ WriteDictionary :
1274 
1275  This routine is part of WriteLists and should be called from there.
1276 */
1277 
1278 void WriteDictionary(DICTIONARY *dict)
1279 {
1280  GETIDENTITY
1281  int i, first;
1282  WORD *skip, na, *a, spec, *t, *tstop, j;
1283  UBYTE str[2], *OutScr, *Out;
1284  WORD oldoutputmode = AC.OutputMode, oldoutputspaces = AC.OutputSpaces;
1285  WORD oldoutskip = AO.OutSkip;
1286  AC.OutputMode = NORMALFORMAT;
1287  AC.OutputSpaces = NOSPACEFORMAT;
1288  MesPrint("===Contents of dictionary %s===",dict->name);
1289  skip = &AO.OutSkip;
1290  *skip = 3;
1291  AO.OutputLine = AO.OutFill = (UBYTE *)AT.WorkPointer;
1292  for ( j = 0; j < *skip; j++ ) *(AO.OutFill)++ = ' ';
1293 
1294  OutScr = (UBYTE *)AT.WorkPointer + ( TOLONG(AT.WorkTop) - TOLONG(AT.WorkPointer) ) /2;
1295  for ( i = 0; i < dict->numelements; i++ ) {
1296  switch ( dict->elements[i]->type ) {
1297  case DICT_INTEGERNUMBER:
1298  LongToLine((UWORD *)(dict->elements[i]->lhs),dict->elements[i]->size);
1299  Out = OutScr; *Out = 0;
1300  break;
1301  case DICT_RATIONALNUMBER:
1302  a = dict->elements[i]->lhs;
1303  na = a[a[0]-1]; na = (ABS(na)-1)/2;
1304  RatToLine((UWORD *)(a+1),na);
1305  Out = OutScr; *Out = 0;
1306  break;
1307  case DICT_SYMBOL:
1308  na = dict->elements[i]->lhs[0];
1309  Out = StrCopy(VARNAME(symbols,na),OutScr);
1310  break;
1311  case DICT_VECTOR:
1312  na = dict->elements[i]->lhs[0]-AM.OffsetVector;
1313  Out = StrCopy(VARNAME(vectors,na),OutScr);
1314  break;
1315  case DICT_INDEX:
1316  na = dict->elements[i]->lhs[0]-AM.OffsetIndex;
1317  Out = StrCopy(VARNAME(indices,na),OutScr);
1318  break;
1319  case DICT_FUNCTION:
1320  na = dict->elements[i]->lhs[0]-FUNCTION;
1321  Out = StrCopy(VARNAME(functions,na),OutScr);
1322  break;
1323  case DICT_FUNCTION_WITH_ARGUMENTS:
1324  t = dict->elements[i]->lhs;
1325  na = *t-FUNCTION;
1326  Out = StrCopy(VARNAME(functions,na),OutScr);
1327  spec = functions[*t - FUNCTION].spec;
1328  tstop = t + t[1];
1329  first = 1;
1330  if ( t[1] <= FUNHEAD ) {}
1331  else if ( spec >= TENSORFUNCTION ) {
1332  t += FUNHEAD; *Out++ = (UBYTE)'(';
1333  while ( t < tstop ) {
1334  if ( first == 0 ) *Out++ = (UBYTE)(',');
1335  else first = 0;
1336  j = *t++;
1337  if ( j >= 0 ) {
1338  if ( j < AM.OffsetIndex ) { Out = NumCopy(j,Out); }
1339  else if ( j < AM.IndDum ) {
1340  Out = StrCopy(VARNAME(indices,j-AM.OffsetIndex),Out);
1341  }
1342  else {
1343  MesPrint("Currently wildcards are not allowed in dictionary elements");
1344  Terminate(-1);
1345  }
1346  }
1347  else {
1348  Out = StrCopy(VARNAME(vectors,j-AM.OffsetVector),Out);
1349  }
1350  }
1351  *Out++ = (UBYTE)')'; *Out = 0;
1352  }
1353  else {
1354  t += FUNHEAD; *Out++ = (UBYTE)'('; *Out = 0;
1355  TokenToLine(OutScr);
1356  while ( t < tstop ) {
1357  if ( !first ) TokenToLine((UBYTE *)",");
1358  WriteArgument(t);
1359  NEXTARG(t)
1360  first = 0;
1361  }
1362  Out = OutScr;
1363  *Out++ = (UBYTE)')'; *Out = 0;
1364  }
1365  break;
1366  case DICT_SPECIALCHARACTER:
1367  str[0] = (UBYTE)(dict->elements[i]->lhs[0]);
1368  str[1] = 0;
1369  Out = StrCopy(str,OutScr);
1370  break;
1371  default:
1372  Out = OutScr; *Out = 0;
1373  break;
1374  }
1375  Out = StrCopy((UBYTE *)": \"",Out);
1376  Out = StrCopy((UBYTE *)(dict->elements[i]->rhs),Out);
1377  Out = StrCopy((UBYTE *)"\"",Out);
1378  TokenToLine(OutScr);
1379  FiniLine();
1380  }
1381  MesPrint("========End of dictionary %s===",dict->name);
1382  AC.OutputMode = oldoutputmode;
1383  AC.OutputSpaces = oldoutputspaces;
1384  AO.OutSkip = oldoutskip;
1385 }
1386 
1387 /*
1388  #] WriteDictionary :
1389  #[ WriteArgument : VOID WriteArgument(WORD *t)
1390 
1391  Write a single argument field. The general field goes to
1392  WriteExpression and the fast field is dealt with here.
1393 */
1394 
1395 VOID WriteArgument(WORD *t)
1396 {
1397  UBYTE buffer[180];
1398  UBYTE *Out;
1399  WORD i;
1400  int oldoutsidefun, oldlowestlevel = lowestlevel;
1401  lowestlevel = 0;
1402  if ( *t > 0 ) {
1403  oldoutsidefun = AC.outsidefun; AC.outsidefun = 0;
1404  WriteExpression(t+ARGHEAD,(LONG)(*t-ARGHEAD));
1405  AC.outsidefun = oldoutsidefun;
1406  goto CleanUp;
1407  }
1408  Out = buffer;
1409  if ( *t == -SNUMBER) {
1410  NumCopy(t[1],Out);
1411  }
1412  else if ( *t == -SYMBOL ) {
1413  if ( t[1] >= MAXVARIABLES-cbuf[AM.sbufnum].numrhs ) {
1414  Out = StrCopy(FindExtraSymbol(MAXVARIABLES-t[1]),Out);
1415 /*
1416  Out = StrCopy((UBYTE *)AC.extrasym,Out);
1417  if ( AC.extrasymbols == 0 ) {
1418  Out = NumCopy((MAXVARIABLES-t[1]),Out);
1419  Out = StrCopy((UBYTE *)"_",Out);
1420  }
1421  else if ( AC.extrasymbols == 1 ) {
1422  Out = AddArrayIndex((MAXVARIABLES-t[1]),Out);
1423  }
1424 */
1425 /*
1426  else if ( AC.extrasymbols == 2 ) {
1427  Out = NumCopy((MAXVARIABLES-t[1]),Out);
1428  }
1429 */
1430  }
1431  else {
1432  StrCopy(FindSymbol(t[1]),Out);
1433 /* StrCopy(VARNAME(symbols,t[1]),Out); */
1434  }
1435  }
1436  else if ( *t == -VECTOR ) {
1437  if ( t[1] == FUNNYVEC ) { *Out++ = '?'; *Out = 0; }
1438  else
1439  StrCopy(FindVector(t[1]),Out);
1440 /* StrCopy(VARNAME(vectors,t[1] - AM.OffsetVector),Out); */
1441  }
1442  else if ( *t == -MINVECTOR ) {
1443  *Out++ = '-';
1444  StrCopy(FindVector(t[1]),Out);
1445 /* StrCopy(VARNAME(vectors,t[1] - AM.OffsetVector),Out); */
1446  }
1447  else if ( *t == -INDEX ) {
1448  if ( t[1] >= 0 ) {
1449  if ( t[1] < AM.OffsetIndex ) { NumCopy(t[1],Out); }
1450  else {
1451  i = t[1];
1452  if ( i >= AM.IndDum ) {
1453  i -= AM.IndDum;
1454  *Out++ = 'N';
1455  Out = NumCopy(i,Out);
1456  *Out++ = '_';
1457  *Out++ = '?';
1458  *Out = 0;
1459  }
1460  else {
1461  i -= AM.OffsetIndex;
1462  Out = StrCopy(FindIndex(i%WILDOFFSET+AM.OffsetIndex),Out);
1463 /* Out = StrCopy(VARNAME(indices,i%WILDOFFSET),Out); */
1464  if ( i >= WILDOFFSET ) { *Out++ = '?'; *Out = 0; }
1465  }
1466  }
1467  }
1468  else if ( t[1] == FUNNYVEC ) { *Out++ = '?'; *Out = 0; }
1469  else
1470  StrCopy(FindVector(t[1]),Out);
1471 /* StrCopy(VARNAME(vectors,t[1] - AM.OffsetVector),Out); */
1472  }
1473  else if ( *t == -DOLLAREXPRESSION ) {
1474  DOLLARS d = Dollars + t[1];
1475  *Out++ = '$';
1476  StrCopy(AC.dollarnames->namebuffer+d->name,Out);
1477  }
1478  else if ( *t == -EXPRESSION ) {
1479  StrCopy(EXPRNAME(t[1]),Out);
1480  }
1481  else if ( *t <= -FUNCTION ) {
1482  StrCopy(FindFunction(-*t),Out);
1483 /* StrCopy(VARNAME(functions,-*t-FUNCTION),Out); */
1484  }
1485  else {
1486  MesPrint("Illegal function argument while writing");
1487  goto CleanUp;
1488  }
1489  TokenToLine(buffer);
1490 CleanUp:
1491  lowestlevel = oldlowestlevel;
1492  return;
1493 }
1494 
1495 /*
1496  #] WriteArgument :
1497  #[ WriteSubTerm : WORD WriteSubTerm(sterm,first)
1498 
1499  Writes a single subterm field to the output line.
1500  There is a recursion for functions.
1501 
1502 
1503 #define NUMSPECS 8
1504 UBYTE *specfunnames[NUMSPECS] = {
1505  (UBYTE *)"fac" , (UBYTE *)"nargs", (UBYTE *)"binom"
1506  , (UBYTE *)"sign", (UBYTE *)"mod", (UBYTE *)"min", (UBYTE *)"max"
1507  , (UBYTE *)"invfac" };
1508 */
1509 
1510 WORD WriteSubTerm(WORD *sterm, WORD first)
1511 {
1512  UBYTE buffer[80];
1513  UBYTE *Out, closepar[2] = { (UBYTE)')', 0};
1514  WORD *stopper, *t, *tt, i, j, po = 0;
1515  int oldoutsidefun;
1516  stopper = sterm + sterm[1];
1517  t = sterm + 2;
1518  switch ( *sterm ) {
1519  case SYMBOL :
1520  while ( t < stopper ) {
1521  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1522  FiniLine();
1523  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1524  else IniLine(3);
1525  if ( first ) TokenToLine((UBYTE *)" ");
1526  }
1527  if ( !first ) MultiplyToLine();
1528  if ( AC.OutputMode == CMODE && t[1] != 1 ) {
1529  if ( AC.Cnumpows >= t[1] && t[1] > 0 ) {
1530  po = t[1];
1531  Out = StrCopy((UBYTE *)"POW",buffer);
1532  Out = NumCopy(po,Out);
1533  Out = StrCopy((UBYTE *)"(",Out);
1534  TokenToLine(buffer);
1535  }
1536  else {
1537  TokenToLine((UBYTE *)"pow(");
1538  }
1539  }
1540  if ( *t < NumSymbols ) {
1541  Out = StrCopy(FindSymbol(*t),buffer); t++;
1542 /* Out = StrCopy(VARNAME(symbols,*t),buffer); t++; */
1543  }
1544  else {
1545 /*
1546  see also routine PrintSubtermList.
1547 */
1548  Out = StrCopy(FindExtraSymbol(MAXVARIABLES-*t),buffer);
1549 /*
1550  Out = StrCopy((UBYTE *)AC.extrasym,buffer);
1551  if ( AC.extrasymbols == 0 ) {
1552  Out = NumCopy((MAXVARIABLES-*t),Out);
1553  Out = StrCopy((UBYTE *)"_",Out);
1554  }
1555  else if ( AC.extrasymbols == 1 ) {
1556  Out = AddArrayIndex((MAXVARIABLES-*t),Out);
1557  }
1558 */
1559 /*
1560  else if ( AC.extrasymbols == 2 ) {
1561  Out = NumCopy((MAXVARIABLES-*t),Out);
1562  }
1563 */
1564  t++;
1565  }
1566  if ( AC.OutputMode == CMODE && po > 1
1567  && AC.Cnumpows >= po ) {
1568  Out = StrCopy((UBYTE *)")",Out);
1569  po = 0;
1570  }
1571  else if ( *t != 1 ) WrtPower(Out,*t);
1572  TokenToLine(buffer);
1573  t++;
1574  first = 0;
1575  }
1576  break;
1577  case VECTOR :
1578  while ( t < stopper ) {
1579  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1580  FiniLine();
1581  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1582  else IniLine(3);
1583  if ( first ) TokenToLine((UBYTE *)" ");
1584  }
1585  if ( !first ) MultiplyToLine();
1586 
1587  Out = StrCopy(FindVector(*t),buffer);
1588 /* Out = StrCopy(VARNAME(vectors,*t - AM.OffsetVector),buffer); */
1589  t++;
1590  if ( AC.OutputMode == MATHEMATICAMODE ) *Out++ = '[';
1591  else *Out++ = '(';
1592  if ( *t >= AM.OffsetIndex ) {
1593  i = *t++;
1594  if ( i >= AM.IndDum ) {
1595  i -= AM.IndDum;
1596  *Out++ = 'N';
1597  Out = NumCopy(i,Out);
1598  *Out++ = '_';
1599  *Out++ = '?';
1600  *Out = 0;
1601  }
1602  else
1603  Out = StrCopy(FindIndex(i),Out);
1604 /* Out = StrCopy(VARNAME(indices,i - AM.OffsetIndex),Out); */
1605  }
1606  else if ( *t == FUNNYVEC ) { *Out++ = '?'; *Out = 0; }
1607  else {
1608  Out = NumCopy(*t++,Out);
1609  }
1610  if ( AC.OutputMode == MATHEMATICAMODE ) *Out++ = ']';
1611  else *Out++ = ')';
1612  *Out = 0;
1613  TokenToLine(buffer);
1614  first = 0;
1615  }
1616  break;
1617  case INDEX :
1618  while ( t < stopper ) {
1619  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1620  FiniLine();
1621  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1622  else IniLine(3);
1623  if ( first ) TokenToLine((UBYTE *)" ");
1624  }
1625  if ( !first ) MultiplyToLine();
1626  if ( *t >= 0 ) {
1627  if ( *t < AM.OffsetIndex ) {
1628  TalToLine((UWORD)(*t++));
1629  }
1630  else {
1631  i = *t++;
1632  if ( i >= AM.IndDum ) {
1633  i -= AM.IndDum;
1634  Out = buffer;
1635  *Out++ = 'N';
1636  Out = NumCopy(i,Out);
1637  *Out++ = '_';
1638  *Out++ = '?';
1639  *Out = 0;
1640  }
1641  else {
1642  i -= AM.OffsetIndex;
1643  Out = StrCopy(FindIndex(i%WILDOFFSET+AM.OffsetIndex),buffer);
1644 /* Out = StrCopy(VARNAME(indices,i%WILDOFFSET),buffer); */
1645  if ( i >= WILDOFFSET ) { *Out++ = '?'; *Out = 0; }
1646  }
1647  TokenToLine(buffer);
1648  }
1649  }
1650  else {
1651  TokenToLine(FindVector(*t)); t++;
1652 /* TokenToLine(VARNAME(vectors,*t - AM.OffsetVector)); t++; */
1653  }
1654  first = 0;
1655  }
1656  break;
1657  case DOLLAREXPRESSION:
1658  {
1659  DOLLARS d = Dollars + sterm[2];
1660  Out = StrCopy((UBYTE *)"$",buffer);
1661  Out = StrCopy(AC.dollarnames->namebuffer+d->name,Out);
1662  if ( sterm[3] != 1 ) WrtPower(Out,sterm[3]);
1663  TokenToLine(buffer);
1664  }
1665  first = 0;
1666  break;
1667  case DELTA :
1668  while ( t < stopper ) {
1669  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1670  FiniLine();
1671  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1672  else IniLine(3);
1673  if ( first ) TokenToLine((UBYTE *)" ");
1674  }
1675  if ( !first ) MultiplyToLine();
1676  Out = StrCopy((UBYTE *)"d_(",buffer);
1677  if ( *t >= AM.OffsetIndex ) {
1678  if ( *t < AM.IndDum ) {
1679  Out = StrCopy(FindIndex(*t),Out);
1680 /* Out = StrCopy(VARNAME(indices,*t - AM.OffsetIndex),Out); */
1681  t++;
1682  }
1683  else {
1684  *Out++ = 'N';
1685  Out = NumCopy( *t++ - AM.IndDum, Out);
1686  *Out++ = '_';
1687  *Out++ = '?';
1688  *Out = 0;
1689  }
1690  }
1691  else if ( *t == FUNNYVEC ) { *Out++ = '?'; *Out = 0; }
1692  else {
1693  Out = NumCopy(*t++,Out);
1694  }
1695  *Out++ = ',';
1696  if ( *t >= AM.OffsetIndex ) {
1697  if ( *t < AM.IndDum ) {
1698  Out = StrCopy(FindIndex(*t),Out);
1699 /* Out = StrCopy(VARNAME(indices,*t - AM.OffsetIndex),Out); */
1700  t++;
1701  }
1702  else {
1703  *Out++ = 'N';
1704  Out = NumCopy(*t++ - AM.IndDum,Out);
1705  *Out++ = '_';
1706  *Out++ = '?';
1707  }
1708  }
1709  else {
1710  Out = NumCopy(*t++,Out);
1711  }
1712  *Out++ = ')';
1713  *Out = 0;
1714  TokenToLine(buffer);
1715  first = 0;
1716  }
1717  break;
1718  case DOTPRODUCT :
1719  while ( t < stopper ) {
1720  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1721  FiniLine();
1722  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1723  else IniLine(3);
1724  if ( first ) TokenToLine((UBYTE *)" ");
1725  }
1726  if ( !first ) MultiplyToLine();
1727  if ( AC.OutputMode == CMODE && t[2] != 1 )
1728  TokenToLine((UBYTE *)"pow(");
1729  Out = StrCopy(FindVector(*t),buffer);
1730 /* Out = StrCopy(VARNAME(vectors,*t - AM.OffsetVector),buffer); */
1731  t++;
1732  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
1733  || AC.OutputMode == CMODE )
1734  *Out++ = AO.FortDotChar;
1735  else *Out++ = '.';
1736  Out = StrCopy(FindVector(*t),Out);
1737 /* Out = StrCopy(VARNAME(vectors,*t - AM.OffsetVector),Out); */
1738  t++;
1739  if ( *t != 1 ) WrtPower(Out,*t);
1740  t++;
1741  TokenToLine(buffer);
1742  first = 0;
1743  }
1744  break;
1745  case EXPONENT :
1746 #if FUNHEAD != 2
1747  t += FUNHEAD - 2;
1748 #endif
1749  if ( !first ) MultiplyToLine();
1750  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)"pow(");
1751  else TokenToLine((UBYTE *)"(");
1752  WriteArgument(t);
1753  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
1754  || AC.OutputMode == REDUCEMODE )
1755  TokenToLine((UBYTE *)")**(");
1756  else if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)",");
1757  else TokenToLine((UBYTE *)")^(");
1758  NEXTARG(t)
1759  WriteArgument(t);
1760  TokenToLine((UBYTE *)")");
1761  break;
1762  case DENOMINATOR :
1763 #if FUNHEAD != 2
1764  t += FUNHEAD - 2;
1765 #endif
1766  if ( first ) TokenToLine((UBYTE *)"1/(");
1767  else TokenToLine((UBYTE *)"/(");
1768  WriteArgument(t);
1769  TokenToLine((UBYTE *)")");
1770  break;
1771  case SUBEXPRESSION:
1772  if ( !first ) MultiplyToLine();
1773  TokenToLine((UBYTE *)"(");
1774  t = cbuf[sterm[4]].rhs[sterm[2]];
1775  tt = t;
1776  while ( *tt ) tt += *tt;
1777  oldoutsidefun = AC.outsidefun; AC.outsidefun = 0;
1778  if ( *t ) {
1779  WriteExpression(t,(LONG)(tt-t));
1780  }
1781  else {
1782  TokenToLine((UBYTE *)"0");
1783  }
1784  AC.outsidefun = oldoutsidefun;
1785  TokenToLine((UBYTE *)")");
1786  if ( sterm[3] != 1 ) {
1787  TokenToLine((UBYTE *)"^");
1788  Out = buffer;
1789  NumCopy(sterm[3],Out);
1790  TokenToLine(buffer);
1791  }
1792  break;
1793  default :
1794  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1795  FiniLine();
1796  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1797  else IniLine(3);
1798  if ( first ) TokenToLine((UBYTE *)" ");
1799  }
1800  if ( *sterm < FUNCTION ) {
1801  return(MesPrint("Illegal subterm while writing"));
1802  }
1803  if ( !first ) MultiplyToLine();
1804  first = 1;
1805  { UBYTE *tmp;
1806  if ( ( tmp = FindFunWithArgs(sterm) ) != 0 ) {
1807  TokenToLine(tmp);
1808  break;
1809  }
1810  }
1811  t += FUNHEAD-2;
1812 
1813  if ( *sterm == GAMMA && t[-FUNHEAD+1] == FUNHEAD+1 ) {
1814  TokenToLine((UBYTE *)"gi_(");
1815  }
1816  else {
1817  if ( *sterm != DUMFUN ) {
1818  Out = StrCopy(FindFunction(*sterm),buffer);
1819 /* Out = StrCopy(VARNAME(functions,*sterm - FUNCTION),buffer); */
1820  }
1821  else { Out = buffer; *Out = 0; }
1822  if ( t >= stopper ) {
1823  TokenToLine(buffer);
1824  break;
1825  }
1826  if ( AC.OutputMode == MATHEMATICAMODE ) { *Out++ = '['; closepar[0] = (UBYTE)']'; }
1827  else { *Out++ = '('; }
1828  *Out = 0;
1829  TokenToLine(buffer);
1830  }
1831  i = functions[*sterm - FUNCTION].spec;
1832  if ( i >= TENSORFUNCTION ) {
1833  int curdict = AO.CurrentDictionary;
1834  if ( AO.CurrentDictionary && AO.CurDictNotInFunctions > 0 )
1835  AO.CurrentDictionary = 0;
1836  t = sterm + FUNHEAD;
1837  while ( t < stopper ) {
1838  if ( !first ) TokenToLine((UBYTE *)",");
1839  else first = 0;
1840  j = *t++;
1841  if ( j >= 0 ) {
1842  if ( j < AM.OffsetIndex ) TalToLine((UWORD)(j));
1843  else if ( j < AM.IndDum ) {
1844  i = j - AM.OffsetIndex;
1845  Out = StrCopy(FindIndex(i%WILDOFFSET+AM.OffsetIndex),buffer);
1846 /* Out = StrCopy(VARNAME(indices,i%WILDOFFSET),buffer); */
1847  if ( i >= WILDOFFSET ) { *Out++ = '?'; *Out = 0; }
1848  TokenToLine(buffer);
1849  }
1850  else {
1851  Out = buffer;
1852  *Out++ = 'N';
1853  Out = NumCopy(j - AM.IndDum,Out);
1854  *Out++ = '_';
1855  *Out++ = '?';
1856  *Out = 0;
1857  TokenToLine(buffer);
1858  }
1859  }
1860  else if ( j == FUNNYVEC ) { TokenToLine((UBYTE *)"?"); }
1861  else if ( j > -WILDOFFSET ) {
1862  Out = buffer;
1863  Out = NumCopy((UWORD)(-j + 4),Out);
1864  *Out++ = '_';
1865  *Out = 0;
1866  TokenToLine(buffer);
1867  }
1868  else {
1869  TokenToLine(FindVector(j));
1870 /* TokenToLine(VARNAME(vectors,j - AM.OffsetVector)); */
1871  }
1872  }
1873  AO.CurrentDictionary = curdict;
1874  }
1875  else {
1876  int curdict = AO.CurrentDictionary;
1877  if ( AO.CurrentDictionary && AO.CurDictNotInFunctions > 0 )
1878  AO.CurrentDictionary = 0;
1879  while ( t < stopper ) {
1880  if ( !first ) TokenToLine((UBYTE *)",");
1881  WriteArgument(t);
1882  NEXTARG(t)
1883  first = 0;
1884  }
1885  AO.CurrentDictionary = curdict;
1886  }
1887  TokenToLine(closepar);
1888  closepar[0] = (UBYTE)')';
1889  break;
1890  }
1891  return(0);
1892 }
1893 
1894 /*
1895  #] WriteSubTerm :
1896  #[ WriteInnerTerm : WORD WriteInnerTerm(term,first)
1897 
1898  Writes the contents of term to the output.
1899  Only the part that is inside parentheses is written.
1900 
1901 */
1902 
1903 WORD WriteInnerTerm(WORD *term, WORD first)
1904 {
1905  WORD *t, *s, *s1, *s2, n, i, pow;
1906  t = term;
1907  s = t+1;
1908  GETCOEF(t,n);
1909  while ( s < t ) {
1910  if ( *s == HAAKJE ) break;
1911  s += s[1];
1912  }
1913  if ( s < t ) { s += s[1]; }
1914  else { s = term+1; }
1915 
1916  if ( n < 0 || !first ) {
1917  if ( n > 0 ) { TOKENTOLINE(" + ","+") }
1918  else if ( n < 0 ) { n = -n; TOKENTOLINE(" - ","-") }
1919  }
1920  if ( AC.modpowers ) {
1921  if ( n == 1 && *t == 1 && t > s ) first = 1;
1922  else if ( ABS(AC.ncmod) == 1 ) {
1923  LongToLine((UWORD *)AC.powmod,AC.npowmod);
1924  TokenToLine((UBYTE *)"^");
1925  TalToLine(AC.modpowers[(LONG)((UWORD)*t)]);
1926  first = 0;
1927  }
1928  else {
1929  LONG jj;
1930  LongToLine((UWORD *)AC.powmod,AC.npowmod);
1931  TokenToLine((UBYTE *)"^");
1932  jj = (UWORD)*t;
1933  if ( n == 2 ) jj += ((LONG)t[1])<<BITSINWORD;
1934  if ( AC.modpowers[jj+1] == 0 ) {
1935  TalToLine(AC.modpowers[jj]);
1936  }
1937  else {
1938  LongToLine(AC.modpowers+jj,2);
1939  }
1940  first = 0;
1941  }
1942  }
1943  else if ( n != 1 || *t != 1 || t[1] != 1 || t <= s ) {
1944  if ( lowestlevel && ( ( AO.PrintType & PRINTONEFUNCTION ) != 0 ) ) {
1945  FiniLine();
1946  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1947  else IniLine(3);
1948  }
1949  if ( AO.CurrentDictionary > 0 ) TransformRational((UWORD *)t,n);
1950  else RatToLine((UWORD *)t,n);
1951  first = 0;
1952  }
1953  else first = 1;
1954  while ( s < t ) {
1955  if ( lowestlevel && ( (AO.PrintType & (PRINTONEFUNCTION | PRINTALL)) == PRINTONEFUNCTION ) ) {
1956  FiniLine();
1957  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1958  else IniLine(3);
1959  }
1960 
1961 /*
1962  #[ NEWGAMMA :
1963 */
1964 #ifdef NEWGAMMA
1965  if ( *s == GAMMA ) { /* String them up */
1966  WORD *tt,*ss;
1967  ss = AT.WorkPointer;
1968  *ss++ = GAMMA;
1969  *ss++ = s[1];
1970  FILLFUN(ss)
1971  *ss++ = s[FUNHEAD];
1972  tt = s + FUNHEAD + 1;
1973  n = s[1] - FUNHEAD-1;
1974  do {
1975  while ( --n >= 0 ) *ss++ = *tt++;
1976  tt = s + s[1];
1977  while ( *tt == GAMMA && tt[FUNHEAD] == s[FUNHEAD] && tt < t ) {
1978  s = tt;
1979  tt += FUNHEAD + 1;
1980  n = s[1] - FUNHEAD-1;
1981  if ( n > 0 ) break;
1982  }
1983  } while ( n > 0 );
1984  tt = AT.WorkPointer;
1985  AT.WorkPointer = ss;
1986  tt[1] = WORDDIF(ss,tt);
1987  if ( WriteSubTerm(tt,first) ) {
1988  MesCall("WriteInnerTerm");
1989  SETERROR(-1)
1990  }
1991  AT.WorkPointer = tt;
1992  }
1993  else
1994 #endif
1995 /*
1996  #] NEWGAMMA :
1997 */
1998  {
1999  if ( *s >= FUNCTION && AC.funpowers > 0
2000  && functions[*s-FUNCTION].spec == 0 && ( AC.funpowers == ALLFUNPOWERS ||
2001  ( AC.funpowers == COMFUNPOWERS && functions[*s-FUNCTION].commute == 0 ) ) ) {
2002  pow = 1;
2003  for(;;) {
2004  s1 = s; s2 = s + s[1]; i = s[1];
2005  if ( s2 < t ) {
2006  while ( --i >= 0 && *s1 == *s2 ) { s1++; s2++; }
2007  if ( i < 0 ) {
2008  pow++; s = s+s[1];
2009  }
2010  else break;
2011  }
2012  else break;
2013  }
2014  if ( pow > 1 ) {
2015  if ( AC.OutputMode == CMODE ) {
2016  if ( !first ) MultiplyToLine();
2017  TokenToLine((UBYTE *)"pow(");
2018  first = 1;
2019  }
2020  if ( WriteSubTerm(s,first) ) {
2021  MesCall("WriteInnerTerm");
2022  SETERROR(-1)
2023  }
2024  if ( AC.OutputMode == FORTRANMODE
2025  || AC.OutputMode == PFORTRANMODE ) { TokenToLine((UBYTE *)"**"); }
2026  else if ( AC.OutputMode == CMODE ) { TokenToLine((UBYTE *)","); }
2027  else { TokenToLine((UBYTE *)"^"); }
2028  TalToLine(pow);
2029  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)")");
2030  }
2031  else if ( WriteSubTerm(s,first) ) {
2032  MesCall("WriteInnerTerm");
2033  SETERROR(-1)
2034  }
2035  }
2036  else if ( WriteSubTerm(s,first) ) {
2037  MesCall("WriteInnerTerm");
2038  SETERROR(-1)
2039  }
2040  }
2041  first = 0;
2042  s += s[1];
2043  }
2044  return(0);
2045 }
2046 
2047 /*
2048  #] WriteInnerTerm :
2049  #[ WriteTerm : WORD WriteTerm(term,lbrac,first,prtf,br)
2050 
2051  Writes a term to output. It tests the bracket information first.
2052  If there are no brackets or the bracket is the same all is passed
2053  to WriteInnerTerm. If there are brackets and the bracket is not
2054  the same as for the predecessor the old bracket is closed and
2055  a new one is opened.
2056  br indicates whether we are in a subexpression, barring zeroing
2057  AO.IsBracket
2058 
2059 */
2060 
2061 WORD WriteTerm(WORD *term, WORD *lbrac, WORD first, WORD prtf, WORD br)
2062 {
2063  WORD *t, *stopper, *b, n;
2064  int oldIsFortran90 = AC.IsFortran90, i;
2065  if ( *lbrac >= 0 ) {
2066  t = term + 1;
2067  stopper = (term + *term - 1);
2068  stopper -= ABS(*stopper) - 1;
2069  while ( t < stopper ) {
2070  if ( *t == HAAKJE ) {
2071  stopper = t;
2072  t = term+1;
2073  if ( *lbrac == ( n = WORDDIF(stopper,t) ) ) {
2074  b = AO.bracket + 1;
2075  t = term + 1;
2076  while ( n > 0 && ( *b++ == *t++ ) ) { n--; }
2077  if ( n <= 0 && ( ( AO.InFbrack < AM.FortranCont )
2078  || ( lowestlevel == 0 ) ) ) {
2079 /*
2080  We continue inside a bracket.
2081 */
2082  AO.IsBracket = 1;
2083  if ( ( prtf & PRINTCONTENTS ) != 0 ) {
2084  AO.NumInBrack++;
2085  }
2086  else {
2087  if ( WriteInnerTerm(term,0) ) goto WrtTmes;
2088  if ( ( AO.PrintType & PRINTONETERM ) != 0 ) {
2089  FiniLine();
2090  TokenToLine((UBYTE *)" ");
2091  }
2092  }
2093  return(0);
2094  }
2095  t = term + 1;
2096  n = WORDDIF(stopper,t);
2097  }
2098 /*
2099  Close the bracket
2100 */
2101  if ( *lbrac ) {
2102  if ( ( prtf & PRINTCONTENTS ) ) PrtTerms();
2103  TOKENTOLINE(" )",")")
2104  if ( AC.OutputMode == CMODE && AO.FactorMode == 0 )
2105  TokenToLine((UBYTE *)";");
2106  else if ( AO.FactorMode && ( n == 0 ) ) {
2107 /*
2108  This should not happen.
2109 */
2110  return(0);
2111  }
2112  AC.IsFortran90 = ISNOTFORTRAN90;
2113  FiniLine();
2114  AC.IsFortran90 = oldIsFortran90;
2115  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE
2116  && AC.OutputSpaces == NORMALFORMAT
2117  && AO.FactorMode == 0 ) FiniLine();
2118  }
2119  else {
2120  if ( AC.OutputMode == CMODE && AO.FactorMode == 0 )
2121  TokenToLine((UBYTE *)";");
2122  if ( AO.FortFirst == 0 ) {
2123  if ( !first ) {
2124  AC.IsFortran90 = ISNOTFORTRAN90;
2125  FiniLine();
2126  AC.IsFortran90 = oldIsFortran90;
2127  }
2128  }
2129  }
2130  if ( AO.FactorMode == 0 ) {
2131  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2132  && !first ) {
2133  WORD oldmode = AC.OutputMode;
2134  AC.OutputMode = 0;
2135  IniLine(0);
2136  AC.OutputMode = oldmode;
2137  AO.OutSkip = 7;
2138 
2139  if ( AO.FortFirst == 0 ) {
2140  TokenToLine(AO.CurBufWrt);
2141  TOKENTOLINE(" = ","=")
2142  TokenToLine(AO.CurBufWrt);
2143  }
2144  else {
2145  AO.FortFirst = 0;
2146  TokenToLine(AO.CurBufWrt);
2147  TOKENTOLINE(" = ","=")
2148  }
2149  }
2150  else if ( AC.OutputMode == CMODE && !first ) {
2151  IniLine(0);
2152  if ( AO.FortFirst == 0 ) {
2153  TokenToLine(AO.CurBufWrt);
2154  TOKENTOLINE(" += ","+=")
2155  }
2156  else {
2157  AO.FortFirst = 0;
2158  TokenToLine(AO.CurBufWrt);
2159  TOKENTOLINE(" = ","=")
2160  }
2161  }
2162  else if ( startinline == 0 ) {
2163  IniLine(0);
2164  }
2165  AO.InFbrack = 0;
2166  if ( ( *lbrac = n ) > 0 ) {
2167  b = AO.bracket;
2168  *b++ = n + 4;
2169  while ( --n >= 0 ) *b++ = *t++;
2170  *b++ = 1; *b++ = 1; *b = 3;
2171  AO.IsBracket = 0;
2172  if ( WriteInnerTerm(AO.bracket,0) ) {
2173  /* Error message */
2174  WORD i;
2175 WrtTmes: t = term;
2176  AO.OutSkip = 3;
2177  FiniLine();
2178  i = *t;
2179  while ( --i >= 0 ) { TalToLine((UWORD)(*t++));
2180  if ( AC.OutputSpaces == NORMALFORMAT )
2181  TokenToLine((UBYTE *)" "); }
2182  AO.OutSkip = 0;
2183  FiniLine();
2184  MesCall("WriteTerm");
2185  SETERROR(-1)
2186  }
2187  TOKENTOLINE(" * ( ","*(")
2188  AO.NumInBrack = 0;
2189  AO.IsBracket = 1;
2190  if ( ( prtf & PRINTONETERM ) != 0 ) {
2191  first = 0;
2192  FiniLine();
2193  TokenToLine((UBYTE *)" ");
2194  }
2195  else first = 1;
2196  }
2197  else {
2198  AO.IsBracket = 0;
2199  first = 0;
2200  }
2201  }
2202  else {
2203 /*
2204  Here is the code that writes the glue between two factors.
2205  We should not forget factors that are zero!
2206 */
2207  if ( ( *lbrac = n ) > 0 ) {
2208  b = AO.bracket;
2209  *b++ = n + 4;
2210  while ( --n >= 0 ) *b++ = *t++;
2211  *b++ = 1; *b++ = 1; *b = 3;
2212  for ( i = AO.FactorNum+1; i < AO.bracket[4]; i++ ) {
2213  if ( first ) {
2214  TOKENTOLINE(" ( 0 )"," (0)")
2215  first = 0;
2216  }
2217  else {
2218  TOKENTOLINE(" * ( 0 )","*(0)")
2219  }
2220  FiniLine();
2221  IniLine(0);
2222  }
2223  AO.FactorNum = AO.bracket[4];
2224  }
2225  else {
2226  AO.NumInBrack = 0;
2227  return(0);
2228  }
2229  if ( first == 0 ) { TOKENTOLINE(" * ( ","*(") }
2230  else { TOKENTOLINE(" ( "," (") }
2231  AO.NumInBrack = 0;
2232  first = 1;
2233  }
2234  if ( ( prtf & PRINTCONTENTS ) != 0 ) AO.NumInBrack++;
2235  else if ( WriteInnerTerm(term,first) ) goto WrtTmes;
2236  if ( ( AO.PrintType & PRINTONETERM ) != 0 ) {
2237  FiniLine();
2238  TokenToLine((UBYTE *)" ");
2239  }
2240  return(0);
2241  }
2242  else t += t[1];
2243  }
2244  if ( *lbrac > 0 ) {
2245  if ( ( prtf & PRINTCONTENTS ) != 0 ) PrtTerms();
2246  TokenToLine((UBYTE *)" )");
2247  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)";");
2248  if ( AO.FortFirst == 0 ) {
2249  AC.IsFortran90 = ISNOTFORTRAN90;
2250  FiniLine();
2251  AC.IsFortran90 = oldIsFortran90;
2252  }
2253  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE
2254  && AC.OutputSpaces == NORMALFORMAT ) FiniLine();
2255  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2256  && !first ) {
2257  WORD oldmode = AC.OutputMode;
2258  AC.OutputMode = 0;
2259  IniLine(0);
2260  AC.OutputMode = oldmode;
2261  AO.OutSkip = 7;
2262  if ( AO.FortFirst == 0 ) {
2263  TokenToLine(AO.CurBufWrt);
2264  TOKENTOLINE(" = ","=")
2265  TokenToLine(AO.CurBufWrt);
2266  }
2267  else {
2268  AO.FortFirst = 0;
2269  TokenToLine(AO.CurBufWrt);
2270  TOKENTOLINE(" = ","=")
2271  }
2272 /*
2273  TokenToLine(AO.CurBufWrt);
2274  TOKENTOLINE(" = ","=")
2275  if ( AO.FortFirst == 0 )
2276  TokenToLine(AO.CurBufWrt);
2277  else AO.FortFirst = 0;
2278 */
2279  }
2280  else if ( AC.OutputMode == CMODE && !first ) {
2281  IniLine(0);
2282  if ( AO.FortFirst == 0 ) {
2283  TokenToLine(AO.CurBufWrt);
2284  TOKENTOLINE(" += ","+=")
2285  }
2286  else {
2287  AO.FortFirst = 0;
2288  TokenToLine(AO.CurBufWrt);
2289  TOKENTOLINE(" = ","=")
2290  }
2291 /*
2292  TokenToLine(AO.CurBufWrt);
2293  if ( AO.FortFirst == 0 ) { TOKENTOLINE(" += ","+=") }
2294  else {
2295  TOKENTOLINE(" = ","=")
2296  AO.FortFirst = 0;
2297  }
2298 */
2299  }
2300  else IniLine(0);
2301  *lbrac = 0;
2302  first = 1;
2303  }
2304  }
2305  if ( !br ) AO.IsBracket = 0;
2306  if ( ( AO.InFbrack >= AM.FortranCont ) && lowestlevel ) {
2307  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)";");
2308  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2309  && !first ) {
2310  WORD oldmode = AC.OutputMode;
2311  if ( AO.FortFirst == 0 ) {
2312  AC.IsFortran90 = ISNOTFORTRAN90;
2313  FiniLine();
2314  AC.IsFortran90 = oldIsFortran90;
2315  AC.OutputMode = 0;
2316  IniLine(0);
2317  AC.OutputMode = oldmode;
2318  AO.OutSkip = 7;
2319  TokenToLine(AO.CurBufWrt);
2320  TOKENTOLINE(" = ","=")
2321  TokenToLine(AO.CurBufWrt);
2322  }
2323  else {
2324  AO.FortFirst = 0;
2325 /*
2326  TokenToLine(AO.CurBufWrt);
2327  TOKENTOLINE(" = ","=")
2328 */
2329  }
2330 /*
2331  TokenToLine(AO.CurBufWrt);
2332  TOKENTOLINE(" = ","=")
2333  if ( AO.FortFirst == 0 )
2334  TokenToLine(AO.CurBufWrt);
2335  else AO.FortFirst = 0;
2336 */
2337  }
2338  else if ( AC.OutputMode == CMODE && !first ) {
2339  FiniLine();
2340  IniLine(0);
2341  if ( AO.FortFirst == 0 ) {
2342  TokenToLine(AO.CurBufWrt);
2343  TOKENTOLINE(" += ","+=")
2344  }
2345  else {
2346  AO.FortFirst = 0;
2347  TokenToLine(AO.CurBufWrt);
2348  TOKENTOLINE(" = ","=")
2349  }
2350 /*
2351  TokenToLine(AO.CurBufWrt);
2352  if ( AO.FortFirst == 0 ) { TOKENTOLINE(" += ","+=") }
2353  else {
2354  TOKENTOLINE(" = ","=")
2355  AO.FortFirst = 0;
2356  }
2357 */
2358  }
2359  else {
2360  FiniLine();
2361  IniLine(0);
2362  }
2363  AO.InFbrack = 0;
2364  }
2365  if ( WriteInnerTerm(term,first) ) goto WrtTmes;
2366  if ( ( AO.PrintType & PRINTONETERM ) != 0 ) {
2367  FiniLine();
2368  IniLine(0);
2369  }
2370  return(0);
2371 }
2372 
2373 /*
2374  #] WriteTerm :
2375  #[ WriteExpression : WORD WriteExpression(terms,ltot)
2376 
2377  Writes a subexpression to output.
2378  The subexpression is in terms and contains ltot words.
2379  This is only used for function arguments.
2380 
2381 */
2382 
2383 WORD WriteExpression(WORD *terms, LONG ltot)
2384 {
2385  WORD *stopper;
2386  WORD first, btot;
2387  WORD OldIsBracket = AO.IsBracket, OldPrintType = AO.PrintType;
2388  if ( !AC.outsidefun ) { AO.PrintType &= ~PRINTONETERM; first = 1; }
2389  else first = 0;
2390  stopper = terms + ltot;
2391  btot = -1;
2392  while ( terms < stopper ) {
2393  AO.IsBracket = OldIsBracket;
2394  if ( WriteTerm(terms,&btot,first,0,1) ) {
2395  MesCall("WriteExpression");
2396  SETERROR(-1)
2397  }
2398  first = 0;
2399  terms += *terms;
2400  }
2401 /* AO.IsBracket = 0; */
2402  AO.IsBracket = OldIsBracket;
2403  AO.PrintType = OldPrintType;
2404  return(0);
2405 }
2406 
2407 /*
2408  #] WriteExpression :
2409  #[ WriteAll : WORD WriteAll()
2410 
2411  Writes all expressions that should be written
2412 */
2413 
2414 WORD WriteAll()
2415 {
2416  GETIDENTITY
2417  WORD lbrac, first;
2418  WORD *t, *stopper, n, prtf;
2419  int oldIsFortran90 = AC.IsFortran90, i;
2420  POSITION pos;
2421  FILEHANDLE *f;
2422  EXPRESSIONS e;
2423  if ( AM.exitflag ) return(0);
2424 #ifdef WITHMPI
2425  if ( PF.me != MASTER ) {
2426  /*
2427  * For the slaves, we need to call Optimize() the same number of times
2428  * as the master. The first argument doesn't have any important role.
2429  */
2430  for ( n = 0; n < NumExpressions; n++ ) {
2431  e = &Expressions[n];
2432  if ( !e->printflag & PRINTON ) continue;
2433  switch ( e->status ) {
2434  case LOCALEXPRESSION:
2435  case GLOBALEXPRESSION:
2436  case UNHIDELEXPRESSION:
2437  case UNHIDEGEXPRESSION:
2438  break;
2439  default:
2440  continue;
2441  }
2442  e->printflag = 0;
2443  PutPreVar(AM.oldnumextrasymbols, GetPreVar((UBYTE *)"EXTRASYMBOLS_", 0), 0, 1);
2444  if ( AO.OptimizationLevel > 0 ) {
2445  if ( Optimize(0, 1) ) return(-1);
2446  }
2447  }
2448  return(0);
2449  }
2450 #endif
2451  SeekScratch(AR.outfile,&pos);
2452  if ( ResetScratch() ) {
2453  MesCall("WriteAll");
2454  SETERROR(-1)
2455  }
2456  AO.termbuf = AT.WorkPointer;
2457  AO.bracket = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
2458  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2);
2459  AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer;
2460  AT.WorkPointer += 2*AC.LineLength;
2461  *(AR.CompressBuffer) = 0;
2462  first = 0;
2463  for ( n = 0; n < NumExpressions; n++ ) {
2464  if ( ( Expressions[n].printflag & PRINTON ) != 0 ) { first = 1; break; }
2465  }
2466  if ( !first ) goto EndWrite;
2467  AO.IsBracket = 0;
2468  AO.OutSkip = 3;
2469  AR.DeferFlag = 0;
2470  while ( GetTerm(BHEAD AO.termbuf) ) {
2471  t = AO.termbuf + 1;
2472  e = Expressions + AO.termbuf[3];
2473  n = e->status;
2474  if ( ( n == LOCALEXPRESSION || n == GLOBALEXPRESSION
2475  || n == UNHIDELEXPRESSION || n == UNHIDEGEXPRESSION ) &&
2476  ( ( prtf = e->printflag ) & PRINTON ) != 0 ) {
2477  e->printflag = 0;
2478  AO.NumInBrack = 0;
2479  PutPreVar(AM.oldnumextrasymbols,
2480  GetPreVar((UBYTE *)"EXTRASYMBOLS_",0),0,1);
2481  if ( ( prtf & PRINTLFILE ) != 0 ) {
2482  if ( AC.LogHandle < 0 ) prtf &= ~PRINTLFILE;
2483  }
2484  AO.PrintType = prtf;
2485 /*
2486  if ( AC.OutputMode == VORTRANMODE ) {
2487  UBYTE *oldOutFill = AO.OutFill, *oldOutputLine = AO.OutputLine;
2488  AO.OutSkip = 6;
2489  if ( Optimize(AO.termbuf[3], 1) ) goto AboWrite;
2490  AO.OutSkip = 3;
2491  AO.OutFill = oldOutFill; AO.OutputLine = oldOutputLine;
2492  FiniLine();
2493  continue;
2494  }
2495  else
2496 */
2497  if ( AO.OptimizationLevel > 0 ) {
2498  UBYTE *oldOutFill = AO.OutFill, *oldOutputLine = AO.OutputLine;
2499  AO.OutSkip = 6;
2500  if ( Optimize(AO.termbuf[3], 1) ) goto AboWrite;
2501  AO.OutSkip = 3;
2502  AO.OutFill = oldOutFill; AO.OutputLine = oldOutputLine;
2503  FiniLine();
2504  continue;
2505  }
2506  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2507  AO.OutSkip = 6;
2508  FiniLine();
2509  AO.CurBufWrt = EXPRNAME(AO.termbuf[3]);
2510  TokenToLine(AO.CurBufWrt);
2511  stopper = t + t[1];
2512  t += SUBEXPSIZE;
2513  if ( t < stopper ) {
2514  TokenToLine((UBYTE *)"(");
2515  first = 1;
2516  while ( t < stopper ) {
2517  n = *t;
2518  if ( !first ) TokenToLine((UBYTE *)",");
2519  switch ( n ) {
2520  case SYMTOSYM :
2521  TokenToLine(FindSymbol(t[2]));
2522 /* TokenToLine(VARNAME(symbols,t[2])); */
2523  break;
2524  case VECTOVEC :
2525  TokenToLine(FindVector(t[2]));
2526 /* TokenToLine(VARNAME(vectors,t[2] - AM.OffsetVector)); */
2527  break;
2528  case INDTOIND :
2529  TokenToLine(FindIndex(t[2]));
2530 /* TokenToLine(VARNAME(indices,t[2] - AM.OffsetIndex)); */
2531  break;
2532  default :
2533  TokenToLine(FindFunction(t[2]));
2534 /* TokenToLine(VARNAME(functions,t[2] - FUNCTION)); */
2535  break;
2536  }
2537  t += t[1];
2538  first = 0;
2539  }
2540  TokenToLine((UBYTE *)")");
2541  }
2542  TOKENTOLINE(" =","=");
2543  lbrac = 0;
2544  AO.InFbrack = 0;
2545  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2546  AO.FortFirst = 1;
2547  else
2548  AO.FortFirst = 0;
2549  first = 1;
2550  if ( ( e->vflags & ISFACTORIZED ) != 0 ) {
2551  AO.FactorMode = 1+e->numfactors;
2552  AO.FactorNum = 0; /* Which factor are we doing. For factors that are zero */
2553  }
2554  else {
2555  AO.FactorMode = 0;
2556  }
2557  while ( GetTerm(BHEAD AO.termbuf) ) {
2558  WORD *m;
2559  GETSTOP(AO.termbuf,m);
2560  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2561  && ( ( prtf & PRINTONETERM ) != 0 ) ) {}
2562  else {
2563  if ( first ) {
2564  FiniLine();
2565  IniLine(0);
2566  }
2567  }
2568  if ( ( prtf & PRINTONETERM ) != 0 ) first = 0;
2569  if ( WriteTerm(AO.termbuf,&lbrac,first,prtf,0) )
2570  goto AboWrite;
2571  first = 0;
2572  }
2573  if ( AO.FactorMode ) {
2574  if ( first ) { AO.FactorNum = 1; TOKENTOLINE(" ( 0 )"," (0)") }
2575  else TOKENTOLINE(" )",")");
2576  for ( i = AO.FactorNum+1; i <= e->numfactors; i++ ) {
2577  FiniLine();
2578  IniLine(0);
2579  TOKENTOLINE(" * ( 0 )","*(0)");
2580  }
2581  AO.FactorNum = e->numfactors;
2582  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE )
2583  TokenToLine((UBYTE *)";");
2584  }
2585  else if ( AO.FactorMode == 0 || first ) {
2586  if ( first ) { TOKENTOLINE(" 0","0") }
2587  else if ( lbrac ) {
2588  if ( ( prtf & PRINTCONTENTS ) != 0 ) PrtTerms();
2589  TOKENTOLINE(" )",")")
2590  }
2591  else if ( ( prtf & PRINTCONTENTS ) != 0 ) {
2592  TOKENTOLINE(" + 1 * ( ","+1*(")
2593  PrtTerms();
2594  TOKENTOLINE(" )",")")
2595  }
2596  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE )
2597  TokenToLine((UBYTE *)";");
2598  }
2599  AO.OutSkip = 3;
2600  AC.IsFortran90 = ISNOTFORTRAN90;
2601  FiniLine();
2602  AC.IsFortran90 = oldIsFortran90;
2603  AO.FactorMode = 0;
2604  }
2605  else {
2606  do { } while ( GetTerm(BHEAD AO.termbuf) );
2607  }
2608  }
2609  if ( AC.OutputSpaces == NORMALFORMAT ) FiniLine();
2610 EndWrite:
2611  if ( AR.infile->handle >= 0 ) {
2612  SeekFile(AR.infile->handle,&(AR.infile->filesize),SEEK_SET);
2613  }
2614  AO.IsBracket = 0;
2615  AT.WorkPointer = AO.termbuf;
2616  SetScratch(AR.infile,&pos);
2617  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2618  return(0);
2619 AboWrite:
2620  SetScratch(AR.infile,&pos);
2621  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2622  MesCall("WriteAll");
2623  Terminate(-1);
2624  return(-1);
2625 }
2626 
2627 /*
2628  #] WriteAll :
2629  #[ WriteOne : WORD WriteOne(name,alreadyinline)
2630 
2631  Writes one expression from the preprocessor
2632 */
2633 
2634 WORD WriteOne(UBYTE *name, int alreadyinline, int nosemi)
2635 {
2636  GETIDENTITY
2637  WORD number;
2638  WORD lbrac, first;
2639  POSITION pos;
2640  FILEHANDLE *f;
2641 
2642  if ( GetName(AC.exprnames,name,&number,NOAUTO) != CEXPRESSION ) {
2643  MesPrint("@%s is not an expression",name);
2644  return(-1);
2645  }
2646  switch ( Expressions[number].status ) {
2647  case HIDDENLEXPRESSION:
2648  case HIDDENGEXPRESSION:
2649  case HIDELEXPRESSION:
2650  case HIDEGEXPRESSION:
2651  case UNHIDELEXPRESSION:
2652  case UNHIDEGEXPRESSION:
2653 /*
2654  case DROPHLEXPRESSION:
2655  case DROPHGEXPRESSION:
2656 */
2657  AR.GetFile = 2;
2658  break;
2659  case LOCALEXPRESSION:
2660  case GLOBALEXPRESSION:
2661  case SKIPLEXPRESSION:
2662  case SKIPGEXPRESSION:
2663 /*
2664  case DROPLEXPRESSION:
2665  case DROPGEXPRESSION:
2666 */
2667  AR.GetFile = 0;
2668  break;
2669  default:
2670  MesPrint("@expressions %s is not active. It cannot be written",name);
2671  return(-1);
2672  }
2673  SeekScratch(AR.outfile,&pos);
2674 
2675  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2676 /*
2677  if ( ResetScratch() ) {
2678  MesCall("WriteOne");
2679  SETERROR(-1)
2680  }
2681 */
2682  if ( AR.GetFile == 2 ) f = AR.hidefile;
2683  else f = AR.infile;
2684 /*
2685  Now position the file
2686 */
2687  if ( f->handle >= 0 ) {
2688  SetScratch(f,&(Expressions[number].onfile));
2689  }
2690  else {
2691  f->POfill = (WORD *)((UBYTE *)(f->PObuffer)
2692  + BASEPOSITION(Expressions[number].onfile));
2693  }
2694  AO.termbuf = AT.WorkPointer;
2695  AO.bracket = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
2696  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2);
2697 
2698  AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer;
2699  AT.WorkPointer += 2*AC.LineLength;
2700  *(AR.CompressBuffer) = 0;
2701 
2702  AO.IsBracket = 0;
2703  AO.OutSkip = 3;
2704  AR.DeferFlag = 0;
2705 
2706  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2707  AO.OutSkip = 6;
2708  if ( GetTerm(BHEAD AO.termbuf) <= 0 ) {
2709  MesPrint("@ReadError in expression %s",name);
2710  goto AboWrite;
2711  }
2712 /*
2713  PutPreVar(AM.oldnumextrasymbols,
2714  GetPreVar((UBYTE *)"EXTRASYMBOLS_",0),0,1);
2715 */
2716  /*
2717  * Currently WriteOne() is called only from writeToChannel() with setting
2718  * AO.OptimizationLevel = 0, which means Optimize() is never called here.
2719  * So we don't need to think about how to ensure that the master and the
2720  * slaves call Optimize() at the same time. (TU 26 Jul 2013)
2721  */
2722  if ( AO.OptimizationLevel > 0 ) {
2723  AO.OutSkip = 6;
2724  if ( Optimize(AO.termbuf[3], 1) ) goto AboWrite;
2725  AO.OutSkip = 3;
2726  FiniLine();
2727  }
2728  else {
2729  lbrac = 0;
2730  AO.InFbrack = 0;
2731  AO.FortFirst = 0;
2732  first = 1;
2733  while ( GetTerm(BHEAD AO.termbuf) ) {
2734  WORD *m;
2735  GETSTOP(AO.termbuf,m);
2736  if ( first ) {
2737  IniLine(0);
2738  startinline = alreadyinline;
2739  AO.OutFill = AO.OutputLine + startinline;
2740  }
2741  if ( WriteTerm(AO.termbuf,&lbrac,first,0,0) )
2742  goto AboWrite;
2743  first = 0;
2744  }
2745  if ( first ) {
2746  IniLine(0);
2747  startinline = alreadyinline;
2748  AO.OutFill = AO.OutputLine + startinline;
2749  TOKENTOLINE(" 0","0");
2750  }
2751  else if ( lbrac ) {
2752  TOKENTOLINE(" )",")");
2753  }
2754  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE
2755  && nosemi == 0 ) TokenToLine((UBYTE *)";");
2756  AO.OutSkip = 3;
2757  if ( AC.OutputSpaces == NORMALFORMAT && nosemi == 0 ) {
2758  FiniLine();
2759  }
2760  else {
2761  noextralinefeed = 1;
2762  FiniLine();
2763  noextralinefeed = 0;
2764  }
2765  }
2766  AO.IsBracket = 0;
2767  AT.WorkPointer = AO.termbuf;
2768  SetScratch(f,&pos);
2769  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2770  AO.InFbrack = 0;
2771  return(0);
2772 AboWrite:
2773  SetScratch(AR.infile,&pos);
2774  f->POposition = pos;
2775  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2776  MesCall("WriteOne");
2777  Terminate(-1);
2778  return(-1);
2779 }
2780 
2781 /*
2782  #] WriteOne :
2783  #] schryf-Writes :
2784 */
int PutPreVar(UBYTE *, UBYTE *, UBYTE *, int)
Definition: pre.c:638
Definition: structs.h:620
WORD ** lhs
Definition: structs.h:925
Definition: structs.h:921
WORD ** rhs
Definition: structs.h:926
LONG TimeCPU(WORD)
Definition: tools.c:3418
int handle
Definition: structs.h:648