Front page | perl.perl5.porters |
Postings from August 2008
patch available, needs review (was: pack "q" in 32-bit environments)
Thread Previous
|
Thread Next
From:
Ted Zlatanov
Date:
August 6, 2008 12:30
Subject:
patch available, needs review (was: pack "q" in 32-bit environments)
Message ID:
861w12j5tf.fsf_-_@lifelogs.com
This patch makes it possible to enable quad support in vec(), (un)pack(),
and sprintf() on systems where Perl knows how to use quads. [Currently they
are supported only on systems where IV is a quad.]
This feature is enabled with -DUSE_QUAD_ANYWAY only. Defining USE_QUAD_ANYWAY
is safe: if no quad support is available, it has no effect.
Enjoy,
Ilya
P.S. This is a "minimal disruption" patch. Of course, a correct fix is to
disable this `#undef HAS_QUAD' mess in perl.h, but it may have some
effects due to backward-compatibility.
Moreover, I would be more happy to have SvQV(sv) and sv_setqv(sv,quad)
which can be made much more convenient than the code used below; but
again, introducing new API one should be quite careful due to binary
compatibility issues. I will be happy to fix this at a later time,
when I may switch to 5.9.* branch.
P.P.S. Three possible case can be controled separately by VEC_QUAD,
SPRINTF_QUAD and PACK_QUAD - but these 3 are not safe to use in absense
of quad support.
--- ./sv.c-pre Mon Nov 3 00:04:30 2003
+++ ./sv.c Tue Dec 16 16:34:22 2003
@@ -8348,6 +8352,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
unsigned base = 0;
IV iv = 0;
UV uv = 0;
+#if defined(SPRINTF_QUAD) && !defined(HAS_QUAD)
+ Uquad_t quv;
+#else
+# define quv uv
+#endif
/* we need a long double target in case HAS_LONG_DOUBLE but
not USE_LONG_DOUBLE
*/
@@ -8540,10 +8549,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
q++;
break;
#endif
-#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+#if defined(SPRINTF_QUAD) || defined(HAS_LONG_DOUBLE)
case 'L': /* Ld */
/* FALL THROUGH */
-#ifdef HAS_QUAD
+#ifdef SPRINTF_QUAD
case 'q': /* qd */
#endif
intsize = 'q';
@@ -8551,7 +8560,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
break;
#endif
case 'l':
-#if defined(HAS_QUAD) || defined(HAS_LONG_DOUBLE)
+#if defined(SPRINTF_QUAD) || defined(HAS_LONG_DOUBLE)
if (*(q + 1) == 'l') { /* lld, llf */
intsize = 'q';
q += 2;
@@ -8691,8 +8700,23 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
default: iv = va_arg(*args, int); break;
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
-#ifdef HAS_QUAD
- case 'q': iv = va_arg(*args, Quad_t); break;
+#ifdef SPRINTF_QUAD
+ case 'q': {
+ Quad_t qiv = va_arg(*args, Quad_t);
+# ifdef IV_IS_QUAD
+ iv = (IV)qiv;
+# else
+ if (qiv < 0) {
+ quv = -qiv;
+ esignbuf[esignlen++] = '-';
+ }
+ else
+ quv = qiv;
+ base = 10;
+ goto quad_integer;
+# endif
+ }
+ break;
#endif
}
}
@@ -8703,8 +8727,25 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
default: break;
case 'l': iv = (long)iv; break;
case 'V': break;
-#ifdef HAS_QUAD
- case 'q': iv = (Quad_t)iv; break;
+#ifdef SPRINTF_QUAD
+ case 'q':
+# ifdef IV_IS_QUAD
+ iv = (Quad_t)iv; break;
+
+# else
+ {
+ Quad_t qiv = (Quad_t)SvNVx(argsv);
+
+ if (qiv < 0) {
+ quv = -qiv;
+ esignbuf[esignlen++] = '-';
+ }
+ else
+ quv = qiv;
+ base = 10;
+ goto quad_integer;
+ }
+# endif
#endif
}
}
@@ -8775,8 +8816,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
default: uv = va_arg(*args, unsigned); break;
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
-#ifdef HAS_QUAD
- case 'q': uv = va_arg(*args, Quad_t); break;
+#ifdef SPRINTF_QUAD
+ case 'q': quv = va_arg(*args, Quad_t);
+# ifndef USE_QUAD
+ goto quad_integer;
+# endif
+ break;
#endif
}
}
@@ -8787,8 +8832,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
default: break;
case 'l': uv = (unsigned long)uv; break;
case 'V': break;
-#ifdef HAS_QUAD
- case 'q': uv = (Quad_t)uv; break;
+#ifdef SPRINTF_QUAD
+ case 'q':
+# ifdef USE_QUAD
+ quv = (Uquad_t)uv;
+# else
+ quv = (Uquad_t)SvNVx(argsv);
+ goto quad_integer;
+# endif
+ break;
#endif
}
}
@@ -8858,6 +8910,72 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
}
break;
+#if defined(SPRINTF_QUAD) && !defined(USE_QUAD)
+ quad_integer:
+ eptr = ebuf + sizeof ebuf;
+ switch (base) {
+ unsigned dig;
+ case 16:
+ if (!quv)
+ alt = FALSE;
+ p = (char*)((c == 'X')
+ ? "0123456789ABCDEF" : "0123456789abcdef");
+ do {
+ dig = quv & 15;
+ *--eptr = p[dig];
+ } while (quv >>= 4);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = c; /* 'x' or 'X' */
+ }
+ break;
+ case 8:
+ do {
+ dig = quv & 7;
+ *--eptr = '0' + dig;
+ } while (quv >>= 3);
+ if (alt && *eptr != '0')
+ *--eptr = '0';
+ break;
+ case 2:
+ do {
+ dig = quv & 1;
+ *--eptr = '0' + dig;
+ } while (quv >>= 1);
+ if (alt) {
+ esignbuf[esignlen++] = '0';
+ esignbuf[esignlen++] = 'b';
+ }
+ break;
+ default: /* it had better be ten or less */
+#if defined(PERL_Y2KWARN)
+ if (ckWARN(WARN_Y2K)) {
+ STRLEN n;
+ char *s = SvPV(sv,n);
+ if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
+ && (n == 2 || !isDIGIT(s[n-3])))
+ {
+ Perl_warner(aTHX_ packWARN(WARN_Y2K),
+ "Possible Y2K bug: %%%c %s",
+ c, "format string following '19'");
+ }
+ }
+#endif
+ do {
+ dig = quv % base;
+ *--eptr = '0' + dig;
+ } while (quv /= base);
+ break;
+ }
+ elen = (ebuf + sizeof ebuf) - eptr;
+ if (has_precis) {
+ if (precis > elen)
+ zeros = precis - elen;
+ else if (precis == 0 && elen == 1 && *eptr == '0')
+ elen = 0;
+ }
+ break;
+#endif
/* FLOATING POINT */
case 'F':
@@ -9057,7 +9175,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
default: *(va_arg(*args, int*)) = i; break;
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
-#ifdef HAS_QUAD
+#ifdef SPRINTF_QUAD
case 'q': *(va_arg(*args, Quad_t*)) = i; break;
#endif
}
@@ -9178,6 +9296,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const cha
goto vector;
}
}
+#undef quv
}
/* =========================================================================
--- ./pp_pack.c-pre Sat Oct 18 11:45:42 2003
+++ ./pp_pack.c Wed Dec 10 00:28:22 2003
@@ -291,7 +291,7 @@ S_measure_struct(pTHX_ register tempsym_
case 'p':
size = sizeof(char*);
break;
-#ifdef HAS_QUAD
+#ifdef PACK_QUAD
case 'q':
size = sizeof(Quad_t);
break;
@@ -547,15 +547,17 @@ S_unpack_rec(pTHX_ register tempsym_t* s
short ashort;
int aint;
long along;
-#ifdef HAS_QUAD
+#ifdef PACK_QUAD
Quad_t aquad;
+ Uquad_t auquad;
+ Uquad_t cuquad = 0;
+ const int bits_in_uquad = 8 * sizeof(cuquad);
+#else
+ const int bits_in_uquad = 8 * sizeof(UV);
#endif
U16 aushort;
unsigned int auint;
U32 aulong;
-#ifdef HAS_QUAD
- Uquad_t auquad;
-#endif
char *aptr;
float afloat;
double adouble;
@@ -606,6 +608,9 @@ S_unpack_rec(pTHX_ register tempsym_t* s
checksum = len;
cuv = 0;
cdouble = 0;
+#ifdef PACK_QUAD
+ cuquad = 0;
+#endif
continue;
break;
case '(':
@@ -794,8 +799,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
aint = *s++;
if (aint >= 128) /* fake up signed chars */
aint -= 256;
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aint;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aint;
+#endif
else
cuv += aint;
}
@@ -858,8 +867,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV));
along = alen;
s += along;
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)auint;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)auint;
+#endif
else
cuv += auint;
}
@@ -890,11 +903,14 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
COPYNN(s, &ashort, sizeof(short));
s += sizeof(short);
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)ashort;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)ashort;
+#endif
else
cuv += ashort;
-
}
}
else {
@@ -927,8 +943,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
ashort -= 65536;
#endif
s += SIZE16;
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)ashort;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)ashort;
+#endif
else
cuv += ashort;
}
@@ -964,6 +984,10 @@ S_unpack_rec(pTHX_ register tempsym_t* s
s += sizeof(unsigned short);
if (checksum > bits_in_uv)
cdouble += (NV)aushort;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aushort;
+#endif
else
cuv += aushort;
}
@@ -1004,8 +1028,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
if (datumtype == 'v')
aushort = vtohs(aushort);
#endif
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aushort;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aushort;
+#endif
else
cuv += aushort;
}
@@ -1041,8 +1069,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
Copy(s, &aint, 1, int);
s += sizeof(int);
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aint;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aint;
+#endif
else
cuv += aint;
}
@@ -1095,8 +1127,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
Copy(s, &auint, 1, unsigned int);
s += sizeof(unsigned int);
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)auint;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)auint;
+#endif
else
cuv += auint;
}
@@ -1130,8 +1166,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
Copy(s, &aiv, 1, IV);
s += IVSIZE;
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aiv;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aiv;
+#endif
else
cuv += aiv;
}
@@ -1158,8 +1198,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
Copy(s, &auv, 1, UV);
s += UVSIZE;
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)auv;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)auv;
+#endif
else
cuv += auv;
}
@@ -1187,8 +1231,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
COPYNN(s, &along, sizeof(long));
s += sizeof(long);
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)along;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)along;
+#endif
else
cuv += along;
}
@@ -1225,8 +1273,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
along -= 4294967296;
#endif
s += SIZE32;
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)along;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)along;
+#endif
else
cuv += along;
}
@@ -1262,8 +1314,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
unsigned long aulong;
COPYNN(s, &aulong, sizeof(unsigned long));
s += sizeof(unsigned long);
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aulong;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aulong;
+#endif
else
cuv += aulong;
}
@@ -1304,8 +1360,12 @@ S_unpack_rec(pTHX_ register tempsym_t* s
if (datumtype == 'V')
aulong = vtohl(aulong);
#endif
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aulong;
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aulong;
+#endif
else
cuv += aulong;
}
@@ -1411,7 +1471,7 @@ S_unpack_rec(pTHX_ register tempsym_t* s
sv_setpvn(sv, aptr, len);
PUSHs(sv_2mortal(sv));
break;
-#ifdef HAS_QUAD
+#ifdef PACK_QUAD
case 'q':
along = (strend - s) / sizeof(Quad_t);
if (len > along)
@@ -1420,8 +1480,10 @@ S_unpack_rec(pTHX_ register tempsym_t* s
while (len-- > 0) {
Copy(s, &aquad, 1, Quad_t);
s += sizeof(Quad_t);
- if (checksum > bits_in_uv)
+ if (checksum > bits_in_uquad)
cdouble += (NV)aquad;
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)aquad;
else
cuv += aquad;
}
@@ -1441,8 +1503,11 @@ S_unpack_rec(pTHX_ register tempsym_t* s
sv = NEWSV(42, 0);
if (aquad >= IV_MIN && aquad <= IV_MAX)
sv_setiv(sv, (IV)aquad);
- else
+ else {
+ sv_setpvf(sv, "%qd", aquad);
sv_setnv(sv, (NV)aquad);
+ SvPOK_on(sv); /* ==> double-headed */
+ }
PUSHs(sv_2mortal(sv));
}
}
@@ -1457,6 +1522,8 @@ S_unpack_rec(pTHX_ register tempsym_t* s
s += sizeof(Uquad_t);
if (checksum > bits_in_uv)
cdouble += (NV)auquad;
+ else if (checksum > bits_in_uv)
+ cuquad += (Uquad_t)auquad;
else
cuv += auquad;
}
@@ -1476,8 +1543,11 @@ S_unpack_rec(pTHX_ register tempsym_t* s
sv = NEWSV(43, 0);
if (auquad <= UV_MAX)
sv_setuv(sv, (UV)auquad);
- else
- sv_setnv(sv, (NV)auquad);
+ else {
+ sv_setpvf(sv, "%qu", auquad);
+ sv_setnv(sv, (NV)auquad);
+ SvPOK_on(sv); /* ==> double-headed */
+ }
PUSHs(sv_2mortal(sv));
}
}
@@ -1650,7 +1720,7 @@ S_unpack_rec(pTHX_ register tempsym_t* s
if (checksum) {
sv = NEWSV(42, 0);
if (strchr("fFdD", datumtype) ||
- (checksum > bits_in_uv &&
+ (checksum > bits_in_uquad &&
strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) {
NV trouble;
@@ -1664,6 +1734,18 @@ S_unpack_rec(pTHX_ register tempsym_t* s
cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble;
sv_setnv(sv, cdouble);
}
+#ifdef PACK_QUAD
+ else if (checksum > bits_in_uv
+ && strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) {
+ if (checksum < bits_in_uquad) {
+ Uquad_t mask = ((Uquad_t)1 << checksum) - 1;
+ cuquad &= mask;
+ }
+ sv_setpvf(sv, "%qu", cuquad);
+ sv_setnv(sv, (NV)cuquad);
+ SvPOK_on(sv); /* Make it double-headed */
+ }
+#endif
else {
if (checksum < bits_in_uv) {
UV mask = ((UV)1 << checksum) - 1;
@@ -1908,7 +1990,7 @@ S_pack_rec(pTHX_ SV *cat, register temps
#if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)
long double aldouble;
#endif
-#ifdef HAS_QUAD
+#ifdef PACK_QUAD
Quad_t aquad;
Uquad_t auquad;
#endif
@@ -2545,18 +2627,38 @@ S_pack_rec(pTHX_ SV *cat, register temps
CAT32(cat, &along);
}
break;
-#ifdef HAS_QUAD
+#ifdef PACK_QUAD
case 'Q':
while (len-- > 0) {
fromstr = NEXTFROM;
+#ifdef UV_IS_QUAD
auquad = (Uquad_t)SvUV(fromstr);
+#else
+ anv = SvNV(fromstr);
+ if (anv >= (NV)UQUAD_MAX)
+ auquad = UQUAD_MAX;
+ else if (anv <= 0)
+ auquad = 0;
+ else
+ auquad = (Uquad_t)anv;
+#endif
sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t));
}
break;
case 'q':
while (len-- > 0) {
fromstr = NEXTFROM;
+#ifdef IV_IS_QUAD
aquad = (Quad_t)SvIV(fromstr);
+#else
+ anv = SvNV(fromstr);
+ if (anv >= (NV)QUAD_MAX)
+ aquad = QUAD_MAX;
+ else if (anv <= (NV)QUAD_MIN)
+ aquad = QUAD_MIN;
+ else
+ aquad = (Quad_t)anv;
+#endif
sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t));
}
break;
--- ./perl.h-pre Sat Nov 1 04:24:06 2003
+++ ./perl.h Wed Dec 10 02:01:26 2003
@@ -1078,6 +1078,10 @@ int sockatmark(int);
typedef IVTYPE IV;
typedef UVTYPE UV;
+#ifdef HAS_QUAD /* XXX Silly equilibristic... */
+# define CAN_USE_QUAD
+#endif
+
#if defined(USE_64_BIT_INT) && defined(HAS_QUAD)
# if QUADKIND == QUAD_IS_INT64_T && defined(INT64_MAX)
# define IV_MAX INT64_MAX
@@ -1119,12 +1123,19 @@ typedef UVTYPE UV;
# define UV_IS_QUAD
# ifndef HAS_QUAD
# define HAS_QUAD
+# define CAN_USE_QUAD
# endif
# else
# undef IV_IS_QUAD
# undef UV_IS_QUAD
# undef HAS_QUAD
# endif
+#endif
+
+#if defined(CAN_USE_QUAD) && (defined(HAS_QUAD) || defined(USE_QUAD_ANYWAY))
+# define PACK_QUAD
+# define SPRINTF_QUAD
+# define VEC_QUAD
#endif
#if defined(uts) || defined(UTS)
--- ./handy.h-pre Tue Sep 30 09:10:34 2003
+++ ./handy.h Tue Dec 9 23:47:24 2003
@@ -136,13 +136,13 @@ typedef U16TYPE U16;
typedef I32TYPE I32;
typedef U32TYPE U32;
#ifdef PERL_CORE
-# ifdef HAS_QUAD
+# ifdef CAN_USE_QUAD
typedef I64TYPE I64;
typedef U64TYPE U64;
# endif
#endif /* PERL_CORE */
-#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
+#if defined(CAN_USE_QUAD)
# ifndef UINT64_C /* usually from <inttypes.h> */
# if defined(HAS_LONG_LONG) && QUADKIND == QUAD_IS_LONG_LONG
# define INT64_C(c) CAT2(c,LL)
@@ -208,6 +208,22 @@ typedef U64TYPE U64;
#endif
#endif
+
+#if defined(CAN_USE_QUAD)
+# ifndef INT64_MAX
+# define INT64_MAX INT64_C(9223372036854775807)
+# endif
+# ifndef INT64_MIN
+# define INT64_MIN (-INT64_MAX-1)
+# endif
+# ifndef UINT64_MAX
+# define UINT64_MAX UINT64_C(18446744073709551615)
+# endif
+#endif
+
+#define QUAD_MAX INT64_MAX
+#define QUAD_MIN INT64_MIN
+#define UQUAD_MAX UINT64_MAX
/* log(2) is pretty close to 0.30103, just in case anyone is grepping for it */
#define BIT_DIGITS(N) (((N)*146)/485 + 1) /* log2(10) =~ 146/485 */
--- ./t/op/pack.t-pre Sat Oct 18 11:46:30 2003
+++ ./t/op/pack.t Wed Dec 10 01:34:58 2003
@@ -293,7 +293,7 @@ foreach my $t (@templates) {
is(scalar @t, 2);
SKIP: {
- skip "$t not expected to work for some reason", 2 if $t =~ /[nv]/i;
+ # skip "$t not expected to work for some reason", 2 if $t =~ /[nv]/i;
is($t[0], 12);
is($t[1], 34);
@@ -390,15 +390,34 @@ sub numbers {
return numbers_with_total ($format, undef, @_);
}
+sub lift_to_power_of_2 { # 2^p + $n for negative $n
+ my ($n, $p) = @_;
+ return 0 unless eval {unpack "%${p}c", pack 'c', -1}; # Give up for high prec
+ return $n if $n >= 0;
+ my $res = unpack "%${p}j", pack "j", $n;
+ # Now check the rounded value, and return invalid value if fishy
+ return -444 unless $res - $n == 2**$p;
+ # Check modulo 0x100
+ return -555 if $res =~ /^\d*(\d{8})$/ and ($1 - $n) % (1<<8);
+ return $res;
+}
+
sub numbers_with_total {
my $format = shift;
my $total = shift;
+ my $appr_total = $total;
if (!defined $total) {
foreach (@_) {
- $total += $_;
+ $appr_total += $_;
}
+ if ($appr_total < 0 && eval {unpack '%55c', pack 'c', -1}) {
+ # can calculate high-precision packs
+ $total = sub { my $prec = shift; lift_to_power_of_2($appr_total, $prec)};
+ } else {
+ $total = $appr_total;
+ }
}
- print "# numbers test for $format\n";
+ print "# numbers test for $format: @_\n";
foreach (@_) {
SKIP: {
my $out = eval {unpack($format, pack($format, $_))};
@@ -406,7 +425,11 @@ sub numbers_with_total {
$@ =~ /Invalid type '$format'/;
is($@, '');
- is($out, $_);
+ if (/e/) {
+ is($out+0, $_+0); # Does not fit into integer
+ } else {
+ is($out, $_);
+ }
}
}
@@ -434,6 +457,8 @@ sub numbers_with_total {
SKIP: {
skip "cannot test checksums over $skip_if_longer_than bits", 1
if $len > $skip_if_longer_than;
+ skip "cannot test checksums with Q on this perl", 1
+ if lc $format eq 'q' and ~0 < 1e10;
# Our problem with testing this portably is that the checksum code in
# pp_unpack is able to cast signed to unsigned, and do modulo 2**n
@@ -469,8 +494,12 @@ sub numbers_with_total {
# UV arithmetic, or because we're doing a floating point checksum)
# and our calculation of the checksum has become rounded up to
# max_checksum + 1
- $calc_sum = 0;
+ $calc_sum = 0
+ unless $format !~ /dDfF/
+ and eval {unpack "%${_}$format", pack $format, -1};
}
+ $calc_sum += 2**64, $calc_sum -= 2**64, $sum += 2**64, $sum -= 2**64
+ if lc $format eq 'q' and ~0 < 1e10; # Round
if ($calc_sum == $sum) { # HAS to be ==, not eq (so no is()).
ok ("unpack '%$_$format' gave $sum");
@@ -480,7 +509,7 @@ sub numbers_with_total {
&& ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) {
pass ("unpack '%$_$format' gave $sum, expected $calc_sum");
} else {
- my $text = ref $total ? &$total($len) : $total;
+ my $text = ref $appr_total ? &$appr_total($len) : $appr_total;
fail;
print "# For list (" . join (", ", @_) . ") (total $text)"
. " packed with $format unpack '%$_$format' gave $sum,"
@@ -516,7 +545,7 @@ numbers ('d', -(2**34), -1, 0, 1, 2**34)
## These don't, but 'd' is NV. XXX wrong, it's double
#numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1));
-numbers_with_total ('q', -1,
+numbers_with_total ('q', -1, # -2^63 etc
-9223372036854775808, -1, 0, 1,9223372036854775807);
# This total is icky, but the true total is 2**65-1, and need a way to generate
# the epxected checksum on any system including those where NVs can preserve
--- ./t/op/64bitint.t-pre Tue Dec 9 22:08:44 2003
+++ ./t/op/64bitint.t Tue Dec 9 22:36:20 2003
@@ -1,11 +1,12 @@
#./perl
+my $is64;
BEGIN {
- eval { my $q = pack "q", 0 };
- if ($@) {
+ eval { $is64 = "1111111111111111112" eq 1+unpack "q", pack "q", 1e19/9 ; 1}
+ or do {
print "1..0 # Skip: no 64-bit types\n";
exit(0);
- }
+ };
chdir 't' if -d 't';
@INC = '../lib';
}
@@ -19,6 +20,8 @@ no warnings qw(overflow portable);
print "1..67\n";
+my $not64 = ($is64 ? 'not ' : '');
+
# as 6 * 6 = 36, the last digit of 6**n will always be six. Hence the last
# digit of 16**n will always be six. Hence 16**n - 1 will always end in 5.
# Assumption is that UVs will always be a multiple of 4 bits long.
@@ -119,15 +122,15 @@ print "ok 17\n";
$x = sprintf("%D", $q);
-print "not " unless $x == $q && $x eq $q && $x > $f;
+print $not64 unless $x == $q && $x eq $q && $x > $f;
print "ok 18\n";
$x = sprintf("%U", $q);
-print "not " unless $x == $q && $x eq $q && $x > $f;
+print $not64 unless $x == $q && $x eq $q && $x > $f;
print "ok 19\n";
$x = sprintf("%O", $q);
-print "not " unless oct($x) == $q && oct($x) > $f;
+print $not64 unless oct($x) == $q && oct($x) > $f;
print "ok 20\n";
@@ -251,6 +254,10 @@ print "ok 39\n";
print "not " unless vec($x, 0, 64) == 0 && vec($x, 2, 64) == 0;
print "ok 40\n";
+unless ($is64) {
+ print "ok $_ # skipped: IV is not 64bit\n" for 41..67;
+ exit;
+}
print "not " unless ~0 == 0xffffffffffffffff;
print "ok 41\n";
--- ./pp.c-pre Tue Sep 30 09:11:50 2003
+++ ./pp.c Wed Dec 10 02:41:08 2003
@@ -3108,6 +3108,16 @@ PP(pp_vec)
LvTARGLEN(TARG) = size;
}
+#if defined(VEC_QUAD) && !defined(UV_IS_QUAD)
+ if (size == 64) {
+ Uquad_t q = ((Uquad_t)do_vecget(src, 2*offset, 32) << 32)
+ + do_vecget(src, 2*offset + 1, 32);
+
+ sv_setpvf(TARG, "%qu", q);
+ sv_setnv(TARG, (NV)q);
+ SvPOK_on(TARG); /* Make two-headed */
+ } else
+#endif
sv_setuv(TARG, do_vecget(src, offset, size));
PUSHs(TARG);
RETURN;
--- ./mg.c-pre Sun Oct 19 10:53:26 2003
+++ ./mg.c Wed Dec 10 02:55:12 2003
@@ -1785,6 +1785,17 @@ Perl_magic_getvec(pTHX_ SV *sv, MAGIC *m
return 0;
}
+#if defined(VEC_QUAD) && !defined(UV_IS_QUAD)
+ if (LvTARGLEN(sv) == 64) {
+ int offset = LvTARGOFF(sv);
+ Uquad_t q = ((Uquad_t)do_vecget(lsv, 2*offset, 32) << 32)
+ + do_vecget(lsv, 2*offset + 1, 32);
+
+ sv_setpvf(sv, "%qu", q);
+ sv_setnv(sv, (NV)q);
+ SvPOK_on(sv); /* Make two-headed */
+ } else
+#endif
sv_setuv(sv, do_vecget(lsv, LvTARGOFF(sv), LvTARGLEN(sv)));
return 0;
}
--- ./doop.c-pre Tue Sep 30 09:09:50 2003
+++ ./doop.c Wed Dec 10 02:30:56 2003
@@ -855,6 +855,12 @@ Perl_do_vecset(pTHX_ SV *sv)
register I32 size;
register unsigned char *s;
register UV lval;
+#if defined(VEC_QUAD) && !defined(UV_IS_QUAD)
+ Uquad_t qlval;
+ I32 osize;
+#else
+# define osize size
+#endif
I32 mask;
STRLEN targlen;
STRLEN len;
@@ -871,16 +877,24 @@ Perl_do_vecset(pTHX_ SV *sv)
}
(void)SvPOK_only(targ);
+ size = LvTARGLEN(sv);
+#if defined(VEC_QUAD) && !defined(UV_IS_QUAD)
+ osize = size;
+ if (size == 64) {
+ size = 32;
+ qlval = (Uquad_t)SvNV(sv);
+ lval = (UV)(qlval >> 32);
+ } else
+#endif
lval = SvUV(sv);
offset = LvTARGOFF(sv);
if (offset < 0)
Perl_croak(aTHX_ "Negative offset to vec in lvalue context");
- size = LvTARGLEN(sv);
if (size < 1 || (size & (size-1))) /* size < 1 or not a power of two */
Perl_croak(aTHX_ "Illegal number of bits in vec");
- offset *= size; /* turn into bit offset */
- len = (offset + size + 7) / 8; /* required number of bytes */
+ offset *= osize; /* turn into bit offset */
+ len = (offset + osize + 7) / 8; /* required number of bytes */
if (len > targlen) {
s = (unsigned char*)SvGROW(targ, len + 1);
(void)memzero((char *)(s + targlen), len - targlen + 1);
@@ -908,6 +922,14 @@ Perl_do_vecset(pTHX_ SV *sv)
s[offset+1] = (U8)((lval >> 16) & 0xff);
s[offset+2] = (U8)((lval >> 8) & 0xff);
s[offset+3] = (U8)( lval & 0xff);
+#if defined(VEC_QUAD) && !defined(UV_IS_QUAD)
+ if (osize == 64) {
+ s[offset+4] = (U8)((qlval >> 24) & 0xff);
+ s[offset+5] = (U8)((qlval >> 16) & 0xff);
+ s[offset+6] = (U8)((qlval >> 8) & 0xff);
+ s[offset+7] = (U8)( qlval & 0xff);
+ }
+#endif
}
#ifdef UV_IS_QUAD
else if (size == 64) {
@@ -926,6 +948,7 @@ Perl_do_vecset(pTHX_ SV *sv)
#endif
}
SvSETMAGIC(targ);
+#undef osize
}
void
Thread Previous
|
Thread Next