wip

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,37 @@ 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);
+        print("OPERATION: ", _print($operation), "\n");
+        die "operation is not a pair"
+            unless is_pair($operation);
+
+        # XXX: first, check if the form is (gensym := ...)
+        # (and in that case, only allow a subset of the op types)
+        my $op_name = car($operation);
+        if (is_symbol_of_name($op_name, "return")) {
+            # XXX: handle checking of 'return' operands
+        }
+        # (gensym_0004 (compose =) ((prim (quote id)) gensym_0003 (quote pair)))
+        elsif (is_gensym($op_name)) {
+            # XXX: handle the above operation more in detail
+        }
+        else {
+            die "unrecognized operation: ", _print($operation);
+        }
+
+        $body = cdr($body);
+    }
+}
+
 1;