From c89df6bff3e1d35ec00d05ede1265446fbb1d8c0 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Thu, 12 Jul 2001 02:36:42 +0000 Subject: UTS tweaks for Hal Morris. p4raw-id: //depot/perl@11284 --- MANIFEST | 1 + hints/uts.sh | 9 +-- perl.h | 4 ++ uts/sprintf_wrap.c | 196 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 206 insertions(+), 4 deletions(-) create mode 100644 uts/sprintf_wrap.c diff --git a/MANIFEST b/MANIFEST index 21b935b327..4ea5fa5220 100644 --- a/MANIFEST +++ b/MANIFEST @@ -2138,6 +2138,7 @@ utils/perlcc.PL Front-end for compiler utils/perldoc.PL A simple tool to find & display perl's documentation utils/pl2pm.PL A pl to pm translator utils/splain.PL Stand-alone version of diagnostics.pm +uts/sprintf_wrap.c sprintf wrapper for UTS uts/strtol_wrap.c strtol wrapper for UTS vmesa/Makefile VM/ESA Makefile vmesa/vmesa.c VM/ESA-specific C code for Perl core diff --git a/hints/uts.sh b/hints/uts.sh index 2f3b733c72..74bedbda06 100644 --- a/hints/uts.sh +++ b/hints/uts.sh @@ -1,8 +1,8 @@ archname='s390' -archobjs='uts/strtol_wrap.o' -cc='cc' +archobjs='uts/strtol_wrap.o uts/sprintf_wrap.o' +cc='cc -Xa' +ccflags='-XTSTRINGS=1500000 -DStrtol=strtol_wrap32 -DStrtoul=strtoul_wrap32 -DPERL_IGNORE_FPUSIG=SIGFPE -DSPRINTF_E_BUG' cccdlflags='-pic' -ccflags='-Xa -XTSTRINGS=1500000 -DStrtol=strtol_wrap32 -DStrtoul=strtoul_wrap32 -DPERL_IGNORE_FPUSIG=SIGFPE' d_bincompat3='undef' d_csh='undef' d_lstat='define' @@ -13,7 +13,7 @@ ld='ld' lddlflags='-G -z text' libperl='libperl.so' libpth='/lib /usr/lib /usr/ccs/lib' -libs='-lsocket -lnsl -ldl -lm' +libs='-lsocket -lnsl -ldl -lm' libswanted='m' prefix='/usr/local' toke_cflags='optimize=""' @@ -23,6 +23,7 @@ useshrplib='define' # Some less routine stuff: ################################# cc -g -Xa -c -pic -O uts/strtol_wrap.c -o uts/strtol_wrap.o +cc -g -Xa -c -pic -O uts/sprintf_wrap.c -o uts/sprintf_wrap.o # Make POSIX a static extension. cat <<'EOSH' > config.over static_ext='POSIX B' diff --git a/perl.h b/perl.h index 8f1cad367e..b4b1a4fb0c 100644 --- a/perl.h +++ b/perl.h @@ -1066,6 +1066,10 @@ int sockatmark(int); #undef UV #endif +#ifdef SPRINTF_E_BUG +# define sprintf UTS_sprintf_wrap +#endif + /* Configure gets this right but the UTS compiler gets it wrong. -- Hal Morris */ #ifdef UTS diff --git a/uts/sprintf_wrap.c b/uts/sprintf_wrap.c new file mode 100644 index 0000000000..e86eae084b --- /dev/null +++ b/uts/sprintf_wrap.c @@ -0,0 +1,196 @@ +#include +#include +#include +#include + +char *UTS_sprintf_wrap(); +char *do_efmt(); +char *do_gfmt(); +char *Fill(); + +/* main(argc, argv) + * char **argv; + * { + * double d; + * char *Fmt, *Ret; + * char obuf[200]; + * + * assert(argc > 2); + * Fmt = argv[1]; + * d = strtod(argv[2], (char **)0); + * + * putchar('{'); + * printf(Fmt, d); + * printf("}\n"); + * + * Ret = UTS_sprintf_wrap(obuf, Fmt, d); + * assert(Ret == obuf); + * + * printf("{%s}\n", obuf); + * } + */ + +char * +UTS_sprintf_wrap(obuf, fmt, d, + a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15) +char *obuf, *fmt; +double d; +{ + int fmtlen, Width=0, Precision=6, Alt=0, Plus=0, Minus=0, + Zero = 0; + int FmtChar, BaseFmt = 0; + char *f = fmt, *AfterWidth = 0, *AfterPrecision = 0; + char *Dot; + + if(*f++ != '%') { + return +sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15); + } + fmtlen = strlen(fmt); + FmtChar = fmt[fmtlen - 1]; + switch(FmtChar) { + case 'f': + case 'F': + return +sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15); + case 'e': + case 'E': + BaseFmt = 'e'; + goto BaseFmt_IsSet; + case 'g': + case 'G': + BaseFmt = 'g'; +BaseFmt_IsSet: + if(*f == '#') { Alt = 1; ++f; } /* Always has '.' */ + if(*f == '+') { Plus = 1; ++f; } /* Force explicit sign */ + if(*f == '-') { Minus = 1; ++f; } /* Left justify */ + if(*f == '0') { Zero = 1; ++f;} /* Fill using 0s*/ + if(Dot = strchr(f, '.')) { + Precision = strtol(Dot+1, &AfterPrecision, 0); + } + if(!Dot || (Dot && Dot > f)) { /* Next char=='.' => no width*/ + Width = strtol(f, &AfterWidth, 0); + } + if(Dot) { f = AfterPrecision; } + else if(AfterWidth) { f = AfterWidth; } + if(*f != FmtChar) goto regular_sprintf; + /* It doesn't look like a f.p. sprintf call */ + /* from Perl_sv_vcatpvfn */ + + if(BaseFmt == 'e') { + return do_efmt(d, obuf, Width, Precision, Alt, + Plus, Minus, Zero, FmtChar == 'E'); + } else { + return do_gfmt(d, obuf, Width, Precision, Alt, + Plus, Minus, Zero, FmtChar == 'G'); + } + default: +regular_sprintf: + return +sprintf(obuf, fmt, d, a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,a11,a12,a13,a14,a15); + } +} + +char * +do_efmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase) +char *obuf; +double d; +{ + char *Ecvt; + char *ob; + int decpt, sign, E; + int len; + int AllZeroes = 0; + + Ecvt = ecvt( d , Precision+1, &decpt, &sign); + + /* fprintf(stderr, "decpt=%d, sign=%d\n", decpt, sign); */ + + len = strlen(Ecvt); + if(strspn(Ecvt, "0") == len) AllZeroes = 1; + + ob = obuf; + if(sign) *ob++ = '-'; + else if(Plus) *ob++ = '+'; + + *ob++ = Ecvt[0]; + + if(Precision > 0 || Alt) *ob++ = '.'; + strcpy(ob, &Ecvt[1]); + + ob += strlen(ob); /* ADVANCE TO END OF WHAT WE JUST ADDED */ + *ob++ = UpperCase ? 'E' : 'e'; + + if(AllZeroes) E = 0; + else E = decpt - 1; + + if(E < 0) { *ob++ = '-'; E = -E; } + else { *ob++ = '+'; } + + sprintf(ob, "%.2d", E); /* Too much horsepower used here */ + + if(Width > strlen(obuf)) return Fill(obuf, Width, Minus, Zero); + else return obuf; +} + +char * +do_gfmt(d, obuf, Width, Precision, Alt, Plus, Minus, Zero, UpperCase) +char *obuf; +double d; +{ + char *Ecvt = gcvt(d, Precision ? Precision : 1, obuf); + int len = strlen(obuf); + + /* gcvt fails (maybe give a warning? For now return empty string): */ + if(!Ecvt) { *obuf = '\0'; return obuf; } + + /* printf("Ecvt='%s'\n", Ecvt); */ + if(Plus && (Ecvt[0] != '-')) { + memmove(obuf+1, obuf, len+1); /* "+1" to get '\0' at end */ + obuf[0] = '+'; + ++len; + } + if(Alt && !strchr(Ecvt, '.')) { + int LenUpTo_E = strcspn(obuf, "eE"); + int E_etc_len = strlen(&obuf[LenUpTo_E]); + /* ABOVE: Will be 0 if there's no E/e because */ + /* strcspn will return length of whole string */ + + if(E_etc_len) + memmove(obuf+LenUpTo_E+1, obuf+LenUpTo_E, E_etc_len); + obuf[LenUpTo_E] = '.'; + obuf[LenUpTo_E + 1 + E_etc_len ] = '\0'; + } + { char *E_loc; + if(UpperCase && (E_loc = strchr(obuf, 'e'))) { *E_loc = 'E'; } + } + if(Width > len) + return Fill(obuf, Width, Minus, Zero); + else + return obuf; +} + +char * +Fill(obuf, Width, LeftJustify, Zero) +char *obuf; +{ + int W = strlen(obuf); + int diff = Width - W; + /* LeftJustify means there was a '-' flag, and in that case, */ + /* printf man page (UTS4.4) says ignore '0' */ + char FillChar = (Zero && !LeftJustify) ? '0' : ' '; + int i; + int LeftFill = ! LeftJustify; + + if(Width <= W) return obuf; + + if(LeftFill) { + memmove(obuf+diff, obuf, W+1); /* "+1" to get '\0' at end */ + for(i=0 ; i < diff ; ++i) { obuf[i] = FillChar; } + } else { + for(i=W ; i < Width ; ++i) + obuf[i] = FillChar; + obuf[Width] = '\0'; + } + return obuf; +} -- cgit v1.2.1