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 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ dist.ini | 3 + lib/Fun.pm | 78 +++++++++++++++++++ t/basic.t | 32 ++++++++ t/compile-time.t | 14 ++++ t/recursion.t | 25 ++++++ 6 files changed, 378 insertions(+) create mode 100644 Fun.xs create mode 100644 t/basic.t create mode 100644 t/compile-time.t create mode 100644 t/recursion.t 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); +} diff --git a/dist.ini b/dist.ini index ec2b251..20422fc 100644 --- a/dist.ini +++ b/dist.ini @@ -7,5 +7,8 @@ copyright_holder = Jesse Luehrs :version = 0.08 dist = Fun repository = github +awesome = =inc::MakeMaker [AutoPrereqs] +[Prereqs] +perl = 5.014 diff --git a/lib/Fun.pm b/lib/Fun.pm index e69de29..188adfb 100644 --- a/lib/Fun.pm +++ b/lib/Fun.pm @@ -0,0 +1,78 @@ +package Fun; +use strict; +use warnings; +# ABSTRACT: simple function signatures + +use Devel::CallParser; +use XSLoader; + +XSLoader::load( + __PACKAGE__, + exists $Fun::{VERSION} ? ${ $Fun::{VERSION} } : (), +); + +use Exporter 'import'; +our @EXPORT = our @EXPORT_OK = ('fun'); + +=head1 SYNOPSIS + +=head1 DESCRIPTION + +=cut + +=head1 EXPORTS + +=head2 fun + +=cut + +sub fun { + my ($name, $code) = @_; + my $caller = caller; + no strict 'refs'; + *{ $caller . '::' . $name } = $code; +} + +=head1 BUGS + +No known bugs. + +Please report any bugs through RT: email +C, or browse to +L. + +=head1 SEE ALSO + +L, etc... + +=head1 SUPPORT + +You can find this documentation for this module with the perldoc command. + + perldoc Fun + +You can also look for information at: + +=over 4 + +=item * AnnoCPAN: Annotated CPAN documentation + +L + +=item * CPAN Ratings + +L + +=item * RT: CPAN's request tracker + +L + +=item * Search CPAN + +L + +=back + +=cut + +1; diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..080c2cf --- /dev/null +++ b/t/basic.t @@ -0,0 +1,32 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Fun; + +fun mul ($x, $y) { + return $x * $y; +} + +is(mul(3, 4), 12); + +fun sum (@nums) { + my $sum; + for my $num (@nums) { + $sum += $num; + } + return $sum; +} + +is(sum(1, 2, 3, 4), 10); + +{ + package Foo; + use Fun; + fun foo { } +} + +ok(exists $Foo::{foo}); + +done_testing; diff --git a/t/compile-time.t b/t/compile-time.t new file mode 100644 index 0000000..a20ff6c --- /dev/null +++ b/t/compile-time.t @@ -0,0 +1,14 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +use Fun; + +TODO: { todo_skip "doesn't work at compile time yet", 1; +is(foo(), "FOO"); +} + +fun foo { "FOO" } + +done_testing; diff --git a/t/recursion.t b/t/recursion.t new file mode 100644 index 0000000..0b13da9 --- /dev/null +++ b/t/recursion.t @@ -0,0 +1,25 @@ +#!/usr/bin/env perl +use strict; +use warnings; +use Test::More; + +BEGIN { + if (!eval { require 5.016; 1 }) { + plan skip_all => "This test requires 5.16"; + } +} + +use 5.016; + +use Fun; + +fun fact ($n) { + if ($n < 2) { + return 1; + } + return $n * __SUB__->($n - 1); +} + +is(fact(5), 120); + +done_testing; -- cgit v1.2.3