/* pp.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#include "EXTERN.h"
#define PERL_IN_PP_C
#include "perl.h"
+#include "keywords.h"
/* variations on pp_null */
I32 oa;
char str[ MAX_ARGS_OP * 2 + 2 ]; /* One ';', one '\0' */
+ if (code == -KEY_chop || code == -KEY_chomp)
+ goto set;
while (i < MAXO) { /* The slow way. */
if (strEQ(s + 6, PL_op_name[i])
|| strEQ(s + 6, PL_op_desc[i]))
{
UV left = 0;
UV right = 0;
- bool left_neg;
- bool right_neg;
+ bool left_neg = FALSE;
+ bool right_neg = FALSE;
bool use_double = FALSE;
bool dright_valid = FALSE;
NV dright = 0.0;
while (tmps < send) {
UV c = utf8n_to_uvchr(tmps, send-tmps, &l, UTF8_ALLOW_ANYUV);
tmps += UTF8SKIP(tmps);
- result = uvchr_to_utf8(result, ~c);
+ result = uvchr_to_utf8_flags(result, ~c, UNICODE_ALLOW_ANY);
}
*result = '\0';
result -= targlen;
value = POPn;
if (value <= 0.0) {
SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take log of %g", value);
+ DIE(aTHX_ "Can't take log of %"NVgf, value);
}
value = Perl_log(value);
XPUSHn(value);
value = POPn;
if (value < 0.0) {
SET_NUMERIC_STANDARD();
- DIE(aTHX_ "Can't take sqrt of %g", value);
+ DIE(aTHX_ "Can't take sqrt of %"NVgf, value);
}
value = Perl_sqrt(value);
XPUSHn(value);
}
}
+/*
+ * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
+ * These need to be revisited when a newer toolchain becomes available.
+ */
+#if defined(__sparc64__) && defined(__GNUC__)
+# if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
+# undef SPARC64_MODF_WORKAROUND
+# define SPARC64_MODF_WORKAROUND 1
+# endif
+#endif
+
+#if defined(SPARC64_MODF_WORKAROUND)
+static NV
+sparc64_workaround_modf(NV theVal, NV *theIntRes)
+{
+ NV res, ret;
+ ret = Perl_modf(theVal, &res);
+ *theIntRes = res;
+ return ret;
+}
+#endif
+
PP(pp_int)
{
dSP; dTARGET; tryAMAGICun(int);
if (value < (NV)UV_MAX + 0.5) {
SETu(U_V(value));
} else {
-#if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
-# ifdef HAS_MODFL_POW32_BUG
+#if defined(SPARC64_MODF_WORKAROUND)
+ (void)sparc64_workaround_modf(value, &value);
+#else
+# if defined(HAS_MODFL) || defined(LONG_DOUBLE_EQUALS_DOUBLE)
+# ifdef HAS_MODFL_POW32_BUG
/* some versions of glibc split (i + d) into (i-1, d+1) for 2^32 <= i < 2^64 */
{
NV offset = Perl_modf(value, &value);
(void)Perl_modf(offset, &offset);
value += offset;
}
-# else
+# else
(void)Perl_modf(value, &value);
-# endif
-#else
+# endif
+# else
double tmp = (double)value;
(void)Perl_modf(tmp, &tmp);
value = (NV)tmp;
+# endif
#endif
SETn(value);
}
STRLEN len;
NV result_nv;
UV result_uv;
+ SV* sv = POPs;
- tmps = (SvPVx(POPs, len));
+ tmps = (SvPVx(sv, len));
+ if (DO_UTF8(sv)) {
+ /* If Unicode, try to downgrade
+ * If not possible, croak. */
+ SV* tsv = sv_2mortal(newSVsv(sv));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPVX(tsv);
+ }
result_uv = grok_hex (tmps, &len, &flags, &result_nv);
if (flags & PERL_SCAN_GREATER_THAN_UV_MAX) {
XPUSHn(result_nv);
STRLEN len;
NV result_nv;
UV result_uv;
+ SV* sv = POPs;
- tmps = (SvPVx(POPs, len));
+ tmps = (SvPVx(sv, len));
+ if (DO_UTF8(sv)) {
+ /* If Unicode, try to downgrade
+ * If not possible, croak. */
+ SV* tsv = sv_2mortal(newSVsv(sv));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPVX(tsv);
+ }
while (*tmps && len && isSPACE(*tmps))
tmps++, len--;
if (*tmps == '0')
if (value > 255 && !IN_BYTES) {
SvGROW(TARG, UNISKIP(value)+1);
- tmps = (char*)uvchr_to_utf8((U8*)SvPVX(TARG), value);
+ tmps = (char*)uvchr_to_utf8_flags((U8*)SvPVX(TARG), value,
+ UNICODE_ALLOW_SUPER);
SvCUR_set(TARG, tmps - SvPVX(TARG));
*tmps = '\0';
(void)SvPOK_only(TARG);
STRLEN n_a;
STRLEN len;
char *tmps = SvPV(left, len);
- char *t = 0;
+
if (DO_UTF8(left)) {
- /* If Unicode take the crypt() of the low 8 bits
- * of the characters of the string. */
- char *s = tmps;
- char *send = tmps + len;
- STRLEN i = 0;
- Newz(688, t, len, char);
- while (s < send) {
- t[i++] = utf8_to_uvchr((U8*)s, 0) & 0xFF;
- s += UTF8SKIP(s);
- }
- tmps = t;
+ /* If Unicode, try to downgrade.
+ * If not possible, croak.
+ * Yes, we made this up. */
+ SV* tsv = sv_2mortal(newSVsv(left));
+
+ SvUTF8_on(tsv);
+ sv_utf8_downgrade(tsv, FALSE);
+ tmps = SvPVX(tsv);
}
# ifdef FCRYPT
sv_setpv(TARG, fcrypt(tmps, SvPV(right, n_a)));
# else
sv_setpv(TARG, PerlProc_crypt(tmps, SvPV(right, n_a)));
# endif
- Safefree(t);
#else
DIE(aTHX_
"The crypt() function is unimplemented due to excessive paranoia.");
STRLEN slen;
if (DO_UTF8(sv)) {
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
STRLEN ulen;
STRLEN tculen;
if (DO_UTF8(sv) && (s = (U8*)SvPV(sv, slen)) && slen && UTF8_IS_START(*s)) {
STRLEN ulen;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
U8 *tend;
UV uv;
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
s = (U8*)SvPV(sv,len);
if (!len) {
STRLEN ulen;
register U8 *d;
U8 *send;
- U8 tmpbuf[UTF8_MAXLEN*2+1];
+ U8 tmpbuf[UTF8_MAXLEN_UCLC+1];
s = (U8*)SvPV(sv,len);
if (!len) {
if (MARK < SP)
sv_setsv(val, *++MARK);
else if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment");
+ Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in anonymous hash");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
projects / p5sagit/p5-mst-13.2.git / blobdiff