Skip to content

Commit 4ce3396

Browse files
masakmasak
committed
Introduce check_postcondition
1 parent 9c8bdb9 commit 4ce3396

File tree

5 files changed

+281
-3
lines changed

5 files changed

+281
-3
lines changed

‎lib/Language/Bel/Compiler/Gensym.pm

+7-2
Original file line numberDiff line numberDiff line change
@@ -19,12 +19,17 @@ sub gensym {
1919
return $GENSYM_PREFIX . sprintf("%04d", ++$unique_gensym_index);
2020
}
2121

22+
sub starts_with {
23+
my ($string, $prefix) = @_;
24+
25+
return substr($string, 0, length($prefix)) eq $prefix;
26+
}
27+
2228
sub is_gensym {
2329
my ($expr) = @_;
2430

2531
return is_symbol($expr)
26-
&& substr(symbol_name($expr), 0, length($GENSYM_PREFIX))
27-
eq $GENSYM_PREFIX;
32+
&& starts_with(symbol_name($expr), $GENSYM_PREFIX);
2833
}
2934

3035
our @EXPORT_OK = qw(

‎lib/Language/Bel/Compiler/Pass.pm

+7-1
Original file line numberDiff line numberDiff line change
@@ -16,14 +16,20 @@ sub translate {
1616
my ($self, $program) = @_;
1717

1818
$self->check_precondition($program);
19+
my $result = $self->do_translate($program);
20+
$self->check_postcondition($result);
1921

20-
return $self->do_translate($program);
22+
return $result;
2123
}
2224

2325
sub check_precondition {
2426
# do nothing by default
2527
}
2628

29+
sub check_postcondition {
30+
# do nothing by default
31+
}
32+
2733
# @abstract
2834
sub do_translate {
2935
my ($self) = @_;

‎lib/Language/Bel/Compiler/Pass/AllocateRegisters.pm

+119
Original file line numberDiff line numberDiff line change
@@ -6,10 +6,16 @@ use strict;
66
use warnings;
77

88
use Language::Bel::Core qw(
9+
is_nil
910
is_pair
1011
is_symbol
12+
is_symbol_of_name
1113
make_pair
1214
make_symbol
15+
symbol_name
16+
);
17+
use Language::Bel::Printer qw(
18+
_print
1319
);
1420
use Language::Bel::Compiler::Gensym qw(
1521
is_gensym
@@ -42,6 +48,21 @@ sub substitute_registers {
4248
}
4349
}
4450

51+
sub starts_with {
52+
my ($string, $prefix) = @_;
53+
54+
return substr($string, 0, length($prefix)) eq $prefix;
55+
}
56+
57+
my $REGISTER_PREFIX = "%";
58+
59+
sub is_register {
60+
my ($expr) = @_;
61+
62+
return is_symbol($expr)
63+
&& starts_with(symbol_name($expr), $REGISTER_PREFIX);
64+
}
65+
4566
# @override
4667
sub check_precondition {
4768
# no checks
@@ -65,4 +86,102 @@ sub do_translate {
6586
);
6687
}
6788

89+
# @override
90+
sub check_postcondition {
91+
my ($self, $ast) = @_;
92+
93+
my $body = cdr(cdr($ast));
94+
95+
while (!is_nil($body)) {
96+
die "body not a pair"
97+
unless is_pair($body);
98+
99+
my $operation = car($body);
100+
101+
my @operands;
102+
while (!is_nil($operation)) {
103+
die "operation is not a pair"
104+
unless is_pair($operation);
105+
push @operands, car($operation);
106+
$operation = cdr($operation);
107+
}
108+
109+
my $op_name = shift(@operands);
110+
111+
if (is_symbol_of_name($op_name, "return")) {
112+
die "expected gensym as only operand to 'return'"
113+
unless scalar(@operands) == 1 && is_register($operands[0]);
114+
}
115+
elsif (is_register($op_name)) {
116+
die "expected two operands"
117+
unless scalar(@operands) == 2;
118+
die "expected := immediately after gensym"
119+
unless is_pair($operands[0])
120+
&& is_symbol_of_name(car($operands[0]), "compose")
121+
&& is_symbol_of_name(car(cdr($operands[0])), "=");
122+
123+
my $rhs = $operands[1];
124+
my @rhs_operands;
125+
while (!is_nil($rhs)) {
126+
die "rhs operation is not a pair"
127+
unless is_pair($rhs);
128+
push @rhs_operands, car($rhs);
129+
$rhs = cdr($rhs);
130+
}
131+
132+
my $rhs_op = shift(@rhs_operands);
133+
134+
if (is_pair($rhs_op)
135+
&& is_symbol_of_name(car($rhs_op), "prim")
136+
&& is_pair(car(cdr($rhs_op)))
137+
&& is_symbol_of_name(car(car(cdr($rhs_op))), "quote")
138+
&& is_symbol(car(cdr(car(cdr($rhs_op)))))) {
139+
140+
my $primop_name = symbol_name(car(cdr(car(cdr($rhs_op)))));
141+
142+
die "expected primop to be id or type"
143+
unless $primop_name eq "id" || $primop_name eq "type";
144+
145+
if ($primop_name eq "id") {
146+
die "expected prim!id to have 2 operands"
147+
unless scalar(@rhs_operands) == 2;
148+
149+
die "expected first prim!id operand to be a register"
150+
unless is_register($rhs_operands[0]);
151+
152+
die "expected second prim!id operand to be a quoted symbol"
153+
unless is_pair($rhs_operands[1])
154+
&& is_symbol_of_name(car($rhs_operands[1]), "quote")
155+
&& is_symbol(car(cdr($rhs_operands[1])));
156+
}
157+
elsif ($primop_name eq "type") {
158+
die "expected prim!type to have 1 operand"
159+
unless scalar(@rhs_operands) == 1;
160+
161+
die "expected prim!type operand to be a register"
162+
unless is_register($rhs_operands[0]);
163+
}
164+
else {
165+
die "unexpected type of primop: $primop_name";
166+
}
167+
}
168+
elsif (is_symbol_of_name($rhs_op, "quote")) {
169+
die "expected quote to have 1 operand"
170+
unless scalar(@rhs_operands) == 1;
171+
172+
die "expected quote operand to be a symbol"
173+
unless is_symbol($rhs_operands[0]);
174+
}
175+
else {
176+
die "unexpected rhs";
177+
}
178+
}
179+
else {
180+
die "unrecognized operation: ", _print(car($body));
181+
}
182+
183+
$body = cdr($body);
184+
}
185+
}
186+
68187
1;

‎lib/Language/Bel/Compiler/Pass/Alpha.pm

+49
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ use Language::Bel::Core qw(
99
is_nil
1010
is_pair
1111
is_symbol
12+
is_symbol_of_name
1213
make_pair
1314
make_symbol
1415
symbol_name
@@ -23,6 +24,7 @@ use Language::Bel::Compiler::Primitives qw(
2324
);
2425
use Language::Bel::Compiler::Gensym qw(
2526
gensym
27+
is_gensym
2628
);
2729

2830
sub new {
@@ -94,4 +96,51 @@ sub do_translate {
9496
);
9597
}
9698

99+
# @override
100+
sub check_postcondition {
101+
my ($self, $ast) = @_;
102+
103+
my $args = car(cdr(cdr($ast)));
104+
my $body = cdr(cdr(cdr($ast)));
105+
106+
assure_meets_postcondition($body);
107+
}
108+
109+
sub is_among_symbol_names {
110+
my ($value, @names) = @_;
111+
112+
for my $name (@names) {
113+
return 1
114+
if is_symbol_of_name($value, $name);
115+
}
116+
return '';
117+
}
118+
119+
sub assure_meets_postcondition {
120+
my ($value) = @_;
121+
122+
if (is_nil($value)) {
123+
return;
124+
}
125+
elsif (is_pair($value) && is_symbol_of_name(car($value), "quote")) {
126+
return;
127+
}
128+
elsif (is_pair($value)) {
129+
assure_meets_postcondition(car($value));
130+
assure_meets_postcondition(cdr($value));
131+
}
132+
elsif (is_gensym($value)) {
133+
return;
134+
}
135+
elsif (is_among_symbol_names($value, "id", "type")) {
136+
return;
137+
}
138+
elsif (is_symbol_of_name($value, "no")) {
139+
return; # XXX: should be generalized to "known globals"
140+
}
141+
else {
142+
die "Doesn't meet precondition: '", _print($value), "'";
143+
}
144+
}
145+
97146
1;

‎lib/Language/Bel/Compiler/Pass/Flatten.pm

+99
Original file line numberDiff line numberDiff line change
@@ -23,6 +23,7 @@ use Language::Bel::Reader qw(
2323
);
2424
use Language::Bel::Compiler::Gensym qw(
2525
gensym
26+
is_gensym
2627
);
2728
use Language::Bel::Compiler::Primitives qw(
2829
car
@@ -186,4 +187,102 @@ sub do_translate {
186187
);
187188
}
188189

190+
# @override
191+
sub check_postcondition {
192+
my ($self, $ast) = @_;
193+
194+
my $body = cdr(cdr($ast));
195+
196+
while (!is_nil($body)) {
197+
die "body not a pair"
198+
unless is_pair($body);
199+
200+
my $operation = car($body);
201+
202+
my @operands;
203+
while (!is_nil($operation)) {
204+
die "operation is not a pair"
205+
unless is_pair($operation);
206+
push @operands, car($operation);
207+
$operation = cdr($operation);
208+
}
209+
210+
my $op_name = shift(@operands);
211+
212+
if (is_symbol_of_name($op_name, "return")) {
213+
die "expected gensym as only operand to 'return'"
214+
unless scalar(@operands) == 1 && is_gensym($operands[0]);
215+
}
216+
elsif (is_gensym($op_name)) {
217+
die "expected two operands"
218+
unless scalar(@operands) == 2;
219+
die "expected := immediately after gensym"
220+
unless is_pair($operands[0])
221+
&& is_symbol_of_name(car($operands[0]), "compose")
222+
&& is_symbol_of_name(car(cdr($operands[0])), "=");
223+
224+
my $rhs = $operands[1];
225+
my @rhs_operands;
226+
while (!is_nil($rhs)) {
227+
die "rhs operation is not a pair"
228+
unless is_pair($rhs);
229+
push @rhs_operands, car($rhs);
230+
$rhs = cdr($rhs);
231+
}
232+
233+
my $rhs_op = shift(@rhs_operands);
234+
235+
if (is_pair($rhs_op)
236+
&& is_symbol_of_name(car($rhs_op), "prim")
237+
&& is_pair(car(cdr($rhs_op)))
238+
&& is_symbol_of_name(car(car(cdr($rhs_op))), "quote")
239+
&& is_symbol(car(cdr(car(cdr($rhs_op)))))) {
240+
241+
my $primop_name = symbol_name(car(cdr(car(cdr($rhs_op)))));
242+
243+
die "expected primop to be id or type"
244+
unless $primop_name eq "id" || $primop_name eq "type";
245+
246+
if ($primop_name eq "id") {
247+
die "expected prim!id to have 2 operands"
248+
unless scalar(@rhs_operands) == 2;
249+
250+
die "expected first prim!id operand to be a gensym"
251+
unless is_gensym($rhs_operands[0]);
252+
253+
die "expected second prim!id operand to be a quoted symbol"
254+
unless is_pair($rhs_operands[1])
255+
&& is_symbol_of_name(car($rhs_operands[1]), "quote")
256+
&& is_symbol(car(cdr($rhs_operands[1])));
257+
}
258+
elsif ($primop_name eq "type") {
259+
die "expected prim!type to have 1 operand"
260+
unless scalar(@rhs_operands) == 1;
261+
262+
die "expected prim!type operand to be a gensym"
263+
unless is_gensym($rhs_operands[0]);
264+
}
265+
else {
266+
die "unexpected type of primop: $primop_name";
267+
}
268+
}
269+
elsif (is_symbol_of_name($rhs_op, "quote")) {
270+
die "expected quote to have 1 operand"
271+
unless scalar(@rhs_operands) == 1;
272+
273+
die "expected quote operand to be a symbol"
274+
unless is_symbol($rhs_operands[0]);
275+
}
276+
else {
277+
die "unexpected rhs";
278+
}
279+
}
280+
else {
281+
die "unrecognized operation: ", _print(car($body));
282+
}
283+
284+
$body = cdr($body);
285+
}
286+
}
287+
189288
1;

0 commit comments

Comments
 (0)