1# -*- mode: perl -*-
2#
3# Parser.yp
4#
5# Grammar to parse SExpressions for Data::SExpression
6#
7#
8
9%{
10use Data::SExpression::Cons;
11use Scalar::Util qw(weaken);
12%}
13
14%%
15
16sexpression: expression			 { $_[0]->YYAccept; return $_[1]; }
17;
18
19expression:   NUMBER
20            | SYMBOL                     { $_[0]->handler->new_symbol($_[1]) }
21            | STRING                     { $_[0]->handler->new_string($_[1]) }
22            | list
23            | quoted
24
25;
26
27list:       '(' list_interior ')'        { $_[2] }
28;
29
30
31list_interior:
32              expression '.' expression  { $_[0]->handler->new_cons($_[1], $_[3]) }
33            | expression list_interior   { $_[0]->handler->new_cons($_[1], $_[2]) }
34            | expression                 { $_[0]->handler->new_cons($_[1], undef) }
35            |                            { undef }
36
37;
38
39quoted:
40              QUOTE expression           { $_[0]->handler->new_cons($_[0]->handler->new_symbol($_[1]),
41                                                                    $_[0]->handler->new_cons($_[2], undef))}
42;
43
44%%
45
46sub set_input {
47    my $self = shift;
48    my $input = shift;
49    die(__PACKAGE__ . "::set_input called with 0 arguments") unless defined($input);
50    $self->YYData->{INPUT} = $input;
51}
52
53sub set_handler {
54    my $self = shift;
55    my $handler = shift or die(__PACKAGE__ . "::set_handler called with 0 arguments");
56    $self->YYData->{HANDLER} = $handler;
57    weaken $self->YYData->{HANDLER};
58}
59
60sub handler {
61    my $self = shift;
62    return $self->YYData->{HANDLER};
63}
64
65sub unparsed_input {
66    my $self = shift;
67    return substr($self->YYData->{INPUT}, pos($self->YYData->{INPUT}));
68}
69
70
71my %quotes = (q{'} => 'quote',
72              q{`} => 'quasiquote',
73              q{,} => 'unquote');
74
75
76sub lexer {
77    my $self = shift;
78
79    defined($self->YYData->{INPUT}) or return ('', undef);
80
81    my $symbol_char = qr{[*!\$[:alpha:]\?<>=/+:_{}-]};
82
83    for($self->YYData->{INPUT}) {
84        $_ =~ /\G \s* (?: ; .* \s* )* /gcx;
85
86        /\G ([+-]? \d+ (?:[.]\d*)?) /gcx
87        || /\G ([+-]? [.] \d+) /gcx
88          and return ('NUMBER', $1);
89
90        /\G ($symbol_char ($symbol_char | \d | [.] )*)/gcx
91          and return ('SYMBOL', $1);
92
93        /\G (\| [^|]* \|) /gcx
94          and return ('SYMBOL', $1);
95
96        /\G " ([^"\\]* (?: \\. [^"\\]*)*) "/gcx
97          and return ('STRING', defined($1) ? $1 : "");
98
99        /\G ([().])/gcx
100          and return ($1, $1);
101
102        /\G ([`',]) /gcx
103          and return ('QUOTE', $quotes{$1});
104
105        return ('', undef);
106    }
107}
108
109sub error {
110    my $self = shift;
111    my ($tok, $val) = $self->YYLexer->($self);
112    die("Parse error near: '" . $self->unparsed_input . "'");
113    return undef;
114}
115
116sub parse {
117    my $self = shift;
118    return $self->YYParse(yylex => \&lexer, yyerror => \&error);
119}
120