FORM  4.2.1
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(UBYTE *mess)
788 {
789  LONG millitime = TimeCPU(1);
790  WORD timepart = (WORD)(millitime%1000);
791  millitime /= 1000;
792  timepart /= 10;
793  MesPrint("At %s: Time = %7l.%2i sec",mess,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 == -SETSET ) {
1482  StrCopy(VARNAME(Sets,t[1]),Out);
1483  }
1484  else if ( *t <= -FUNCTION ) {
1485  StrCopy(FindFunction(-*t),Out);
1486 /* StrCopy(VARNAME(functions,-*t-FUNCTION),Out); */
1487  }
1488  else {
1489  MesPrint("Illegal function argument while writing");
1490  goto CleanUp;
1491  }
1492  TokenToLine(buffer);
1493 CleanUp:
1494  lowestlevel = oldlowestlevel;
1495  return;
1496 }
1497 
1498 /*
1499  #] WriteArgument :
1500  #[ WriteSubTerm : WORD WriteSubTerm(sterm,first)
1501 
1502  Writes a single subterm field to the output line.
1503  There is a recursion for functions.
1504 
1505 
1506 #define NUMSPECS 8
1507 UBYTE *specfunnames[NUMSPECS] = {
1508  (UBYTE *)"fac" , (UBYTE *)"nargs", (UBYTE *)"binom"
1509  , (UBYTE *)"sign", (UBYTE *)"mod", (UBYTE *)"min", (UBYTE *)"max"
1510  , (UBYTE *)"invfac" };
1511 */
1512 
1513 WORD WriteSubTerm(WORD *sterm, WORD first)
1514 {
1515  UBYTE buffer[80];
1516  UBYTE *Out, closepar[2] = { (UBYTE)')', 0};
1517  WORD *stopper, *t, *tt, i, j, po = 0;
1518  int oldoutsidefun;
1519  stopper = sterm + sterm[1];
1520  t = sterm + 2;
1521  switch ( *sterm ) {
1522  case SYMBOL :
1523  while ( t < stopper ) {
1524  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1525  FiniLine();
1526  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1527  else IniLine(3);
1528  if ( first ) TokenToLine((UBYTE *)" ");
1529  }
1530  if ( !first ) MultiplyToLine();
1531  if ( AC.OutputMode == CMODE && t[1] != 1 ) {
1532  if ( AC.Cnumpows >= t[1] && t[1] > 0 ) {
1533  po = t[1];
1534  Out = StrCopy((UBYTE *)"POW",buffer);
1535  Out = NumCopy(po,Out);
1536  Out = StrCopy((UBYTE *)"(",Out);
1537  TokenToLine(buffer);
1538  }
1539  else {
1540  TokenToLine((UBYTE *)"pow(");
1541  }
1542  }
1543  if ( *t < NumSymbols ) {
1544  Out = StrCopy(FindSymbol(*t),buffer); t++;
1545 /* Out = StrCopy(VARNAME(symbols,*t),buffer); t++; */
1546  }
1547  else {
1548 /*
1549  see also routine PrintSubtermList.
1550 */
1551  Out = StrCopy(FindExtraSymbol(MAXVARIABLES-*t),buffer);
1552 /*
1553  Out = StrCopy((UBYTE *)AC.extrasym,buffer);
1554  if ( AC.extrasymbols == 0 ) {
1555  Out = NumCopy((MAXVARIABLES-*t),Out);
1556  Out = StrCopy((UBYTE *)"_",Out);
1557  }
1558  else if ( AC.extrasymbols == 1 ) {
1559  Out = AddArrayIndex((MAXVARIABLES-*t),Out);
1560  }
1561 */
1562 /*
1563  else if ( AC.extrasymbols == 2 ) {
1564  Out = NumCopy((MAXVARIABLES-*t),Out);
1565  }
1566 */
1567  t++;
1568  }
1569  if ( AC.OutputMode == CMODE && po > 1
1570  && AC.Cnumpows >= po ) {
1571  Out = StrCopy((UBYTE *)")",Out);
1572  po = 0;
1573  }
1574  else if ( *t != 1 ) WrtPower(Out,*t);
1575  TokenToLine(buffer);
1576  t++;
1577  first = 0;
1578  }
1579  break;
1580  case VECTOR :
1581  while ( t < stopper ) {
1582  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1583  FiniLine();
1584  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1585  else IniLine(3);
1586  if ( first ) TokenToLine((UBYTE *)" ");
1587  }
1588  if ( !first ) MultiplyToLine();
1589 
1590  Out = StrCopy(FindVector(*t),buffer);
1591 /* Out = StrCopy(VARNAME(vectors,*t - AM.OffsetVector),buffer); */
1592  t++;
1593  if ( AC.OutputMode == MATHEMATICAMODE ) *Out++ = '[';
1594  else *Out++ = '(';
1595  if ( *t >= AM.OffsetIndex ) {
1596  i = *t++;
1597  if ( i >= AM.IndDum ) {
1598  i -= AM.IndDum;
1599  *Out++ = 'N';
1600  Out = NumCopy(i,Out);
1601  *Out++ = '_';
1602  *Out++ = '?';
1603  *Out = 0;
1604  }
1605  else
1606  Out = StrCopy(FindIndex(i),Out);
1607 /* Out = StrCopy(VARNAME(indices,i - AM.OffsetIndex),Out); */
1608  }
1609  else if ( *t == FUNNYVEC ) { *Out++ = '?'; *Out = 0; }
1610  else {
1611  Out = NumCopy(*t++,Out);
1612  }
1613  if ( AC.OutputMode == MATHEMATICAMODE ) *Out++ = ']';
1614  else *Out++ = ')';
1615  *Out = 0;
1616  TokenToLine(buffer);
1617  first = 0;
1618  }
1619  break;
1620  case INDEX :
1621  while ( t < stopper ) {
1622  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1623  FiniLine();
1624  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1625  else IniLine(3);
1626  if ( first ) TokenToLine((UBYTE *)" ");
1627  }
1628  if ( !first ) MultiplyToLine();
1629  if ( *t >= 0 ) {
1630  if ( *t < AM.OffsetIndex ) {
1631  TalToLine((UWORD)(*t++));
1632  }
1633  else {
1634  i = *t++;
1635  if ( i >= AM.IndDum ) {
1636  i -= AM.IndDum;
1637  Out = buffer;
1638  *Out++ = 'N';
1639  Out = NumCopy(i,Out);
1640  *Out++ = '_';
1641  *Out++ = '?';
1642  *Out = 0;
1643  }
1644  else {
1645  i -= AM.OffsetIndex;
1646  Out = StrCopy(FindIndex(i%WILDOFFSET+AM.OffsetIndex),buffer);
1647 /* Out = StrCopy(VARNAME(indices,i%WILDOFFSET),buffer); */
1648  if ( i >= WILDOFFSET ) { *Out++ = '?'; *Out = 0; }
1649  }
1650  TokenToLine(buffer);
1651  }
1652  }
1653  else {
1654  TokenToLine(FindVector(*t)); t++;
1655 /* TokenToLine(VARNAME(vectors,*t - AM.OffsetVector)); t++; */
1656  }
1657  first = 0;
1658  }
1659  break;
1660  case DOLLAREXPRESSION:
1661  {
1662  DOLLARS d = Dollars + sterm[2];
1663  Out = StrCopy((UBYTE *)"$",buffer);
1664  Out = StrCopy(AC.dollarnames->namebuffer+d->name,Out);
1665  if ( sterm[3] != 1 ) WrtPower(Out,sterm[3]);
1666  TokenToLine(buffer);
1667  }
1668  first = 0;
1669  break;
1670  case DELTA :
1671  while ( t < stopper ) {
1672  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1673  FiniLine();
1674  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1675  else IniLine(3);
1676  if ( first ) TokenToLine((UBYTE *)" ");
1677  }
1678  if ( !first ) MultiplyToLine();
1679  Out = StrCopy((UBYTE *)"d_(",buffer);
1680  if ( *t >= AM.OffsetIndex ) {
1681  if ( *t < AM.IndDum ) {
1682  Out = StrCopy(FindIndex(*t),Out);
1683 /* Out = StrCopy(VARNAME(indices,*t - AM.OffsetIndex),Out); */
1684  t++;
1685  }
1686  else {
1687  *Out++ = 'N';
1688  Out = NumCopy( *t++ - AM.IndDum, Out);
1689  *Out++ = '_';
1690  *Out++ = '?';
1691  *Out = 0;
1692  }
1693  }
1694  else if ( *t == FUNNYVEC ) { *Out++ = '?'; *Out = 0; }
1695  else {
1696  Out = NumCopy(*t++,Out);
1697  }
1698  *Out++ = ',';
1699  if ( *t >= AM.OffsetIndex ) {
1700  if ( *t < AM.IndDum ) {
1701  Out = StrCopy(FindIndex(*t),Out);
1702 /* Out = StrCopy(VARNAME(indices,*t - AM.OffsetIndex),Out); */
1703  t++;
1704  }
1705  else {
1706  *Out++ = 'N';
1707  Out = NumCopy(*t++ - AM.IndDum,Out);
1708  *Out++ = '_';
1709  *Out++ = '?';
1710  }
1711  }
1712  else {
1713  Out = NumCopy(*t++,Out);
1714  }
1715  *Out++ = ')';
1716  *Out = 0;
1717  TokenToLine(buffer);
1718  first = 0;
1719  }
1720  break;
1721  case DOTPRODUCT :
1722  while ( t < stopper ) {
1723  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1724  FiniLine();
1725  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1726  else IniLine(3);
1727  if ( first ) TokenToLine((UBYTE *)" ");
1728  }
1729  if ( !first ) MultiplyToLine();
1730  if ( AC.OutputMode == CMODE && t[2] != 1 )
1731  TokenToLine((UBYTE *)"pow(");
1732  Out = StrCopy(FindVector(*t),buffer);
1733 /* Out = StrCopy(VARNAME(vectors,*t - AM.OffsetVector),buffer); */
1734  t++;
1735  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
1736  || AC.OutputMode == CMODE )
1737  *Out++ = AO.FortDotChar;
1738  else *Out++ = '.';
1739  Out = StrCopy(FindVector(*t),Out);
1740 /* Out = StrCopy(VARNAME(vectors,*t - AM.OffsetVector),Out); */
1741  t++;
1742  if ( *t != 1 ) WrtPower(Out,*t);
1743  t++;
1744  TokenToLine(buffer);
1745  first = 0;
1746  }
1747  break;
1748  case EXPONENT :
1749 #if FUNHEAD != 2
1750  t += FUNHEAD - 2;
1751 #endif
1752  if ( !first ) MultiplyToLine();
1753  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)"pow(");
1754  else TokenToLine((UBYTE *)"(");
1755  WriteArgument(t);
1756  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE
1757  || AC.OutputMode == REDUCEMODE )
1758  TokenToLine((UBYTE *)")**(");
1759  else if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)",");
1760  else TokenToLine((UBYTE *)")^(");
1761  NEXTARG(t)
1762  WriteArgument(t);
1763  TokenToLine((UBYTE *)")");
1764  break;
1765  case DENOMINATOR :
1766 #if FUNHEAD != 2
1767  t += FUNHEAD - 2;
1768 #endif
1769  if ( first ) TokenToLine((UBYTE *)"1/(");
1770  else TokenToLine((UBYTE *)"/(");
1771  WriteArgument(t);
1772  TokenToLine((UBYTE *)")");
1773  break;
1774  case SUBEXPRESSION:
1775  if ( !first ) MultiplyToLine();
1776  TokenToLine((UBYTE *)"(");
1777  t = cbuf[sterm[4]].rhs[sterm[2]];
1778  tt = t;
1779  while ( *tt ) tt += *tt;
1780  oldoutsidefun = AC.outsidefun; AC.outsidefun = 0;
1781  if ( *t ) {
1782  WriteExpression(t,(LONG)(tt-t));
1783  }
1784  else {
1785  TokenToLine((UBYTE *)"0");
1786  }
1787  AC.outsidefun = oldoutsidefun;
1788  TokenToLine((UBYTE *)")");
1789  if ( sterm[3] != 1 ) {
1790  TokenToLine((UBYTE *)"^");
1791  Out = buffer;
1792  NumCopy(sterm[3],Out);
1793  TokenToLine(buffer);
1794  }
1795  break;
1796  default :
1797  if ( lowestlevel && ( ( AO.PrintType & PRINTALL ) != 0 ) ) {
1798  FiniLine();
1799  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1800  else IniLine(3);
1801  if ( first ) TokenToLine((UBYTE *)" ");
1802  }
1803  if ( *sterm < FUNCTION ) {
1804  return(MesPrint("Illegal subterm while writing"));
1805  }
1806  if ( !first ) MultiplyToLine();
1807  first = 1;
1808  { UBYTE *tmp;
1809  if ( ( tmp = FindFunWithArgs(sterm) ) != 0 ) {
1810  TokenToLine(tmp);
1811  break;
1812  }
1813  }
1814  t += FUNHEAD-2;
1815 
1816  if ( *sterm == GAMMA && t[-FUNHEAD+1] == FUNHEAD+1 ) {
1817  TokenToLine((UBYTE *)"gi_(");
1818  }
1819  else {
1820  if ( *sterm != DUMFUN ) {
1821  Out = StrCopy(FindFunction(*sterm),buffer);
1822 /* Out = StrCopy(VARNAME(functions,*sterm - FUNCTION),buffer); */
1823  }
1824  else { Out = buffer; *Out = 0; }
1825  if ( t >= stopper ) {
1826  TokenToLine(buffer);
1827  break;
1828  }
1829  if ( AC.OutputMode == MATHEMATICAMODE ) { *Out++ = '['; closepar[0] = (UBYTE)']'; }
1830  else { *Out++ = '('; }
1831  *Out = 0;
1832  TokenToLine(buffer);
1833  }
1834  i = functions[*sterm - FUNCTION].spec;
1835  if ( i >= TENSORFUNCTION ) {
1836  int curdict = AO.CurrentDictionary;
1837  if ( AO.CurrentDictionary && AO.CurDictNotInFunctions > 0 )
1838  AO.CurrentDictionary = 0;
1839  t = sterm + FUNHEAD;
1840  while ( t < stopper ) {
1841  if ( !first ) TokenToLine((UBYTE *)",");
1842  else first = 0;
1843  j = *t++;
1844  if ( j >= 0 ) {
1845  if ( j < AM.OffsetIndex ) TalToLine((UWORD)(j));
1846  else if ( j < AM.IndDum ) {
1847  i = j - AM.OffsetIndex;
1848  Out = StrCopy(FindIndex(i%WILDOFFSET+AM.OffsetIndex),buffer);
1849 /* Out = StrCopy(VARNAME(indices,i%WILDOFFSET),buffer); */
1850  if ( i >= WILDOFFSET ) { *Out++ = '?'; *Out = 0; }
1851  TokenToLine(buffer);
1852  }
1853  else {
1854  Out = buffer;
1855  *Out++ = 'N';
1856  Out = NumCopy(j - AM.IndDum,Out);
1857  *Out++ = '_';
1858  *Out++ = '?';
1859  *Out = 0;
1860  TokenToLine(buffer);
1861  }
1862  }
1863  else if ( j == FUNNYVEC ) { TokenToLine((UBYTE *)"?"); }
1864  else if ( j > -WILDOFFSET ) {
1865  Out = buffer;
1866  Out = NumCopy((UWORD)(-j + 4),Out);
1867  *Out++ = '_';
1868  *Out = 0;
1869  TokenToLine(buffer);
1870  }
1871  else {
1872  TokenToLine(FindVector(j));
1873 /* TokenToLine(VARNAME(vectors,j - AM.OffsetVector)); */
1874  }
1875  }
1876  AO.CurrentDictionary = curdict;
1877  }
1878  else {
1879  int curdict = AO.CurrentDictionary;
1880  if ( AO.CurrentDictionary && AO.CurDictNotInFunctions > 0 )
1881  AO.CurrentDictionary = 0;
1882  while ( t < stopper ) {
1883  if ( !first ) TokenToLine((UBYTE *)",");
1884  WriteArgument(t);
1885  NEXTARG(t)
1886  first = 0;
1887  }
1888  AO.CurrentDictionary = curdict;
1889  }
1890  TokenToLine(closepar);
1891  closepar[0] = (UBYTE)')';
1892  break;
1893  }
1894  return(0);
1895 }
1896 
1897 /*
1898  #] WriteSubTerm :
1899  #[ WriteInnerTerm : WORD WriteInnerTerm(term,first)
1900 
1901  Writes the contents of term to the output.
1902  Only the part that is inside parentheses is written.
1903 
1904 */
1905 
1906 WORD WriteInnerTerm(WORD *term, WORD first)
1907 {
1908  WORD *t, *s, *s1, *s2, n, i, pow;
1909  t = term;
1910  s = t+1;
1911  GETCOEF(t,n);
1912  while ( s < t ) {
1913  if ( *s == HAAKJE ) break;
1914  s += s[1];
1915  }
1916  if ( s < t ) { s += s[1]; }
1917  else { s = term+1; }
1918 
1919  if ( n < 0 || !first ) {
1920  if ( n > 0 ) { TOKENTOLINE(" + ","+") }
1921  else if ( n < 0 ) { n = -n; TOKENTOLINE(" - ","-") }
1922  }
1923  if ( AC.modpowers ) {
1924  if ( n == 1 && *t == 1 && t > s ) first = 1;
1925  else if ( ABS(AC.ncmod) == 1 ) {
1926  LongToLine((UWORD *)AC.powmod,AC.npowmod);
1927  TokenToLine((UBYTE *)"^");
1928  TalToLine(AC.modpowers[(LONG)((UWORD)*t)]);
1929  first = 0;
1930  }
1931  else {
1932  LONG jj;
1933  LongToLine((UWORD *)AC.powmod,AC.npowmod);
1934  TokenToLine((UBYTE *)"^");
1935  jj = (UWORD)*t;
1936  if ( n == 2 ) jj += ((LONG)t[1])<<BITSINWORD;
1937  if ( AC.modpowers[jj+1] == 0 ) {
1938  TalToLine(AC.modpowers[jj]);
1939  }
1940  else {
1941  LongToLine(AC.modpowers+jj,2);
1942  }
1943  first = 0;
1944  }
1945  }
1946  else if ( n != 1 || *t != 1 || t[1] != 1 || t <= s ) {
1947  if ( lowestlevel && ( ( AO.PrintType & PRINTONEFUNCTION ) != 0 ) ) {
1948  FiniLine();
1949  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1950  else IniLine(3);
1951  }
1952  if ( AO.CurrentDictionary > 0 ) TransformRational((UWORD *)t,n);
1953  else RatToLine((UWORD *)t,n);
1954  first = 0;
1955  }
1956  else first = 1;
1957  while ( s < t ) {
1958  if ( lowestlevel && ( (AO.PrintType & (PRINTONEFUNCTION | PRINTALL)) == PRINTONEFUNCTION ) ) {
1959  FiniLine();
1960  if ( AC.OutputSpaces == NOSPACEFORMAT ) IniLine(1);
1961  else IniLine(3);
1962  }
1963 
1964 /*
1965  #[ NEWGAMMA :
1966 */
1967 #ifdef NEWGAMMA
1968  if ( *s == GAMMA ) { /* String them up */
1969  WORD *tt,*ss;
1970  ss = AT.WorkPointer;
1971  *ss++ = GAMMA;
1972  *ss++ = s[1];
1973  FILLFUN(ss)
1974  *ss++ = s[FUNHEAD];
1975  tt = s + FUNHEAD + 1;
1976  n = s[1] - FUNHEAD-1;
1977  do {
1978  while ( --n >= 0 ) *ss++ = *tt++;
1979  tt = s + s[1];
1980  while ( *tt == GAMMA && tt[FUNHEAD] == s[FUNHEAD] && tt < t ) {
1981  s = tt;
1982  tt += FUNHEAD + 1;
1983  n = s[1] - FUNHEAD-1;
1984  if ( n > 0 ) break;
1985  }
1986  } while ( n > 0 );
1987  tt = AT.WorkPointer;
1988  AT.WorkPointer = ss;
1989  tt[1] = WORDDIF(ss,tt);
1990  if ( WriteSubTerm(tt,first) ) {
1991  MesCall("WriteInnerTerm");
1992  SETERROR(-1)
1993  }
1994  AT.WorkPointer = tt;
1995  }
1996  else
1997 #endif
1998 /*
1999  #] NEWGAMMA :
2000 */
2001  {
2002  if ( *s >= FUNCTION && AC.funpowers > 0
2003  && functions[*s-FUNCTION].spec == 0 && ( AC.funpowers == ALLFUNPOWERS ||
2004  ( AC.funpowers == COMFUNPOWERS && functions[*s-FUNCTION].commute == 0 ) ) ) {
2005  pow = 1;
2006  for(;;) {
2007  s1 = s; s2 = s + s[1]; i = s[1];
2008  if ( s2 < t ) {
2009  while ( --i >= 0 && *s1 == *s2 ) { s1++; s2++; }
2010  if ( i < 0 ) {
2011  pow++; s = s+s[1];
2012  }
2013  else break;
2014  }
2015  else break;
2016  }
2017  if ( pow > 1 ) {
2018  if ( AC.OutputMode == CMODE ) {
2019  if ( !first ) MultiplyToLine();
2020  TokenToLine((UBYTE *)"pow(");
2021  first = 1;
2022  }
2023  if ( WriteSubTerm(s,first) ) {
2024  MesCall("WriteInnerTerm");
2025  SETERROR(-1)
2026  }
2027  if ( AC.OutputMode == FORTRANMODE
2028  || AC.OutputMode == PFORTRANMODE ) { TokenToLine((UBYTE *)"**"); }
2029  else if ( AC.OutputMode == CMODE ) { TokenToLine((UBYTE *)","); }
2030  else { TokenToLine((UBYTE *)"^"); }
2031  TalToLine(pow);
2032  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)")");
2033  }
2034  else if ( WriteSubTerm(s,first) ) {
2035  MesCall("WriteInnerTerm");
2036  SETERROR(-1)
2037  }
2038  }
2039  else if ( WriteSubTerm(s,first) ) {
2040  MesCall("WriteInnerTerm");
2041  SETERROR(-1)
2042  }
2043  }
2044  first = 0;
2045  s += s[1];
2046  }
2047  return(0);
2048 }
2049 
2050 /*
2051  #] WriteInnerTerm :
2052  #[ WriteTerm : WORD WriteTerm(term,lbrac,first,prtf,br)
2053 
2054  Writes a term to output. It tests the bracket information first.
2055  If there are no brackets or the bracket is the same all is passed
2056  to WriteInnerTerm. If there are brackets and the bracket is not
2057  the same as for the predecessor the old bracket is closed and
2058  a new one is opened.
2059  br indicates whether we are in a subexpression, barring zeroing
2060  AO.IsBracket
2061 
2062 */
2063 
2064 WORD WriteTerm(WORD *term, WORD *lbrac, WORD first, WORD prtf, WORD br)
2065 {
2066  WORD *t, *stopper, *b, n;
2067  int oldIsFortran90 = AC.IsFortran90, i;
2068  if ( *lbrac >= 0 ) {
2069  t = term + 1;
2070  stopper = (term + *term - 1);
2071  stopper -= ABS(*stopper) - 1;
2072  while ( t < stopper ) {
2073  if ( *t == HAAKJE ) {
2074  stopper = t;
2075  t = term+1;
2076  if ( *lbrac == ( n = WORDDIF(stopper,t) ) ) {
2077  b = AO.bracket + 1;
2078  t = term + 1;
2079  while ( n > 0 && ( *b++ == *t++ ) ) { n--; }
2080  if ( n <= 0 && ( ( AO.InFbrack < AM.FortranCont )
2081  || ( lowestlevel == 0 ) ) ) {
2082 /*
2083  We continue inside a bracket.
2084 */
2085  AO.IsBracket = 1;
2086  if ( ( prtf & PRINTCONTENTS ) != 0 ) {
2087  AO.NumInBrack++;
2088  }
2089  else {
2090  if ( WriteInnerTerm(term,0) ) goto WrtTmes;
2091  if ( ( AO.PrintType & PRINTONETERM ) != 0 ) {
2092  FiniLine();
2093  TokenToLine((UBYTE *)" ");
2094  }
2095  }
2096  return(0);
2097  }
2098  t = term + 1;
2099  n = WORDDIF(stopper,t);
2100  }
2101 /*
2102  Close the bracket
2103 */
2104  if ( *lbrac ) {
2105  if ( ( prtf & PRINTCONTENTS ) ) PrtTerms();
2106  TOKENTOLINE(" )",")")
2107  if ( AC.OutputMode == CMODE && AO.FactorMode == 0 )
2108  TokenToLine((UBYTE *)";");
2109  else if ( AO.FactorMode && ( n == 0 ) ) {
2110 /*
2111  This should not happen.
2112 */
2113  return(0);
2114  }
2115  AC.IsFortran90 = ISNOTFORTRAN90;
2116  FiniLine();
2117  AC.IsFortran90 = oldIsFortran90;
2118  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE
2119  && AC.OutputSpaces == NORMALFORMAT
2120  && AO.FactorMode == 0 ) FiniLine();
2121  }
2122  else {
2123  if ( AC.OutputMode == CMODE && AO.FactorMode == 0 )
2124  TokenToLine((UBYTE *)";");
2125  if ( AO.FortFirst == 0 ) {
2126  if ( !first ) {
2127  AC.IsFortran90 = ISNOTFORTRAN90;
2128  FiniLine();
2129  AC.IsFortran90 = oldIsFortran90;
2130  }
2131  }
2132  }
2133  if ( AO.FactorMode == 0 ) {
2134  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2135  && !first ) {
2136  WORD oldmode = AC.OutputMode;
2137  AC.OutputMode = 0;
2138  IniLine(0);
2139  AC.OutputMode = oldmode;
2140  AO.OutSkip = 7;
2141 
2142  if ( AO.FortFirst == 0 ) {
2143  TokenToLine(AO.CurBufWrt);
2144  TOKENTOLINE(" = ","=")
2145  TokenToLine(AO.CurBufWrt);
2146  }
2147  else {
2148  AO.FortFirst = 0;
2149  TokenToLine(AO.CurBufWrt);
2150  TOKENTOLINE(" = ","=")
2151  }
2152  }
2153  else if ( AC.OutputMode == CMODE && !first ) {
2154  IniLine(0);
2155  if ( AO.FortFirst == 0 ) {
2156  TokenToLine(AO.CurBufWrt);
2157  TOKENTOLINE(" += ","+=")
2158  }
2159  else {
2160  AO.FortFirst = 0;
2161  TokenToLine(AO.CurBufWrt);
2162  TOKENTOLINE(" = ","=")
2163  }
2164  }
2165  else if ( startinline == 0 ) {
2166  IniLine(0);
2167  }
2168  AO.InFbrack = 0;
2169  if ( ( *lbrac = n ) > 0 ) {
2170  b = AO.bracket;
2171  *b++ = n + 4;
2172  while ( --n >= 0 ) *b++ = *t++;
2173  *b++ = 1; *b++ = 1; *b = 3;
2174  AO.IsBracket = 0;
2175  if ( WriteInnerTerm(AO.bracket,0) ) {
2176  /* Error message */
2177  WORD i;
2178 WrtTmes: t = term;
2179  AO.OutSkip = 3;
2180  FiniLine();
2181  i = *t;
2182  while ( --i >= 0 ) { TalToLine((UWORD)(*t++));
2183  if ( AC.OutputSpaces == NORMALFORMAT )
2184  TokenToLine((UBYTE *)" "); }
2185  AO.OutSkip = 0;
2186  FiniLine();
2187  MesCall("WriteTerm");
2188  SETERROR(-1)
2189  }
2190  TOKENTOLINE(" * ( ","*(")
2191  AO.NumInBrack = 0;
2192  AO.IsBracket = 1;
2193  if ( ( prtf & PRINTONETERM ) != 0 ) {
2194  first = 0;
2195  FiniLine();
2196  TokenToLine((UBYTE *)" ");
2197  }
2198  else first = 1;
2199  }
2200  else {
2201  AO.IsBracket = 0;
2202  first = 0;
2203  }
2204  }
2205  else {
2206 /*
2207  Here is the code that writes the glue between two factors.
2208  We should not forget factors that are zero!
2209 */
2210  if ( ( *lbrac = n ) > 0 ) {
2211  b = AO.bracket;
2212  *b++ = n + 4;
2213  while ( --n >= 0 ) *b++ = *t++;
2214  *b++ = 1; *b++ = 1; *b = 3;
2215  for ( i = AO.FactorNum+1; i < AO.bracket[4]; i++ ) {
2216  if ( first ) {
2217  TOKENTOLINE(" ( 0 )"," (0)")
2218  first = 0;
2219  }
2220  else {
2221  TOKENTOLINE(" * ( 0 )","*(0)")
2222  }
2223  FiniLine();
2224  IniLine(0);
2225  }
2226  AO.FactorNum = AO.bracket[4];
2227  }
2228  else {
2229  AO.NumInBrack = 0;
2230  return(0);
2231  }
2232  if ( first == 0 ) { TOKENTOLINE(" * ( ","*(") }
2233  else { TOKENTOLINE(" ( "," (") }
2234  AO.NumInBrack = 0;
2235  first = 1;
2236  }
2237  if ( ( prtf & PRINTCONTENTS ) != 0 ) AO.NumInBrack++;
2238  else if ( WriteInnerTerm(term,first) ) goto WrtTmes;
2239  if ( ( AO.PrintType & PRINTONETERM ) != 0 ) {
2240  FiniLine();
2241  TokenToLine((UBYTE *)" ");
2242  }
2243  return(0);
2244  }
2245  else t += t[1];
2246  }
2247  if ( *lbrac > 0 ) {
2248  if ( ( prtf & PRINTCONTENTS ) != 0 ) PrtTerms();
2249  TokenToLine((UBYTE *)" )");
2250  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)";");
2251  if ( AO.FortFirst == 0 ) {
2252  AC.IsFortran90 = ISNOTFORTRAN90;
2253  FiniLine();
2254  AC.IsFortran90 = oldIsFortran90;
2255  }
2256  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE
2257  && AC.OutputSpaces == NORMALFORMAT ) FiniLine();
2258  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2259  && !first ) {
2260  WORD oldmode = AC.OutputMode;
2261  AC.OutputMode = 0;
2262  IniLine(0);
2263  AC.OutputMode = oldmode;
2264  AO.OutSkip = 7;
2265  if ( AO.FortFirst == 0 ) {
2266  TokenToLine(AO.CurBufWrt);
2267  TOKENTOLINE(" = ","=")
2268  TokenToLine(AO.CurBufWrt);
2269  }
2270  else {
2271  AO.FortFirst = 0;
2272  TokenToLine(AO.CurBufWrt);
2273  TOKENTOLINE(" = ","=")
2274  }
2275 /*
2276  TokenToLine(AO.CurBufWrt);
2277  TOKENTOLINE(" = ","=")
2278  if ( AO.FortFirst == 0 )
2279  TokenToLine(AO.CurBufWrt);
2280  else AO.FortFirst = 0;
2281 */
2282  }
2283  else if ( AC.OutputMode == CMODE && !first ) {
2284  IniLine(0);
2285  if ( AO.FortFirst == 0 ) {
2286  TokenToLine(AO.CurBufWrt);
2287  TOKENTOLINE(" += ","+=")
2288  }
2289  else {
2290  AO.FortFirst = 0;
2291  TokenToLine(AO.CurBufWrt);
2292  TOKENTOLINE(" = ","=")
2293  }
2294 /*
2295  TokenToLine(AO.CurBufWrt);
2296  if ( AO.FortFirst == 0 ) { TOKENTOLINE(" += ","+=") }
2297  else {
2298  TOKENTOLINE(" = ","=")
2299  AO.FortFirst = 0;
2300  }
2301 */
2302  }
2303  else IniLine(0);
2304  *lbrac = 0;
2305  first = 1;
2306  }
2307  }
2308  if ( !br ) AO.IsBracket = 0;
2309  if ( ( AO.InFbrack >= AM.FortranCont ) && lowestlevel ) {
2310  if ( AC.OutputMode == CMODE ) TokenToLine((UBYTE *)";");
2311  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2312  && !first ) {
2313  WORD oldmode = AC.OutputMode;
2314  if ( AO.FortFirst == 0 ) {
2315  AC.IsFortran90 = ISNOTFORTRAN90;
2316  FiniLine();
2317  AC.IsFortran90 = oldIsFortran90;
2318  AC.OutputMode = 0;
2319  IniLine(0);
2320  AC.OutputMode = oldmode;
2321  AO.OutSkip = 7;
2322  TokenToLine(AO.CurBufWrt);
2323  TOKENTOLINE(" = ","=")
2324  TokenToLine(AO.CurBufWrt);
2325  }
2326  else {
2327  AO.FortFirst = 0;
2328 /*
2329  TokenToLine(AO.CurBufWrt);
2330  TOKENTOLINE(" = ","=")
2331 */
2332  }
2333 /*
2334  TokenToLine(AO.CurBufWrt);
2335  TOKENTOLINE(" = ","=")
2336  if ( AO.FortFirst == 0 )
2337  TokenToLine(AO.CurBufWrt);
2338  else AO.FortFirst = 0;
2339 */
2340  }
2341  else if ( AC.OutputMode == CMODE && !first ) {
2342  FiniLine();
2343  IniLine(0);
2344  if ( AO.FortFirst == 0 ) {
2345  TokenToLine(AO.CurBufWrt);
2346  TOKENTOLINE(" += ","+=")
2347  }
2348  else {
2349  AO.FortFirst = 0;
2350  TokenToLine(AO.CurBufWrt);
2351  TOKENTOLINE(" = ","=")
2352  }
2353 /*
2354  TokenToLine(AO.CurBufWrt);
2355  if ( AO.FortFirst == 0 ) { TOKENTOLINE(" += ","+=") }
2356  else {
2357  TOKENTOLINE(" = ","=")
2358  AO.FortFirst = 0;
2359  }
2360 */
2361  }
2362  else {
2363  FiniLine();
2364  IniLine(0);
2365  }
2366  AO.InFbrack = 0;
2367  }
2368  if ( WriteInnerTerm(term,first) ) goto WrtTmes;
2369  if ( ( AO.PrintType & PRINTONETERM ) != 0 ) {
2370  FiniLine();
2371  IniLine(0);
2372  }
2373  return(0);
2374 }
2375 
2376 /*
2377  #] WriteTerm :
2378  #[ WriteExpression : WORD WriteExpression(terms,ltot)
2379 
2380  Writes a subexpression to output.
2381  The subexpression is in terms and contains ltot words.
2382  This is only used for function arguments.
2383 
2384 */
2385 
2386 WORD WriteExpression(WORD *terms, LONG ltot)
2387 {
2388  WORD *stopper;
2389  WORD first, btot;
2390  WORD OldIsBracket = AO.IsBracket, OldPrintType = AO.PrintType;
2391  if ( !AC.outsidefun ) { AO.PrintType &= ~PRINTONETERM; first = 1; }
2392  else first = 0;
2393  stopper = terms + ltot;
2394  btot = -1;
2395  while ( terms < stopper ) {
2396  AO.IsBracket = OldIsBracket;
2397  if ( WriteTerm(terms,&btot,first,0,1) ) {
2398  MesCall("WriteExpression");
2399  SETERROR(-1)
2400  }
2401  first = 0;
2402  terms += *terms;
2403  }
2404 /* AO.IsBracket = 0; */
2405  AO.IsBracket = OldIsBracket;
2406  AO.PrintType = OldPrintType;
2407  return(0);
2408 }
2409 
2410 /*
2411  #] WriteExpression :
2412  #[ WriteAll : WORD WriteAll()
2413 
2414  Writes all expressions that should be written
2415 */
2416 
2417 WORD WriteAll()
2418 {
2419  GETIDENTITY
2420  WORD lbrac, first;
2421  WORD *t, *stopper, n, prtf;
2422  int oldIsFortran90 = AC.IsFortran90, i;
2423  POSITION pos;
2424  FILEHANDLE *f;
2425  EXPRESSIONS e;
2426  if ( AM.exitflag ) return(0);
2427 #ifdef WITHMPI
2428  if ( PF.me != MASTER ) {
2429  /*
2430  * For the slaves, we need to call Optimize() the same number of times
2431  * as the master. The first argument doesn't have any important role.
2432  */
2433  for ( n = 0; n < NumExpressions; n++ ) {
2434  e = &Expressions[n];
2435  if ( !e->printflag & PRINTON ) continue;
2436  switch ( e->status ) {
2437  case LOCALEXPRESSION:
2438  case GLOBALEXPRESSION:
2439  case UNHIDELEXPRESSION:
2440  case UNHIDEGEXPRESSION:
2441  break;
2442  default:
2443  continue;
2444  }
2445  e->printflag = 0;
2446  PutPreVar(AM.oldnumextrasymbols, GetPreVar((UBYTE *)"EXTRASYMBOLS_", 0), 0, 1);
2447  if ( AO.OptimizationLevel > 0 ) {
2448  if ( Optimize(0, 1) ) return(-1);
2449  }
2450  }
2451  return(0);
2452  }
2453 #endif
2454  SeekScratch(AR.outfile,&pos);
2455  if ( ResetScratch() ) {
2456  MesCall("WriteAll");
2457  SETERROR(-1)
2458  }
2459  AO.termbuf = AT.WorkPointer;
2460  AO.bracket = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
2461  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2);
2462  AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer;
2463  AT.WorkPointer += 2*AC.LineLength;
2464  *(AR.CompressBuffer) = 0;
2465  first = 0;
2466  for ( n = 0; n < NumExpressions; n++ ) {
2467  if ( ( Expressions[n].printflag & PRINTON ) != 0 ) { first = 1; break; }
2468  }
2469  if ( !first ) goto EndWrite;
2470  AO.IsBracket = 0;
2471  AO.OutSkip = 3;
2472  AR.DeferFlag = 0;
2473  while ( GetTerm(BHEAD AO.termbuf) ) {
2474  t = AO.termbuf + 1;
2475  e = Expressions + AO.termbuf[3];
2476  n = e->status;
2477  if ( ( n == LOCALEXPRESSION || n == GLOBALEXPRESSION
2478  || n == UNHIDELEXPRESSION || n == UNHIDEGEXPRESSION ) &&
2479  ( ( prtf = e->printflag ) & PRINTON ) != 0 ) {
2480  e->printflag = 0;
2481  AO.NumInBrack = 0;
2482  PutPreVar(AM.oldnumextrasymbols,
2483  GetPreVar((UBYTE *)"EXTRASYMBOLS_",0),0,1);
2484  if ( ( prtf & PRINTLFILE ) != 0 ) {
2485  if ( AC.LogHandle < 0 ) prtf &= ~PRINTLFILE;
2486  }
2487  AO.PrintType = prtf;
2488 /*
2489  if ( AC.OutputMode == VORTRANMODE ) {
2490  UBYTE *oldOutFill = AO.OutFill, *oldOutputLine = AO.OutputLine;
2491  AO.OutSkip = 6;
2492  if ( Optimize(AO.termbuf[3], 1) ) goto AboWrite;
2493  AO.OutSkip = 3;
2494  AO.OutFill = oldOutFill; AO.OutputLine = oldOutputLine;
2495  FiniLine();
2496  continue;
2497  }
2498  else
2499 */
2500  if ( AO.OptimizationLevel > 0 ) {
2501  UBYTE *oldOutFill = AO.OutFill, *oldOutputLine = AO.OutputLine;
2502  AO.OutSkip = 6;
2503  if ( Optimize(AO.termbuf[3], 1) ) goto AboWrite;
2504  AO.OutSkip = 3;
2505  AO.OutFill = oldOutFill; AO.OutputLine = oldOutputLine;
2506  FiniLine();
2507  continue;
2508  }
2509  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2510  AO.OutSkip = 6;
2511  FiniLine();
2512  AO.CurBufWrt = EXPRNAME(AO.termbuf[3]);
2513  TokenToLine(AO.CurBufWrt);
2514  stopper = t + t[1];
2515  t += SUBEXPSIZE;
2516  if ( t < stopper ) {
2517  TokenToLine((UBYTE *)"(");
2518  first = 1;
2519  while ( t < stopper ) {
2520  n = *t;
2521  if ( !first ) TokenToLine((UBYTE *)",");
2522  switch ( n ) {
2523  case SYMTOSYM :
2524  TokenToLine(FindSymbol(t[2]));
2525 /* TokenToLine(VARNAME(symbols,t[2])); */
2526  break;
2527  case VECTOVEC :
2528  TokenToLine(FindVector(t[2]));
2529 /* TokenToLine(VARNAME(vectors,t[2] - AM.OffsetVector)); */
2530  break;
2531  case INDTOIND :
2532  TokenToLine(FindIndex(t[2]));
2533 /* TokenToLine(VARNAME(indices,t[2] - AM.OffsetIndex)); */
2534  break;
2535  default :
2536  TokenToLine(FindFunction(t[2]));
2537 /* TokenToLine(VARNAME(functions,t[2] - FUNCTION)); */
2538  break;
2539  }
2540  t += t[1];
2541  first = 0;
2542  }
2543  TokenToLine((UBYTE *)")");
2544  }
2545  TOKENTOLINE(" =","=");
2546  lbrac = 0;
2547  AO.InFbrack = 0;
2548  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2549  AO.FortFirst = 1;
2550  else
2551  AO.FortFirst = 0;
2552  first = 1;
2553  if ( ( e->vflags & ISFACTORIZED ) != 0 ) {
2554  AO.FactorMode = 1+e->numfactors;
2555  AO.FactorNum = 0; /* Which factor are we doing. For factors that are zero */
2556  }
2557  else {
2558  AO.FactorMode = 0;
2559  }
2560  while ( GetTerm(BHEAD AO.termbuf) ) {
2561  WORD *m;
2562  GETSTOP(AO.termbuf,m);
2563  if ( ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2564  && ( ( prtf & PRINTONETERM ) != 0 ) ) {}
2565  else {
2566  if ( first ) {
2567  FiniLine();
2568  IniLine(0);
2569  }
2570  }
2571  if ( ( prtf & PRINTONETERM ) != 0 ) first = 0;
2572  if ( WriteTerm(AO.termbuf,&lbrac,first,prtf,0) )
2573  goto AboWrite;
2574  first = 0;
2575  }
2576  if ( AO.FactorMode ) {
2577  if ( first ) { AO.FactorNum = 1; TOKENTOLINE(" ( 0 )"," (0)") }
2578  else TOKENTOLINE(" )",")");
2579  for ( i = AO.FactorNum+1; i <= e->numfactors; i++ ) {
2580  FiniLine();
2581  IniLine(0);
2582  TOKENTOLINE(" * ( 0 )","*(0)");
2583  }
2584  AO.FactorNum = e->numfactors;
2585  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE )
2586  TokenToLine((UBYTE *)";");
2587  }
2588  else if ( AO.FactorMode == 0 || first ) {
2589  if ( first ) { TOKENTOLINE(" 0","0") }
2590  else if ( lbrac ) {
2591  if ( ( prtf & PRINTCONTENTS ) != 0 ) PrtTerms();
2592  TOKENTOLINE(" )",")")
2593  }
2594  else if ( ( prtf & PRINTCONTENTS ) != 0 ) {
2595  TOKENTOLINE(" + 1 * ( ","+1*(")
2596  PrtTerms();
2597  TOKENTOLINE(" )",")")
2598  }
2599  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE )
2600  TokenToLine((UBYTE *)";");
2601  }
2602  AO.OutSkip = 3;
2603  AC.IsFortran90 = ISNOTFORTRAN90;
2604  FiniLine();
2605  AC.IsFortran90 = oldIsFortran90;
2606  AO.FactorMode = 0;
2607  }
2608  else {
2609  do { } while ( GetTerm(BHEAD AO.termbuf) );
2610  }
2611  }
2612  if ( AC.OutputSpaces == NORMALFORMAT ) FiniLine();
2613 EndWrite:
2614  if ( AR.infile->handle >= 0 ) {
2615  SeekFile(AR.infile->handle,&(AR.infile->filesize),SEEK_SET);
2616  }
2617  AO.IsBracket = 0;
2618  AT.WorkPointer = AO.termbuf;
2619  SetScratch(AR.infile,&pos);
2620  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2621  return(0);
2622 AboWrite:
2623  SetScratch(AR.infile,&pos);
2624  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2625  MesCall("WriteAll");
2626  Terminate(-1);
2627  return(-1);
2628 }
2629 
2630 /*
2631  #] WriteAll :
2632  #[ WriteOne : WORD WriteOne(name,alreadyinline)
2633 
2634  Writes one expression from the preprocessor
2635 */
2636 
2637 WORD WriteOne(UBYTE *name, int alreadyinline, int nosemi, WORD plus)
2638 {
2639  GETIDENTITY
2640  WORD number;
2641  WORD lbrac, first;
2642  POSITION pos;
2643  FILEHANDLE *f;
2644  WORD prf;
2645 
2646  if ( GetName(AC.exprnames,name,&number,NOAUTO) != CEXPRESSION ) {
2647  MesPrint("@%s is not an expression",name);
2648  return(-1);
2649  }
2650  switch ( Expressions[number].status ) {
2651  case HIDDENLEXPRESSION:
2652  case HIDDENGEXPRESSION:
2653  case HIDELEXPRESSION:
2654  case HIDEGEXPRESSION:
2655  case UNHIDELEXPRESSION:
2656  case UNHIDEGEXPRESSION:
2657 /*
2658  case DROPHLEXPRESSION:
2659  case DROPHGEXPRESSION:
2660 */
2661  AR.GetFile = 2;
2662  break;
2663  case LOCALEXPRESSION:
2664  case GLOBALEXPRESSION:
2665  case SKIPLEXPRESSION:
2666  case SKIPGEXPRESSION:
2667 /*
2668  case DROPLEXPRESSION:
2669  case DROPGEXPRESSION:
2670 */
2671  AR.GetFile = 0;
2672  break;
2673  default:
2674  MesPrint("@expressions %s is not active. It cannot be written",name);
2675  return(-1);
2676  }
2677  SeekScratch(AR.outfile,&pos);
2678 
2679  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2680 /*
2681  if ( ResetScratch() ) {
2682  MesCall("WriteOne");
2683  SETERROR(-1)
2684  }
2685 */
2686  if ( AR.GetFile == 2 ) f = AR.hidefile;
2687  else f = AR.infile;
2688  prf = Expressions[number].printflag;
2689  if ( plus ) prf |= PRINTONETERM;
2690 /*
2691  Now position the file
2692 */
2693  if ( f->handle >= 0 ) {
2694  SetScratch(f,&(Expressions[number].onfile));
2695  }
2696  else {
2697  f->POfill = (WORD *)((UBYTE *)(f->PObuffer)
2698  + BASEPOSITION(Expressions[number].onfile));
2699  }
2700  AO.termbuf = AT.WorkPointer;
2701  AO.bracket = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer);
2702  AT.WorkPointer = (WORD *)(((UBYTE *)(AT.WorkPointer)) + AM.MaxTer*2);
2703 
2704  AO.OutFill = AO.OutputLine = (UBYTE *)AT.WorkPointer;
2705  AT.WorkPointer += 2*AC.LineLength;
2706  *(AR.CompressBuffer) = 0;
2707 
2708  AO.IsBracket = 0;
2709  AO.OutSkip = 3;
2710  AR.DeferFlag = 0;
2711 
2712  if ( AC.OutputMode == FORTRANMODE || AC.OutputMode == PFORTRANMODE )
2713  AO.OutSkip = 6;
2714  if ( GetTerm(BHEAD AO.termbuf) <= 0 ) {
2715  MesPrint("@ReadError in expression %s",name);
2716  goto AboWrite;
2717  }
2718 /*
2719  PutPreVar(AM.oldnumextrasymbols,
2720  GetPreVar((UBYTE *)"EXTRASYMBOLS_",0),0,1);
2721 */
2722  /*
2723  * Currently WriteOne() is called only from writeToChannel() with setting
2724  * AO.OptimizationLevel = 0, which means Optimize() is never called here.
2725  * So we don't need to think about how to ensure that the master and the
2726  * slaves call Optimize() at the same time. (TU 26 Jul 2013)
2727  */
2728  if ( AO.OptimizationLevel > 0 ) {
2729  AO.OutSkip = 6;
2730  if ( Optimize(AO.termbuf[3], 1) ) goto AboWrite;
2731  AO.OutSkip = 3;
2732  FiniLine();
2733  }
2734  else {
2735  lbrac = 0;
2736  AO.InFbrack = 0;
2737  AO.FortFirst = 0;
2738  first = 1;
2739  while ( GetTerm(BHEAD AO.termbuf) ) {
2740  WORD *m;
2741  GETSTOP(AO.termbuf,m);
2742  if ( first ) {
2743  IniLine(0);
2744  startinline = alreadyinline;
2745  AO.OutFill = AO.OutputLine + startinline;
2746  if ( WriteTerm(AO.termbuf,&lbrac,first,0,0) )
2747  goto AboWrite;
2748  first = 0;
2749  }
2750  else {
2751  if ( ( prf & PRINTONETERM ) != 0 ) first = 1;
2752  if ( first ) {
2753  FiniLine();
2754  IniLine(0);
2755  }
2756  first = 0;
2757  if ( WriteTerm(AO.termbuf,&lbrac,first,0,0) )
2758  goto AboWrite;
2759  }
2760  }
2761  if ( first ) {
2762  IniLine(0);
2763  startinline = alreadyinline;
2764  AO.OutFill = AO.OutputLine + startinline;
2765  TOKENTOLINE(" 0","0");
2766  }
2767  else if ( lbrac ) {
2768  TOKENTOLINE(" )",")");
2769  }
2770  if ( AC.OutputMode != FORTRANMODE && AC.OutputMode != PFORTRANMODE
2771  && nosemi == 0 ) TokenToLine((UBYTE *)";");
2772  AO.OutSkip = 3;
2773  if ( AC.OutputSpaces == NORMALFORMAT && nosemi == 0 ) {
2774  FiniLine();
2775  }
2776  else {
2777  noextralinefeed = 1;
2778  FiniLine();
2779  noextralinefeed = 0;
2780  }
2781  }
2782  AO.IsBracket = 0;
2783  AT.WorkPointer = AO.termbuf;
2784  SetScratch(f,&pos);
2785  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2786  AO.InFbrack = 0;
2787  return(0);
2788 AboWrite:
2789  SetScratch(AR.infile,&pos);
2790  f->POposition = pos;
2791  f = AR.outfile; AR.outfile = AR.infile; AR.infile = f;
2792  MesCall("WriteOne");
2793  Terminate(-1);
2794  return(-1);
2795 }
2796 
2797 /*
2798  #] WriteOne :
2799  #] schryf-Writes :
2800 */
int PutPreVar(UBYTE *, UBYTE *, UBYTE *, int)
Definition: pre.c:642
Definition: structs.h:633
WORD ** lhs
Definition: structs.h:942
Definition: structs.h:938
WORD ** rhs
Definition: structs.h:943
LONG TimeCPU(WORD)
Definition: tools.c:3478
int handle
Definition: structs.h:661