cvs commit: ponie/perl embed.fnc embed.h global.sym pp_ctl.c proto.h scope.c scope.h
[email protected] (Nicholas Clark) 16 Oct 2004 10:28:03 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
cvsuser 04/10/16 03:28:01
Modified: perl embed.fnc embed.h global.sym pp_ctl.c proto.h
scope.c scope.h
Log:
ponie can't (sanely) support save_set_svflags as it needs direct access to the
SV's flag bits. Add save_set_padstale, which implements all that is needed
for the only (core) user of save_set_svflags, which is to restore the PADSTALE
flag.
Revision Changes Path
1.32 +1 -0 ponie/perl/embed.fnc
Index: embed.fnc
===================================================================
RCS file: /cvs/public/ponie/perl/embed.fnc,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -w -r1.31 -r1.32
--- embed.fnc 24 Jun 2004 14:31:33 -0000 1.31
+++ embed.fnc 16 Oct 2004 10:27:59 -0000 1.32
@@ -1464,6 +1464,7 @@
p |int |get_debug_opts |char **s
#endif
Ap |void |save_set_svflags|SV* sv|U32 mask|U32 val
+Ap |void |save_set_padstale|SV* sv|
Apod |void |hv_assert |HV* tb
#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
1.22 +2 -0 ponie/perl/embed.h
Index: embed.h
===================================================================
RCS file: /cvs/public/ponie/perl/embed.h,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -w -r1.21 -r1.22
--- embed.h 24 Jun 2004 14:31:33 -0000 1.21
+++ embed.h 16 Oct 2004 10:27:59 -0000 1.22
@@ -2205,6 +2205,7 @@
#endif
#endif
#define save_set_svflags Perl_save_set_svflags
+#define save_set_padstale Perl_save_set_padstale
#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define hv_delete_common S_hv_delete_common
@@ -4760,6 +4761,7 @@
#endif
#endif
#define save_set_svflags(a,b,c) Perl_save_set_svflags(aTHX_ a,b,c)
+#define save_set_padstale(a) Perl_save_set_padstale(aTHX_ a)
#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
#ifdef PERL_CORE
#define hv_delete_common(a,b,c,d,e,f,g) S_hv_delete_common(aTHX_ a,b,c,d,e,f,g)
1.16 +1 -0 ponie/perl/global.sym
Index: global.sym
===================================================================
RCS file: /cvs/public/ponie/perl/global.sym,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -w -r1.15 -r1.16
--- global.sym 24 Jun 2004 10:04:16 -0000 1.15
+++ global.sym 16 Oct 2004 10:27:59 -0000 1.16
@@ -738,6 +738,7 @@
Perl_PerlIO_stdout
Perl_PerlIO_stderr
Perl_save_set_svflags
+Perl_save_set_padstale
Perl_hv_assert
Perl_hv_clear_placeholders
Perl_hv_scalar
1.2 +189 -115 ponie/perl/pp_ctl.c
Index: pp_ctl.c
===================================================================
RCS file: /cvs/public/ponie/perl/pp_ctl.c,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- pp_ctl.c 9 Sep 2003 11:58:52 -0000 1.1
+++ pp_ctl.c 16 Oct 2004 10:27:59 -0000 1.2
@@ -1,7 +1,7 @@
/* pp_ctl.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -59,6 +59,7 @@
/* XXXX Should store the old value to allow for tie/overload - and
restore in regcomp, where marked with XXXX. */
PL_reginterp_cnt = 0;
+ TAINT_NOT;
return NORMAL;
}
@@ -158,15 +159,12 @@
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
SV *nsv = Nullsv;
-
- {
REGEXP *old = PM_GETRE(pm);
if(old != rx) {
if(old)
ReREFCNT_dec(old);
PM_SETRE(pm,rx);
}
- }
rxres_restore(&cx->sb_rxres, rx);
RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
@@ -258,6 +256,7 @@
sv_pos_b2u(sv, &i);
mg->mg_len = i;
}
+ if (old != rx)
ReREFCNT_inc(rx);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
@@ -370,15 +369,20 @@
bool item_is_utf8 = FALSE;
bool targ_is_utf8 = FALSE;
SV * nsv = Nullsv;
+ OP * parseres = 0;
+ char *fmt;
+ bool oneline;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
if (SvREADONLY(tmpForm)) {
SvREADONLY_off(tmpForm);
- doparseform(tmpForm);
+ parseres = doparseform(tmpForm);
SvREADONLY_on(tmpForm);
}
else
- doparseform(tmpForm);
+ parseres = doparseform(tmpForm);
+ if (parseres)
+ return parseres;
}
SvPV_force(PL_formtarget, len);
if (DO_UTF8(PL_formtarget))
@@ -414,6 +418,7 @@
case FF_LINEMARK: name = "LINEMARK"; break;
case FF_END: name = "END"; break;
case FF_0DECIMAL: name = "0DECIMAL"; break;
+ case FF_LINESNGL: name = "LINESNGL"; break;
}
if (arg >= 0)
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
@@ -520,6 +525,7 @@
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
@@ -559,6 +565,7 @@
while (s < send) {
if (*s == '\r') {
itemsize = s - item;
+ chophere = s;
break;
}
if (*s++ & ~31)
@@ -649,7 +656,7 @@
sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
for (; t < SvEND(PL_formtarget); t++) {
#ifdef EBCDIC
- int ch = *t++ = *s++;
+ int ch = *t;
if (iscntrl(ch))
#else
if (!(*t & ~31))
@@ -679,7 +686,13 @@
SvSETMAGIC(sv);
break;
+ case FF_LINESNGL:
+ chopspace = 0;
+ oneline = TRUE;
+ goto ff_line;
case FF_LINEGLOB:
+ oneline = FALSE;
+ ff_line:
item = s = SvPV(sv, len);
itemsize = len;
if ((item_is_utf8 = DO_UTF8(sv)))
@@ -688,19 +701,30 @@
bool chopped = FALSE;
gotsome = TRUE;
send = s + len;
+ chophere = s + itemsize;
while (s < send) {
if (*s++ == '\n') {
+ if (oneline) {
+ chopped = TRUE;
+ chophere = s;
+ break;
+ } else {
if (s == send) {
itemsize--;
chopped = TRUE;
- }
- else
+ } else
lines++;
}
}
+ }
SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
if (targ_is_utf8)
SvUTF8_on(PL_formtarget);
+ if (oneline) {
+ SvCUR_set(sv, chophere - item);
+ sv_catsv(PL_formtarget, sv);
+ SvCUR_set(sv, itemsize);
+ } else
sv_catsv(PL_formtarget, sv);
if (chopped)
SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
@@ -711,46 +735,24 @@
}
break;
+ case FF_0DECIMAL:
+ arg = *fpc++;
+#if defined(USE_LONG_DOUBLE)
+ fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl;
+#else
+ fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f";
+#endif
+ goto ff_dec;
case FF_DECIMAL:
- /* If the field is marked with ^ and the value is undefined,
- blank it out. */
arg = *fpc++;
- if ((arg & 512) && !SvOK(sv)) {
- arg = fieldsize;
- while (arg--)
- *t++ = ' ';
- break;
- }
- gotsome = TRUE;
- value = SvNV(sv);
- /* Formats aren't yet marked for locales, so assume "yes". */
- {
- STORE_NUMERIC_STANDARD_SET_LOCAL();
#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
+ fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl;
#else
- if (arg & 256) {
- sprintf(t, "%#*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%*.0f",
- (int) fieldsize, value);
- }
+ fmt = (arg & 256) ? "%#*.*f" : "%*.*f";
#endif
- RESTORE_NUMERIC_STANDARD();
- }
- t += fieldsize;
- break;
-
- case FF_0DECIMAL:
+ ff_dec:
/* If the field is marked with ^ and the value is undefined,
blank it out. */
- arg = *fpc++;
if ((arg & 512) && !SvOK(sv)) {
arg = fieldsize;
while (arg--)
@@ -759,26 +761,17 @@
}
gotsome = TRUE;
value = SvNV(sv);
+ /* overflow evidence */
+ if (num_overflow(value, fieldsize, arg)) {
+ arg = fieldsize;
+ while (arg--)
+ *t++ = '#';
+ break;
+ }
/* Formats aren't yet marked for locales, so assume "yes". */
{
STORE_NUMERIC_STANDARD_SET_LOCAL();
-#if defined(USE_LONG_DOUBLE)
- if (arg & 256) {
- sprintf(t, "%#0*.*" PERL_PRIfldbl,
- (int) fieldsize, (int) arg & 255, value);
-/* is this legal? I don't have long doubles */
- } else {
- sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
- }
-#else
- if (arg & 256) {
- sprintf(t, "%#0*.*f",
- (int) fieldsize, (int) arg & 255, value);
- } else {
- sprintf(t, "%0*.0f",
- (int) fieldsize, value);
- }
-#endif
+ sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value);
RESTORE_NUMERIC_STANDARD();
}
t += fieldsize;
@@ -870,13 +863,18 @@
ENTER; /* enter outer scope */
SAVETMPS;
- /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
- SAVESPTR(DEFSV);
+ if (PL_op->op_private & OPpGREP_LEX)
+ SAVESPTR(PAD_SVl(PL_op->op_targ));
+ else
+ SAVE_DEFSV;
ENTER; /* enter inner scope */
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
DEFSV = src;
PUTBACK;
@@ -941,9 +939,20 @@
}
/* copy the new items down to the destination list */
dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
+ if (gimme == G_ARRAY) {
while (items-- > 0)
*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
}
+ else {
+ /* scalar context: we don't care about which values map returns
+ * (we use undef here). And so we certainly don't want to do mortal
+ * copies of meaningless values. */
+ while (items-- > 0) {
+ (void)POPs;
+ *dst-- = &PL_sv_undef;
+ }
+ }
+ }
LEAVE; /* exit inner scope */
/* All done yet? */
@@ -956,9 +965,16 @@
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
+ if (PL_op->op_private & OPpGREP_LEX) {
+ SV* sv = sv_newmortal();
+ sv_setiv(sv, items);
+ PUSHs(sv);
+ }
+ else {
dTARGET;
XPUSHi(items);
}
+ }
else if (gimme == G_ARRAY)
SP += items;
RETURN;
@@ -972,6 +988,9 @@
/* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
SvTEMP_off(src);
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
DEFSV = src;
RETURNOP(cLOGOP->op_other);
@@ -1032,6 +1051,16 @@
}
}
+/* This code tries to decide if "$left .. $right" should use the
+ magical string increment, or if the range is numeric (we make
+ an exception for .."0" [#18165]). AMS 20021031. */
+
+#define RANGE_IS_NUMERIC(left,right) ( \
+ SvNIOKp(left) || (SvOK(left) && !SvPOKp(left)) || \
+ SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
+ (((!SvOK(left) && SvOK(right)) || (looks_like_number(left) && \
+ SvPOKp(left) && *SvPVX(left) != '0')) && looks_like_number(right)))
+
PP(pp_flop)
{
dSP;
@@ -1047,15 +1076,7 @@
if (SvGMAGICAL(right))
mg_get(right);
- /* This code tries to decide if "$left .. $right" should use the
- magical string increment, or if the range is numeric (we make
- an exception for .."0" [#18165]). AMS 20021031. */
-
- if (SvNIOKp(left) || !SvPOKp(left) ||
- SvNIOKp(right) || !SvPOKp(right) ||
- (looks_like_number(left) && *SvPVX(left) != '0' &&
- looks_like_number(right)))
- {
+ if (RANGE_IS_NUMERIC(left,right)) {
if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
DIE(aTHX_ "Range iterator outside integer range");
i = SvIV(left);
@@ -1402,6 +1423,9 @@
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, n_a);
+ SV *nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+ &PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
@@ -1703,7 +1727,6 @@
PUSHBLOCK(cx, CXt_SUB, SP);
PUSHSUB_DB(cx);
CvDEPTH(cv)++;
- (void)SvREFCNT_inc(cv);
PAD_SET_CUR(CvPADLIST(cv),1);
RETURNOP(CvSTART(cv));
}
@@ -1733,8 +1756,7 @@
if (PL_op->op_targ) {
if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
- SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
- SVs_PADSTALE, SVs_PADSTALE);
+ SAVESETPADSTALE(PAD_SVl(PL_op->op_targ));
}
#ifndef USE_ITHREADS
svp = &PAD_SVl(PL_op->op_targ); /* "my" variable */
@@ -1767,20 +1789,18 @@
cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
dPOPss;
- /* See comment in pp_flop() */
- if (SvNIOKp(sv) || !SvPOKp(sv) ||
- SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
- (looks_like_number(sv) && *SvPVX(sv) != '0' &&
- looks_like_number((SV*)cx->blk_loop.iterary)))
- {
+ if (RANGE_IS_NUMERIC(sv,(SV*)cx->blk_loop.iterary)) {
if (SvNV(sv) < IV_MIN ||
SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
DIE(aTHX_ "Range iterator outside integer range");
cx->blk_loop.iterix = SvIV(sv);
cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
}
- else
+ else {
+ STRLEN n_a;
cx->blk_loop.iterlval = newSVsv(sv);
+ SvPV_force(cx->blk_loop.iterlval,n_a);
+ }
}
}
else {
@@ -2097,6 +2117,7 @@
TOPBLOCK(cx);
oldsave = PL_scopestack[PL_scopestack_ix - 1];
LEAVE_SCOPE(oldsave);
+ FREETMPS;
return cx->blk_loop.redo_op;
}
@@ -2164,6 +2185,7 @@
char *label;
int do_dump = (PL_op->op_type == OP_DUMP);
static char must_have_label[] = "goto must have label";
+ AV *oldav = Nullav;
label = 0;
if (PL_op->op_flags & OPf_STACKED) {
@@ -2224,7 +2246,7 @@
GvAV(PL_defgv) = cx->blk_sub.savearray;
/* abandon @_ if it got reified */
if (AvREAL(av)) {
- (void)sv_2mortal((SV*)av); /* delay until return */
+ oldav = av; /* delay until return */
av = newAV();
av_extend(av, items-1);
AvFLAGS(av) = AVf_REIFY;
@@ -2250,6 +2272,9 @@
/* Now do some callish stuff. */
SAVETMPS;
+ /* For reified @_, delay freeing till return from new sub */
+ if (oldav)
+ SAVEFREESV((SV*)oldav);
SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
if (CvXSUB(cv)) {
#ifdef PERL_XSUB_OLDSTYLE
@@ -2677,7 +2702,7 @@
SAVETMPS;
/* switch to eval mode */
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
SAVECOPSTASH_FREE(&PL_compiling);
CopSTASH_set(&PL_compiling, PL_curstash);
}
@@ -2707,17 +2732,16 @@
#else
SAVEVPTR(PL_op);
#endif
- PL_hints &= HINT_UTF8;
/* we get here either during compilation, or via pp_regcomp at runtime */
- runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
+ runtime = IN_PERL_RUNTIME;
if (runtime)
runcv = find_runcv(NULL);
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
+ PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
if (runtime)
@@ -2733,7 +2757,7 @@
/* XXX DAPM do this properly one year */
*padp = (AV*)SvREFCNT_inc(PL_comppad);
LEAVE;
- if (PL_curcop == &PL_compiling)
+ if (IN_PERL_COMPILETIME)
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
#ifdef OP_IN_REGISTER
op = PL_opsave;
@@ -2842,7 +2866,7 @@
sv_setpv(ERRSV,"");
if (yyparse() || PL_error_count || !PL_eval_root) {
SV **newsp; /* Used by POPBLOCK. */
- PERL_CONTEXT *cx;
+ PERL_CONTEXT *cx = &cxstack[cxstack_ix];
I32 optype = 0; /* Might be reset by POPEVAL. */
STRLEN n_a;
@@ -2861,6 +2885,9 @@
LEAVE;
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, n_a);
+ SV *nsv = cx->blk_eval.old_namesv;
+ (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
+ &PL_sv_undef, 0);
DIE(aTHX_ "%sCompilation failed in require",
*msg ? msg : "Unknown error\n");
}
@@ -3049,9 +3076,12 @@
DIE(aTHX_ "Null filename used");
TAINT_PROPER("require");
if (PL_op->op_type == OP_REQUIRE &&
- (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
- *svp != &PL_sv_undef)
+ (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
+ if (*svp != &PL_sv_undef)
RETPUSHYES;
+ else
+ DIE(aTHX_ "Compilation failed in require");
+ }
/* prepare to compile file */
@@ -3167,6 +3197,7 @@
PERL_SCRIPT_MODE);
}
}
+ SP--;
}
PUTBACK;
@@ -3551,7 +3582,7 @@
RETURNOP(retop);
}
-STATIC void
+STATIC OP *
S_doparseform(pTHX_ SV *sv)
{
STRLEN len;
@@ -3567,7 +3598,8 @@
U32 *linepc = 0;
register I32 arg;
bool ischop;
- int maxops = 2; /* FF_LINEMARK + FF_END) */
+ bool unchopnum = FALSE;
+ int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
if (len == 0)
Perl_croak(aTHX_ "Null picture in formline");
@@ -3607,8 +3639,12 @@
case ' ': case '\t':
skipspaces++;
continue;
-
- case '\n': case 0:
+ case 0:
+ if (s < send) {
+ skipspaces = 0;
+ continue;
+ } /* else FALL THROUGH */
+ case '\n':
arg = s - base;
skipspaces++;
arg -= skipspaces;
@@ -3664,7 +3700,11 @@
*fpc++ = FF_FETCH;
if (*s == '*') {
s++;
- *fpc++ = 0;
+ *fpc++ = 2; /* skip the @* or ^* */
+ if (ischop) {
+ *fpc++ = FF_LINESNGL;
+ *fpc++ = FF_CHOP;
+ } else
*fpc++ = FF_LINEGLOB;
}
else if (*s == '#' || (*s == '.' && s[1] == '#')) {
@@ -3683,6 +3723,7 @@
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_DECIMAL;
*fpc++ = (U16)arg;
+ unchopnum |= ! ischop;
}
else if (*s == '0' && s[1] == '#') { /* Zero padded decimals */
arg = ischop ? 512 : 0;
@@ -3701,6 +3742,7 @@
*fpc++ = s - base; /* fieldsize for FETCH */
*fpc++ = FF_0DECIMAL;
*fpc++ = (U16)arg;
+ unchopnum |= ! ischop;
}
else {
I32 prespace = 0;
@@ -3755,6 +3797,38 @@
Safefree(fops);
sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
SvCOMPILED_on(sv);
+
+ if (unchopnum && repeat)
+ DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
+ return 0;
+}
+
+
+STATIC bool
+S_num_overflow(NV value, I32 fldsize, I32 frcsize)
+{
+ /* Can value be printed in fldsize chars, using %*.*f ? */
+ NV pwr = 1;
+ NV eps = 0.5;
+ bool res = FALSE;
+ int intsize = fldsize - (value < 0 ? 1 : 0);
+
+ if (frcsize & 256)
+ intsize--;
+ frcsize &= 255;
+ intsize -= frcsize;
+
+ while (intsize--) pwr *= 10.0;
+ while (frcsize--) eps /= 10.0;
+
+ if( value >= 0 ){
+ if (value + eps >= pwr)
+ res = TRUE;
+ } else {
+ if (value - eps <= -pwr)
+ res = TRUE;
+ }
+ return res;
}
static I32
1.32 +1 -0 ponie/perl/proto.h
Index: proto.h
===================================================================
RCS file: /cvs/public/ponie/perl/proto.h,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -w -r1.31 -r1.32
--- proto.h 24 Jun 2004 14:31:34 -0000 1.31
+++ proto.h 16 Oct 2004 10:27:59 -0000 1.32
@@ -1405,6 +1405,7 @@
PERL_CALLCONV int Perl_get_debug_opts(pTHX_ char **s);
#endif
PERL_CALLCONV void Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val);
+PERL_CALLCONV void Perl_save_set_padstale(pTHX_ SV* sv);
PERL_CALLCONV void Perl_hv_assert(pTHX_ HV* tb);
#if defined(PERL_IN_HV_C) || defined(PERL_DECL_PROT)
1.7 +19 -0 ponie/perl/scope.c
Index: scope.c
===================================================================
RCS file: /cvs/public/ponie/perl/scope.c,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -w -r1.6 -r1.7
--- scope.c 13 Oct 2004 13:30:20 -0000 1.6
+++ scope.c 16 Oct 2004 10:27:59 -0000 1.7
@@ -310,6 +310,8 @@
Perl_save_set_svflags(pTHX_ SV* sv, U32 mask, U32 val)
{
SSCHECK(4);
+ Perl_croak(aTHX_ "panic: save_set_svflags called val=%08X mask=%08X",
+ val, mask);
SSPUSHPTR(sv);
SSPUSHINT(mask);
SSPUSHINT(val);
@@ -317,6 +319,14 @@
}
void
+Perl_save_set_padstale(pTHX_ SV* sv)
+{
+ SSCHECK(2);
+ SSPUSHPTR(sv);
+ SSPUSHINT(SAVEt_SET_PADSTALE);
+}
+
+void
Perl_save_gp(pTHX_ GV *gv, I32 empty)
{
SSGROW(6);
@@ -1077,10 +1087,19 @@
{
U32 val = (U32)SSPOPINT;
U32 mask = (U32)SSPOPINT;
+ Perl_croak(aTHX_
+ "panic: restore saved svflags val=%08X mask=%08X",
+ val, mask);
+
sv = (SV*)SSPOPPTR;
SvFLAGS(sv) &= ~mask;
SvFLAGS(sv) |= val;
}
+ case SAVEt_SET_PADSTALE:
+ {
+ sv = (SV*)SSPOPPTR;
+ SvPADSTALE_on(sv);
+ }
break;
default:
Perl_croak(aTHX_ "panic: leave_scope inconsistency");
1.2 +6 -1 ponie/perl/scope.h
Index: scope.h
===================================================================
RCS file: /cvs/public/ponie/perl/scope.h,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -w -r1.1 -r1.2
--- scope.h 9 Sep 2003 11:58:55 -0000 1.1
+++ scope.h 16 Oct 2004 10:27:59 -0000 1.2
@@ -1,7 +1,7 @@
/* scope.h
*
* Copyright (C) 1993, 1994, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, by Larry Wall and others
+ * 2000, 2001, 2002, 2004, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
@@ -48,6 +48,7 @@
#define SAVEt_SHARED_PVREF 37
#define SAVEt_BOOL 38
#define SAVEt_SET_SVFLAGS 39
+#define SAVEt_SET_PADSTALE 40
#ifndef SCOPE_SAVES_SIGNAL_MASK
#define SCOPE_SAVES_SIGNAL_MASK 0
@@ -133,7 +134,11 @@
#define SAVEGENERICSV(s) save_generic_svref((SV**)&(s))
#define SAVEGENERICPV(s) save_generic_pvref((char**)&(s))
#define SAVESHAREDPV(s) save_shared_pvref((char**)&(s))
+#if 0
+/* This epxects direct access to the SV flags, which ponie cannot support. *//
#define SAVESETSVFLAGS(sv,mask,val) save_set_svflags(sv,mask,val)
+#endif
+#define SAVESETPADSTALE(sv) save_set_padstale(sv)
#define SAVEDELETE(h,k,l) \
save_delete(SOFT_CAST(HV*)(h), SOFT_CAST(char*)(k), (I32)(l))
#define SAVEDESTRUCTOR(f,p) \