#define PERL_IN_SV_C
#include "perl.h"
-#ifdef OVR_DBL_DIG
-/* Use an overridden DBL_DIG */
-# ifdef DBL_DIG
-# undef DBL_DIG
-# endif
-# define DBL_DIG OVR_DBL_DIG
-#else
-/* The following is all to get DBL_DIG, in order to pick a nice
- default value for printing floating point numbers in Gconvert.
- (see config.h)
-*/
-#ifdef I_LIMITS
-#include <limits.h>
-#endif
-#ifdef I_FLOAT
-#include <float.h>
-#endif
-#ifndef HAS_DBL_DIG
-#define DBL_DIG 15 /* A guess that works lots of places */
-#endif
-#endif
-
-#ifdef PERL_OBJECT
-#define VTBL this->*vtbl
-#else /* !PERL_OBJECT */
-#define VTBL *vtbl
-#endif /* PERL_OBJECT */
-
#define FCALL *f
#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
pv = (char*)SvRV(sv);
cur = 0;
len = 0;
- iv = (IV)pv;
- nv = (NV)(unsigned long)pv;
+ iv = PTR2IV(pv);
+ nv = PTR2NV(pv);
del_XRV(SvANY(sv));
magic = 0;
stash = 0;
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
return SvIV(tmpstr);
- return (IV)SvRV(sv);
+ return PTR2IV(SvRV(sv));
}
if (SvREADONLY(sv) && !SvOK(sv)) {
dTHR;
#ifdef IV_IS_QUAD
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
- (UV)sv,
+ PTR2UV(sv),
(UV)SvUVX(sv), (IV)SvUVX(sv)));
#else
DEBUG_c(PerlIO_printf(Perl_debug_log,
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
return SvUV(tmpstr);
- return (UV)SvRV(sv);
+ return PTR2UV(SvRV(sv));
}
if (SvREADONLY(sv) && !SvOK(sv)) {
dTHR;
(void)SvNOK_on(sv);
(void)SvIOK_on(sv);
#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
(unsigned long)sv, SvNVX(sv)));
#else
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
return SvNV(tmpstr);
- return (NV)(unsigned long)SvRV(sv);
+ return PTR2NV(SvRV(sv));
}
if (SvREADONLY(sv) && !SvOK(sv)) {
dTHR;
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
RESTORE_NUMERIC_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIg64 ")\n",
+ PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
(unsigned long)sv, SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
RESTORE_NUMERIC_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
+ PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
(unsigned long)sv, SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
goto tokensave;
}
if (SvNOKp(sv)) {
- Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
+ Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
else
sv_setpv(tsv, s);
#ifdef IV_IS_QUAD
- Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv);
+ Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", PTR2UV(sv));
#else
Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
#endif
}
if (SvNOKp(sv)) { /* See note in sv_2uv() */
/* XXXX 64-bit? IV may have better precision... */
+ /* I tried changing this for to be 64-bit-aware and
+ * the t/op/numconvert.t became very, very, angry.
+ * --jhi Sep 1999 */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvGROW(sv, 28);
else
#endif /*apollo*/
{
- Gconvert(SvNVX(sv), DBL_DIG, 0, s);
+ Gconvert(SvNVX(sv), NV_DIG, 0, s);
}
errno = olderrno;
#ifdef FIXNEGATIVEZERO
MGVTBL* vtbl = mg->mg_virtual;
*mgp = mg->mg_moremagic;
if (vtbl && (vtbl->svt_free != NULL))
- (VTBL->svt_free)(aTHX_ sv, mg);
+ CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
if (mg->mg_ptr && mg->mg_type != 'g')
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
/* Here is some breathtakingly efficient cheating */
- cnt = PerlIO_get_cnt(aTHX_ fp); /* get count into register */
+ cnt = PerlIO_get_cnt(fp); /* get count into register */
(void)SvPOK_only(sv); /* validate pointer */
if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
if (cnt > 80 && SvLEN(sv) > append) {
else
shortbuffered = 0;
bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
- ptr = (STDCHAR*)PerlIO_get_ptr(aTHX_ fp);
+ ptr = (STDCHAR*)PerlIO_get_ptr(fp);
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
- (long)PerlIO_get_ptr(aTHX_ fp), (long)PerlIO_get_cnt(aTHX_ fp),
- (long)(PerlIO_has_base(fp) ? PerlIO_get_base(aTHX_ fp) : 0)));
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
screamer:
if (cnt > 0) {
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
- PerlIO_set_ptrcnt(aTHX_ fp, ptr, cnt); /* deregisterize cnt and ptr */
+ PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
- (long)PerlIO_get_ptr(aTHX_ fp), (long)PerlIO_get_cnt(aTHX_ fp),
- (long)(PerlIO_has_base (fp) ? PerlIO_get_base(aTHX_ fp) : 0)));
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
/* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
- (long)PerlIO_get_ptr(aTHX_ fp), (long)PerlIO_get_cnt(aTHX_ fp),
- (long)(PerlIO_has_base (fp) ? PerlIO_get_base(aTHX_ fp) : 0)));
- cnt = PerlIO_get_cnt(aTHX_ fp);
- ptr = (STDCHAR*)PerlIO_get_ptr(aTHX_ fp); /* reregisterize cnt and ptr */
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+ cnt = PerlIO_get_cnt(fp);
+ ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
- PerlIO_set_ptrcnt(aTHX_ fp, ptr, cnt); /* put these back or we're in trouble */
+ PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
- (long)PerlIO_get_ptr(aTHX_ fp), (long)PerlIO_get_cnt(aTHX_ fp),
- (long)(PerlIO_has_base (fp) ? PerlIO_get_base(aTHX_ fp) : 0)));
+ (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
+ (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
*bp = '\0';
SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
DEBUG_P(PerlIO_printf(Perl_debug_log,
IV i;
if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
return;
- i = (IV)SvRV(sv);
+ i = PTR2IV(SvRV(sv));
sv_unref(sv);
sv_setiv(sv, i);
}
IV i;
if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
return;
- i = (IV)SvRV(sv);
+ i = PTR2IV(SvRV(sv));
sv_unref(sv);
sv_setiv(sv, i);
}
SvSETMAGIC(rv);
}
else
- sv_setiv(newSVrv(rv,classname), (IV)pv);
+ sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
return rv;
}
char *eptr = Nullch;
STRLEN elen = 0;
- char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
+ /* Times 4: a decimal digit takes more than 3 binary digits.
+ * NV_DIG: mantissa takes than many decimal digits.
+ * Plus 32: Playing safe. */
+ char ebuf[IV_DIG * 4 + NV_DIG + 32];
+ /* large enough for "%#.#f" --chip */
+ /* what about long double NVs? --jhi */
char c;
int i;
unsigned base;
case 'p':
if (args)
- uv = (UV)va_arg(*args, void*);
+ uv = PTR2UV(va_arg(*args, void*));
else
- uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
+ uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
base = 16;
goto integer;
case 'D':
#ifdef IV_IS_QUAD
- /* nothing */
+ intsize = 'q';
#else
intsize = 'l';
#endif
if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
-#ifdef IV_IS_QUAD
- default: iv = va_arg(*args, IV); break;
-#else
default: iv = va_arg(*args, int); break;
-#endif
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
#ifdef HAS_QUAD
iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
switch (intsize) {
case 'h': iv = (short)iv; break;
-#ifdef IV_IS_QUAD
- default: break;
-#else
default: iv = (int)iv; break;
-#endif
case 'l': iv = (long)iv; break;
case 'V': break;
#ifdef HAS_QUAD
case 'U':
#ifdef IV_IS_QUAD
- /* nothing */
+ intsize = 'q';
#else
intsize = 'l';
#endif
case 'O':
#ifdef IV_IS_QUAD
- /* nothing */
+ intsize = 'q';
#else
intsize = 'l';
#endif
if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
-#ifdef UV_IS_QUAD
- default: uv = va_arg(*args, UV); break;
-#else
default: uv = va_arg(*args, unsigned); break;
-#endif
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
#ifdef HAS_QUAD
uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
switch (intsize) {
case 'h': uv = (unsigned short)uv; break;
-#ifdef UV_IS_QUAD
- default: break;
-#else
default: uv = (unsigned)uv; break;
-#endif
case 'l': uv = (unsigned long)uv; break;
case 'V': break;
#ifdef HAS_QUAD
dig = uv & 1;
*--eptr = '0' + dig;
} while (uv >>= 1);
- if (alt && *eptr != '0')
- *--eptr = '0';
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = 'b';
+ }
break;
default: /* it had better be ten or less */
do {
*--eptr = c;
#ifdef USE_LONG_DOUBLE
{
- char* p = PRIfldbl + sizeof(PRIfldbl) - 3;
- while (p >= PRIfldbl) { *--eptr = *p-- }
+ char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
+ while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
}
#endif
if (has_precis) {
if (args) {
switch (intsize) {
case 'h': *(va_arg(*args, short*)) = i; break;
-#ifdef IV_IS_QUAD
- default: *(va_arg(*args, IV*)) = i; break;
-#else
default: *(va_arg(*args, int*)) = i; break;
-#endif
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
#ifdef HAS_QUAD