#!/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 #####################################
