initial implementation

6 files changed, 378 insertions, 0 deletions

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<bug-fun at rt.cpan.org>, or browse to
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Fun>.
+
+=head1 SEE ALSO
+
+L<signatures>, 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<http://annocpan.org/dist/Fun>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Fun>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Fun>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Fun>
+
+=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;