1 /****************************************************************/
2 /* file print.c
3 
4 ARIBAS interpreter for Arithmetic
5 Copyright (C) 1996 O.Forster
6 
7 This program is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2 of the License, or
10 (at your option) any later version.
11 
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15 GNU General Public License for more details.
16 
17 You should have received a copy of the GNU General Public License
18 along with this program; if not, write to the Free Software
19 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
20 
21 Address of the author
22 
23     Otto Forster
24     Math. Institut der LMU
25     Theresienstr. 39
26     D-80333 Muenchen, Germany
27 
28 Email   forster@rz.mathematik.uni-muenchen.de
29 */
30 /****************************************************************/
31 
32 /*
33 ** print.c
34 ** functions for output formatting
35 **
36 ** date of last change
37 ** 1995-01-03: integer return for write and writeln
38 ** 1995-01-26: NEEDFLUSH
39 ** 1995-03-11: changed s1form, s2form
40 ** 1995-03-28: fRECORD, fPOINTER
41 ** 1995-04-08: ASCII 0 in strings
42 ** 1995-07-16: fixed bug in left alignment of strings
43 ** 1996-08-04: fixed bug in base 8 formatting
44 ** 1996-11-03: renamed protocol() to transcript()
45 ** 1997-04-13: reorg (newintsym)
46 ** 1997-07-05: changed setcols (no special role of tstdout)
47 **       error return value of write() and writeln() set to -1
48 ** 1997-12-20: small change in fprintline
49 ** 1998-10-01: adjustments for Win32GUI
50 ** 2001-01-01: multiprec floats
51 ** 2001-03-30: Win32GUI replaces genWinGUI
52 ** 2001-06-02: function flushlog
53 ** 2002-04-01: allow interrupt while printing vectors
54 ** 2002-08-03: baseprefix changed,
55 **      changed argument type of s1form, s2form, sformaux
56 ** 2003-02-21: Gformat also for gf2nint's
57 */
58 
59 #include "common.h"
60 
61 #ifdef DjGPP
62 #define NEEDFLUSH
63 #endif
64 
65 PUBLIC void iniprint    _((int cols));
66 PUBLIC int logout   _((int ch));
67 PUBLIC void strlogout   _((char *str));
68 PUBLIC void closelog    _((void));
69 PUBLIC void flushlog    _((void));
70 PUBLIC void tprint  _((truc strom, truc obj));
71 PUBLIC int strcopy  _((char *tostr, char *fromstr));
72 PUBLIC int strncopy _((char *tostr, char *fromstr, int maxlen));
73 PUBLIC int fprintstr    _((truc strom, char *str));
74 PUBLIC void fprintline  _((truc strom, char *str));
75 PUBLIC void fnewline    _((truc strom));
76 PUBLIC void ffreshline  _((truc strom));
77 PUBLIC void flinepos0   _((truc strom));
78 PUBLIC int s1form   _((char *buf, char *fmt, wtruc dat));
79 PUBLIC int s2form   _((char *buf, char *fmt, wtruc dat1, wtruc dat2));
80 PUBLIC int setprnprec _((int prec));
81 PUBLIC truc writesym, writlnsym, formatsym;
82 PUBLIC truc transcsym;
83 
84 PUBLIC char OutBuf[IOBUFSIZE+4];
85 PUBLIC int Log_on = 0;
86 
87 /*----------------------------------------------------*/
88 #define FORMPARAM   5
89 #define NOTSET     -32768
90 #define DEFAULT     0
91 
92 typedef struct {
93     int mode;
94     int param[FORMPARAM];
95 } forminfo;
96 
97 PRIVATE ifun putcfun    _((truc strom));
98 PRIVATE int charout _((int ch));
99 PRIVATE int log2out _((int ch));
100 PRIVATE truc Ftranscript    _((int argn));
101 PRIVATE truc F1write    _((int argn));
102 PRIVATE truc Fwritln    _((int argn));
103 PRIVATE truc Fint2str   _((int argn));
104 PRIVATE truc Fflt2str   _((void));
105 PRIVATE truc Secvt  _((void));
106 PRIVATE truc Gformat    _((void));
107 PRIVATE int Gprint  _((int argn, int nl));
108 PRIVATE int setcols _((truc strom, truc *ptr));
109 PRIVATE void getform    _((forminfo *fptr, truc obj, truc *arr, int n));
110 PRIVATE truc Fsetpbase  _((void));
111 PRIVATE truc Fgetpbase  _((void));
112 PRIVATE int admissbase  _((int base));
113 PRIVATE int printbase   _((int base));
114 PRIVATE char *baseprefix   _((int base, int mode));
115 PRIVATE int nibasci0       _((word2 *x, int k));
116 PRIVATE void printfint     _((truc strom, truc obj, forminfo *fptr));
117 PRIVATE void printfloat    _((truc strom, truc obj, forminfo *fptr));
118 PRIVATE int printvector    _((truc strom, truc obj));
119 PRIVATE int printrecord    _((truc strom, truc obj));
120 PRIVATE int printvvrr      _((truc strom, truc obj, int flg));
121 PRIVATE void printstring   _((truc strom, truc obj, forminfo *fptr));
122 PRIVATE void printbstring  _((truc strom, truc obj, forminfo *fptr));
123 PRIVATE int bytes2hex   _((char *str, byte *buf, int len));
124 PRIVATE int sym2str _((truc obj, char *buf));
125 PRIVATE int float2str   _((truc obj, char *buf, forminfo *fptr, word2 *hilf));
126 PRIVATE int fixstring   _((numdata *nptr, int dec, char *buf));
127 PRIVATE int char2str    _((truc obj, char *buf, forminfo *fptr));
128 PRIVATE int bool2str    _((truc obj, char *buf));
129 PRIVATE word4 truc2msf  _((truc obj));
130 PRIVATE int ptr2str _((truc obj, char *buf));
131 PRIVATE int obj2str _((int flg, truc obj, char *buf));
132 PRIVATE int leftpad _((char *buf, int width, int ch));
133 PRIVATE int fillspaces  _((char *buf, int n));
134 PRIVATE void strnfcopy  _((char *tostr, char *fromstr, unsigned len));
135 PRIVATE int fprintwrap  _((truc strom, char *str, int bound, int contmark));
136 PRIVATE int fprintmarg  _((truc strom, char *str, int len));
137 PRIVATE int fprintch    _((truc strom, int ch));
138 PRIVATE int long2alfa   _((char *buf, long u));
139 PRIVATE int long2s0alfa  _((char *buf, long u, int len));
140 PRIVATE int word4xalfa  _((char *buf, word4 u));
141 PRIVATE int sformaux    _((forminfo *fmptr, char *buf, wtruc dat));
142 PRIVATE char *formscan  _((char *str, forminfo *fmptr));
143 PRIVATE int isformdir   _((int ch));
144 
145 PRIVATE truc basesym, groupsym, columsym, digssym;
146 PRIVATE truc setpbsym, getpbsym;
147 PRIVATE truc itoasym, ftoasym, ecvtsym;
148 
149 
150 PRIVATE int quotemode = 1;
151 
152 PRIVATE FILE *outfile;
153 PRIVATE FILE *logfile;
154 
155 PRIVATE int MaxCols;
156 PRIVATE int PrintCols;
157 PRIVATE int PrintPrec;
158 
159 #define DECprec(prec)   ((prec)*95 - 10)/20
160 /*------------------------------------------------------------------*/
iniprint(cols)161 PUBLIC void iniprint(cols)
162 int cols;
163 {
164     truc write_sym, writln_sym;
165 
166     if(cols >= MAXCOLS/2 && cols <= 2*MAXCOLS)
167         MaxCols = cols;
168     else
169         MaxCols = MAXCOLS;
170     PrintCols = MaxCols-1;
171     PrintPrec = deffltprec();
172 
173     write_sym = new0symsig("write",sFBINARY,(wtruc)F1write, s_1u);
174     writesym  = newsym("write",   sPARSAUX, write_sym);
175     writln_sym= new0symsig("writeln",sFBINARY,(wtruc)Fwritln,s_0u);
176     writlnsym = newsym("writeln",   sPARSAUX, writln_sym);
177 
178     basesym   = newsym("base",  sUNBOUND, nullsym);
179     groupsym  = newsym("group", sUNBOUND, nullsym);
180     columsym  = newsym("columns",   sUNBOUND, nullsym);
181     digssym   = newsym("digits",    sUNBOUND, nullsym);
182 
183     formatsym = newintsym("", sFBINARY, (wtruc)Gformat);
184     setpbsym  = newsymsig("set_printbase",sFBINARY,(wtruc)Fsetpbase,s_ii);
185     getpbsym  = newsymsig("get_printbase",sFBINARY,(wtruc)Fgetpbase,s_0);
186     transcsym = newsymsig("transcript", sFBINARY,(wtruc)Ftranscript, s_01);
187     itoasym   = newsymsig("itoa",      sFBINARY, (wtruc)Fint2str, s_12);
188     ftoasym   = newsymsig("ftoa",      sFBINARY, (wtruc)Fflt2str, s_1);
189     ecvtsym   = newsymsig("float_ecvt",sSBINARY,(wtruc)Secvt, s_4);
190 }
191 /*------------------------------------------------------------------*/
putcfun(strom)192 PRIVATE ifun putcfun(strom)
193 truc strom;
194 {
195     outfile = STREAMfile(strom);
196     if(Log_on && (strom == tstdout || strom == tstderr))
197         return(log2out);
198     else {
199 #ifdef genWinGUI
200         if ((strom == tstdout || strom == tstderr))
201             return(wincharout);
202         else
203 #endif
204         return(charout);
205     }
206 }
207 /*------------------------------------------------------------------*/
208 #ifdef NEEDFLUSH
209 /*
210 ** there were problems with one version the DOS-Port (D.J. Delorie)
211 ** of the Gnu-Compiler (ver 2.5.7)
212 ** which necessitated a fflush
213 */
214 /*------------------------------------------------------------------*/
charout(ch)215 PRIVATE int charout(ch)
216 int ch;
217 {
218     int ret = putc(ch,outfile);
219 
220     fflush(outfile);
221     return ret;
222 }
223 /*------------------------------------------------------------------*/
logout(ch)224 PUBLIC int logout(ch)
225 int ch;
226 {
227     int ret = putc(ch,logfile);
228 
229     fflush(logfile);
230     return ret;
231 }
232 /*------------------------------------------------------------------*/
log2out(ch)233 PRIVATE int log2out(ch)
234 int ch;
235 {
236     int ret;
237 
238     putc(ch,logfile);
239     fflush(logfile);
240     ret = putc(ch,stdout);
241     fflush(stdout);
242     return ret;
243 }
244 /*-------------------------------------------------------------------*/
245 #else   /* #ifndef NEEDFLUSH */
246 /*------------------------------------------------------------------*/
charout(ch)247 PRIVATE int charout(ch)
248 int ch;
249 {
250     return putc(ch,outfile);
251 }
252 /*------------------------------------------------------------------*/
logout(ch)253 PUBLIC int logout(ch)
254 int ch;
255 {
256     return putc(ch,logfile);
257 }
258 /*------------------------------------------------------------------*/
log2out(ch)259 PRIVATE int log2out(ch)
260 int ch;
261 {
262     putc(ch,logfile);
263 #ifdef genWinGUI
264     return wincharout(ch);
265 #else
266     return putc(ch,stdout);
267 #endif
268 }
269 /*-------------------------------------------------------------------*/
270 #endif  /* #ifndef NEEDFLUSH */
271 
272 /*-------------------------------------------------------------------*/
strlogout(str)273 PUBLIC void strlogout(str)
274 char *str;
275 {
276     int ch;
277 
278     while((ch = *str++))
279         logout(ch);
280 }
281 /*------------------------------------------------------------------*/
Ftranscript(argn)282 PRIVATE truc Ftranscript(argn)
283 int argn;
284 {
285     char name[84];
286     char *logname = "aribas";
287     char *extens = ".log";
288     char *str;
289     int strerr;
290 
291     if(argn == 1 && *argStkPtr == zero) {
292         closelog();
293         return(zero);
294     }
295     if(argn == 1) {
296         if(*FLAGPTR(argStkPtr) == fSTRING) {
297             str = STRINGPTR(argStkPtr);
298             strerr = (str[0] ? 0 : 1);
299         }
300         else
301             strerr = 1;
302         if(strerr) {
303             error(transcsym,err_str,*argStkPtr);
304             return(brkerr());
305         }
306     }
307     else
308         str = logname;
309     fnextens(str,name,extens);
310     logfile = fopen(name,"w");
311     if(logfile == NULL) {
312         error(transcsym,err_open,scratch(name));
313         return(false);
314     }
315     else {
316         Log_on = 1;
317         return(true);
318     }
319 }
320 /*-------------------------------------------------------------------*/
flushlog()321 PUBLIC void flushlog()
322 {
323     if(Log_on)
324         fflush(logfile);
325 }
326 /*------------------------------------------------------------------*/
closelog()327 PUBLIC void closelog()
328 {
329     if(Log_on) {
330         Log_on = 0;
331         fclose(logfile);
332     }
333 }
334 /*------------------------------------------------------------------*/
F1write(argn)335 PRIVATE truc F1write(argn)  /* to avoid name clash with system function */
336 int argn;
337 {
338     int n = Gprint(argn,0);
339     return(mksfixnum(n));
340 }
341 /*------------------------------------------------------------------*/
Fwritln(argn)342 PRIVATE truc Fwritln(argn)
343 int argn;
344 {
345     int n = Gprint(argn,1);
346     return(mksfixnum(n));
347 }
348 /*------------------------------------------------------------------*/
349 #define MAXINT2STRLEN   4000
Fint2str(argn)350 PRIVATE truc Fint2str(argn)
351 int argn;
352 {
353     truc *argptr;
354     truc strobj;
355     word2 *x, *y;
356     char *cpt;
357     long nn;
358     int flg, len, len1, sign, base;
359     int bpd, dig;
360     int errflg = 0;
361 
362     argptr = argStkPtr - argn + 1;
363 
364     flg = *FLAGPTR(argptr);
365     if(flg != fFIXNUM && flg != fBIGNUM) {
366         error(itoasym,err_int,*argptr);
367         return(brkerr());
368     }
369     if(argn == 2) {
370         if(*FLAGPTR(argStkPtr) != fFIXNUM)
371             errflg = 1;
372         base = *WORD2PTR(argStkPtr);
373         if(base != 10 && base != 16 && base != 2 && base != 8)
374             errflg = 1;
375         if(errflg) {
376             error(itoasym,err_pbase,*argStkPtr);
377             return(brkerr());
378         }
379     }
380     else
381         base = 10;
382     x = AriBuf;
383     y = (base == 10 ? AriScratch : x);
384     len = bigretr(argptr,y,&sign);
385     if(len == 0)
386         return(mkstr("0"));
387     if(len > MAXINT2STRLEN) {
388         error(itoasym,err_2big,voidsym);
389         return(brkerr());
390     }
391     if(base == 10) {
392         len = big2bcd(y,len,x);
393         len = (len + 3) >> 2;
394     }
395     if(base >= 10)      /* base == 16 || base == 10 */
396         bpd = 4;
397     else if(base == 8) {
398         x[len] = 0; /* !!! */
399         bpd = 3;
400     }
401     else            /* base == 2 */
402         bpd = 1;
403     nn = bit_length(x,len);
404     nn = (nn + bpd - 1)/bpd;    /* Anzahl der Ziffern */
405     len1 = (sign ? nn+1 : nn);
406     strobj = mkstr0(len1);
407     cpt = STRING(strobj);
408     if(sign)
409         *cpt++ = '-';
410     while(--nn >= 0) {
411         dig = nibndigit(bpd,x,nn);
412         *cpt++ = hexascii(dig);
413     }
414     return strobj;
415 }
416 #undef MAXINT2STRLEN
417 /*------------------------------------------------------------------*/
Fflt2str()418 PRIVATE truc Fflt2str()
419 {
420     forminfo fmt;
421     int prec, flg;
422     char *out;
423 
424     flg = chknum(ftoasym,argStkPtr);
425     if(flg == aERROR)
426         return(brkerr());
427     prec = fltprec(flg);
428     fmt.mode = 'G';
429     fmt.param[0] = 0;
430     fmt.param[1] = DECprec(prec);
431     out = (char *)AriBuf;
432     float2str(*argStkPtr,out,&fmt,AriScratch);
433     return(mkstr(out));
434 }
435 /*------------------------------------------------------------------*/
Secvt()436 PRIVATE truc Secvt()
437 {
438     numdata acc;
439     truc res;
440     word2 *x;
441     char *cpt ;
442     int k, len, digs, digsmax, decpos, sign, flg;
443     int errflg = 0;
444 
445     acc.digits = x = AriBuf;
446 
447     res = eval(ARGNPTR(evalStkPtr,1));
448     ARGpush(res);
449     res = eval(ARGNPTR(evalStkPtr,2));
450     ARGpush(res);
451     flg = *FLAGPTR(argStkPtr-1);
452     if(flg < fFIXNUM) {
453         error(ecvtsym,err_num,argStkPtr[-1]);
454         errflg = 1;
455         goto cleanup;
456     }
457     flg = *FLAGPTR(argStkPtr);
458     if(flg != fFIXNUM) {
459         error(ecvtsym,err_int,*argStkPtr);
460         errflg = 1;
461         goto cleanup;
462     }
463     digs = *WORD2PTR(argStkPtr);
464     if(digs < 2)
465         digs = 2;
466     else if(digs > (digsmax = FltPrec[MaxFltLevel] * 5))
467         digs = digsmax;
468     len = float2bcd(digs,argStkPtr-1,&acc,AriScratch);
469     sign = (acc.sign ? -1 : 0);
470     decpos = (len ? len + acc.expo : 0);
471     res = mkstr0(digs);
472     cpt = STRING(res);
473     for(k=len-1; k>=0; k--)
474         *cpt++ = nibascii(x,k);
475     for(k=digs-len; k>0; k--)
476         *cpt++ = '0';
477     Lvalassign(ARGNPTR(evalStkPtr,3),mksfixnum(decpos));
478     Lvalassign(ARGNPTR(evalStkPtr,4),mksfixnum(sign));
479   cleanup:
480     if(errflg)
481         res = brkerr();
482     ARGnpop(2);
483     return(res);
484 }
485 /*------------------------------------------------------------------*/
486 /*
487 ** Auswertung der Format-Anweisung bei write oder writeln
488 ** argStkPtr[-1]: zu schreibendes Objekt,
489 ** argStkPtr[0]: Tupel mit Formatangaben
490 ** Zurueckgegeben wird ein Tupel, dessen 0-te Komponente
491 ** das Objekt und die weiteren Komponenten die ausgewerteten
492 ** Formatangaben sind. Falls die Formatangaben nicht
493 ** sinnvoll sind, wird nur das Objekt zurueckgegeben.
494 */
Gformat()495 PRIVATE truc Gformat()
496 {
497     truc *arr, *ptr;
498     truc obj, grp, bas, wid, dig;
499     int i, m, n;
500     int flg;
501 
502     flg = *FLAGPTR(argStkPtr-1);
503     arr = workStkPtr + 1;
504     WORKpush(argStkPtr[-1]);
505     ptr = VECTORPTR(argStkPtr);
506     m = *VECLENPTR(argStkPtr);
507     for(i=0; i<m; i++)
508         WORKpush(ptr[i]);
509     if(flg >= fFLTOBJ) {
510         n = (m > 1 ? 3 : 2);
511         for(i=1; i<n; i++) {
512             arr[i] = eval(arr+i);
513             if(*FLAGPTR(arr+i) != fFIXNUM) {
514                 n = 0;
515                 break;
516             }
517         }
518     }
519     else if((flg >= fINTTYPE0 && flg <= fINTTYPE1) || flg == fBYTESTRING) {
520         if(m < 4)
521             for(i=m; i<4; i++)
522                 WORKpush(zero);
523         bas = wid = dig = zero;
524         grp = nullsym;
525         n = 2;
526         for(i=1; i<=m; i++) {
527         if(*FLAGPTR(arr+i) == fFUNCALL) {
528             ptr = TAddress(arr+i);
529             if(*ptr == basesym) {
530                 if(n < 3) n = 3;
531                 if(ptr[1] == constone) {
532                     obj = eval(ptr+2);
533                     if(Tflag(obj) == fFIXNUM)
534                         bas = obj;
535                 }
536                 continue;
537             }
538             else if(*ptr == groupsym) {
539                 if(n < 4) n = 4;
540                 if(ptr[1] == constone) {
541                     obj = eval(ptr+2);
542                     if(Tflag(obj) == fFIXNUM)
543                         grp = obj;
544                 }
545                 continue;
546             }
547             else if(*ptr == digssym) {
548                 if(n < 5) n = 5;
549                 if(ptr[1] == constone) {
550                     obj = eval(ptr+2);
551                     if(Tflag(obj) == fFIXNUM)
552                         dig = obj;
553                 }
554                 continue;
555             }
556         }
557         obj = eval(arr+i);
558         if(Tflag(obj) == fFIXNUM)
559             wid = obj;
560         }
561         arr[1] = wid;
562         arr[2] = bas;
563         arr[3] = grp;
564         arr[4] = dig;
565     }
566     else if(flg == fSTRING || flg == fCHARACTER) {
567     /* fehlt Analyse von escape Anweisungen */
568         arr[1] = eval(arr+1);
569         if(*FLAGPTR(arr+1) != fFIXNUM)
570             n = 0;
571         else
572             n = 2;
573     }
574     else if(flg == fSTREAM) {
575         n = 0;
576         if(*FLAGPTR(arr+1) == fFUNCALL) {
577             ptr = TAddress(arr+1);
578             if(*ptr == columsym) {
579                 if(ptr[1] == constone) {
580                     obj = eval(ptr+2);
581                     if(Tflag(obj) == fFIXNUM) {
582                         arr[1] = obj;
583                         n = 2;
584                     }
585                 }
586             }
587         }
588     }
589     else
590         n = 0;
591     obj = (n ? mkntuple(fTUPLE,arr,n) : arr[0]);
592     workStkPtr = arr - 1;
593     return(obj);
594 }
595 /*------------------------------------------------------------------*/
Gprint(argn,nl)596 PRIVATE int Gprint(argn,nl)
597 int argn;
598 int nl;
599 {
600     truc *ptr;
601     truc strom;
602     truc obj;
603     int changecols = 0;
604     int savemode, flg;
605     int i;
606 
607     strom = tstdout;
608     if(argn > 0) {
609         ptr = argStkPtr - argn + 1;
610         flg = *FLAGPTR(ptr);
611         if(flg == fTUPLE) {
612             obj = *ptr;
613             if(*VECLENPTR(ptr) >= 2) {
614                 ptr = VECTOR(obj);
615                 flg = *FLAGPTR(ptr);
616                 changecols = 1;
617             }
618         }
619         if(flg == fSTREAM) {
620             if(!isoutfile(ptr,aTEXT)) {
621                 error(writesym,err_tout,voidsym);
622                 return(-1);
623             }
624             else {
625                 argn--;
626                 strom = *ptr;
627             }
628             if(changecols) {
629                 PrintCols = setcols(strom,ptr+1);
630             }
631         }
632     }
633     savemode = quotemode;
634     quotemode = 0;
635     for(i=-argn+1; i<=0; i++) {
636         tprint(strom,argStkPtr[i]);
637     }
638     if(nl)
639         fnewline(strom);
640     quotemode = savemode;
641     PrintCols = MaxCols-1;
642     return(argn);
643 }
644 /*------------------------------------------------------------------*/
setcols(strom,ptr)645 PRIVATE int setcols(strom,ptr)
646 truc strom;
647 truc *ptr;
648 {
649     unsigned k;
650 
651 
652     if(*FLAGPTR(ptr) != fFIXNUM)
653         return(MaxCols-1);
654     k = *WORD2PTR(ptr);
655     if(k < MAXCOLS/4)
656         k = MAXCOLS/4;
657     else if(k > IOBUFSIZE)
658         k = IOBUFSIZE;
659     return(k);
660 }
661 /*------------------------------------------------------------------*/
tprint(strom,obj)662 PUBLIC void tprint(strom,obj)
663 truc strom, obj;
664 {
665     forminfo fmt;
666     truc *ptr;
667     int m, flg, len;
668 
669     flg = Tflag(obj);
670     if(flg == fTUPLE) {     /* Format-Angaben */
671         ptr = VECTOR(obj);
672         m = VEClen(obj);
673         flg = *FLAGPTR(ptr);
674         obj = ptr[0];
675         getform(&fmt,obj,ptr+1,m-1);
676     }
677     else {              /* default format */
678         getform(&fmt,obj,NULL,0);
679     }
680 
681     if(flg == fSYMBOL)
682         len = sym2str(obj,OutBuf);
683     else if(flg == fBIGNUM || flg == fFIXNUM) {
684         printfint(strom,obj,&fmt);
685         return;
686     }
687     else if(flg == fGF2NINT) {
688         printfint(strom,obj,&fmt);
689         return;
690     }
691     else if(flg >= fFLTOBJ) {
692         printfloat(strom,obj,&fmt);
693         return;
694     }
695     else if(flg == fCHARACTER) {
696         len = char2str(obj,OutBuf,&fmt);
697     }
698     else if(flg == fBOOL) {
699         len = bool2str(obj,OutBuf);
700     }
701     else if(flg == fSTRING) {
702         printstring(strom,obj,&fmt);
703         return;
704     }
705     else if(flg == fBYTESTRING) {
706         printbstring(strom,obj,&fmt);
707         return;
708     }
709     else if(flg == fVECTOR) {
710         printvector(strom,obj);
711         return;
712     }
713     else if(flg == fRECORD) {
714         printrecord(strom,obj);
715         return;
716     }
717     else if(flg == fPOINTER) {
718         len = ptr2str(obj,OutBuf);
719     }
720     else
721         len = obj2str(flg,obj,OutBuf);
722 
723     fprintmarg(strom,OutBuf,len);
724 }
725 /*--------------------------------------------------------------*/
getform(fptr,obj,arr,n)726 PRIVATE void getform(fptr,obj,arr,n)
727 forminfo *fptr;
728 truc obj;
729 truc *arr;
730 int n;
731 {
732     int x;
733     int prec, len, base, group, digs;
734     int flg = Tflag(obj);
735 
736     if(n >= 1) {
737         x = *WORD2PTR(arr);
738         if(x > PrintCols-1)
739             x = PrintCols - 1;
740         if(*SIGNPTR(arr))
741             x = -x;
742         fptr->param[0] = x; /* Gesamt-Breite */
743     }
744     else {
745         fptr->param[0] = 0; /* default */
746     }
747 
748     if(flg >= fFLTOBJ) {
749         prec = fltprec(flg);
750         if(fptr->param[0] == 0 && PrintPrec && prec > PrintPrec)
751             prec = PrintPrec;
752         if(n <= 1) {
753             fptr->mode = (n==0 ? 'G' : 'E');
754             fptr->param[1] = DECprec(prec);
755         }
756         else {
757             fptr->mode = 'F';
758             fptr->param[2] = DECprec(prec);
759             x = *WORD2PTR(arr+1);
760             if(x < 1)
761                 x = 1;
762             else if(x > FltPrec[MaxFltLevel]*5)
763                 x = FltPrec[MaxFltLevel]*5;
764             fptr->param[1] = x;
765             /* Stellen nach dem Dezimalpunkt */
766         }
767     }
768     else if(flg == fFIXNUM || flg == fBIGNUM || flg == fGF2NINT) {
769         if(n <= 1)
770             base = printbase(0);
771         else if(n >= 2) {
772             base = *WORD2PTR(arr+1);
773             base = admissbase(base);
774         }
775         if(flg == fGF2NINT) {
776             if(base == 10)
777                 base = 16;
778         }
779         if(n < 3 || arr[2] == nullsym) {
780             if(flg == fBIGNUM || flg == fGF2NINT)
781                 len = VEClen(obj);
782             else
783                 len = 1;
784             switch(base) {
785             case 16:
786                 group = (len > 2 ? 4 : 8);
787                 break;
788             case 8:
789                 group = 5;
790                 break;
791             case 2:
792                 group = 8;
793                 break;
794             default:    /* base == 10 */
795                 group = (len > 2 ? 5 : 10);
796                 break;
797             }
798         }
799         else
800             group = *WORD2PTR(arr+2);
801 
802         if(n >= 4)
803             digs = *WORD2PTR(arr+3) & 0x7FFF;
804         else
805             digs = 0;
806         fptr->param[1] = base;
807         fptr->param[2] = group;
808         fptr->param[3] = digs;
809     }
810     else if(flg == fBYTESTRING) {
811         if(n < 3 || arr[2] == nullsym)
812             group = 4;
813         else
814             group = *WORD2PTR(arr+2);
815         fptr->param[2] = group;
816     }
817     else {
818         fptr->mode = flg;
819         if(n > 1)       /* vorlaeufig */
820             n = 1;
821         fptr->param[n] = DEFAULT;
822     }
823 }
824 /*--------------------------------------------------------------*/
Fsetpbase()825 PRIVATE truc Fsetpbase()
826 {
827     int flg;
828     int base;
829     int errflg = 0;
830 
831     flg = *FLAGPTR(argStkPtr);
832     if(flg != fFIXNUM)
833         errflg = 1;
834     else {
835         base = *WORD2PTR(argStkPtr);
836         if(base == 16 || base == 10 || base == 8 || base == 2)
837             printbase(base);
838         else {
839             errflg = 1;
840         }
841     }
842     if(errflg) {
843         base = printbase(0);
844         error(setpbsym,err_pbase,*argStkPtr);
845     }
846     return(mkfixnum(base));
847 }
848 /*--------------------------------------------------------------*/
Fgetpbase()849 PRIVATE truc Fgetpbase()
850 {
851     return(mkfixnum(printbase(0)));
852 }
853 /*--------------------------------------------------------------*/
admissbase(base)854 PRIVATE int admissbase(base)
855 int base;
856 {
857     switch(base) {
858     case 2:
859     case 8:
860     case 10:
861     case 16:
862         return(base);
863     default:
864         return(printbase(0));
865     }
866 }
867 /*--------------------------------------------------------------*/
printbase(base)868 PRIVATE int printbase(base)
869 int base;
870 {
871     static int pbase = 10;
872 
873     switch(base) {
874     case 2:
875     case 8:
876     case 10:
877     case 16:
878         pbase = base;
879         return(base);
880     default:
881         return(pbase);
882     }
883 }
884 /*--------------------------------------------------------------*/
setprnprec(prec)885 PUBLIC int setprnprec(prec)
886 int prec;
887 {
888     int prec1;
889 
890     if(prec < 0)
891         return(PrintPrec);
892     /* else */
893     prec1 = maxfltprec();
894     if(prec > prec1)
895         prec = prec1;
896     return (PrintPrec = prec);
897 }
898 /*--------------------------------------------------------------*/
baseprefix(base,mode)899 PRIVATE char *baseprefix(base, mode)
900 int base, mode;
901 {
902     static char pref[4];
903 
904     switch(base) {
905     case 16:
906         strcopy(pref,"0x");
907         break;
908     case 8:
909         strcopy(pref,"0o");
910         break;
911     case 2:
912         strcopy(pref,"0y");
913         break;
914     default:
915         pref[0] = '\0';
916     }
917     if(mode == 2 && strlen(pref) > 1)
918         pref[0] = '2';
919     return pref;
920 }
921 /*--------------------------------------------------------------*/
922 /*
923 ** Formatierte Ausgabe von Integern
924 */
printfint(strom,obj,fptr)925 PRIVATE void printfint(strom,obj,fptr)
926 truc strom, obj;
927 forminfo *fptr;
928 {
929     truc big;
930     word2 *x;
931     char *cpt;
932     long nn, NN, nn1, nn2, pp, m;
933     int sign, len, base, width, grp, noofdigs;
934     int k, n, diff, bpd;
935     int dig;
936     int rightpad;
937     int mode;
938 
939     big = obj;
940     len = bigretr(&big,AriBuf,&sign);
941     base = fptr->param[1];
942     if(base == 10) {
943         len = big2bcd(AriBuf,len,AriScratch);
944         len = (len + 3)>>2;
945         x = AriScratch;
946     }
947     else {
948         x = AriBuf;
949     }
950     width = fptr->param[0];
951     grp = fptr->param[2];
952     if(grp == 0)
953         grp = 1;
954     else if(grp == 1)
955         grp = 2;
956     else if(grp > PrintCols-1)
957         grp = PrintCols-1;
958 
959     noofdigs = fptr->param[3];
960 
961     if(len == 0 && noofdigs == 0)
962         noofdigs = 1;
963 
964     if(base >= 10) {
965         bpd = 4;
966     }
967     else if(base == 8) {
968         x[len] = 0; /* !!! */
969         bpd = 3;
970     }
971     else
972         bpd = 1;
973 
974     nn = bit_length(x,len);
975     nn = (nn + bpd - 1)/bpd;  /* Anzahl der Ziffern ohne leading 0 */
976     NN = (noofdigs > nn ? noofdigs : nn);
977     pp = (NN + grp - 1)/grp;  /* Zahl der Bloecke */
978     k = NN - (pp-1)*grp;      /* Zahl der Ziffern im 1.Block */
979     n = (sign ? strcopy(OutBuf,"-") : 0);
980     if(quotemode) {
981         mode = (FLAG(big) == fGF2NINT ? 2 : 0);
982         n += strcopy(OutBuf+n,baseprefix(base,mode));
983     }
984     m = NN + n + (grp==1 ? 0 : (pp-1));
985 
986     rightpad = 0;
987     if(width > 0 && m < width) {
988         diff = width - m;
989         OutBuf[n] = 0;
990         n = leftpad(OutBuf,n+diff,' ');
991     }
992     else if(width < 0 && m < -width) {
993         diff = -width - m;
994         rightpad = 1;
995     }
996     while(--pp >= 0) {
997         cpt = OutBuf + n;
998         nn2 = pp * grp;
999         for(nn1 = nn2+k-1; nn1 >= nn2; nn1--) {
1000             if(nn1 >= nn)
1001                 dig = 0;
1002             else
1003                 dig = nibndigit(bpd,x,nn1);
1004             *cpt++ = hexascii(dig);
1005         }
1006         if(pp > 0 && grp > 1)
1007             *cpt++ = '_';
1008         *cpt = 0;
1009         n = cpt - OutBuf;
1010         fprintmarg(strom,OutBuf,n);
1011         n = 0; k = grp;
1012     }
1013     if(rightpad) {
1014         fillspaces(OutBuf,diff);
1015         fprintstr(strom,OutBuf);
1016     }
1017 }
1018 /*--------------------------------------------------------------*/
nibasci0(x,k)1019 PRIVATE int nibasci0(x,k)
1020 word2 *x;
1021 int k;
1022 {
1023     if(k >= 0)
1024         return nibascii(x,k);
1025     else
1026         return '0';
1027 }
1028 /*--------------------------------------------------------------*/
1029 /*
1030 ** prints float obj
1031 ** uses AriBuf and ScratchBuf
1032 */
printfloat(strom,obj,fptr)1033 PRIVATE void printfloat(strom,obj,fptr)
1034 truc strom, obj;
1035 forminfo *fptr;
1036 {
1037     numdata acc;
1038     truc fltnum;
1039     word2 *x;
1040     char *cpt;
1041     long decpos, expo;
1042     int k, len, digs, dec, width, sign, mode;
1043     int eflg;
1044     int grp=5;
1045 
1046     mode = fptr->mode;
1047     width = fptr->param[0];
1048     if(mode == 'G' || mode == 'E') {
1049         digs = fptr->param[1];
1050     }
1051     else {      /* mode == 'F' */
1052         dec = fptr->param[1];
1053         digs = fptr->param[2];
1054     }
1055     if(width > 0 && width <= PrintCols-1) { /* vorlaeufig */
1056         len = float2str(obj,OutBuf,fptr,AriScratch);
1057         fprintmarg(strom,OutBuf,len);
1058         return;
1059     }
1060     /* else */
1061     acc.digits = x = AriBuf;
1062     fltnum = obj;
1063     len = float2bcd(digs,&fltnum,&acc,AriScratch);
1064     sign = (acc.sign ? -1 : 0);
1065     decpos = (len ? len + acc.expo : 0);
1066     if(decpos <= grp && decpos > -grp) {
1067         eflg = 0;
1068     }
1069     else {
1070         eflg = 1;
1071         expo = decpos - 1;
1072         decpos = 1;
1073     }
1074 
1075     if(digs < 20)   /* vorlaeufig */
1076         grp = 20;
1077     /* print head */
1078     cpt = OutBuf;
1079     if(sign)
1080         *cpt++ = '-';
1081     if(decpos <= 0) {
1082         cpt += strcopy(cpt,"0.");
1083         for(k=0; k>=decpos+1; k--)
1084             *cpt++ = '0';
1085         for(k=decpos; (k>-grp) && (--digs>=0); k--)
1086             *cpt++ = nibasci0(x,--len);
1087     }
1088     else {  /* decpos > 0 */
1089         for(k=decpos; (k>0) && (--digs>=0); k--)
1090             *cpt++ = nibasci0(x,--len);
1091         *cpt++ = '.';
1092         for(k=0; (k<grp) && (--digs>=0); k++)
1093             *cpt++ = nibasci0(x,--len);
1094     }
1095     if(digs > 0)
1096         *cpt++ = '_';
1097     *cpt = 0;
1098     fprintmarg(strom,OutBuf,strlen(OutBuf));
1099     /* print next groups */
1100     while(digs > 0) {
1101         cpt = OutBuf;
1102         for(k=0; (k<grp) && (--digs>=0); k++)
1103             *cpt++ = nibasci0(x,--len);
1104         if(digs > 0)
1105             *cpt++ = '_';
1106         *cpt = 0;
1107         fprintmarg(strom,OutBuf,strlen(OutBuf));
1108     }
1109     if(eflg) {
1110         k = s1form(OutBuf,"e~D",(wtruc)expo);
1111         fprintmarg(strom,OutBuf,k);
1112     }
1113 }
1114 /*--------------------------------------------------------------*/
printvector(strom,obj)1115 PRIVATE int printvector(strom,obj)
1116 truc strom, obj;
1117 {
1118     return(printvvrr(strom,obj,fVECTOR));
1119 }
1120 /*--------------------------------------------------------------*/
printrecord(strom,obj)1121 PRIVATE int printrecord(strom,obj)
1122 truc strom, obj;
1123 {
1124     return(printvvrr(strom,obj,fRECORD));
1125 }
1126 /*--------------------------------------------------------------*/
1127 /*
1128 ** Ausgabe von Arrays und Records
1129 */
printvvrr(strom,obj,flg)1130 PRIVATE int printvvrr(strom,obj,flg)
1131 truc strom, obj;
1132 int flg;
1133 {
1134     static char *brace[] = {"(","{","&("};
1135     static char *closebrace[] = {")","}",")"};
1136     truc *ptr;
1137     int braceno;
1138     int savemode;
1139     int n, len;
1140     int pos;
1141 
1142     savemode = quotemode;
1143     quotemode = 1;
1144     WORKpush(obj);
1145     n = len = *VECLENPTR(workStkPtr);
1146     ptr = VECTORPTR(workStkPtr);
1147     if(flg == fRECORD) {
1148         ptr++;
1149         braceno = 2;
1150     }
1151     else if(len == 1)
1152         braceno = 1;
1153     else
1154         braceno = 0;
1155     fprintmarg(strom,brace[braceno],5);
1156     while(--n >= 0) {
1157         tprint(strom,*ptr);
1158         if(n) {
1159             fprintch(strom,',');
1160             pos = STREAMpos(strom);
1161             if(pos >= 1 && pos <= PrintCols - 1)
1162                 fprintch(strom,' ');
1163         }
1164         if((n & 0xF) == 0 && INTERRUPT) {
1165             setinterrupt(0);
1166             len = strcopy(OutBuf,"...user interrupt... ");
1167             fprintmarg(strom,OutBuf,len);
1168             break;
1169         }
1170         ptr++;
1171     }
1172     WORKpop();
1173     fprintmarg(strom,closebrace[braceno],2);
1174     quotemode = savemode;
1175     return(len);
1176 }
1177 /*--------------------------------------------------------------*/
printstring(strom,obj,fptr)1178 PRIVATE void printstring(strom,obj,fptr)
1179 truc strom, obj;
1180 forminfo *fptr;
1181 {
1182     struct strcell *strpt;
1183     char *s;
1184     unsigned len;
1185     int width, fill;
1186     int align;
1187 
1188     strpt = stringptr(obj);
1189     len = strpt->len;
1190     s = (char *)AriScratch;
1191     strnfcopy(s,&(strpt->ch0),len);
1192 /**** fehlt Behandlung nichtdruckbarer Zeichen *****/
1193 
1194     width = fptr->param[0];
1195     if(width >= 0) {
1196         align = 1;
1197     }
1198     else {
1199         align = -1;
1200         width = -width;
1201     }
1202     if(width > len)
1203         fill = width - len;
1204     else
1205         align = 0;
1206     if(fill >= PrintCols)
1207         align = 0;
1208     if(align == 0) {
1209         fill = 0;
1210         width = len;
1211     }
1212     if(quotemode)       /* only in unformatted mode */
1213         width += 2;
1214     if(STREAMpos(strom) >= PrintCols-width)
1215         fnewline(strom);
1216     if(quotemode) {
1217         fprintch(strom,'"');
1218         fprintwrap(strom,s,PrintCols-1,'\\');
1219         fprintch(strom,'"');
1220     }
1221     else {
1222         if(align <= 0)
1223             fprintwrap(strom,s,PrintCols,0);
1224         if(align) {
1225             fillspaces(OutBuf,fill);
1226             fprintstr(strom,OutBuf);
1227         }
1228         if(align > 0)
1229             fprintwrap(strom,s,PrintCols,0);
1230     }
1231 }
1232 /*--------------------------------------------------------------*/
1233 /*
1234 ** print byte string in hex format
1235 */
printbstring(strom,obj,fptr)1236 PRIVATE void printbstring(strom,obj,fptr)
1237 truc strom,obj;
1238 forminfo *fptr;
1239 {
1240     struct strcell *strpt;
1241     byte *buf;
1242     size_t k = 0, len;
1243     int n = 0, m, grp;
1244     int weiter = 1;
1245 
1246     strpt = stringptr(obj);
1247     buf = (byte *)&(strpt->ch0);
1248     len = strpt->len;
1249     grp = fptr->param[2];
1250     if(grp == 1)
1251         grp = 2;
1252     else if(grp > PrintCols-1)
1253         grp = PrintCols-1;
1254     if(quotemode)
1255         n = strcopy(OutBuf,"$");
1256     while(weiter) {
1257         m = (grp ? grp/2 : 2);
1258         if(k+m > len)
1259             m = (k <= len ? len-k : 0);
1260         n += bytes2hex(OutBuf+n,buf+k,m);
1261         if(k+m < len) {
1262             if(grp)
1263                 n += strcopy(OutBuf+n,"_");
1264             k += m;
1265         }
1266         else
1267             weiter = 0;
1268         fprintmarg(strom,OutBuf,n);
1269         n = 0;
1270     }
1271 }
1272 /*--------------------------------------------------------------*/
bytes2hex(str,buf,len)1273 PRIVATE int bytes2hex(str,buf,len)
1274 char *str;
1275 byte *buf;
1276 int len;
1277 {
1278     unsigned u;
1279     int i;
1280 
1281     for(i=0; i<len; i++) {
1282         u = buf[i];
1283         *str++ = hexascii((u >> 4) & 0x0F);
1284         *str++ = hexascii(u & 0x0F);
1285     }
1286     *str = 0;
1287     return(2*len);
1288 }
1289 /*--------------------------------------------------------------*/
1290 /*
1291 ** kopiert fromstr nach tostr
1292 ** Rueckgabewert: Laenge des Strings
1293 */
strcopy(tostr,fromstr)1294 PUBLIC int strcopy(tostr,fromstr)
1295 char *tostr, *fromstr;
1296 {
1297     int i=0;
1298 
1299     while((*tostr++ = *fromstr++))
1300         i++;
1301     return(i);
1302 }
1303 /*--------------------------------------------------------------*/
1304 /*
1305 ** kopiert hoechstens maxlen characters von fromstr nach tostr
1306 ** und setzt in diesen den Endmarkierer '\0'
1307 ** Rueckgabewert: Laenge des neuen Strings
1308 */
strncopy(tostr,fromstr,maxlen)1309 PUBLIC int strncopy(tostr,fromstr,maxlen)
1310 char *tostr, *fromstr;
1311 int maxlen;
1312 {
1313     int i=0;
1314 
1315     while((*tostr++ = *fromstr++)) {
1316         if(++i >= maxlen) {
1317             *tostr = 0;
1318             break;
1319         }
1320     }
1321     return(i);
1322 }
1323 /*--------------------------------------------------------------*/
1324 /*
1325 ** kopiert len Zeichen von fromstr nach tostr, wobei jedes Nullbyte
1326 ** durch SPACE ersetzt wird. tostr wird durch Nullbyte abgeschlossen
1327 */
strnfcopy(tostr,fromstr,len)1328 PRIVATE void strnfcopy(tostr,fromstr,len)
1329 char *tostr, *fromstr;
1330 unsigned len;
1331 {
1332     int ch;
1333 
1334     while(len--) {
1335         ch = *fromstr++;
1336         *tostr++ = (ch ? ch : ' ');
1337     }
1338     *tostr = 0;
1339 }
1340 /*--------------------------------------------------------------*/
sym2str(obj,buf)1341 PRIVATE int sym2str(obj,buf)
1342 truc obj;
1343 char *buf;
1344 {
1345     return(strncopy(buf,SYMname(obj),PrintCols-1));
1346 }
1347 /*--------------------------------------------------------------*/
float2str(obj,buf,fptr,hilf)1348 PRIVATE int float2str(obj,buf,fptr,hilf)
1349 truc obj;
1350 char *buf;
1351 forminfo *fptr;
1352 word2 *hilf;
1353 {
1354     numdata acc;
1355     truc fltnum;
1356     long  expo;
1357     word2 *scratch;
1358     int len,len1,n,fill;
1359     int mode, width, wd1, prec, prec1, dec;
1360 
1361     acc.digits = hilf;
1362 
1363     mode = fptr->mode;
1364     width = fptr->param[0];
1365     if(mode == 'G' || mode == 'E') {
1366         prec = fptr->param[1];
1367     }
1368     else {      /* mode == 'F' */
1369         dec = fptr->param[1];
1370         prec = fptr->param[2];
1371     }
1372 
1373     fltnum = obj;
1374     scratch = hilf + 4 + (prec/4);
1375     len = float2bcd(prec,&fltnum,&acc,scratch);
1376     if(mode == 'F') {
1377         len1 = len + acc.expo + dec + 1;
1378         if(len1 <= width || len1 <= prec-1) {
1379             prec1 = prec + dec + acc.expo;
1380             if(prec1 < prec)
1381                 roundbcd(prec1,&acc);
1382             wd1 = fixstring(&acc,dec,buf);
1383             width = leftpad(buf,width,' ');
1384             return(width);
1385         }
1386         else {
1387             mode = 'G';
1388         }
1389     }
1390     if(mode == 'E') {
1391         if(width-8 >= prec) {
1392             dec = prec - 1;
1393         }
1394         else if(width >= 10) {
1395             dec = width - 9;
1396         }
1397         else {
1398             dec = 1;
1399             width = 10;
1400         }
1401         len = roundbcd(dec+1,&acc);
1402         expo = (len ? acc.expo + dec : 0);
1403         acc.expo = -dec;
1404         fill = width - dec - 9;
1405         if(acc.sign == 0)
1406             fill++;
1407         buf += fillspaces(buf,fill);
1408         wd1 = fixstring(&acc,dec,buf);
1409         buf[wd1] = 'e';
1410         n = long2s0alfa(buf+wd1+1,expo,5);
1411         return(fill+wd1+1+n);
1412     }
1413     if(len > 0) {     /* mode == 'G' */
1414         if(acc.expo <= -1 && acc.expo >= -prec - 2) {
1415             dec = -acc.expo;
1416             n = fixstring(&acc,dec,buf);
1417         }
1418         else {
1419             expo = acc.expo + prec - 1;
1420             acc.expo = -prec + 1;
1421             n = fixstring(&acc,prec-1,buf);
1422             n += s1form(buf+n,"e~D",(wtruc)expo);
1423         }
1424     }
1425     else {
1426         n = strcopy(buf,"0.0");
1427     }
1428     return(n);
1429 }
1430 /*--------------------------------------------------------------*/
1431 /*
1432 ** Schreibt die in *nptr gegebene Float-Zahl als fixed-point-string
1433 ** mit dec Dezimalstellen hinter dem Komma in buf.
1434 ** Rueckgabewert Laenge des Strings.
1435 */
fixstring(nptr,dec,buf)1436 PRIVATE int fixstring(nptr,dec,buf)
1437 numdata *nptr;
1438 int dec;
1439 char *buf;
1440 {
1441     word2 *x;
1442     char *cpt;
1443     int len, k, sh;
1444 
1445     cpt = buf;
1446     if(nptr->sign)
1447         *cpt++ = '-';
1448     len = nptr->len;
1449 
1450     x = nptr->digits;
1451     if(len > 0) {
1452         sh = dec + nptr->expo;
1453         len = shiftbcd(x,len,sh);
1454     }
1455     if(len <= dec) {        /* '0' vor dem Dezimalpunkt */
1456         *cpt++ = '0';
1457         *cpt++ = '.';
1458         for(k=dec-1; k>=len; k--)
1459             *cpt++ = '0';
1460         for(k=len-1; k>=0; k--)
1461             *cpt++ = nibascii(x,k);
1462     }
1463     else {      /* len-dec Stellen vor dem Dezimalpunkt */
1464         for(k=len-1; k>=dec; k--)
1465             *cpt++ = nibascii(x,k);
1466         *cpt++ = '.';
1467         for(k=dec-1; k>=0; k--)
1468             *cpt++ = nibascii(x,k);
1469     }
1470     *cpt = 0;
1471     return(cpt-buf);
1472 }
1473 /*--------------------------------------------------------------*/
char2str(obj,buf,fptr)1474 PRIVATE int char2str(obj,buf,fptr)
1475 truc obj;
1476 char *buf;
1477 forminfo *fptr;
1478 {
1479     variant v;
1480     int k, ch, len, width;
1481 
1482     v.xx = obj;
1483     ch = v.pp.ww;
1484     if(quotemode) {
1485         if(ch < ' ' || ch == 127) {
1486             len = s1form(buf,"chr(~D)",(wtruc)ch);
1487         }
1488         else {
1489             len = s1form(buf,"'~C'",(wtruc)ch);
1490         }
1491         return(len);
1492     }
1493     if(!ch)
1494         ch = ' ';
1495     width = fptr->param[0];
1496     if(width == 0)
1497         len = 1;
1498     else
1499         len = (width > 0 ? width : -width);
1500     fillspaces(buf,len);
1501     k = (width >= 0 ? len-1 : 0);
1502     buf[k] = ch;
1503     return(len);
1504 }
1505 /*--------------------------------------------------------------*/
bool2str(obj,buf)1506 PRIVATE int bool2str(obj,buf)
1507 truc obj;
1508 char *buf;
1509 {
1510     obj = (obj == true ? truesym : falsesym);
1511     return(strcopy(buf,SYMname(obj)));
1512 }
1513 /*--------------------------------------------------------------*/
1514 /*
1515 ** Verwandelt ein truc obj = (b0,b1: byte; ww: word2) in ein word4,
1516 ** so dass b0 das most significant byte wird
1517 */
truc2msf(obj)1518 PRIVATE word4 truc2msf(obj)
1519 truc obj;
1520 {
1521     variant v;
1522     word4 u;
1523 
1524     v.xx = (word4)obj;
1525     u = v.pp.b0;
1526     u = (u << 8)|v.pp.b1;
1527     u = (u << 16)|v.pp.ww;
1528     return(u);
1529 }
1530 /*--------------------------------------------------------------*/
ptr2str(obj,buf)1531 PRIVATE int ptr2str(obj,buf)
1532 truc obj;
1533 char *buf;
1534 {
1535     obj = PTRtarget(obj);
1536     if(obj == nil)
1537         return(strcopy(buf,SYMname(nil)));
1538     return(s1form(buf,"<PTR^~X>",(wtruc)truc2msf(obj)));
1539 }
1540 /*--------------------------------------------------------------*/
obj2str(flg,obj,buf)1541 PRIVATE int obj2str(flg,obj,buf)
1542 int flg;
1543 truc obj;
1544 char *buf;
1545 {
1546     word4 u;
1547     char *str;
1548 
1549     u = truc2msf(obj);
1550     switch(flg) {
1551     case fSTACK:
1552         str = "STACK";
1553         break;
1554     case fFUNDEF:
1555         str = "FUNCTION";
1556         break;
1557     case fSTREAM:
1558         u = (word4)STREAMfile(obj);
1559         str = "STREAM";
1560         break;
1561     default:
1562         if(flg >= fSPECIAL1 && flg <= fBUILTINn) {
1563             str = "PROC";
1564         }
1565         else
1566             str = "OBJECT";
1567     }
1568     return(s2form(buf,"<~A:~X>",(wtruc)str,(wtruc)u));
1569 }
1570 /*--------------------------------------------------------------*/
leftpad(buf,width,ch)1571 PRIVATE int leftpad(buf,width,ch)
1572 char *buf;
1573 int width;
1574 int ch;
1575 {
1576     int i, diff;
1577     int len = strlen(buf);
1578 
1579     diff = width - len;
1580     if(diff <= 0)
1581         return(len);
1582     for(i=len; i>=0; i--)
1583         buf[diff+i] = buf[i];
1584     for(i=0; i<diff; i++)
1585         buf[i] = ch;
1586     return(width);
1587 }
1588 /*--------------------------------------------------------------*/
fillspaces(buf,n)1589 PRIVATE int fillspaces(buf,n)
1590 char *buf;
1591 int n;
1592 {
1593     int i;
1594 
1595     for(i=0; i<n; i++)
1596         *buf++ = ' ';
1597     *buf = 0;
1598     return(n);
1599 }
1600 /*--------------------------------------------------------------*/
fprintstr(strom,str)1601 PUBLIC int fprintstr(strom,str)
1602 truc strom;
1603 char *str;
1604 {
1605     return fprintwrap(strom,str,PrintCols,0);
1606 }
1607 /*--------------------------------------------------------------*/
fprintwrap(strom,str,bound,contmark)1608 PRIVATE int fprintwrap(strom,str,bound,contmark)
1609 truc strom;
1610 char *str;
1611 int bound, contmark;
1612 {
1613     ifun writech;
1614     int ch;
1615     int i, n;
1616 
1617     writech = putcfun(strom);
1618     i = STREAMpos(strom);
1619     n = 0;
1620     while((ch = *str++)) {
1621         writech(ch);
1622         n++;
1623         if(ch >= ' ') {
1624             i++;
1625         }
1626         else {
1627             if((ch == EOL) || (ch == '\r'))
1628                 i = 0;
1629             else if(ch == '\b')
1630                 i = (i > 0 ? i-1 : 0);
1631             else if(ch == '\t')
1632                 i = (i | 0x3) + 1;
1633             else if(ch)
1634                 i++;
1635         }
1636         if(i >= bound) {
1637             i = 0;
1638             if(contmark)
1639                 writech(contmark);
1640             writech(EOL);
1641         }
1642     }
1643     STREAMpos(strom) = i;
1644     return(n);
1645 }
1646 /*--------------------------------------------------------------*/
fprintmarg(strom,str,len)1647 PRIVATE int fprintmarg(strom,str,len)
1648 truc strom;
1649 char *str;
1650 int len;
1651 {
1652     if(STREAMpos(strom) >= PrintCols-len)
1653         fnewline(strom);
1654     return fprintwrap(strom,str,PrintCols,0);
1655 }
1656 /*--------------------------------------------------------------*/
fprintline(strom,str)1657 PUBLIC void fprintline(strom,str)
1658 truc strom;
1659 char *str;
1660 {
1661     fprintwrap(strom,str,PrintCols,0);
1662     fnewline(strom);
1663 }
1664 /*--------------------------------------------------------------*/
fnewline(strom)1665 PUBLIC void fnewline(strom)
1666 truc strom;
1667 {
1668     ifun writech;
1669 
1670     writech = putcfun(strom);
1671     writech(EOL);
1672     STREAMpos(strom) = 0;
1673 }
1674 /*--------------------------------------------------------------*/
ffreshline(strom)1675 PUBLIC void ffreshline(strom)
1676 truc strom;
1677 {
1678     if(STREAMpos(strom) != 0)
1679         fnewline(strom);
1680 }
1681 /*--------------------------------------------------------------*/
flinepos0(strom)1682 PUBLIC void flinepos0(strom)
1683 truc strom;
1684 {
1685     STREAMpos(strom) = 0;
1686 }
1687 /*--------------------------------------------------------------*/
fprintch(strom,ch)1688 PRIVATE int fprintch(strom,ch)
1689 truc strom;
1690 int ch;
1691 {
1692     ifun writech;
1693 
1694     writech = putcfun(strom);
1695     if(STREAMpos(strom) >= PrintCols || ch == EOL) {
1696         writech(EOL);
1697         STREAMpos(strom) = 0;
1698     }
1699     if(ch != EOL) {
1700         writech(ch);
1701         STREAMpos(strom) += 1;
1702     }
1703     return(STREAMpos(strom));
1704 }
1705 /*--------------------------------------------------------------*/
long2alfa(buf,u)1706 PRIVATE int long2alfa(buf,u)
1707 char *buf;
1708 long u;
1709 {
1710     word2 x[2], y[3];
1711     int n, s = 0;
1712 
1713     if(u < 0) {
1714         u = - u;
1715         *buf++ = '-';
1716         s = 1;
1717     }
1718     n = long2big(u,x);
1719     n = big2bcd(x,n,y);
1720     return(bcd2str(y,n,buf) + s);
1721 }
1722 /*--------------------------------------------------------------*/
long2s0alfa(buf,u,len)1723 PRIVATE int long2s0alfa(buf,u,len)
1724 char *buf;
1725 long u;
1726 int len;
1727 {
1728     word2 x[2], y[3];
1729     int i,n;
1730     int m = 0, s = 0;
1731 
1732     if(u < 0) {
1733         u = - u;
1734         s = 1;
1735     }
1736     n = long2big(u,x);
1737     n = big2bcd(x,n,y);
1738     if(s || n < len) {
1739         *buf++ = (s ? '-' : '+');
1740         m++;
1741     }
1742     for(i=n+m; i<len; i++) {
1743         *buf++ = '0';
1744         m++;
1745     }
1746     if(n > 0)
1747         bcd2str(y,n,buf);
1748     else
1749         *buf = 0;
1750     return(n + m);
1751 }
1752 /*--------------------------------------------------------------*/
word4xalfa(buf,u)1753 PRIVATE int word4xalfa(buf,u)
1754 char *buf;
1755 word4 u;
1756 {
1757     word2 x[2];
1758     int n;
1759 
1760     n = long2big(u,x);
1761     return(big2xstr(x,n,buf));
1762 }
1763 /*--------------------------------------------------------------*/
s1form(buf,fmt,dat)1764 PUBLIC int s1form(buf,fmt,dat)
1765 char *buf;
1766 char *fmt;
1767 wtruc dat;
1768 {
1769     return(s2form(buf,fmt,dat,(wtruc)0));
1770 }
1771 /*--------------------------------------------------------------*/
s2form(buf,fmt,dat1,dat2)1772 PUBLIC int s2form(buf,fmt,dat1,dat2)
1773 char *buf;
1774 char *fmt;
1775 wtruc dat1, dat2;
1776 {
1777     forminfo finf;
1778     char *fmt1;
1779     wtruc dat;
1780     int mode;
1781     int n = 0;
1782     int count = 0;
1783 
1784     while((fmt1 = formscan(fmt,&finf))) {
1785         mode = finf.mode;
1786         if(mode == 0) {
1787             n += strncopy(buf+n,fmt,finf.param[0]);
1788         }
1789         else if(mode == '%') {
1790             n += strcopy(buf+n,"\n");
1791         }
1792         else if(mode == aERROR) {
1793             buf[n] = 0;
1794             break;
1795         }
1796         else {
1797             if(++count > 2)
1798                 break;
1799             dat = (count == 1 ? dat1 : dat2);
1800             n += sformaux(&finf,buf+n,dat);
1801         }
1802         fmt = fmt1;
1803     }
1804     return(n);
1805 }
1806 /*--------------------------------------------------------------*/
1807 /*
1808 ** Unterstuetzte Optionen:
1809 ** ~A string, ~D long int, ~X long hex, ~C character
1810 **
1811 */
sformaux(fmptr,buf,dat)1812 PRIVATE int sformaux(fmptr,buf,dat)
1813 forminfo *fmptr;
1814 char *buf;
1815 wtruc dat;
1816 {
1817     char *ptr1, *ptr2;
1818     int i, len, width, mode;
1819     char fill;
1820 
1821     mode = fmptr->mode;
1822     switch(mode) {
1823         case 'A':
1824             ptr1 = (char *)dat;
1825             len = strcopy(buf,ptr1);
1826             break;
1827         case 'D':
1828             len = long2alfa(buf,(long)dat);
1829             break;
1830         case 'X':
1831             len = word4xalfa(buf,(word4)dat);
1832             break;
1833         case 'C':
1834             buf[0] = (char)dat;
1835             buf[1] = 0;
1836             len = 1;
1837             break;
1838         default:
1839             buf[0] = 0;
1840             return(0);
1841     }
1842     width = fmptr->param[0];
1843     if(width > len) {
1844         fill = fmptr->param[1];
1845         ptr2 = buf + width;
1846         ptr1 = buf + len;
1847         for(i=0; i<=len; i++, ptr1--, ptr2--)
1848             *ptr2 = *ptr1;
1849         for(i=len; i<width; i++, ptr2--)
1850             *ptr2 = fill;
1851         len = width;
1852     }
1853     return(len);
1854 }
1855 /*--------------------------------------------------------------*/
formscan(str,fmptr)1856 PRIVATE char *formscan(str,fmptr)
1857 char *str;
1858 forminfo *fmptr;
1859 {
1860     int n, x;
1861     int sign, ch;
1862 
1863     if(*str == 0)
1864         return(NULL);
1865     for(n=0; n<FORMPARAM; n++)
1866         fmptr->param[n] = NOTSET;
1867 
1868     if(*str != '~') {
1869         fmptr->mode = 0;
1870         for(n=1; (ch=*++str); n++)
1871             if(ch == '~') break;
1872         fmptr->param[0] = n;
1873         return(str);
1874     }
1875 
1876     str++;
1877     ch = *str;
1878     if(ch == '0') {
1879         fmptr->param[1] = '0';
1880         str++;
1881     }
1882     else {
1883         fmptr->param[1] = ' ';
1884     }
1885     x = str2int(str,&n);
1886     fmptr->param[0] = x;
1887     str += n;
1888 
1889     if((ch = isformdir(*str))) {
1890         fmptr->mode = ch;
1891         return(str + 1);
1892     }
1893     else {
1894         fmptr->mode = aERROR;
1895         return(NULL);
1896     }
1897 }
1898 /*--------------------------------------------------------------*/
isformdir(ch)1899 PRIVATE int isformdir(ch)
1900 int ch;
1901 {
1902     if(ch == 'A' || ch == 'C' || ch == 'D' || ch == 'X' || ch == '%')
1903         return(ch);
1904     else
1905         return(0);
1906 }
1907 /****************************************************************/
1908