From 6d034593a5f0b02eb9e5b7069fa86814aae07b7c Mon Sep 17 00:00:00 2001 From: Jesse Luehrs Date: Sat, 18 Aug 2012 18:34:54 -0500 Subject: initial implementation --- Fun.xs | 226 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 226 insertions(+) create mode 100644 Fun.xs (limited to 'Fun.xs') diff --git a/Fun.xs b/Fun.xs new file mode 100644 index 0000000..50e802b --- /dev/null +++ b/Fun.xs @@ -0,0 +1,226 @@ +#include "EXTERN.h" +#include "perl.h" +#include "callparser1.h" +#include "XSUB.h" + +/* stolen (with modifications) from Scope::Escape::Sugar */ + +#define SVt_PADNAME SVt_PVMG + +#ifndef COP_SEQ_RANGE_LOW_set +# define COP_SEQ_RANGE_LOW_set(sv,val) \ + do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xlow = val; } while(0) +# define COP_SEQ_RANGE_HIGH_set(sv,val) \ + do { ((XPVNV*)SvANY(sv))->xnv_u.xpad_cop_seq.xhigh = val; } while(0) +#endif /* !COP_SEQ_RANGE_LOW_set */ + +/* + * pad handling + * + * The public API for the pad system is lacking any way to add items to + * the pad. This is a minimal implementation of the necessary facilities. + * It doesn't warn about shadowing. + */ + +#define pad_add_my_pvn(namepv, namelen, type) \ + THX_pad_add_my_pvn(aTHX_ namepv, namelen, type) +static PADOFFSET THX_pad_add_my_pvn(pTHX_ + char const *namepv, STRLEN namelen, svtype type) +{ + PADOFFSET offset; + SV *namesv, *myvar; + myvar = *av_fetch(PL_comppad, AvFILLp(PL_comppad) + 1, 1); + offset = AvFILLp(PL_comppad); + SvPADMY_on(myvar); + SvUPGRADE(myvar, type); + PL_curpad = AvARRAY(PL_comppad); + namesv = newSV_type(SVt_PADNAME); + sv_setpvn(namesv, namepv, namelen); + COP_SEQ_RANGE_LOW_set(namesv, PL_cop_seqmax); + COP_SEQ_RANGE_HIGH_set(namesv, PERL_PADSEQ_INTRO); + PL_cop_seqmax++; + av_store(PL_comppad_name, offset, namesv); + return offset; +} + +#define pad_add_my_sv(namesv, type) THX_pad_add_my_sv(aTHX_ namesv, type) +static PADOFFSET THX_pad_add_my_sv(pTHX_ SV *namesv, svtype type) +{ + char const *pv; + STRLEN len; + pv = SvPV(namesv, len); + return pad_add_my_pvn(pv, len, type); +} + +#define pad_add_my_scalar_sv(namesv) THX_pad_add_my_sv(aTHX_ namesv, SVt_NULL) +#define pad_add_my_array_sv(namesv) THX_pad_add_my_sv(aTHX_ namesv, SVt_PVAV) +#define pad_add_my_hash_sv(namesv) THX_pad_add_my_sv(aTHX_ namesv, SVt_PVHV) +#define pad_add_my_scalar_pvn(namepv, namelen) \ + THX_pad_add_my_pvn(aTHX_ namepv, namelen, SVt_NULL) +#define pad_add_my_array_pvn(namepv, namelen) \ + THX_pad_add_my_pvn(aTHX_ namepv, namelen, SVt_PVAV) +#define pad_add_my_hash_pvn(namepv, namelen) \ + THX_pad_add_my_pvn(aTHX_ namepv, namelen, SVt_PVHV) + +/* + * parser pieces + * + * These functions reimplement fairly low-level parts of the Perl syntax, + * using the character-level public lexer API. + */ + +#define DEMAND_IMMEDIATE 0x00000001 +#define DEMAND_NOCONSUME 0x00000002 +#define demand_unichar(c, f) THX_demand_unichar(aTHX_ c, f) +static void THX_demand_unichar(pTHX_ I32 c, U32 flags) +{ + if(!(flags & DEMAND_IMMEDIATE)) lex_read_space(0); + if(lex_peek_unichar(0) != c) croak("syntax error"); + if(!(flags & DEMAND_NOCONSUME)) lex_read_unichar(0); +} + +#define parse_idword(prefix) THX_parse_idword(aTHX_ prefix) +static SV *THX_parse_idword(pTHX_ char const *prefix) +{ + STRLEN prefixlen, idlen; + SV *sv; + char *start, *s, c; + s = start = PL_parser->bufptr; + c = *s; + if(!isIDFIRST(c)) croak("syntax error"); + do { + c = *++s; + } while(isALNUM(c)); + lex_read_to(s); + prefixlen = strlen(prefix); + idlen = s-start; + sv = sv_2mortal(newSV(prefixlen + idlen)); + Copy(prefix, SvPVX(sv), prefixlen, char); + Copy(start, SvPVX(sv)+prefixlen, idlen, char); + SvPVX(sv)[prefixlen + idlen] = 0; + SvCUR_set(sv, prefixlen + idlen); + SvPOK_on(sv); + return sv; +} + +#define parse_varname(sigil) THX_parse_varname(aTHX_ sigil) +static SV *THX_parse_varname(pTHX_ const char *sigil) +{ + demand_unichar(sigil[0], DEMAND_IMMEDIATE); + lex_read_space(0); + return parse_idword(sigil); +} + +#define parse_scalar_varname() THX_parse_varname(aTHX_ "$") +#define parse_array_varname() THX_parse_varname(aTHX_ "@") +#define parse_hash_varname() THX_parse_varname(aTHX_ "%") + +/* end stolen from Scope::Escape::Sugar */ + +#define parse_function_prototype() THX_parse_function_prototype(aTHX) +static OP *THX_parse_function_prototype(pTHX) +{ + OP *myvars, *get_args; + + demand_unichar('(', DEMAND_IMMEDIATE); + + lex_read_space(0); + if (lex_peek_unichar(0) == ')') { + lex_read_unichar(0); + return NULL; + } + + myvars = newLISTOP(OP_LIST, 0, NULL, NULL); + myvars->op_private |= OPpLVAL_INTRO; + + for (;;) { + OP *pad_op; + char next; + I32 type; + + lex_read_space(0); + next = lex_peek_unichar(0); + if (next == '$') { + pad_op = newOP(OP_PADSV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST); + pad_op->op_targ = pad_add_my_scalar_sv(parse_scalar_varname()); + } + else if (next == '@') { + pad_op = newOP(OP_PADAV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST); + pad_op->op_targ = pad_add_my_array_sv(parse_array_varname()); + } + else if (next == '%') { + pad_op = newOP(OP_PADHV, (OPpLVAL_INTRO<<8)|OPf_WANT_LIST); + pad_op->op_targ = pad_add_my_hash_sv(parse_hash_varname()); + } + else { + croak("syntax error"); + } + + op_append_elem(OP_LIST, myvars, pad_op); + + lex_read_space(0); + next = lex_peek_unichar(0); + if (next == ',') { + lex_read_unichar(0); + } + else if (next == ')') { + lex_read_unichar(0); + break; + } + else { + croak("syntax error"); + } + } + + myvars->op_flags |= OPf_PARENS; + + get_args = newUNOP(OP_RV2AV, 0, newGVOP(OP_GV, 0, gv_fetchpv("_", 0, SVt_PVAV))); + + return newASSIGNOP(OPf_STACKED, myvars, 0, get_args); +} + +static OP *parse_fun(pTHX_ GV *namegv, SV *psobj, U32 *flagsp) +{ + I32 floor; + SV *function_name = NULL; + OP *arg_assign = NULL, *block, *code; + + *flagsp |= CALLPARSER_STATEMENT; + + floor = start_subparse(0, CVf_ANON); + + lex_read_space(0); + function_name = parse_idword(""); + + lex_read_space(0); + if (lex_peek_unichar(0) == '(') { + arg_assign = parse_function_prototype(); + } + + demand_unichar('{', DEMAND_NOCONSUME); + + block = parse_block(0); + + if (arg_assign) { + block = op_prepend_elem(OP_LINESEQ, + newSTATEOP(0, NULL, arg_assign), + block); + } + + code = newANONSUB(floor, NULL, block); + + SvREFCNT_inc(function_name); + return newLISTOP(OP_LIST, 0, + newSVOP(OP_CONST, 0, function_name), + code); +} + + +MODULE = Fun PACKAGE = Fun + +PROTOTYPES: DISABLE + +BOOT: +{ + cv_set_call_parser(get_cv("Fun::fun", 0), parse_fun, &PL_sv_undef); +} -- cgit v1.2.3-54-g00ecf