#define magic_clearsig Perl_magic_clearsig
#define magic_existspack Perl_magic_existspack
#define magic_freeregexp Perl_magic_freeregexp
+#define magic_freeovrld Perl_magic_freeovrld
#define magic_get Perl_magic_get
#define magic_getarylen Perl_magic_getarylen
#define magic_getdefelem Perl_magic_getdefelem
#define magic_clearsig(a,b) Perl_magic_clearsig(aTHX_ a,b)
#define magic_existspack(a,b) Perl_magic_existspack(aTHX_ a,b)
#define magic_freeregexp(a,b) Perl_magic_freeregexp(aTHX_ a,b)
+#define magic_freeovrld(a,b) Perl_magic_freeovrld(aTHX_ a,b)
#define magic_get(a,b) Perl_magic_get(aTHX_ a,b)
#define magic_getarylen(a,b) Perl_magic_getarylen(aTHX_ a,b)
#define magic_getdefelem(a,b) Perl_magic_getdefelem(aTHX_ a,b)
#define magic_existspack Perl_magic_existspack
#define Perl_magic_freeregexp CPerlObj::Perl_magic_freeregexp
#define magic_freeregexp Perl_magic_freeregexp
+#define Perl_magic_freeovrld CPerlObj::Perl_magic_freeovrld
+#define magic_freeovrld Perl_magic_freeovrld
#define Perl_magic_get CPerlObj::Perl_magic_get
#define magic_get Perl_magic_get
#define Perl_magic_getarylen CPerlObj::Perl_magic_getarylen
p |int |magic_clearsig |SV* sv|MAGIC* mg
p |int |magic_existspack|SV* sv|MAGIC* mg
p |int |magic_freeregexp|SV* sv|MAGIC* mg
+p |int |magic_freeovrld|SV* sv|MAGIC* mg
p |int |magic_get |SV* sv|MAGIC* mg
p |int |magic_getarylen|SV* sv|MAGIC* mg
p |int |magic_getdefelem|SV* sv|MAGIC* mg
}
#endif /* Microport 2.4 hack */
+int
+Perl_magic_freeovrld(pTHX_ SV *sv, MAGIC *mg)
+{
+ AMT *amtp = (AMT*)mg->mg_ptr;
+ if (amtp && AMT_AMAGIC(amtp)) {
+ int i;
+ for (i = 1; i < NofAMmeth; i++) {
+ CV *cv = amtp->table[i];
+ if (cv != Nullcv) {
+ SvREFCNT_dec((SV *) cv);
+ amtp->table[i] = Nullcv;
+ }
+ }
+ }
+ return 0;
+}
+
/* Updates and caches the CV's */
bool
if (mg && amtp->was_ok_am == PL_amagic_generation
&& amtp->was_ok_sub == PL_sub_generation)
return AMT_OVERLOADED(amtp);
- if (amtp && AMT_AMAGIC(amtp)) { /* Have table. */
- int i;
- for (i=1; i<NofAMmeth; i++) {
- if (amtp->table[i]) {
- SvREFCNT_dec(amtp->table[i]);
- }
- }
- }
sv_unmagic((SV*)stash, 'c');
DEBUG_o( Perl_deb(aTHX_ "Recalcing overload magic in package %s\n",HvNAME(stash)) );
+ Zero(&amt,1,AMT);
amt.was_ok_am = PL_amagic_generation;
amt.was_ok_sub = PL_sub_generation;
amt.fallback = AMGfallNO;
moremagic = mg->mg_moremagic;
if (vtbl && vtbl->svt_free)
CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
- if (mg->mg_ptr && mg->mg_type != 'g')
+ if (mg->mg_ptr && mg->mg_type != 'g') {
if (mg->mg_len >= 0)
Safefree(mg->mg_ptr);
else if (mg->mg_len == HEf_SVKEY)
SvREFCNT_dec((SV*)mg->mg_ptr);
+ }
if (mg->mg_flags & MGf_REFCOUNTED)
SvREFCNT_dec(mg->mg_obj);
Safefree(mg);
return 0;
}
+
#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
#include <signal.h>
#endif
#ifdef PERL_FOR_X2P
/*
- * This file is being used for x2p stuff.
+ * This file is being used for x2p stuff.
* Above symbol is defined via -D in 'x2p/Makefile.SH'
- * Decouple x2p stuff from some of perls more extreme eccentricities.
+ * Decouple x2p stuff from some of perls more extreme eccentricities.
*/
#undef MULTIPLICITY
#undef USE_STDIO
#endif /* PERL_FOR_X2P */
#define VOIDUSED 1
-#ifdef PERL_MICRO
+#ifdef PERL_MICRO
# include "uconfig.h"
#else
# include "config.h"
# define END_EXTERN_C }
# define EXTERN_C extern "C"
#else
-# define START_EXTERN_C
-# define END_EXTERN_C
+# define START_EXTERN_C
+# define END_EXTERN_C
# define EXTERN_C extern
#endif
#define TAINT_ENV() if (PL_tainting) { taint_env(); }
#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(Nullch, s); }
-/* XXX All process group stuff is handled in pp_sys.c. Should these
+/* XXX All process group stuff is handled in pp_sys.c. Should these
defines move there? If so, I could simplify this a lot. --AD 9/96.
*/
/* Process group stuff changed from traditional BSD to POSIX.
# define HAS_GETPGRP /* Well, effectively it does . . . */
#endif
-/* These are not exact synonyms, since setpgrp() and getpgrp() may
+/* These are not exact synonyms, since setpgrp() and getpgrp() may
have different behaviors, but perl.h used to define USE_BSDPGRP
(prior to 5.003_05) so some extension might depend on it.
*/
# undef INCLUDE_PROTOTYPES
# undef PERL_SOCKS_NEED_PROTOTYPES
# endif
-# endif
+# endif
# ifdef I_NETDB
# include <netdb.h>
# endif
#ifndef S_IRWXU
# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR)
-#endif
+#endif
#ifndef S_IRWXG
# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP)
-#endif
+#endif
#ifndef S_IRWXO
# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH)
-#endif
+#endif
#ifndef S_IREAD
# define S_IREAD S_IRUSR
#define PERL_PRESERVE_IVUV
#endif
-/*
+/*
* The macros INT2PTR and NUM2PTR are (despite their names)
* bi-directional: they will convert int/float to or from pointers.
* However the conversion to int/float are named explicitly:
# define PTRV UV
# define INT2PTR(any,d) (any)(d)
#else
-# if PTRSIZE == LONGSIZE
+# if PTRSIZE == LONGSIZE
# define PTRV unsigned long
# else
# define PTRV unsigned
#define PTR2IV(p) INT2PTR(IV,p)
#define PTR2UV(p) INT2PTR(UV,p)
#define PTR2NV(p) NUM2PTR(NV,p)
-#if PTRSIZE == LONGSIZE
+#if PTRSIZE == LONGSIZE
# define PTR2ul(p) (unsigned long)(p)
#else
# define PTR2ul(p) INT2PTR(unsigned long,p)
#endif
-
+
#ifdef USE_LONG_DOUBLE
# if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE == DOUBLESIZE
# define LONG_DOUBLE_EQUALS_DOUBLE
#endif
#if !defined(Perl_atof) && defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)
-# if !defined(Perl_atof) && defined(HAS_STRTOLD)
+# if !defined(Perl_atof) && defined(HAS_STRTOLD)
# define Perl_atof(s) (NV)strtold(s, (char**)NULL)
# endif
# if !defined(Perl_atof) && defined(HAS_ATOLF)
# define Perl_atof2(s,f) ((f) = (NV)Perl_atof(s))
#endif
-/* Previously these definitions used hardcoded figures.
+/* Previously these definitions used hardcoded figures.
* It is hoped these formula are more portable, although
* no data one way or another is presently known to me.
* The "PERL_" names are used because these calculated constants
# define PERL_UCHAR_MAX ((unsigned char)~(unsigned)0)
# endif
#endif
-
+
/*
* CHAR_MIN and CHAR_MAX are not included here, as the (char) type may be
* ambiguous. It may be equivalent to (signed char) or (unsigned char)
# define FSEEKSIZE LSEEKSIZE
# else
# define FSEEKSIZE LONGSIZE
-# endif
+# endif
#endif
#if defined(USE_LARGE_FILES) && !defined(NO_64_BIT_STDIO)
# endif
#endif
-/*
+/*
* USE_THREADS needs to be after unixish.h as <pthread.h> includes
* <sys/signal.h> which defines NSIG - which will stop inclusion of <signal.h>
* this results in many functions being undeclared which bothers C++
# define SVf "p"
# else
# define SVf "_"
-# endif
+# endif
#endif
#ifndef UVf
# define UVf UVuf
# else
# define UVf "Vu"
-# endif
+# endif
#endif
#ifndef VDf
# define VDf "p"
# else
# define VDf "vd"
-# endif
+# endif
#endif
/* Some unistd.h's give a prototype for pause() even though
# if !defined(DONT_DECLARE_STD) || \
(defined(__svr4__) && defined(__GNUC__) && defined(sun)) || \
defined(__sgi) || \
- defined(__DGUX)
+ defined(__DGUX)
extern char ** environ; /* environment variables supplied via exec */
# endif
# endif
#endif /* PERL_GLOBAL_STRUCT */
#if defined(MULTIPLICITY) || defined(PERL_OBJECT)
-/* If we have multiple interpreters define a struct
+/* If we have multiple interpreters define a struct
holding variables which must be per-interpreter
- If we don't have threads anything that would have
+ If we don't have threads anything that would have
be per-thread is per-interpreter.
*/
#ifndef PERL_CALLCONV
# define PERL_CALLCONV
-#endif
+#endif
#ifndef NEXT30_NO_ATTRIBUTE
# ifndef HASATTRIBUTE /* disable GNU-cc attribute checking? */
# include "embedvar.h"
#endif
-/* Now include all the 'global' variables
+/* Now include all the 'global' variables
* If we don't have threads or multiple interpreters
- * these include variables that would have been their struct-s
+ * these include variables that would have been their struct-s
*/
-
+
#define PERLVAR(var,type) EXT type PL_##var;
#define PERLVARA(var,n,type) EXT type PL_##var[n];
#define PERLVARI(var,type,init) EXT type PL_##var INIT(init);
EXT MGVTBL PL_vtbl_backref = {0, 0,
0, 0, MEMBER_TO_FPTR(Perl_magic_killbackrefs)};
+EXT MGVTBL PL_vtbl_ovrld = {0, 0,
+ 0, 0, MEMBER_TO_FPTR(Perl_magic_freeovrld)};
+
#else /* !DOINIT */
EXT MGVTBL PL_vtbl_sv;
EXT MGVTBL PL_vtbl_bm;
EXT MGVTBL PL_vtbl_fm;
EXT MGVTBL PL_vtbl_uvar;
+EXT MGVTBL PL_vtbl_ovrld;
#ifdef USE_THREADS
EXT MGVTBL PL_vtbl_mutex;
copy_amg, neg_amg,
to_sv_amg, to_av_amg,
to_hv_amg, to_gv_amg,
- to_cv_amg, iter_amg,
+ to_cv_amg, iter_amg,
DESTROY_amg, max_amg_code
/* Do not leave a trailing comma here. C9X allows it, C89 doesn't. */
};
#endif
#if !defined(PERLIO_IS_STDIO) && defined(HASATTRIBUTE)
-/*
- * Now we have __attribute__ out of the way
- * Remap printf
+/*
+ * Now we have __attribute__ out of the way
+ * Remap printf
*/
#undef printf
#define printf PerlIO_stdoutf
#undef PERL_PATCHLEVEL_H_IMPLICIT
/* Mention
-
+
NV_PRESERVES_UV
HAS_ICONV
PERL_CALLCONV int Perl_magic_clearsig(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_existspack(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_freeregexp(pTHX_ SV* sv, MAGIC* mg);
+PERL_CALLCONV int Perl_magic_freeovrld(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_get(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_getarylen(pTHX_ SV* sv, MAGIC* mg);
PERL_CALLCONV int Perl_magic_getdefelem(pTHX_ SV* sv, MAGIC* mg);
{
/* With these two if statements:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
+
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
+
If you wish to remove them, please benchmark to see what the effect is
*/
if (u <= (UV)IV_MAX) {
{
/* With these two if statements:
u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
-
+
without
u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
-
+
If you wish to remove them, please benchmark to see what the effect is
*/
if (u <= (UV)IV_MAX) {
Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
changes - now IV and NV together means that the two are interchangeable
SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
-
+
The benefit of this is operations such as pp_add know that if SvIOK is
true for both left and right operands, then integer addition can be
used instead of floating point. (for cases where the result won't
(NV)UVX == NVX are both true, but the values differ. :-(
Hopefully for 2s complement IV_MIN is something like
0x8000000000000000 which will be exact. NWC */
- }
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (
(NV)UVX == NVX are both true, but the values differ. :-(
Hopefully for 2s complement IV_MIN is something like
0x8000000000000000 which will be exact. NWC */
- }
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (
UV u;
char *num_begin = SvPVX(sv);
int save_errno = errno;
-
+
/* seems that strtoul taking numbers that start with - is
implementation dependant, and can't be relied upon. */
if (numtype & IS_NUMBER_NEG) {
if (*num_begin == '-')
num_begin++;
}
-
+
/* Is it an integer that we could convert with strtoul?
So try it, and if it doesn't set errno then it's pukka.
This should be faster than going atof and then thinking. */
&& ((errno = 0), 1) /* always true */
&& ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
&& (errno == 0)
- /* If known to be negative, check it didn't undeflow IV
+ /* If known to be negative, check it didn't undeflow IV
XXX possibly we should put more negative values as NVs
direct rather than go via atof below */
&& ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
* LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
* do this, and vendors have had 11 years to get it right.
* However, will try to make it still work with only atol
- *
+ *
* IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
* IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
* IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
nbegin = s;
/*
- * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
+ * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
* integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
* possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
* will need (int)atof().
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
case 'c':
- mg->mg_virtual = 0;
+ mg->mg_virtual = &PL_vtbl_ovrld;
break;
case 'B':
mg->mg_virtual = &PL_vtbl_bm;
SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
SvREFCNT(&tmpref) = 1;
- do {
+ do {
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
/* It's (privately or publicly) a float, but not tested as an
integer, so test it to see. */
- (void) SvIV(sv);
+ (void) SvIV(sv);
flags = SvFLAGS(sv);
}
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
so $a="9.22337203685478e+18"; $a+0; $a++
needs to be the same as $a="9.22337203685478e+18"; $a++
or we go insane. */
-
+
(void) sv_2iv(sv);
if (SvIOK(sv))
goto oops_its_int;
so $a="9.22337203685478e+18"; $a+0; $a--
needs to be the same as $a="9.22337203685478e+18"; $a--
or we go insane. */
-
+
(void) sv_2iv(sv);
if (SvIOK(sv))
goto oops_its_int;
projects / platform / upstream / perl.git / commitdiff