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