Introduces SvREPADTMP(sv) that marks a repad SvIV as a offset

[p5sagit/p5-mst-13.2.git] / sv.c

diff --git a/sv.c b/sv.c
index 7fbe14a..cd89509 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -540,7 +540,7 @@ Perl_report_uninit(pTHX)
 {
     if (PL_op)
        Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
-                   " in ", PL_op_desc[PL_op->op_type]);
+                   " in ", OP_DESC(PL_op));
     else
        Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
 }
@@ -1616,7 +1616,7 @@ Perl_sv_setiv(pTHX_ register SV *sv, IV i)
     case SVt_PVFM:
     case SVt_PVIO:
        Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
-                  PL_op_desc[PL_op->op_type]);
+                  OP_DESC(PL_op));
     }
     (void)SvIOK_only(sv);                      /* validate number */
     SvIVX(sv) = i;
@@ -1727,7 +1727,7 @@ Perl_sv_setnv(pTHX_ register SV *sv, NV num)
     case SVt_PVFM:
     case SVt_PVIO:
        Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
-                  PL_op_name[PL_op->op_type]);
+                  OP_NAME(PL_op));
     }
     SvNVX(sv) = num;
     (void)SvNOK_only(sv);                      /* validate number */
@@ -1807,7 +1807,7 @@ S_not_a_number(pTHX_ SV *sv)
     if (PL_op)
        Perl_warner(aTHX_ WARN_NUMERIC,
                    "Argument \"%s\" isn't numeric in %s", tmpbuf,
-               PL_op_desc[PL_op->op_type]);
+                       OP_DESC(PL_op));
     else
        Perl_warner(aTHX_ WARN_NUMERIC,
                    "Argument \"%s\" isn't numeric", tmpbuf);
@@ -2054,7 +2054,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
                ) {
                SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
                DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                     "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
+                                     "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n",
                                      PTR2UV(sv),
                                      SvNVX(sv),
                                      SvIVX(sv)));
@@ -2065,7 +2065,7 @@ Perl_sv_2iv(pTHX_ register SV *sv)
                   that PV->IV would be better than PV->NV->IV
                   flags already correct - don't set public IOK.  */
                DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                     "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
+                                     "0x%"UVxf" iv(%"NVgf" => %"IVdf") (imprecise)\n",
                                      PTR2UV(sv),
                                      SvNVX(sv),
                                      SvIVX(sv)));
@@ -2348,7 +2348,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
                ) {
                SvIOK_on(sv);  /* Can this go wrong with rounding? NWC */
                DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                     "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
+                                     "0x%"UVxf" uv(%"NVgf" => %"IVdf") (precise)\n",
                                      PTR2UV(sv),
                                      SvNVX(sv),
                                      SvIVX(sv)));
@@ -2359,7 +2359,7 @@ Perl_sv_2uv(pTHX_ register SV *sv)
                   that PV->IV would be better than PV->NV->IV
                   flags already correct - don't set public IOK.  */
                DEBUG_c(PerlIO_printf(Perl_debug_log,
-                                     "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
+                                     "0x%"UVxf" uv(%"NVgf" => %"IVdf") (imprecise)\n",
                                      PTR2UV(sv),
                                      SvNVX(sv),
                                      SvIVX(sv)));
@@ -2628,10 +2628,10 @@ Perl_sv_2nv(pTHX_ register SV *sv)
     }
     else if (SvTYPE(sv) < SVt_PVNV)
        sv_upgrade(sv, SVt_PVNV);
-    if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
-       SvNOK_on(sv);
+    if (SvNOKp(sv)) {
+        return SvNVX(sv);
     }
-    else if (SvIOKp(sv)) {
+    if (SvIOKp(sv)) {
        SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
 #ifdef NV_PRESERVES_UV
        SvNOK_on(sv);
@@ -3355,7 +3355,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
                        if (first && ch > 255) {
                            if (PL_op)
                                Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
-                                          PL_op_desc[PL_op->op_type]);
+                                          OP_DESC(PL_op);
                            else
                                Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
                            first = 0;
@@ -3370,7 +3370,7 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
                else {
                    if (PL_op)
                        Perl_croak(aTHX_ "Wide character in %s",
-                                  PL_op_desc[PL_op->op_type]);
+                                  OP_DESC(PL_op));
                    else
                        Perl_croak(aTHX_ "Wide character");
                }
@@ -3597,7 +3597,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
     case SVt_PVIO:
        if (PL_op)
            Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
-               PL_op_name[PL_op->op_type]);
+               OP_NAME(PL_op));
        else
            Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
        break;
@@ -4500,11 +4500,11 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     case PERL_MAGIC_dbline:
        mg->mg_virtual = &PL_vtbl_dbline;
        break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
     case PERL_MAGIC_mutex:
        mg->mg_virtual = &PL_vtbl_mutex;
        break;
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
 #ifdef USE_LOCALE_COLLATE
     case PERL_MAGIC_collxfrm:
         mg->mg_virtual = &PL_vtbl_collxfrm;
@@ -5829,7 +5829,9 @@ Perl_sv_inc(pTHX_ register SV *sv)
     }
     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
        /* It's publicly an integer, or privately an integer-not-float */
+#ifdef PERL_PRESERVE_IVUV
       oops_its_int:
+#endif
        if (SvIsUV(sv)) {
            if (SvUVX(sv) == UV_MAX)
                sv_setnv(sv, (NV)UV_MAX + 1.0);
@@ -5977,7 +5979,9 @@ Perl_sv_dec(pTHX_ register SV *sv)
     flags = SvFLAGS(sv);
     if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
        /* It's publicly an integer, or privately an integer-not-float */
+#ifdef PERL_PRESERVE_IVUV
       oops_its_int:
+#endif
        if (SvIsUV(sv)) {
            if (SvUVX(sv) == 0) {
                (void)SvIOK_only(sv);
@@ -6760,7 +6764,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
     else {
        if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
            Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
-               PL_op_name[PL_op->op_type]);
+               OP_NAME(PL_op));
        }
        else
            s = sv_2pv_flags(sv, lp, flags);
@@ -8318,8 +8322,8 @@ ptr_table_* functions.
 
 #if defined(USE_ITHREADS)
 
-#if defined(USE_THREADS)
-#  include "error: USE_THREADS and USE_ITHREADS are incompatible"
+#if defined(USE_5005THREADS)
+#  include "error: USE_5005THREADS and USE_ITHREADS are incompatible"
 #endif
 
 #ifndef GpREFCNT_inc
@@ -8403,6 +8407,10 @@ Perl_re_dup(pTHX_ REGEXP *r, clone_params *param)
                ret->regstclass = (regnode*)d->data[i];
                break;
            case 'o':
+               /* Compiled op trees are readonly, and can thus be
+                  shared without duplication. */
+               d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
+               break;
            case 'n':
                d->data[i] = r->data->data[i];
                break;
@@ -9086,6 +9094,11 @@ Perl_sv_dup(pTHX_ SV *sstr, clone_params* param)
        CvROOT(dstr)    = OpREFCNT_inc(CvROOT(sstr));
        CvXSUB(dstr)    = CvXSUB(sstr);
        CvXSUBANY(dstr) = CvXSUBANY(sstr);
+       if (CvCONST(sstr)) {
+           CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(sstr)) ?
+                SvREFCNT_inc(CvXSUBANY(sstr).any_ptr) :
+                sv_dup_inc(CvXSUBANY(sstr).any_ptr, param);
+       }
        CvGV(dstr)      = gv_dup(CvGV(sstr), param);
        if (param->flags & CLONEf_COPY_STACKS) {
          CvDEPTH(dstr) = CvDEPTH(sstr);
@@ -9545,6 +9558,8 @@ Create and return a new interpreter by cloning the current one.
 */
 
 /* XXX the above needs expanding by someone who actually understands it ! */
+EXTERN_C PerlInterpreter *
+perl_clone_host(PerlInterpreter* proto_perl, UV flags);
 
 PerlInterpreter *
 perl_clone(PerlInterpreter *proto_perl, UV flags)
@@ -9773,6 +9788,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_e_script                = sv_dup_inc(proto_perl->Ie_script, param);
     PL_perldb          = proto_perl->Iperldb;
     PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
+    PL_exit_flags       = proto_perl->Iexit_flags;
 
     /* magical thingies */
     /* XXX time(&PL_basetime) when asked for? */
@@ -9937,7 +9953,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
 #ifdef CSH
     PL_cshlen          = proto_perl->Icshlen;
-    PL_cshname         = SAVEPVN(proto_perl->Icshname, PL_cshlen);
+    PL_cshname         = proto_perl->Icshname; /* XXX never deallocated */
 #endif
 
     PL_lex_state       = proto_perl->Ilex_state;
@@ -10247,6 +10263,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_reg_re          = (regexp*)NULL;
     PL_reg_ganch       = Nullch;
     PL_reg_sv          = Nullsv;
+    PL_reg_sv_utf8     = FALSE;
     PL_reg_magic       = (MAGIC*)NULL;
     PL_reg_oldpos      = 0;
     PL_reg_oldcurpm    = (PMOP*)NULL;