develooper 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


nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About