-
Notifications
You must be signed in to change notification settings - Fork 0
/
pispy.pl
91 lines (77 loc) · 2.2 KB
/
pispy.pl
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
#!/usr/bin/perl
use feature qw/switch/;
use List::MoreUtils qw/zip/;
use Data::Dumper;
$env = {
'+' => sub { $_[0]+$_[1] },
'-' => sub { $_[0]-$_[1] },
'*' => sub { $_[0]*$_[1] },
'/' => sub { $_[0]/$_[1] },
'=' => sub { $_[0]==$_[1] },
'<' => sub { $_[0]<$_[1] },
'>' => sub { $_[0]>$_[1] },
'<=' => sub { $_[0]<=$_[0] },
'>=' => sub { $_[0]>=$_[1] },
'car' => sub { $_[0]->[0] },
'cdr' => sub { [@{$_[0]}[1..@{$_[0]}-1]] },
'apply' => sub { $_[0]->(@{$_[1]}) },
'length' => sub { +@{$_[0]} }, # scalar @{$_[0]} would be clearer
'append' => sub { [@{$_[0]}, @{$_[1]}] },
'list' => sub { [@_[0..@_-1]] },
OUTER => 0,
};
sub set {
my ($env, $key, $val) = @_;
(defined $$env{$key}
? $$env{$key} : $$env{OUTER}{$key}) = $val
}
sub find {
my ($key, $env) = @_;
return $$env{$key} if defined $$env{$key};
return 0 unless $$env{OUTER};
return find($key, $$env{OUTER});
}
sub scm_parse {
$_ = join ' ', map {s/([^\[\]]+)/'$1'/;
s/([^\[]+)/$1,/r} split /\s/, $_[0] =~ y/()/[]/r;
s/("[^"]*?)',(\s+)'([^"]*?"')/$1$2$3/g;
eval
}
sub scm_eval {
my ($in, $env) = @_;
return find($in, $env) if find($in, $env);
return $in if ref $in ne 'ARRAY';
given ($$in[0]) {
when ('lambda') { sub { scm_eval($$in[2], {zip(@{$$in[1]},@_), OUTER=>$env}) } }
when ('define') { $$env{$$in[1]} = scm_eval($$in[2], $env) }
when ('if') { scm_eval(scm_eval($$in[1], $env) ? $$in[2] : $$in[3], $env) }
when ('set!') { set($env, $$in[1], scm_eval($$in[2], $env)) }
when ('quote') { [@$in[1..@$in-1]] }
when ('begin') { [map { scm_eval($_, $env) } @$in[1..@$in-1]]->[-1] }
when ('defmacro')
{ ... }
default {
@exp = map {scm_eval($_, $env)} @$in;
$exp[0]->(@exp[1..$#exp])
}
}
}
sub scm_write {
$_ = shift;
return '(' . (join ' ', @$_) . ')' if ref $_ eq 'ARRAY';
return $_ if /^\d+(\.\d+)?$/;
s/^"(.*)"$/$1/, return $_ if /^".*?"$/;
return "function $_" if ref $_ eq 'CODE';
warn "Didn't recognize type -- $_";
}
sub pe {
scm_eval scm_parse($_[0]), $env
}
sub scm_repl {
print '==> ';
while (<STDIN>) {
print scm_write(scm_eval(scm_parse($_), $env));
print "\n==> ";
}
}
scm_repl();