1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
package reader;
use feature qw(switch);
use strict;
use warnings FATAL => qw(all);
no if $] >= 5.018, warnings => "experimental::smartmatch";
use Exporter 'import';
our @EXPORT_OK = qw( read_str );
use types qw($nil $true $false _keyword _hash_map);
use Data::Dumper;
{
package Reader;
sub new {
my $class = shift;
bless { position => 0, tokens => shift } => $class
}
sub next { my $self = shift; return $self->{tokens}[$self->{position}++] }
sub peek { my $self = shift; return $self->{tokens}[$self->{position}] }
}
sub tokenize {
my($str) = @_;
my @tokens = $str =~ /[\s,]*(~@|[\[\]{}()'`~^@]|"(?:\\.|[^\\"])*"|;.*|[^\s\[\]{}('"`,;)]*)/g;
return grep {! /^;|^$/} @tokens;
}
sub read_atom {
my($rdr) = @_;
my $token = $rdr->next();
given ($token) {
when(/^-?[0-9]+$/) { return Integer->new($token) }
when(/^"/) {
my $str = substr $token, 1, -1;
$str =~ s/\\"/"/g;
$str =~ s/\\n/\n/g;
return String->new($str)
}
when(/^:/) { return _keyword(substr($token,1)) }
when(/^nil$/) { return $nil }
when(/^true$/) { return $true }
when(/^false$/) { return $false }
default { return Symbol->new($token) }
}
}
sub read_list {
my($rdr,$class,$start,$end) = @_;
$start = $start || '(';
$end = $end || ')';
my $token = $rdr->next();
my @lst = ();
if ($token ne $start) {
die "expected '$start'";
}
while (($token = $rdr->peek()) ne $end) {
if (! defined $token) {
die "expected '$end', got EOF";
}
push(@lst, read_form($rdr));
}
$rdr->next();
if ($class eq 'List') {
return List->new(\@lst);
} elsif ($class eq 'Vector') {
return Vector->new(\@lst);
} else {
return _hash_map(@lst);
}
}
sub read_form {
my($rdr) = @_;
my $token = $rdr->peek();
given ($token) {
when("'") { $rdr->next(); List->new([Symbol->new('quote'),
read_form($rdr)]) }
when('`') { $rdr->next(); List->new([Symbol->new('quasiquote'),
read_form($rdr)]) }
when('~') { $rdr->next(); List->new([Symbol->new('unquote'),
read_form($rdr)]) }
when('~@') { $rdr->next(); List->new([Symbol->new('splice-unquote'),
read_form($rdr)]) }
when('^') { $rdr->next(); my $meta = read_form($rdr);
List->new([Symbol->new('with-meta'),
read_form($rdr), $meta]) }
when('@') { $rdr->next(); List->new([Symbol->new('deref'),
read_form($rdr)]) }
when(')') { die "unexpected ')'" }
when('(') { return read_list($rdr, 'List') }
when(']') { die "unexpected ']'" }
when('[') { return read_list($rdr, 'Vector', '[', ']') }
when('}') { die "unexpected '}'" }
when('{') { return read_list($rdr, 'HashMap', '{', '}') }
default { return read_atom($rdr) }
}
}
sub read_str {
my($str) = @_;
my @tokens = tokenize($str);
#print "tokens: " . Dumper(\@tokens);
if (scalar(@tokens) == 0) { die BlankException->new(); }
return read_form(Reader->new(\@tokens));
}
#print Dumper(read_str("123"));
#print Dumper(read_str("+"));
#print Dumper(read_str("\"abc\""));
#print Dumper(read_str("nil"));
#print Dumper(read_str("true"));
#print Dumper(read_str("false"));
#print Dumper(read_str("(+ 2 3)"));
#print Dumper(read_str("(foo 2 (3 4))"));
1;
|
