X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=d89ac738be3b359d5e1f835f8b9b4cc83d85a325;hb=29404ae038d75e5ffd5727a026889b0987db9cd5;hp=d09d19143b0cac2bd8d120297e40c96a829dfc43;hpb=5aaec2b4ba9ed3b1a9d1569e09bc40d19ec30f8c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index d09d191..d89ac73 100644 --- a/toke.c +++ b/toke.c @@ -107,15 +107,6 @@ static const char* const lex_state_names[] = { #endif #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline)) -/* According to some strict interpretations of ANSI C89 one cannot - * cast void pointers to code pointers or vice versa (as filter_add(), - * filter_del(), and filter_read() will want to do). We should still - * be able to use a union for sneaky "casting". */ -typedef union { - XPVIO* iop; - filter_t filter; -} xpvio_filter_u; - /* * Convenience functions to return different tokens and prime the * lexer for the next token. They all take an argument. @@ -176,25 +167,29 @@ typedef union { * The UNIDOR macro is for unary functions that can be followed by the // * operator (such as C). */ -#define UNI2(f,x) return ( \ - yylval.ival = f, \ - PL_expect = x, \ - PL_bufptr = s, \ - PL_last_uni = PL_oldbufptr, \ - PL_last_lop_op = f, \ - REPORT( \ - (*s == '(' || (s = skipspace(s), *s == '(') \ - ? (int)FUNC1 : (int)UNIOP))) +#define UNI2(f,x) { \ + yylval.ival = f; \ + PL_expect = x; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + PL_last_lop_op = f; \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \ + } #define UNI(f) UNI2(f,XTERM) #define UNIDOR(f) UNI2(f,XTERMORDORDOR) -#define UNIBRACK(f) return ( \ - yylval.ival = f, \ - PL_bufptr = s, \ - PL_last_uni = PL_oldbufptr, \ - REPORT( \ - (*s == '(' || (s = skipspace(s), *s == '(') \ - ? (int)FUNC1 : (int)UNIOP))) +#define UNIBRACK(f) { \ + yylval.ival = f; \ + PL_bufptr = s; \ + PL_last_uni = PL_oldbufptr; \ + if (*s == '(') \ + return REPORT( (int)FUNC1 ); \ + s = skipspace(s); \ + return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \ + } /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) @@ -334,7 +329,7 @@ S_tokereport(pTHX_ const char* s, I32 rv) if (PL_oldbufptr && *PL_oldbufptr) sv_catpv(report, PL_tokenbuf); } - PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen(report)); + PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report)); }; return (int)rv; } @@ -534,7 +529,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - char *s; + const char *s; STRLEN len; SAVEI32(PL_lex_dojoin); @@ -590,7 +585,7 @@ Perl_lex_start(pTHX_ SV *line) PL_linestr = line; if (SvREADONLY(PL_linestr)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - s = SvPV(PL_linestr, len); + s = SvPV_const(PL_linestr, len); if (!len || s[len-1] != ';') { if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) PL_linestr = sv_2mortal(newSVsv(PL_linestr)); @@ -976,7 +971,7 @@ Perl_str_to_version(pTHX_ SV *sv) NV retval = 0.0; NV nshift = 1.0; STRLEN len; - const char *start = SvPVx(sv,len); + const char *start = SvPV_const(sv,len); const char *end = start + len; const bool utf = SvUTF8(sv) ? TRUE : FALSE; while (start < end) { @@ -1023,7 +1018,7 @@ S_force_version(pTHX_ char *s, int guessing) version = yylval.opval; ver = cSVOPx(version)->op_sv; if (SvPOK(ver) && !SvNIOK(ver)) { - (void)SvUPGRADE(ver, SVt_PVNV); + SvUPGRADE(ver, SVt_PVNV); SvNV_set(ver, str_to_version(ver)); SvNOK_on(ver); /* hint that it is a version */ } @@ -1136,7 +1131,7 @@ S_sublex_start(pTHX) if (SvTYPE(sv) == SVt_PVIV) { /* Overloaded constants, nothing fancy: Convert to SVt_PV: */ STRLEN len; - const char *p = SvPV(sv, len); + const char *p = SvPV_const(sv, len); SV * const nsv = newSVpvn(p, len); if (SvUTF8(sv)) SvUTF8_on(nsv); @@ -1640,7 +1635,7 @@ S_scan_const(pTHX_ char *start) src = (U8 *)d - 1; dst = src+hicount; d += hicount; - while (src >= (U8 *)SvPVX(sv)) { + while (src >= (const U8 *)SvPVX_const(sv)) { if (!NATIVE_IS_INVARIANT(*src)) { U8 ch = NATIVE_TO_ASCII(*src); *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch); @@ -1680,7 +1675,7 @@ S_scan_const(pTHX_ char *start) char* e = strchr(s, '}'); SV *res; STRLEN len; - char *str; + const char *str; if (!e) { yyerror("Missing right brace on \\N{}"); @@ -1702,7 +1697,7 @@ S_scan_const(pTHX_ char *start) res, Nullsv, "\\N{...}" ); if (has_utf8) sv_utf8_upgrade(res); - str = SvPV(res,len); + str = SvPV_const(res,len); #ifdef EBCDIC_NEVER_MIND /* charnames uses pack U and that has been * recently changed to do the below uni->native @@ -1712,14 +1707,14 @@ S_scan_const(pTHX_ char *start) * gets revoked, but the semantics is still * desireable for charnames. --jhi */ { - UV uv = utf8_to_uvchr((U8*)str, 0); + UV uv = utf8_to_uvchr((const U8*)str, 0); if (uv < 0x100) { U8 tmpbuf[UTF8_MAXBYTES+1], *d; d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv)); sv_setpvn(res, (char *)tmpbuf, d - tmpbuf); - str = SvPV(res, len); + str = SvPV_const(res, len); } } #endif @@ -2137,8 +2132,6 @@ S_incl_perldb(pTHX) SV * Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) { - xpvio_filter_u u; - if (!funcp) return Nullsv; @@ -2146,12 +2139,11 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) PL_rsfp_filters = newAV(); if (!datasv) datasv = NEWSV(255,0); - (void)SvUPGRADE(datasv, SVt_PVIO); - u.filter = funcp; - IoANY(datasv) = u.iop; /* stash funcp into spare field */ + SvUPGRADE(datasv, SVt_PVIO); + IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", - (void*)u.iop, SvPV_nolen(datasv))); + IoANY(datasv), SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -2163,18 +2155,15 @@ void Perl_filter_del(pTHX_ filter_t funcp) { SV *datasv; - xpvio_filter_u u; #ifdef DEBUGGING - u.filter = funcp; - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)u.iop)); + DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp))); #endif if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); - u.iop = IoANY(datasv); - if (u.filter == funcp) { + if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) { IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; IoANY(datasv) = (void *)NULL; sv_free(av_pop(PL_rsfp_filters)); @@ -2193,7 +2182,6 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) { filter_t funcp; SV *datasv = NULL; - xpvio_filter_u u; if (!PL_rsfp_filters) return -1; @@ -2235,11 +2223,10 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ - u.iop = IoANY(datasv); - funcp = u.filter; + funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", - idx, (void*)u.iop, SvPV_nolen(datasv))); + idx, datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -2285,7 +2272,7 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { SV *sv; if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { - pkgname = SvPV_nolen(sv); + pkgname = SvPV_nolen_const(sv); } } @@ -2787,8 +2774,8 @@ Perl_yylex(pTHX) else { STRLEN blen; STRLEN llen; - const char *bstart = SvPV(CopFILESV(PL_curcop),blen); - const char *lstart = SvPV(x,llen); + const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen); + const char *lstart = SvPV_const(x,llen); if (llen < blen) { bstart += blen - llen; if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') { @@ -3907,6 +3894,8 @@ Perl_yylex(pTHX) if (!s) missingterm((char*)0); yylval.ival = OP_CONST; + /* FIXME. I think that this can be const if char *d is replaced by + more localised variables. */ for (d = SvPV(PL_lex_stuff, len); len; len--, d++) { if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) { yylval.ival = OP_STRINGIFY; @@ -4285,7 +4274,7 @@ Perl_yylex(pTHX) /* Is there a prototype? */ if (SvPOK(cv)) { STRLEN len; - char *proto = SvPV((SV*)cv, len); + const char *proto = SvPV_const((SV*)cv, len); if (!len) TERM(FUNC0SUB); if (*proto == '$' && proto[1] == '\0') @@ -9026,9 +9015,8 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { - STRLEN n_a; sv_catpv(ERRSV, "Propagated"); - yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */ + yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */ (void)POPs; res = SvREFCNT_inc(sv); } @@ -9659,7 +9647,7 @@ S_scan_inputsymbol(pTHX_ char *start) { register char *s = start; /* current position in buffer */ register char *d; - register char *e; + const char *e; char *end; I32 len; @@ -9904,7 +9892,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) while (cont) { int offset = s - SvPVX_const(PL_linestr); - bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, + const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, &offset, (char*)termstr, termlen); const char *ns = SvPVX_const(PL_linestr) + offset; char *svlast = SvEND(sv) - 1; @@ -10670,8 +10658,9 @@ Perl_yyerror(pTHX_ const char *s) if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; - else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 && - PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) { + else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr && + PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr && + PL_oldbufptr != PL_bufptr) { /* Only for NetWare: The code below is removed for NetWare because it abends/crashes on NetWare @@ -10686,8 +10675,8 @@ Perl_yyerror(pTHX_ const char *s) context = PL_oldoldbufptr; contlen = PL_bufptr - PL_oldoldbufptr; } - else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 && - PL_oldbufptr != PL_bufptr) { + else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr && + PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) { /* Only for NetWare: The code below is removed for NetWare because it abends/crashes on NetWare