#!/usr/local/bin/perl
#
#	occheck - check reachability analysis on oc files.
#
#	v1.0
#		-- Carlos Puchol, Nov 1995.
#		-- cpg@cs.utexas.edu
#
# To do:
# 	Need to make sure that in the event of a ctrl-c,
#	the temp file is unlinked.
#
#	Need to be able to handle ocfiles with a '-' instead of the
#	signal number.

$sml = "sml_run_time_prototype";	# change this if the sml command is different
$sml_heap="occheck_heap_prototype";	# replace your path to the heap file

$debug0=0;			# check the type of oc file
$debug1=0;			# debug get_state
$debug2=0;			# debug get_trace
$debug3=0;			# debug read_state
$debug4=0;			# debug compute_emitted
$debug5=0;			# debug signal parsing
$debugformat=0;			# debug formatting
$debuginputs=0;			# debug inputs parsing
$debugoutputs=0;		# debug outputs parsing
$debugIO=0;			# sho input/output info

$snumber = 0;			# number of the signal
$nsignals = 0;			# number of signals
$show_all_signals=0;

&open_file;

&get_io;			# Get the name of the i/o signals

&dump_states;

&get_trace;

&cleanup;

#################################################################
#
#	Subroutines
#
#################################################################

sub byebye {
    local($stat)=($_[0]);

    unlink ($tempfile);
    exit $stat;
}

sub open_file {

    $0 =~ /[^\/]+$/;		# Take the basename
    $progname=$&;

    if ($ARGV[0] =~ "-a") {
	shift (@ARGV);
	$show_all_signals=1;
    }

    if (@ARGV < 2) {
	die ("Usage: $progname [-a] <fname> <signal>\n",
	     "\tPerform a reachability check for <signal> on <fname>.\n",
	     "\t-a to include a report of all internal signals.\n");
    }

    $tempfile = "/tmp/ocdump$$";

    open(OC, "$ARGV[0]") || die "$progname: can't open $ARGV[0]: $!.\n";

    open(TEMP, ">$tempfile") || die "$progname: can't open $tempfile: $!.\n";

    $signal = $ARGV[1];		# name of the signal

    $SIG{'INT'} = '&byebye(0)';
    $SIG{'QUIT'} = '&byebye(0)';
    $SIG{'TERM'} = '&byebye(0)';
}

sub cleanup {
    unlink ($tempfile);
}

sub get_io {

    while (<OC>) {
	if (/(oc\d+):/) {
	    $octype= $1;
	    last;
	}
    }
    if ($debug0) { print "OCTYPE is $octype\n"; }

    while (<OC>) {
	if (/signals:/) {
	    $nsignals= int($');
	    last;
	}
    }

    while (<OC>) {
	if (/(\d+): input: (\w+) +(\d+|-)/) {
	    $index = ($3 == '-') ? $1 : $3;
	    $is[$index] = $2;
	    $isnumber{$2}= $index;
	    if ($debug5) {
		print "Input signal: $2 has index $index.\n";
	    }
	} elsif (/(\d+): output: (\w+) +(\d+|-)/) {
	    $index = ($3 == '-') ? $1 : $3;
	    $os[$index] = $2;
	    $osnumber{$2}=$index;
	    if ($debug5) {
		print "Output signal: $2 has index $index.\n";
	    }
	} elsif (/(\d+): inputoutput: (\w+) *(\d+|-) *(\d+|-)/) {
	    $iindex = ($3 == '-') ? $1 : $3;
	    $oindex = ($4 == '-') ? $1 : $4;
	    $is[$iindex] = $2;
	    $isnumber{$2}=$iindex;
	    $os[$oindex] = $2;
	    $osnumber{$2}=$oindex;
	    if ($debug5) {
		print "Input signal: $2 has index $iindex.\n";
		print "Output signal: $2 has index $oindex.\n";
	    }
	} else { last }
    }

    while (1) {
	if (/(\d+): local:.*%name: (\w+)%/) {
	    $ls[$1] =  $2;
	    $lsnumber{$2}=$1;
	    $_=<OC>;
	} elsif (/(\d+): exception:.*%name: (\w+)%/) {
	    $es[$1] = $show_all_signals ? $2 : "";
	    $esnumber{$2}=$1;
	    $_=<OC>;
	} else { last }
    }

    die "$progname: signal $signal is not an output signal.\n" if ($osnumber{$signal} eq "");
    $snumber = int($osnumber{$signal});
}

sub dump_states {
    local($first_s, $current_s, $sep);

    while (<OC>) {
	if (/states: (\d+)/) { $nstates = int($1); last }
    }
    while (<OC>) {
	if (/startpoint: (\d+)/) { $startpoint = int($1); last }
    }

    if ($debug3) {
	print "NStates: $nstates\n";
	print "Signal number: $snumber\n";
	print "Start point: $startpoint\n";
    }

    $first_s=0;
    $current_s=0;
    $sep=$/;
    $/="\n\n";			# Make sure the field separator is a blank line

    while (<OC>) {
	($line=$_) =~ s/\n/ /g;	# Read all state in one line, clear the newlines
	if (/^(\d+):/) {
	    $current_s = int($1);
	    $states[$current_s]=$line;
	    print TEMP "$line\n";
	    if ($debug3) { print "State $current_s is \"$line\".\n"; }
	}
    }
    if ($nstates != @states) {
	print "$progname: Warning number of states read unexpected (", scalar(@states), ").\n";
    }

    if ($debug3) { print "Last state is $current_s.\n"; }
    if ($debug3) { print "$progname: checking for reachability of $signal.\n" }

    $/=$sep;			# Restore field separator
    close (TEMP);
}


sub format_trace {
    local($top, $f_state, $f_next_state, $f_inputl, $f_outputl);

    print "Trace for signal: $ARGV[1] ($osnumber{$ARGV[1]}):\n";

    format top =
---------------------------------------------------------------------------|
Curr Next |                             |                                  |
St.  St.  | Input event                 | Output event                     |
---------------------------------------------------------------------------|
.
    format =
@<<< @<<< | ^<<<<<<<<<<<<<<<<<<<<<<<<<< | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
$f_state, $f_next_state, $f_inputl,       $f_outputl
~~        | ^<<<<<<<<<<<<<<<<<<<<<<<<<< | ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<|
            $f_inputl,                    $f_outputl
---------------------------------------------------------------------------|
.
}


sub separate_inputs {		# find out which inputs are actually emitted

    local($raw, *table, $result)=($_[0], $_[1], "");

    if ($debuginputs) { print "------> \"$raw\"\n"; }
    foreach $val (split (/ +/, $raw)) {
	if ($debuginputs) { print ">>>>>>> \"$val\", ", $val, " is ", $is[$val], "\n"; }
	if ($val eq "#") {
	    $result .= "#";
	} elsif ($val ne "") {
	    $result .= $table[$val] . " ";
	}
    }

    if ($result =~ /^ *([^ ].*[^ ]) *$/) {
	$result = $1;
    }
    if ($debuginputs) { print "======> \"$result\"\n"; }

    return $result;
}

sub separate_outputs {		# find out which signals are actually emitted

    local($raw, $table, $result)=($_[0]);

    if ($debugoutputs) { print "------> \"$raw\"\n"; }
    $result="";
    foreach $val (split (/ +/, $raw)) {
	if ($debugoutputs) { print ">>>>>>> \"$val\", ", $val, " is ", $os[$val], "\n"; }
	if ($val != "") {
		$result .= $os[$val] . " ";
	}
    }

    if ($debugoutputs) { print "======> \"$result\"\n"; }

    return $result;
}


sub do_formatting {		# do_formatting(state, next state, inputs, outputs, locals)

    local($st, $ns, $ti, $to, $tl)=($_[0], $_[1], $_[2], $_[3], $_[4]);

    # $ti $to and $tl could be empty

    if ($debugformat) {
	print "This State: $st\n";
	print "Next State: $ns\n";
	print "Inputs:     \"$ti\"\n";
	print "Outputs:    \"$to\"\n";
	print "Locals:     \"$tl\"\n";
    }

    $f_state=$st;
    $f_next_state=$ns;
    undef $f_inputl;
    undef $f_outputl;
    $f_inputl=&separate_inputs($ti, *is);
    $f_outputl=&separate_inputs($to, *os);
    if ($show_all_signals) {
	$f_outputl .= "\r-----vvv-----LOCALS-----vvv-----\r" . &separate_inputs($tl, *ls);
    }
    write;
}


sub get_trace {

    local ($command) = ("$sml \@SMLdebug=/dev/null \@SMLquiet \@SMLload=$sml_heap");
    local ($length) = -1;

    open (CHECK, "$command $snumber <$tempfile |") || die "$progname: can't execute the sml subprocess ($!).";

    &format_trace;

    while (<CHECK>) {
	if (/trace:/) {
	    $length = 0;
	    last;
	}
    }
    if ((eof CHECK) || ($length == -1)) {
	print ("$progname: there was a problem executing the sml process.\n");
	print ("$progname: (perhaps not the proper version of sml?)\n");
	&byebye(1);
    }

    while (<CHECK>) {
	if (/(\d+) : (\d*) : ([^:]*) : ([^:]*) : ([^;]*);/) {
	    $length++;
	    &do_formatting($1, $2, $3, $4, $5);
	} elsif (/done./) { last }
    }

    close CHECK;

    if ($length == -1) {
	print ("There was a problem executing the sml process.\n");
	&byebye(1);
    }
    if ($length == 0) {
	print ("There exists no trace leading to the emission of signal $signal.\n");
	&byebye(0);
    }
    print ("The trace has length $length.\n");
    &byebye(0);
}
