#!/usr/bin/perl

#### reminder: this file (which resides in $JR_HOME/bin or $JR_HOME\bin)
#### is generated from files in $JR_HOME/preproc,
#### so you probably don't want to edit this file directly.


################### start of common.pl #####################################


use strict;

# global variables -- initialized in code.
# scan:
my $tok;
my $realtok;
my $line;
my $wholeline;

# error:
my $exitstatus;
my $errorcnt;
my $MAXERRCNT;
my $Ifile;

my $JR_HOME; # from environment variable

use File::Basename;
my $cmdname;
my $cmdpath;
# 2003-12-05 no longer a .pl file
# my $cmdsuffix;
# ($cmdname,$cmdpath,$cmdsuffix) = fileparse($0,qr{\.pl});
($cmdname,$cmdpath) = fileparse($0);

# banner to protect against clobbering good .jr file
my $BANNER="/* This JR file was generated by $cmdname */";

sub checkfile {
    my $a = shift(@_);
    my $fsuffix = shift(@_);

    # make sure it's a $fsuffix file
    if ("$a" !~ /\.$fsuffix$/) {
	$! = 1;
	die "usage: $cmdname file.$fsuffix\n";
    }
    my $basen;
    my $bpath;
    my $bsuffix;
    ($basen,$bpath,$bsuffix) = fileparse($a,qr{\.$fsuffix});
##  print "$basen\n";
    my $newn = $basen . ".jr";
    # if .jr output file exists, check that it was generated by this tool
    # so that we do not mistakenly blow away a good file.
    if ( -r "$newn" ) {
	open(F, "$newn");
	my $line1 = <F>;
	chop($line1);
	if ("$line1" ne "$BANNER") {
	    $! = 1;
	    die "$newn exists and was not created by $cmdname " .
		"- will not overwrite\n";
	}
	close(F);
    }
    return $newn;
}

sub checkenv {

  $JR_HOME = "";
  $JR_HOME = $ENV{"JR_HOME"};
##  print "x$JR_HOME-\n";

  if(!$JR_HOME){
    warn "$cmdname requires environment variable JR_HOME\n";
    warn "  to be set to the absolute pathname of JR's home;\n";
    warn "  won't be able to copy file(s) needed for JR translation.\n";
    return 0;
  }

  if(!opendir D, $JR_HOME){
    warn "$cmdname: environment variable JR_HOME set to $JR_HOME,\n";
    warn "  but that directory does not exist or is not readable;\n";
    warn "  won't be able to copy file(s) needed for JR translation.\n";
    return 0;
  }
  closedir D;
  return 1;
}

# operates in two similar modes, depending on $matchopen:
# (1)  return as a single string all tokens between $open and matching $close
#      e.g., [ ] or ( )  { }
#      returns opening and closing tokens if ocret param set.
# (2)  return as a single string all tokens upto an unmatched $close
#      include all tokens between matching $open and $close.
#      doesn't return closing token.
#      e.g., "[","]" for string "3+x]" returns "3+x"
#      e.g., "[","]" for string "3+a[4]*9]" returns "3+a[4]*9"
#
# note: unlike skip(), put only " " (not "\n") after id
# so that string can be output within " " without line breaking
# and getting an error.
# we actually do that in printing errors on CSP I/O.
sub grabmatch {
  my $open = shift(@_);
  my $close = shift(@_);
  my $matchopen = shift(@_);
  my $ocret = shift(@_);
  my $ret = "";
  if ($matchopen == 1) {
    mustbe($open);
    if ($ocret == 1) {
      $ret = $ret . $open;
    }
  }
  while ($tok ne "EOF" && $tok ne $close) {
    if ($tok eq $open) {
        # note: recursive calls always set $matchopen.
	$ret = $ret . grabmatch($open, $close, 1, $ocret); # handle nested pair
    }
    else {
      if ($tok eq "ID") {
        $ret = $ret . $realtok . " ";
      }
      else {
        $ret = $ret . $realtok;
      }
      scan();
    }
  }
  mustbe($close);
  if ($ocret == 1) {
    $ret = $ret . $close;
  }
  return $ret;
}

# note: $close must be an ID (so use $realtok in compare and mustbeid).
sub grabupto {
  my $close = shift(@_);
  my $ret = "";
  while ($tok ne "EOF" && $realtok ne $close) { # note: realtok here.
#print "$realtok \n";
    if ($tok eq "ID") {
      $ret = $ret . $realtok . " ";
    }
    else {
      $ret = $ret . $realtok;
    }
    scan();
  }
  mustbeid($close);
  return $ret;
}

sub skip {
  my $delim = shift(@_); # delimiter to skip to
  while ( $tok ne "EOF" && $tok ne $delim) {
    if ($tok eq "ID") {
      outln($realtok);
    }
    else {
      out($realtok);
    }
    scan();
  }
  if ($delim ne "{") {
    mustbe($delim);
  }
}


# code generation routine
sub out {
  print O shift(@_);
}
sub outln { # just do an out with a newline.
  out(shift(@_) . "\n");
}

# checks that tok is t.
# if so, gobbles it and advances to next token.
# returns realtok for current token.
sub mustbe {
  my $t = shift(@_);
  if ( $tok ne $t) {
    error("expected " . $t);
    terminate();
  }
  my $ret = $realtok;
  scan();
  return $ret;
}

# similar to mustbe, but checks for particular ID token.
sub mustbeid {
  my $t = shift(@_);
  if ( $tok ne "ID" || $realtok ne $t) {
    error("expected keyword " . $t);
    terminate();
  }
  my $ret = $realtok;
  scan();
  return $ret;
}



# sets tok to lexical class of actual token
# sets realtok to actual token string value, but only for identifiers
#
# note: in a few places, parsing code calls scan past EOF
# (simplifies parsing code)
# scanner set up to handle that by just returning EOF again.

{ # static local variables
  ## none right now...
  sub scan {
    my $incomment = 0; # 1 iff in /* style comment (not // comment)
    if  ($tok eq "EOF") {
      $realtok = "(*EOF*)";
      return $tok;
    }
    while (1) {
      $line =~ s/^\s+//; # strip any leading white space
      if ($line eq "" ||
          ($incomment == 0 && $line =~ m!^//! )) {
        if (! defined($line = <I>)) {
          if ($incomment == 1) {
            error("comment not terminated at end-of-file");
          }
          $realtok = "(*EOF*)";
          return $tok = "EOF";
        }
        $wholeline = $line; # just for pretty error messages
        # output wholeline to .jr file
        # to make correlating errors in generated code to original easier.
        print O "\n// " . "$Ifile" . ", line " . "$." . ": " .
                $wholeline . "\n";
      }
      else {
        # note: each case below continues (via next) or returns.
#print "uu $line";
        if ($incomment==0 && $line =~ s/^\/\*// ) {
####print "cc" line
          $incomment = 1;
          next;
        }
        if ($incomment==1) {
          if ( $line =~ s/^\*\/// ) {
##**print "ww" line
            $incomment = 0;
          }
          else {
            if ( $line =~ s/^.// ) {
              # gobble a character (but not at EOF)
            }
          }
          next;
        }
        if ( $line =~ s/^\.// ) {
#print "vv $line\n";
            return $realtok = $tok = ".";
	}
        if ( $line =~ s/^([A-Za-z_][A-Za-z_0-9]*)// ) {
	    $realtok = $1;
#print "vv $line\n";
            return $tok = "ID";
	}
        if ( $line =~ s/^;// ) {
#print "vv $line\n";
            return $realtok = $tok = ";";
	}
        if ( $line =~ s/^\{// ) {
#print "vv $line\n";
            return $realtok = $tok = "{";
	}
        if ( $line =~ s/^\}// ) {
#print "vv $line\n";
            return $realtok = $tok = "}";
	}
        if ( $line =~ s/^\[// ) {
#print "vv $line\n";
            return $realtok = $tok = "[";
	}
        if ( $line =~ s/^\]// ) {
#print "vv $line\n";
            return $realtok = $tok = "]";
	}
        if ( $line =~ s/^\(// ) {
#print "vv $line\n";
            return $realtok = $tok = "(";
	}
        if ( $line =~ s/^\)// ) {
#print "vv $line\n";
            return $realtok = $tok = ")";
	}
#print "vvx $line\n";
        if ( $line =~ s/^\,// ) {
#print "vv $line\n";
            return $realtok = $tok = ",";
	}
        if ( $line =~ s/^\=// ) {
#print "vv $line\n";
            return $realtok = $tok = "=";
	}
        if ( $line =~ s/^\!// ) {
#print "vv $line\n";
            return $realtok = $tok = "!";
	}
        if ( $line =~ s/^\?// ) {
#print "vv $line\n";
            return $realtok = $tok = "?";
	}
        if ($line =~ s/^"//) { # probably better Perl way to do this...
#print "vv $line\n";
          my $found = 0;
          my $str = "";
          while ( $line ne "\n" && $line ne "") {
            if ( $line =~ s/^\"//) {
              $found = 1;
              last;
            }
            elsif ( $line =~ s/^(\\\")// || $line =~ s/^(.)// ) {
              $str = $str . $1;
            }
##print "vv-$line-\n";
          }
          if ($found == 0) {
            error("unterminated string");
            terminate();
          }
          $realtok = "\"" . $str . "\"";
          return $tok = "(string)"
        }
        if ($line =~ s/^\'//) { # probably better Perl way to do this...
#print "vv $line\n";
          if ($line eq "") {
            error("unterminated char literal");
            terminate();
          }
          my $chr = "";
          if ($line =~ s/^\\//) {
            $chr = "\\";
          }
          if ( $line =~ s/^(.)// ) {
            $chr = $chr . $1;
          }
          else {
            error("unterminated char literal");
            terminate();
          }
          if ($line !~ s/^\'//) {
            error("unterminated char literal");
            terminate();
          }
          $realtok = "\'" . $chr . "\'";
          return $tok = "(char)";
        }
        if ( $line =~ s/^(.)// ) {
## print "vv $line\n";
            $realtok = $1;
            return $tok = "(other)";
	}
        error("ow! -- scanner fell through.");
      }
    }
  }
}  

sub error {
  my $s = shift(@_);
  $exitstatus = 1;
  $errorcnt++;
  print_error($s);
  if ($errorcnt > $MAXERRCNT) {
    print_error("too many errors; giving up");
    terminate();
  }
}

sub print_error {
  my $s = shift(@_);
  my $wl = $wholeline;
  if ($wl !~ /\n$/ ) { # in case file ends without newline.
    $wl = $wl . "\n";
  }
  warn "$cmdname: " . "$Ifile" . ", line " . "$." . ": " . $wl;
  if (defined($line)) { # $line not defined, e.g., on EOF
    my $cl = $line;
    chop($cl);
    if ($cl ne "") {
      warn "$cmdname: " . "near: \"" . $cl . "\"\n";
    }
  }
  warn "$cmdname: " . $s ."\n";
}

sub terminate() {
  exit $exitstatus;
}

################### end of common.pl #####################################

my $fsuffix = "m";

# which signaling discipline.
my $sigdisc = "-sc";
my %sd; # table for pretty error messages

$sd{"-sc"} = "signal and continue";
$sd{"-sw"} = "signal and wait";
$sd{"-su"} = "signal and urgent wait";
$sd{"-sx"} = "signal and exit";

main();

sub main {

  $exitstatus = 0; # in case no command line args, so terminate works.

  # only allow signaling discipline as first argument.
  my @newargv;
  my $got = 0;
  foreach my $a (@ARGV) {
    if ($a =~ /^-sc$/ || $a =~ /^-sw$/ ||
        $a =~ /^-su$/ || $a =~ /^-sx$/ ) {
      if ($got != 0) {
	$! = 1;
        die "multiple signaling disciplines as command line options\n";
      }
      $sigdisc = $a;
      $got = 1;
    }
    elsif ($a =~ /^-/) {
      $! = 1;
      die "unknown command line option\n";
    }
    else {
      push(@newargv, $a);
    }
  }

  foreach my $a (@newargv) {
    my $newn = checkfile($a, $fsuffix);
    if (!open(I, "$a")) { # input file
      $! = 1;
      die "can't open $a\n";
    }
    $Ifile = "$a";
    if (!open(O, "> $newn")) { # output file
      $! = 1;
      die "can't open $newn\n";
    }
    do1file();
    close(I);
    close(O);
  }
  use File::Copy;
  if ( checkenv() ) {
    my $PREPROC = "$JR_HOME/preproc/";
    use File::Copy;
    copy("$PREPROC/m_condvar.jr",".");
  }
  terminate();
}

sub do1file {

  # (re-)initialize globals
  $tok = ""; # anything not "EOF"
  $realtok = "(**EOF**)";
  $line = "";
  $wholeline = "";

  $exitstatus = 0;
  $errorcnt = 0;
  $MAXERRCNT = 20;

  print O "$BANNER\n";
  print O "/* for the $sd{$sigdisc} signaling discipline */\n\n";
  parse();
  print O "\n";

}

sub parse {
  scan();
  while ($tok ne "EOF") {
    if ($tok eq "ID") {
      if ($realtok eq "_monitor") {
        mmonitor();
        # not supposed to have anything afterwards,
        # so perhaps should make this an error,
        # but maybe not...
        if ($tok ne "EOF") {
            outln($realtok);
        }
      }
      elsif ($realtok =~ /^_/) {
        error("_ID found outside of monitor body");
      }
      else {
        outln($realtok);
      }
    }
    else {
      out($realtok);
    }
    scan();
  }
  if ($tok ne "EOF") {
    error("junk after logical end of input");
  }
}

# note: this checks for "{" and "}"
# but invoker must out() those as desired.
sub block {
  mustbe("{");
  while ($tok ne "EOF" && $tok ne "}") {
##print "tok is $tok\n";
##print "realtok is $realtok\n";
    if ($tok eq "{") {
      out("{");
      block();
      out("}");
    }
    elsif ($tok eq "ID") {
      if ($realtok eq "_monitor") {
        error("_monitor found nested within _monitor");
      }
      elsif ($realtok eq "_proc") {
        mproc();
      }
      elsif ($realtok eq "_var") {
        mvar();
      }
      elsif ($realtok eq "_condvar") {
        mcondvar();
      }
      elsif ($realtok eq "_signal") {
        msignal();
      }
      elsif ($realtok eq "_signal_all") {
        msignal_all();
      }
      elsif ($realtok eq "_wait") {
        mwait();
      }
      elsif ($realtok eq "_return") {
        mreturn(0);
      }
      elsif ($realtok eq "return") {
        # disallow plain return so can use it within
        # any helper methods (i.e., non _proc) w/i monitor.
        error("within a _proc, use _return instead of return");
        mreturn(0);
      }
      elsif ($realtok eq "reply"  ||
             $realtok eq "forward" ) {
        # disallow reply and forward since don't make sense.
        error("within a proc, reply or forward not allowed");
        # treat it like a return just to keep going.
        mreturn(0);
      }
      elsif ($realtok eq "_empty") {
        mutility($realtok);
      }
      elsif ($realtok eq "_minrank") {
        mutility($realtok);
      }
      elsif ($realtok eq "_print") {
        mutility($realtok);
      }
      else { # i.e., non-interesting id.
        outln($realtok);
        scan();
      }
    }
    else { # i.e., not id
      out($realtok);
      scan();
    }
  }
  mustbe("}");
##  print "tok is $tok\n";
##  print "realtok is $realtok\n";
}

sub mmonitor {
  mustbe("ID"); # skip over _monitor
  my $classname = mustbe("ID");
  outln("class ".$classname." {");
  outln("  sem m_mutex = 1;");
  outln("  sem m_urgentq = 0;");
  outln("  int m_n_urgentq = 0;");
  outln("  String m_name;");
  outln("  public $classname(String n) {");
  outln("    this.m_name = n;");
  outln("  }");

  # this is SU code, but it works for all (m_n_urgentq == 0 for others)
  outln("  private void m_next() {");
##  outln("    try {");
  outln("      if (m_n_urgentq > 0) {");
  outln("        m_n_urgentq--;");
  outln("        V(m_urgentq);");
  outln("      }");
  outln("      else {");
  outln("        V(m_mutex);");
  outln("      }");
##  outln("    } catch (Exception oops) {oops.printStackTrace();}");
  outln("  }");
  
  block();
  out("}");
}

sub mvar {
  mustbe("ID"); # skip over _var
  out("private ");
}

sub mcondvar {
  mustbe("ID"); # skip over _condvar
  my $cvname;
  my $cnt;
  my @subs;
  ($cnt, $cvname, @subs) = cvnameandsubs();
  mustbe(";");
  if ($cnt == 0) {
    outln("private m_condvar $cvname = new m_condvar(\"$cvname\");");
  }
  else {
    my $x = "[]" x $cnt;
    out("private m_condvar $x $cvname = new m_condvar ");
    for (my $k = 0; $k < $cnt; $k++) {
      out("[$subs[$k]]");
    }
    outln(";");
    outln("  {");
    for (my $k = 0; $k < $cnt; $k++) {
      my $b = "[0]" x $k;
      outln("    for (int m_i$k = 0; m_i$k < $cvname$b.length; m_i$k++ ) {");
    }
    my $c = "";
    my $d = "";
    for (my $k = 0; $k < $cnt; $k++) {
      $c = $c . "[m_i$k]";
      $d = $d . "[\"+m_i$k+\"]";
    }
    outln("      $cvname$c = new m_condvar(\"$cvname$d\");");
    for (my $k = 0; $k < $cnt; $k++) {
      out("}");
    }
    outln("  }");
  }
}

# cv name, possibly followed by [e1][e2]...
# returns a list:
#  number of subscripts
#  name
#  subscripts
# each return value is a string of tokens,
# which are output later as needed.
sub cvnameandsubs {
  my $cvname = mustbe("ID");
  my $cnt = 0;
  my @subs;
  while ($tok eq "[") {
    $subs[$cnt] = grabmatch("[","]",1,0);
    $cnt++;
  }
  return ($cnt, $cvname, @subs);
}

sub mproc {
  mustbe("ID"); # skip over _proc
##print "start mproc\n";
  outln("public");
  my $rettype = mustbe("ID"); # grab return type
  outln($rettype);
  skip("{"); # skip over proc header
  outln("{");
##  outln("  try {");
  outln("    op void m_return_from_wait();");
  outln("    P(m_mutex);");
##print "mproc ->stuff\n";
  block();
##print "mproc <-stuff\n";
  outln("  m_next();");
##  outln("  } catch (Exception oops) {oops.printStackTrace();}");
  if ($rettype ne "void") {
    outln("throw new RuntimeException(" .
             "\"reached end of non-void _proc ($Ifile, line $.) " .
             "without executing a return\");");
  }
  outln("}");
##print "end mproc\n";
}

# generated code for all statements contains {...}
# so that these statements can appear
# as single statements to if, else, while, etc.
# e.g.,
#  if (x==2) _signal(cv);




# enclose return in an if statement to avoid unreachable code
# messages that come in case _return comes right before end of _proc.
sub mreturn {
  my $how = shift(@_); # 1 <=> SX right after _signal.
  mustbe("ID"); # skip over _return or return
  outln("{ if (true) {");
  if ($how == 1 && $sigdisc eq "-sx") {
    # msignal generated if(!x.m_signal(){ m_next(); }
    # so need only return stuff here.
  }
  else {
    outln("  m_next();");
  }
  outln("  return ");
  skip(";"); # skip over return expr
  outln(";");
  outln("}}");
}

sub msignal {
  mustbe("ID"); # skip over _signal
  my $cv = grabmatch("(",")",1,1);
  if ($sigdisc eq "-sc") {
    outln("$cv.m_signal();");
    mustbe(";");
  }
  elsif ($sigdisc eq "-sw") {
    out("{ if (");
    outln("$cv.m_signal()) {");
    outln("  P(m_mutex);");
    outln("}}");
    mustbe(";");
  }
  elsif ($sigdisc eq "-su") {
    # increment just in case we do wait.
    # if we don't, then we immediately decrement with no harm done.
    # (need to increment if we block and carefully to avoid race.)
    out("{");
    out("m_n_urgentq++;");
    out("if (");
    outln("$cv.m_signal()) {");
    outln("  P(m_urgentq);");
    outln("}");
    outln("else {");
    outln("  m_n_urgentq--;");
    outln("}");
    outln("}");
    mustbe(";");
  }
  else { # if ($sigdisc eq "-sx") {
    outln("{");
    outln("if (! ");
    outln("  $cv.m_signal()) {");
    outln("  m_next();");
    outln("}");
    outln("}");
    mustbe(";");
    # now insist that _return immediately follow _signal for -sx
    if ($realtok eq "_return") {
      mreturn(1);
    }
    elsif ($realtok eq "return") {
      # disallow plain return so can use it within
      # any helper methods (i.e., non _proc) w/i monitor.
      error("within a _proc, use _return instead of return");
      mreturn(1);
    }
    else {
      error("_signal must be followed immediately by _return " .
            "for $sd{$sigdisc} discipline");
    }
  }
}

sub msignal_all {
  if ($sigdisc ne "-sc") {
    error("_signal_all is not defined for $sd{$sigdisc} discipline");
  }
  mustbe("ID"); # skip over _signal_all
  my $cv = grabmatch("(",")",1,1);
  outln("$cv.m_signal_all();");
  mustbe(";");
}

sub mwait {
##print "start mwait\n";
  mustbe("ID"); # skip over _wait
  my $cv = grabmatch("(",")",1,1);
  outln("{  m_condvar m_cv = $cv;");
  if ($tok eq "(") {
    # prioritized wait
    my $rank = grabmatch("(",")",1,1);
    outln("  int m_r = $rank;");
    outln("  send m_cv.m_wait(m_return_from_wait,m_r);");
    outln("  send m_cv.m_wait_ranks(m_r);");
  }
  else { # yeah, could easily combine with above case, but ...
    outln("  send m_cv.m_wait(m_return_from_wait,0);");
    outln("  send m_cv.m_wait_ranks(0);");
  }
  outln("  m_next();");
  outln("  P(m_return_from_wait);");
  if ($sigdisc eq "-sc") {
    outln("  P(m_mutex);");
  }
  out("}");
  mustbe(";");
##print "end mwait\n";
}

sub mutility {
  my $which = shift(@_);
  mustbe("ID"); # skip over keyword
  my $cv = grabmatch("(",")",1,1);
  outln("$cv.m$which()");
}

