#!/usr/bin/perl

# lambda eliminator and named subexpression expander

# syntax: (expr | <sub>=expr)*
#
# expr is Unlambda expression, which may also contain
# named subexpressions <sub>, variables $var, and
# lambda expressions ^var expr
#
# Expression names are nonempty strings not containing ">".
# Variable names are nonempty strings of alphanumeric characters and/or "_".
#
# Comments, marked by # and extending to the end of line, are ignored.
#
# By default the lambda expression optimizer assumes that variables
# never evaluate to the "d" builtin. However, variables whose names
# begin with a capital letter are exempt from such assumption.
# Example: ^x^y`$x$y  ->  i
#          ^X^y`$X$y  ->  `dd
#

# written by Emil Jerabek, public domain

# CHANGELOG:
# 2004-??-??: initial release
# 2006-02-24: changed variable syntax

sub getnext {
# $s is global buffer
    for (;;) {
	$s =~ s/^\s+//;
	$s =~ s/^\#(?:.|\n)*$//;
	return 1 unless $s eq "";
	if (!defined($s = <>)) {
	    $_[0] ? return 0 : die "unexpected end of input\n";
	}
#	print "# $s";
    }
}

# expr = [s, e] or [s, "`", l, r],
# s: "safeness level" of the expression:
#  0 = nothing special,
#  1 = evaluation terminates and has no side-effects,
#  2 = ditto + the final value is not "d"

sub parse {
    getnext();

    $s =~ s/^(.)//;
    my $c = lc $1;

    if ($c =~ m{[skivcder@|/]}) {
	return [($c eq "d" ? 1 : 2), $c];
    }

    if ($c =~ /[.?]/) {
	$s =~ s/^(.|\n)// or die "unexpected end of input\n";
	return [2, "$c$1"];
    }

    if ($c eq '`') {
	my ($a, $b) = (parse(), parse());
	my $safe =
	    $a->[1] eq "d" ||
	    $b->[0] && ($a->[1] =~ /^[sk]/ ||
			$a->[1] eq "`" && $a->[2][1] eq "s" && $a->[3][0]);
	return [($safe ? 2 : 0), "`", $a, $b];
    }

    if ($c eq '$') {
	$s =~ s/^([[:alnum:]_]+)//
	    or die "line $.: \$ not followed by identifier\n";
        my $n = $1;
	return [(($n =~ /^[[:upper:]]/) ? 1 : 2), "\$$n"];
    }

    if ($c eq '<') {
	$s =~ s/^([^>]+)>//
	    or die "line $.: missing >\n";
	return $expr{$1} || die "line $.: unknown expression <$1>\n";
    }

    if ($c eq '^') {
	getnext();
	$s =~ s/^([[:alnum:]_]+)//
	    or die "line $.: ^ not followed by identifier\n";
	return lambda("\$$1", parse());
    }

    die "line $.: unrecognized character $c\n";
}

sub printexp {
    my ($e, $sp) = @_;

    print " " if $sp and $e->[1] =~ /^[a-z]/;
    print $e->[1];
    if ($e->[1] eq "`") {
	$sp = printexp($e->[2]);
	return printexp($e->[3], $sp);
    }
    return $e->[1] =~ /^\$/;
}

sub lambda {
    my ($v, $e) = @_;

    my ($a) = expand($v, $e);
    $a and return $a;
    $e->[0] and return [2, "`", [2, "k"], $e];
    return [2, "`", [1, "d"], [0, "`", [2, "k"], $e]];
}

sub expand {
    my ($v, $e) = @_;

    if ($e->[1] eq "`") {
	my ($a) = expand($v, $e->[2]);
	if (!$a) {
	    if ($e->[3][1] eq $v) {
		$e->[2][0] >= 2 and return $e->[2];
		return [2, "`", [1, "d"], $e->[2]];
	    }
	    my ($b) = expand($v, $e->[3]);
	    $b or return 0;
	    if ($e->[2][0]) {
		$a = [2, "`", [2, "k"], $e->[2]];
	    } else {
		$a = [2, "`", [1, "d"], [0, "`", [2, "k"], $e->[2]]];
	    }
	    return [2, "`", [2, "`", [2, "s"], $a], $b];
	}
	my ($b) = expand($v, $e->[3]);
	if (!$b) {
	    if ($e->[3][0]) {
		$b = [2, "`", [2, "k"], $e->[3]];
	    } else {
		$b = [2, "`", [1, "d"], [0, "`", [2, "k"], $e->[3]]];
	    }
	}
	return [2, "`", [2, "`", [2, "s"], $a], $b];
    }
    return $e->[1] eq $v && [2, "i"];
}

while (getnext(1)) {
    $name = undef;
    if ($s =~ s/^\s*<([^>]+)>\s*=//) {
	$name = $1;
	$expr{$name} and die "line $.: <$name> already defined\n";
    }
    $exp = parse();
    if ($s !~ /^\s*(?:\#.*)?$/) {
	die "line $.: garbage after end of expression: $s\n";
    }
    if (defined $name) {
	$expr{$name} = $exp;
	print "<$name>=";
    }
    printexp($exp);
    print "\n";
}