#!/usr/bin/perl -w

#### 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;
}

sub checkdir {
  my $d = shift(@_);

  if(!opendir D, $d){
    warn "$cmdname requires files in $d\n";
    warn "  but that directory does not exist or is not readable\n";
    warn "  (likely JR installation problem);\n";
    warn "  won't be able to copy file(s) needed for JR translation.\n";
    return 0;
  }
  closedir D;
  return 1;
}

sub mustcopy {
  my $f = shift(@_); # file to copy
  my $d = shift(@_); # where to copy it

  if(!copy($f, $d)){
    warn "$cmdname requires $f\n";
    warn "  but couldn't copy it to directory $d;\n";
    warn "  (likely JR installation problem or directory permission problem);\n";
    warn "  JR translation won't work.\n";
    return 0;
  }
  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 = "ccr";

# parsing routines:
my $gnest; # nesting depth of _region
my $snest; # nesting depth of _resource

# semantic checking
my $sawregion = 0; # have seen any _regions.
my %resources; # names of resources seen
# fields need not be unique across resources,
# so fields won't necessarily be entirely accurate.
# but it's a good quick check in most cases;
# if it fails, then look in resourcesfields, which has complete info.
my %fields; # pairs of (fields, resource in which defined)
my %resourcesfields; # pairs of (resource,field), anything)
my %regions; # names of active regions
my %regions_refcnt; # reference count for active region
                    # (so searching can just use defined().)
my @thisnamestack; # records the thisnames for active regions

main();

sub main {

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

  foreach my $a (@ARGV) {
    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);
  }
  if ( checkenv() ) {
    my $PREPROC = "$JR_HOME/preproc/";
    if  ( checkdir($PREPROC) ) {
      use File::Copy;
      mustcopy("$PREPROC/r_rem.jr",".");
    }
  }
  terminate();
}

sub do1file {

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

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

  $gnest = -1; # -1 since serves as index into stack array.
  $snest = 0;

  print O "$BANNER\n";
  parse();
  print O "\n";

}

sub parse {
  scan();
  stuff("main");
  if ($tok ne "EOF") {
    error("junk after logical end of input (possible extra })");
  }
}

# invoked either for main or region.
# behaves slightly differently.
sub stuff {
  my $how = shift(@_); # not used anymore, except in debug output.
  my $previd = ""; # previous ID (will be the one before a ".")
  while ($tok ne "EOF" && $tok ne "}") {
##    print "tok is $tok\n";
##    print "realtok is $realtok\n";
    if ($tok eq "{") {
      out($tok);
##    print "recursing $how on { $realtok \n";
      scan();
      stuff($how);
##    print "back from recursing $how on { $realtok \n";
      mustbe("}");
      outln("}");
    }
    elsif ($tok eq "ID") {
      if ($realtok eq "_resource") {
        if ($sawregion ne 0) {
          # keep going to try to find other errors
          error("_resource appears after _region");
        }
        resource();
      }
      elsif ($realtok eq "_region") {
        $sawregion = 1;
        region();
      }
      else { # i.e., non-interesting id.
        $previd = $realtok;
        outln($realtok);
        scan();
      }
    }
    elsif ($tok eq ".") {
      out($tok);
      scan();
      if ($tok eq "ID") {
##print "found dot $realtok \n";
        if (defined($fields{$realtok})) { # found field name
##print "$realtok is defined\n";
          my $within = 1; # whether field within region
          if (!(defined($regions{$fields{$realtok}}))) {
##print "$fields{$realtok} is defined\n";
            $within = 0;
            # try a bit harder to find field name
            # it might be duplicated in resources,
            # so its fields is for other resource.
            foreach my $r (keys %regions) {
               if ( defined($resourcesfields{$r,$realtok}) ) {
                 $within = 1;
                 last;
               }
            }
            if ($within == 0) { 
              error("found `" . $realtok . "' outside region");
            }
          }
          if ($within == 1) { # within region, check that 
            if ($previd eq "") { # using only id.id form (e.g., not id[id].id)
              error("must reference `" . $realtok .
                    "' only via region's thisname");
            }
            else { # using id.id, check that first id is a thisname.
              my $k;
              for ($k=0; $k < $gnest; $k++) {
# print "$k \n";
# print "$thisnamestack[$k] \n";
# print "previd = $previd \n";
                if ($thisnamestack[$k] eq $previd) { last;}
              }
              if ($k >= $gnest) {
                error("must reference `" . $realtok .
                       "' only via region's thisname");
              }
            }
          }
	}
      }
      # note that if get id above, then it won't be region (shouldn't happen)
      out($realtok);
      scan();
    }
    else { # i.e., not dot or id
      $previd = "";
      out($realtok);
      scan();
    }
  }
##  print "tok is $tok\n";
##  print "realtok is $realtok\n";
}

sub resource {
  if ($snest > 0 || $gnest > 0) {
    error("_resource nested within _resource or _region; truly weird, Dude.");
    terminate();  }
  $snest++;
  mustbe("ID"); # skip over _resource
  my $classname = mustbe("ID");
  if (defined($resources{$classname})) {
    error("resource `" . $classname . "' already seen");
  }
  $resources{$classname} = "*nothing*"; # any value will do
  outln("class ".$classname." {");
  outln("  r_rem r_r = new r_rem();");
  toplevels($classname);
  out("}");
  $snest--;
}


# don't output top { and  } here; do those in resource
sub toplevels {
  my $classname = shift(@_);
  mustbe("{");
  while ( $tok ne "EOF" && $tok ne "}") {
    toplevel($classname);
  }
  mustbe("}");
}

# handle toplevel declarations or static{} or regular {}
sub toplevel {
  my $classname = shift(@_);

  # static can start a declaration or an initializer
  # for us, it's okay just to skip it.
  my $sawstatic = 0;
  if ($tok eq "ID" && $realtok eq "static") {
    $sawstatic = 1;
    outln($realtok);
    scan();
  }
  if ($tok eq "{") { # handle initializer (static or non-static)
    initializer();
  }
  else {
    decllist($classname,$sawstatic)
  }
}

# gobble up initializer,
# which (for us) consists of stuff within matched pair of {}.
sub initializer {
  mustbe("{");
  outln("{");
  while ( $tok ne "EOF" && $tok ne "}") {
    if ($tok eq "{") {
      initializer();
    }
    else {
      if ($tok eq "ID") {
        outln($realtok);
      }
      else {
        out($realtok);
      }
      scan();
    }
  }
  mustbe("}");
  outln("}");
}

# each of following is an example of a decllist:
#   public boolean free;
#   public int x, y;
#   public int x = 10;
#   public int x = 10, y =  20;
#   public int [] x = new int [10];
#
# idea: keep last id before `;', `,', `='.

sub decllist {
  my $classname = shift(@_);
  my $sawstatic = shift(@_);
  my $myid = "";
  my $sawfinal = 0;
  my $loop1 = 1; # simulate do { ... } while loop
  while ( $loop1 ) {
##print "xx  $tok $realtok\n";
    my $seenequals = 0;
    my $loop2 = 1; # simulate do { ... } while loop
    while ( $loop2 ) {
##print "yy  $tok $realtok\n";
      if ($seenequals == 0 && $tok eq "ID") {
        if ($realtok eq "static") { $sawstatic = 1;}
        elsif ($realtok eq "final") { $sawfinal = 1;}
        $myid = $realtok;
      }
      elsif ($tok eq "=") {
        $seenequals++;
      }
      if ($tok eq "ID") {
        outln($realtok);
      }
      else {
        out($realtok);
      }
      scan();
      $loop2 = $tok ne "," && $tok ne ";" && $tok ne "EOF";
    }

##print "zzz" myid
    if ($myid eq "") {
      error("can't parse declaration");
      terminate();
    }
    if ($sawstatic == 1) {
      if ($sawfinal == 0) {
        error("static non-final declaration in resource not allowed");
      }
    }
    else { # make entry only for non-static fields
      $fields{$myid} = $classname;
      $resourcesfields{$classname,$myid} = "*nothing*"; # any value will do
    }
    $loop1 = $tok ne ";" && $tok ne "EOF";
  }
  out($realtok);
  scan(); # skip semicolon
}

sub region {
  if ($snest > 0) {
    error("_region nested within _resource; truly weird, Dude.");
    terminate();
  }
  $gnest++;
  mustbeid("_region"); # skip over _region
  my $classname = mustbe("ID");
##print "$tok\n";
##print "$realtok\n";
  if (!defined($resources{$classname})) {
    error("_region for unknown resource `" . $classname . "'");
  }
  insert_regions($classname);
  mustbeid("_with");
  my $thisname = mustbe("ID");
  $thisnamestack[$gnest] = $thisname;
##print "$thisname\n";
##print "$tok\n";
##print "$realtok\n";
  mustbe("=");
  out("{ final $classname $thisname = ");
  # skip abitrary expression on RHS.
  my $one = 0;
  while ( $tok ne "EOF" && $realtok ne "_when" && $tok ne "{") {
    $one = 1;
    out($realtok);
    scan();
  }
  if ($one == 0) {
    error("empty right-hand side of =");
  }
  outln(";");
  out("$thisname\.r_r\.enter();");
  # could get rid of bozo if no while, but user could still say
  # _when true or _when false.
  # (perhaps should disallow those?)
  outln("boolean bozo$gnest = false;");
  outln("while (! (bozo$gnest =(");
  if ($realtok eq "_when") {
    scan();
    # skip abitrary _when expression
    my $one = 0;
    while ( $tok ne "EOF" && $tok ne "{") {
      $one = 1;
      out($realtok);
      scan();
    }
    if ($one == 0) {
      error("empty _when expression");
    }
  }
  elsif ($tok ne "{") {
    error("can't find { after _with with no _when");
  }
  else {
    out("true");
  }
  outln("))) {");
  outln("  $thisname\.r_r\.exit1_delay();\n}");
  $gnest++;
  mustbe("{");
  stuff("region");
  mustbe("}");
  outln("$thisname\.r_r\.exit2();\n}");
  delete_regions($classname);
  $gnest--; # note: effectively pops thisnamestack too.
}

sub insert_regions {
  my $classname = shift(@_);
  if (defined($regions{$classname})) {
    $regions_refcnt{$classname}++;
  }
  else {
    $regions{$classname} = "*nothing*"; # just make entry, value unused.
    $regions_refcnt{$classname} = 1;
  }
}

sub delete_regions {
  my $classname = shift(@_);
  if (!defined($regions{$classname})) {
    error("my bad: `" . $classname . "' not in regions (delete_regions)");
    terminate();
  }
  $regions_refcnt{$classname}--;
  if ($regions_refcnt{$classname} == 0) {
    delete $regions{$classname};
  }
}

