Introduce check_postcondition

Author: masak

lib/Language/Bel/Compiler/Gensym.pm

@@ -19,12 +19,17 @@ sub gensym {
     return $GENSYM_PREFIX . sprintf("%04d", ++$unique_gensym_index);
 }
 
+sub starts_with {
+    my ($string, $prefix) = @_;
+
+    return substr($string, 0, length($prefix)) eq $prefix;
+}
+
 sub is_gensym {
     my ($expr) = @_;
 
     return is_symbol($expr)
-        && substr(symbol_name($expr), 0, length($GENSYM_PREFIX))
-            eq $GENSYM_PREFIX;
+        && starts_with(symbol_name($expr), $GENSYM_PREFIX);
 }
 
 our @EXPORT_OK = qw(

lib/Language/Bel/Compiler/Pass.pm

@@ -16,14 +16,20 @@ sub translate {
     my ($self, $program) = @_;
 
     $self->check_precondition($program);
+    my $result = $self->do_translate($program);
+    $self->check_postcondition($result);
 
-    return $self->do_translate($program);
+    return $result;
 }
 
 sub check_precondition {
     # do nothing by default
 }
 
+sub check_postcondition {
+    # do nothing by default
+}
+
 # @abstract
 sub do_translate {
     my ($self) = @_;

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

@@ -9,6 +9,7 @@ use Language::Bel::Core qw(
     is_nil
     is_pair
     is_symbol
+    is_symbol_of_name
     make_pair
     make_symbol
     symbol_name
@@ -23,6 +24,7 @@ use Language::Bel::Compiler::Primitives qw(
 );
 use Language::Bel::Compiler::Gensym qw(
     gensym
+    is_gensym
 );
 
 sub new {
@@ -94,4 +96,51 @@ sub do_translate {
     );
 }
 
+# @override
+sub check_postcondition {
+    my ($self, $ast) = @_;
+
+    my $args = car(cdr(cdr($ast)));
+    my $body = cdr(cdr(cdr($ast)));
+
+    assure_meets_postcondition($body);
+}
+
+sub is_among_symbol_names {
+    my ($value, @names) = @_;
+
+    for my $name (@names) {
+        return 1
+            if is_symbol_of_name($value, $name);
+    }
+    return '';
+}
+
+sub assure_meets_postcondition {
+    my ($value) = @_;
+
+    if (is_nil($value)) {
+        return;
+    }
+    elsif (is_pair($value) && is_symbol_of_name(car($value), "quote")) {
+        return;
+    }
+    elsif (is_pair($value)) {
+        assure_meets_postcondition(car($value));
+        assure_meets_postcondition(cdr($value));
+    }
+    elsif (is_gensym($value)) {
+        return;
+    }
+    elsif (is_among_symbol_names($value, "id", "type")) {
+        return;
+    }
+    elsif (is_symbol_of_name($value, "no")) {
+        return;         # XXX: should be generalized to "known globals"
+    }
+    else {
+        die "Doesn't meet precondition: '", _print($value), "'";
+    }
+}
+
 1;

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

@@ -23,6 +23,7 @@ use Language::Bel::Reader qw(
 );
 use Language::Bel::Compiler::Gensym qw(
     gensym
+    is_gensym
 );
 use Language::Bel::Compiler::Primitives qw(
     car
@@ -186,4 +187,102 @@ sub do_translate {
     );
 }
 
+# @override
+sub check_postcondition {
+    my ($self, $ast) = @_;
+
+    my $body = cdr(cdr($ast));
+
+    while (!is_nil($body)) {
+        die "body not a pair"
+            unless is_pair($body);
+
+        my $operation = car($body);
+
+        my @operands;
+        while (!is_nil($operation)) {
+            die "operation is not a pair"
+                unless is_pair($operation);
+            push @operands, car($operation);
+            $operation = cdr($operation);
+        }
+
+        my $op_name = shift(@operands);
+
+        if (is_symbol_of_name($op_name, "return")) {
+            die "expected gensym as only operand to 'return'"
+                unless scalar(@operands) == 1 && is_gensym($operands[0]);
+        }
+        elsif (is_gensym($op_name)) {
+            die "expected two operands"
+                unless scalar(@operands) == 2;
+            die "expected := immediately after gensym"
+                unless is_pair($operands[0])
+                    && is_symbol_of_name(car($operands[0]), "compose")
+                    && is_symbol_of_name(car(cdr($operands[0])), "=");
+
+            my $rhs = $operands[1];
+            my @rhs_operands;
+            while (!is_nil($rhs)) {
+                die "rhs operation is not a pair"
+                    unless is_pair($rhs);
+                push @rhs_operands, car($rhs);
+                $rhs = cdr($rhs);
+            }
+
+            my $rhs_op = shift(@rhs_operands);
+
+            if (is_pair($rhs_op)
+                && is_symbol_of_name(car($rhs_op), "prim")
+                && is_pair(car(cdr($rhs_op)))
+                && is_symbol_of_name(car(car(cdr($rhs_op))), "quote")
+                && is_symbol(car(cdr(car(cdr($rhs_op)))))) {
+
+                my $primop_name = symbol_name(car(cdr(car(cdr($rhs_op)))));
+
+                die "expected primop to be id or type"
+                    unless $primop_name eq "id" || $primop_name eq "type";
+
+                if ($primop_name eq "id") {
+                    die "expected prim!id to have 2 operands"
+                        unless scalar(@rhs_operands) == 2;
+
+                    die "expected first prim!id operand to be a gensym"
+                        unless is_gensym($rhs_operands[0]);
+
+                    die "expected second prim!id operand to be a quoted symbol"
+                        unless is_pair($rhs_operands[1])
+                            && is_symbol_of_name(car($rhs_operands[1]), "quote")
+                            && is_symbol(car(cdr($rhs_operands[1])));
+                }
+                elsif ($primop_name eq "type") {
+                    die "expected prim!type to have 1 operand"
+                        unless scalar(@rhs_operands) == 1;
+
+                    die "expected prim!type operand to be a gensym"
+                        unless is_gensym($rhs_operands[0]);
+                }
+                else {
+                    die "unexpected type of primop: $primop_name";
+                }
+            }
+            elsif (is_symbol_of_name($rhs_op, "quote")) {
+                die "expected quote to have 1 operand"
+                    unless scalar(@rhs_operands) == 1;
+
+                die "expected quote operand to be a symbol"
+                    unless is_symbol($rhs_operands[0]);
+            }
+            else {
+                die "unexpected rhs";
+            }
+        }
+        else {
+            die "unrecognized operation: ", _print($operation);
+        }
+
+        $body = cdr($body);
+    }
+}
+
 1;