Actions work
This commit is contained in:
Dan Hirsch
parent
1d11527924
commit
4eebe57908
2 changed files with 161 additions and 8 deletions
|
|
@ -28,6 +28,26 @@
|
|||
}
|
||||
}
|
||||
|
||||
%typemap(in) void*[] {
|
||||
if (!SvROK($input))
|
||||
SWIG_exception_fail(SWIG_TypeError, "Expected array ref");
|
||||
|
||||
if (SvTYPE(SvRV($input)) != SVt_PVAV)
|
||||
SWIG_exception_fail(SWIG_TypeError, "Expected array ref");
|
||||
|
||||
AV* av = (AV*) SvRV($input);
|
||||
size_t amax = av_top_index(av) + 1; // I want the length, not the top index...
|
||||
// TODO: is this array copied?
|
||||
$1 = malloc(amax * sizeof(*$1));
|
||||
$1[amax] = NULL;
|
||||
for (int i = 0; i < amax; i++) {
|
||||
int res = SWIG_ConvertPtr(*av_fetch(av, i, 0), &($1[i]), SWIGTYPE_p_HParser_, 0|0);
|
||||
if (!SWIG_IsOK(res)) {
|
||||
SWIG_exception_fail(SWIG_ArgError(res), "Expected a list of parsers and only parsers");
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
%typemap(in) uint8_t {
|
||||
if (SvIOKp($input)) {
|
||||
$1 = SvIV($input);
|
||||
|
|
@ -52,7 +72,12 @@
|
|||
|
||||
%rename("token") h_token;
|
||||
%rename("%(regex:/^h_(.*)/\\1/)s", regextarget=1) "^h_u?int(64|32|16|8)";
|
||||
%rename("end_p") h_end_p;
|
||||
%rename("left") h_left;
|
||||
%rename("middle") h_middle;
|
||||
%rename("right") h_right;
|
||||
%rename("int_range") h_int_range;
|
||||
%rename("whitespace") h_whitespace;
|
||||
%include "../swig/hammer.i";
|
||||
|
||||
|
||||
|
|
@ -76,7 +101,7 @@
|
|||
// TODO: return PyINT if appropriate
|
||||
return newSVuv(token->token_data.uint);
|
||||
case TT_SEQUENCE: {
|
||||
AV* aret;
|
||||
AV* aret = newAV();
|
||||
av_extend(aret, token->token_data.seq->used);
|
||||
for (int i = 0; i < token->token_data.seq->used; i++) {
|
||||
av_store(aret, i, hpt_to_perl(token->token_data.seq->elements[i]));
|
||||
|
|
@ -85,9 +110,7 @@
|
|||
}
|
||||
default:
|
||||
if (token->token_type == h_tt_perl) {
|
||||
return (SV*)token->token_data.user;
|
||||
|
||||
return SvREFCNT_inc(ret);
|
||||
return SvREFCNT_inc((SV*)token->token_data.user);
|
||||
} else {
|
||||
return SWIG_NewPointerObj((void*)token, SWIGTYPE_p_HParsedToken_, 0 | 0);
|
||||
// TODO: support registry
|
||||
|
|
@ -124,6 +147,41 @@
|
|||
return res;
|
||||
}
|
||||
|
||||
static HParsedToken* call_action(const HParseResult *p, void* user_data ) {
|
||||
SV *func = (SV*)user_data;
|
||||
|
||||
dSP;
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
PUSHMARK(SP);
|
||||
if (p->ast != NULL) {
|
||||
mXPUSHs(hpt_to_perl(p->ast));
|
||||
} else {
|
||||
mXPUSHs(newSV(0));
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
int nret = call_sv(func, G_SCALAR);
|
||||
|
||||
SPAGAIN;
|
||||
if (nret != 1)
|
||||
croak("Expected 1 return value, got %d", nret);
|
||||
|
||||
HParsedToken *ret = h_arena_malloc(p->arena, sizeof(*ret));
|
||||
memset(ret, 0, sizeof(*ret));
|
||||
ret->token_type = h_tt_perl;
|
||||
ret->token_data.user = SvREFCNT_inc(POPs);
|
||||
if (p->ast != NULL) {
|
||||
ret->index = p->ast->index;
|
||||
ret->bit_offset = p->ast->bit_offset;
|
||||
}
|
||||
PUTBACK;
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return ret;
|
||||
}
|
||||
|
||||
%}
|
||||
%inline {
|
||||
HParser* ch(uint8_t chr) {
|
||||
|
|
@ -132,12 +190,15 @@
|
|||
HParser* ch_range(uint8_t c0, uint8_t c1) {
|
||||
return h_action(h_ch_range(c0,c1), h__to_char, NULL);
|
||||
}
|
||||
HParser* in(const uint8_t *charset, size_t length) {
|
||||
HParser* h__in(const uint8_t *charset, size_t length) {
|
||||
return h_action(h_in(charset, length), h__to_char, NULL);
|
||||
}
|
||||
HParser* not_in(const uint8_t *charset, size_t length) {
|
||||
HParser* h__not_in(const uint8_t *charset, size_t length) {
|
||||
return h_action(h_not_in(charset, length), h__to_char, NULL);
|
||||
}
|
||||
HParser* action(HParser *parser, SV* sub) {
|
||||
return h_action(parser, call_action, SvREFCNT_inc(sub));
|
||||
}
|
||||
}
|
||||
|
||||
%extend HParser_ {
|
||||
|
|
@ -154,3 +215,19 @@
|
|||
return h_compile($self, backend, NULL) == 0;
|
||||
}
|
||||
}
|
||||
|
||||
%perlcode %{
|
||||
sub sequence {
|
||||
return hammerc::h_sequence__a([@_]);
|
||||
}
|
||||
sub choice {
|
||||
return hammerc::h_choice__a([@_]);
|
||||
}
|
||||
sub in {
|
||||
return h__in(join('',@_));
|
||||
}
|
||||
sub not_in {
|
||||
return h__not_in(join('',@_));
|
||||
}
|
||||
|
||||
%}
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
# -*- cperl -*-
|
||||
use warnings;
|
||||
use Test::More tests => 12;
|
||||
use strict;
|
||||
use Test::More tests => 21;
|
||||
use hammer;
|
||||
|
||||
|
||||
sub check_parse_eq {
|
||||
my ($parser, $input, $expected) = @_;
|
||||
my $actual;
|
||||
|
|
@ -10,6 +12,7 @@ sub check_parse_eq {
|
|||
$actual = $parser->parse($input);
|
||||
};
|
||||
if ($@) {
|
||||
diag($@);
|
||||
ok($@ eq "");
|
||||
} else {
|
||||
is_deeply($actual, $expected);
|
||||
|
|
@ -51,6 +54,7 @@ subtest "ch_range" => sub {
|
|||
|
||||
SKIP: {
|
||||
use integer;
|
||||
no warnings 'portable'; # I know the hex constants are not portable. that's why this test is skipped on <64 bit systems.
|
||||
skip "Needs 64-bit support", 2 if 0x4000000 * 2 eq -1; # TODO: Not sure if this works; may need $Config{ivsize} >= 8
|
||||
subtest "int64" => sub {
|
||||
my $parser = hammer::int64();
|
||||
|
|
@ -110,6 +114,78 @@ subtest "int_range" => sub { # test 12
|
|||
check_parse_failed($parser, "\x0b");
|
||||
};
|
||||
|
||||
1;
|
||||
subtest "whitespace" => sub {
|
||||
my $parser = hammer::whitespace(hammer::ch('a'));
|
||||
check_parse_eq($parser, "a", "a");
|
||||
check_parse_eq($parser, " a", "a");
|
||||
check_parse_eq($parser, " a", "a");
|
||||
check_parse_eq($parser, "\t\n\ra", "a");
|
||||
};
|
||||
|
||||
subtest "whitespace-end" => sub {
|
||||
my $parser = hammer::whitespace(hammer::end_p());
|
||||
check_parse_eq($parser, "", undef);
|
||||
check_parse_eq($parser, " ", undef);
|
||||
check_parse_failed($parser, " x", undef)
|
||||
};
|
||||
|
||||
subtest "left" => sub { # test 15
|
||||
my $parser = hammer::left(hammer::ch('a'),
|
||||
hammer::ch(' '));
|
||||
check_parse_eq($parser, "a ", "a");
|
||||
check_parse_failed($parser, "a");
|
||||
check_parse_failed($parser, " ");
|
||||
};
|
||||
|
||||
subtest "right" => sub {
|
||||
my $parser = hammer::right(hammer::ch(' '),
|
||||
hammer::ch('a'));
|
||||
check_parse_eq($parser, " a", "a");
|
||||
check_parse_failed($parser, "a");
|
||||
check_parse_failed($parser, " ");
|
||||
};
|
||||
|
||||
subtest "middle" => sub {
|
||||
my $parser = hammer::middle(hammer::ch(' '),
|
||||
hammer::ch('a'),
|
||||
hammer::ch(' '));
|
||||
check_parse_eq($parser, " a ", "a");
|
||||
for my $test_string (split('/', "a/ / a/a / b /ba / ab")) {
|
||||
check_parse_failed($parser, $test_string);
|
||||
}
|
||||
};
|
||||
|
||||
subtest "action" => sub {
|
||||
my $parser = hammer::action(hammer::sequence(hammer::choice(hammer::ch('a'),
|
||||
hammer::ch('A')),
|
||||
hammer::choice(hammer::ch('b'),
|
||||
hammer::ch('B'))),
|
||||
sub { [map(uc, @{+shift})]; });
|
||||
check_parse_eq($parser, "ab", ['A', 'B']);
|
||||
check_parse_eq($parser, "AB", ['A', 'B']);
|
||||
check_parse_eq($parser, 'Ab', ['A', 'B']);
|
||||
check_parse_failed($parser, "XX");
|
||||
};
|
||||
|
||||
|
||||
subtest "in" => sub {
|
||||
my $parser = hammer::in('a'..'c');
|
||||
check_parse_eq($parser, 'a', 'a');
|
||||
check_parse_eq($parser, 'b', 'b');
|
||||
check_parse_eq($parser, 'c', 'c');
|
||||
check_parse_failed($parser, 'd');
|
||||
};
|
||||
|
||||
subtest "not_in" => sub { # test 20
|
||||
my $parser = hammer::not_in('a'..'c');
|
||||
check_parse_failed($parser, 'a');
|
||||
check_parse_failed($parser, 'b');
|
||||
check_parse_failed($parser, 'c');
|
||||
check_parse_eq($parser, 'd', 'd');
|
||||
};
|
||||
|
||||
subtest "end_p" => sub {
|
||||
my $parser = hammer::sequence(hammer::ch('a'), hammer::end_p());
|
||||
check_parse_eq($parser, 'a', ['a']);
|
||||
check_parse_failed($parser, 'aa');
|
||||
};
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue