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