//
// Copyright (C) 1999, 2000 Refal+ Development Group
//
// Refal+ is free software; you can redistribute it and/or modify
// it under the terms of the GNU General Public License as published by
// the Free Software Foundation; either version 2 of the License, or
// (at your option) any later version.
//
// Refal+ is distributed in the hope that it will be useful,
// but WITHOUT ANY WARRANTY; without even the implied warranty of
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
// GNU General Public License for more details.
//
// You should have received a copy of the GNU General Public License
// along with Refal+; if not, write to the Free Software
// Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
//
// $Id$

$use "rfp_src"; // rfp_src.rfi
$use "rfp_err"; // rfp_err.rfi
$use "rfp_lex"; // rfp_lex.rfi
$use "rfp_parse"; // rfp_parse.rfi
$use "rfp_compile"; // rfp_compile.rfi
$use "rfp_asail_cpp"; //rfp_asail_cpp.rfi
$use "rfp_asail_java"; //rfp_asail_java.rfi
$use "rfp_asail_tpp"; //rfp_asail_tpp.rfi
$use "rfp_asail_jbc";
$use "rfp_as2as";
$use "rfp_check";
$use "rfp_helper";
$use "rfp_format";
$use "rfp_asail2asail";

$import "java.io.FileOutputStream";
$import "org.refal.plus.comp.CompilerEnvironment";

$use Access Arithm Box Class Compare Convert CppMangle File Java JavaMangle
   Dos List Table StdIO;

$const RevDate = ('$Revision$') ('$Date$');
$func Version = e.version;

// information about available compiler options
$box Options;

// put information about compiler options in the &Options box
$func Init_Options = ;

// display help screen
$func Display_Help = ;

$func Parse_Args (e.files) (e.prevarg) s.index = e.files;

$func Set_Path = ;

// initialize tables
$func Get_Ready_For_Compilation e.Items = ;

$func CPP_Pretty_Print s.Isinner_call s.channel (e.indent) e.expr = ;

// print information about compilation stages when -verbose option is
// supplied on command line
$func Verbose e.string = ;

$func Open_Channel e.name (e.ext) = s.channel s.Isneed_close;

$func? Compilation_Failed = ;

CompileModule s.env =
  <RFP_Src_InitFromEnv s.env>,
  <RFP_Parser <GetModuleName s.env>> : (s t.ModuleName e.Items),
  <Get_Ready_For_Compilation e.Items>,
  <RFP_Check e.Items>,
  <RFP_As2As_Transform e.Items> :: e.Items,
  <RFP_Compile t.ModuleName e.Items> :: t.module,
  {
    <IsInTable &RFP_Options "NO-OPTIM"> = t.module; 
    <Simplify_ASAIL t.module>;
  } :: t.module, 
  {
    <RFP_ASAIL_To_JBC t.module> : e (s.bytecode e.java_module_name) e,
      <MakeClass s.env <ToWord e.java_module_name> s.bytecode>,
      $fail;;
  };


Main =
  <Init_Options>,
  <Parse_Args () () 1> :: e.files,
  <Set_Path>,
  <RFP_Src_InitFromArgs e.files>,
  <Get &DirSeparator> : s.dir_separator,
  e.files : {
    /*empty*/ =
      {
        <IsInTable &RFP_Options HELP>;
        <PrintLn 'Refal+ compiler ' <Version>>,
          'Usage: rfpc' :: e.start,
          <Length e.start> :: s.st_len,
          <Print e.start>,
          <Box> :: s.len,
          <Store s.len s.st_len>,
          {
            <Get &Options> : e (((e.next) e) t e.descr) e,
              <Le (<Length e.next>) (3)>,
              {
                e.descr : (e.arg) e = ' [-' e.next ' <' e.arg '>]';
                ' [-' e.next ']';
              } :: e.next,
              <Length e.next> :: s.n_len,
              <Arithm.Add <ToInt <Get s.len>> s.n_len> :: s.new,
              {
                <Gt (s.new) (64)> =
                  <Store s.len <Arithm.Add s.st_len s.n_len>>,
                  <PrintLn>,
                  <Print <Replicate s.st_len ' '>>;
                <Store s.len s.new>;
              },
              <Print e.next>,
              $fail;
            <PrintLn ' file ...'>;
          },
          <PrintLn>,
          <PrintLnCh &StdErr 'No input files specified'>;
      };
    e01 (e.file) e02,
      {
        e.file : $r e.basename '.' e.ext = e.basename (' .' e.ext);
        e.file ();
      } :: e.in_basename (e.ext),
      {
        e01 : /*empty*/, <Lookup &RFP_Options NAME>;
        e.in_basename;
      } :: e.basename,
      {
        <IsChannel e.basename> = e.in_basename;
        e.basename;
      } :: e.headname,
      {
        e.headname : $r e.dirname s.dir_separator e.filename =
          (e.dirname) e.filename;
        ('.') e.headname;
      } :: (e.dirname) e.filename,
      {
        e.ext : \{ ' .rf'; ' .rfi'; } =
          <Verbose e.file ": parsing started" >,
          {
            <RFP_Parser (e.file)>;
            "Compilation-Failed!";
          } :: t.as,
          {
            <RFP_Parser_Errors> : e (e.error) e,
              e.error : {
                ERROR ((e.efile) ((s.row s.column) t)) (e.message) =
                  e.efile : s.efiletype e.efilename,
                  <PrintLn <Intersperse ('.') e.efilename> " " s.efiletype ": " s.row ", " s.column " --- Error: " e.message>;
                WARNING ((e.efile) ((s.row s.column) t)) (e.message) =
                  e.efile : s.efiletype e.efilename,
                  <PrintLn <Intersperse ('.') e.efilename> " " s.efiletype ": " s.row ", " s.column " --- Warning: " e.message>;
              },
              $fail;
            t.as : "Compilation-Failed!" =
              //<PrintLN! &StdErr "Errors in " e.file>,
              <Compilation_Failed>;
            <Verbose e.file ": parsing finished">,
              "AS-REFAL" t.as;
          };
        e.ext : ' .asr' =
          <Channel> :: s.channel,
          <OpenFile s.channel e.file R>,
          "AS-REFAL" <ReadCh s.channel>;
        e.ext : ' .ast' =
          <Channel> :: s.channel,
          <OpenFile s.channel e.file R>,
          "AS-TRANSFORMED" <ReadCh s.channel>;
        e.ext : ' .asi' =
          <Channel> :: s.channel,
          <OpenFile s.channel e.file R>,
          "AS-AIL" ("AS-AIL" "AS-AIL" <ReadCh s.channel> <ReadCh s.channel>);
        <PrintLnCh &StdErr "Error: unknown extension" e.ext " in " e.file> =
          <Compilation_Failed>;
      } : s.type (s.tag t.ModuleName e.Items),
      {
        s.type : "AS-AIL";
        <Get_Ready_For_Compilation e.Items>;
      },
      s.type e.Items $iter s.type : {
        "AS-REFAL" =
          {
            <IsInTable &RFP_Options "AS-REFAL"> =
              <Open_Channel e.basename ('.asr')> :: s.channel s.Isneed_close,
              <RFP_Pretty_Print s.channel () (s.tag t.ModuleName e.Items)>,
              { s.Isneed_close : 1 = <CloseChannel s.channel>;; };;
          },
          \{
            <Get &Error_Counter> : /*empty*/;
            <Compilation_Failed>;
          },
          {
            <IsInTable &RFP_Options "NO-CHECK">;
            <Verbose "syntax check started">,
              <RFP_Check e.Items>,
              <Verbose "syntax check finished"> =
              \{
                <Get &Error_Counter> : /*empty*/;
                <Compilation_Failed>;
              };
          },
          <Any &IsInTable &RFP_Options (CC HH TPP JAVA JBC "AS-AIL" "AS-TRANSFORMED")>,
          {
            <IsInTable &RFP_Options "NO-TRANSFORM"> = e.Items;
            <Verbose "as-to-as transformation started">,
              <RFP_As2As_Transform e.Items> :: e.Items,
              <Verbose "as-to-as transformation finished">,
              e.Items;
          } :: e.Items,
          "AS-TRANSFORMED" e.Items;
        "AS-TRANSFORMED" =
          {
            <IsInTable &RFP_Options "AS-TRANSFORMED"> =
              <Open_Channel e.basename ('.ast')> :: s.channel s.Isneed_close,
              <RFP_Pretty_Print s.channel () (s.tag t.ModuleName e.Items)>,
              { s.Isneed_close : 1 = <CloseChannel s.channel>;; };;
          },
          <Any &IsInTable &RFP_Options (CC HH TPP JAVA JBC "AS-AIL")>,
          <Verbose "compilation to abstract imperative language started">,
          <RFP_Compile t.ModuleName e.Items> :: t.asail,
          <Verbose "compilation to abstract imperative language finished">,
          "AS-AIL" t.asail;
        "AS-AIL" =
          e.Items : t.module,
          {
            <IsInTable &RFP_Options "NO-OPTIM"> = t.module; 
            <Verbose "as-ail optimization started">,
              <Simplify_ASAIL t.module> :: t.module,
              <Verbose "as-ail optimization finished"> =
              t.module;
          } :: t.module , 
          {
            <IsInTable &RFP_Options "AS-AIL"> =
              <Open_Channel e.basename ('.asi')> :: s.channel s.Isneed_close,
              <RFP_Pretty_Print s.channel () t.module>,
              { s.Isneed_close : 1 = <CloseChannel s.channel>;; };;
          },
          \{
            <IsInTable &RFP_Options CC>,
              <Verbose "compilation from as-ail to c++ started">,
              <RFP_ASAIL_To_CPP t.module> :: e.module,
              <Verbose "compilation from as-ail to c++ finished">,
              <Open_Channel e.basename ('.cc')> :: s.channel s.Isneed_close,
              <CPP_Pretty_Print 0 s.channel () e.module>,
              { s.Isneed_close : 1 = <CloseChannel s.channel>;; },
              $fail;
//            <In-Table? &RFP-Options TPP>, e.asail-module : v,
//              <Verbose "compilation from as-ail to T++ started">,
//              <RFP-ASAIL-To-TPP t.module> :: e.module,
//              <Verbose "compilation from as-ail to T++ finished">,
//              <Open-Channel e.basename ('.tpp')> :: s.channel s.need-close?,
//              <CPP-Pretty-Print 0 s.channel () e.module>,
//              { s.need-close? : 1 = <Close-Channel s.channel>;; },
//              $fail;                   
            <IsInTable &RFP_Options JAVA>,
              <Verbose "compilation from as-ail to java started">,
              <RFP_ASAIL_To_Java t.module> :: (e.javaModuleName) (e.module),
//              {
//                <In-Table? &RFP-Options NAME> = e.basename;
//                e.dirname : v = e.dirname s.dir-separator <Intersperse (s.dir-separator) e.javaModuleName>;
//                <Intersperse (s.dir-separator) e.javaModuleName>;
//              } :: e.javaModuleName,
              {
                <IsChannel e.basename> = <Open_Channel e.basename ('.java')>;
                <Open_Channel e.dirname s.dir_separator <R 0 e.javaModuleName> ('.java')>;
              } :: s.channel s.Isneed_close,
              <CPP_Pretty_Print 0 s.channel () e.module>,
              { s.Isneed_close : 1 = <CloseChannel s.channel>;; },
              <Verbose "compilation from as-ail to java finished">,
              $fail;
            <IsInTable &RFP_Options JBC>,
              <Verbose "compilation from as-ail to java-bytecode started">,
//              {
//                <? &RFP-Include-Path> : e (e.dir) e,
//                  e.dirname : \{
//                    e.dir = (e.dir s.dir-separator) /*empty*/;
//                    e.dir s.dir-separator e.package = (e.dir s.dir-separator) e.package;
//                  };
//                () e.dirname;
//              } :: (e.dir) e.package,
              {
                <RFP_ASAIL_To_JBC t.module> : e (s.bytecode e.javaModuleName) e,
                  <FileOutputStream <ToWord e.dirname s.dir_separator <R 0 e.javaModuleName> ".class">> :: s.stream,
                  <WriteToStream s.stream s.bytecode>,
                  <CloseStream s.stream>,
                  $fail;;
              },
              <Verbose "compilation from as-ail to java-bytecode finished">,
              $fail;
          };
      } :: s.type e.Items,
      $fail;
    e.all_files_have_gone;
  };

Init_Options = <Store &Options
  ((('I') ('ipath')) IPATH
    ("dir") "add <dir> to the list of directories to be searched" "for .rfi files")
  ((('B') ('bootpath')) BPATH
    ("dir") "add <dir> to the list of directories to be searched" "for standard library .rfi files")
  ((('ne') ('no-elaborate')) (BIND "NO-ELABORATE"))
  ((('nc') ('no-check')) (BIND "NO-CHECK")
    "don't perform syntax check")
  ((('nt') ('no-transform')) (BIND "NO-TRANSFORM")
    "don't perform AS-to-AS transformations")
  ((('c') ('check')) (BIND CHECK)
    "check only, causes no file creation in the absence"
    "of other output control options")
  ((('no') ('no-optim')) (BIND "NO-OPTIM") "don't perform ASAIL-optimization")
  ((('ci') ('comp-item')) "COMP-ITEM"
    ("item") "compile <item> only, not the whole source" "(may be used several times)")
  ((('e') ('entry')) ENTRY
    ("func") "use function <func> as an entry to the program")
  ((('h') ('help')) HELP /*"display this help screen"*/)
  ((('v') ('verbose')) (BIND VERBOSE)
    "display information about the stages of compilation")
  ((('u')) (BIND "CASE-INSENSITIVE")
    "convert all symbol-words without surrounding quotes" "to upper case")
  ((('co')) (BIND "IDENT-COMPATIBILITY")
    "compatibility with new identivication names")
  ((('o')) NAME
    ("name| - ") "place outputs for file1 into files <name>.* or send" "them to stdout")
  ((('p') ('package')) PACKAGE
    ("pack") "place output in package <pack>")
  ((('cc')) (BIND CC)
    "output C++ code")
  ((('hh')) (BIND HH)
    "generate header files")
  ((('j') ('java')) (BIND JAVA)
    "output Java code")
  ((('jbc')) (BIND JBC)
    "output Java byte-code")
  ((('t') ('t++')) (BIND TPP)
    "output T++ code")
  ((('asr') ('as-refal')) (BIND "AS-REFAL")
    "output Refal Abstract Syntax")
  ((('ast') ('as-transformed')) (BIND "AS-TRANSFORMED")
    "output Refal Abstract Syntax after AS-to-AS" "transformations")
  ((('asi') ('as-ail')) (BIND "AS-AIL")
    "output Abstract Syntax of Abstract Imperative" "Language")
  ((('int')) INT ("class_name") "class to use for literal integers")
  ((('replace-module')) "REPLACE-MODULE" ("m1" "m2") "use module <m2> instead of <m1>")
  ((('d') ('debug')) (BIND DEBUG))
  ((('dbg')) (BIND DBG) "generate text for debugger")
  ((('trace')) TRACE
    ("fname") "trace function <fname> (may be used several times)")
  ((('traceall')) (BIND TRACEALL) "trace all functions")
>;

Display_Help =
  <Box> :: s.line,
  ' ' :: e.start1,
  29 :: s.2nd_col,
  <Replicate s.2nd_col ' '> :: e.start2,
  <PrintLn "Refal+ compiler " <Version>>,
  <PrintLn "Copyright blah-blah-blah">,
  <PrintLn>,
  <PrintLn "Usage: rfpc [options] file1 [file2 ...]">,
  <PrintLn "Options:">,
  {
    <Get &Options> : e (((e.op) e.opts) t e.descr) e,
      <Store s.line e.start1 '-' e.op>,
      {
        e.opts : e (e.next) e,
          <Put s.line ', -' e.next>,
          $fail;;
      },
      {
        e.descr : (e.params) e.rest =
          {
            e.params : e s.par e,
              <Put s.line ' <' <ToChars s.par> '>'>,
              $fail;
            e.rest;
          };
        e.descr;
      } : \{
        s.phrase e,
          <PrintLn
            <Get s.line>
            <Replicate <Arithm.Sub s.2nd_col <Length <Get s.line>>> ' '>
            s.phrase
          >,
          $fail;
        e s s.phrase e,
          <PrintLn e.start2 s.phrase>,
          $fail;
      };;
  };

Parse_Args (e.files) (e.prevarg) s.index =
{
  <Arg s.index> : v.arg, <Arithm.Add s.index 1> :: s.index =
    {
      e.prevarg : v, e.prevarg :
        {
          IPATH =
            <Store &RFP_Include_Path <Get &RFP_Include_Path> (v.arg)>;
          BPATH =
            <Store &RFP_Boot_Path <Get &RFP_Boot_Path> (v.arg)>;
          "COMP-ITEM" =
            {
              <Lookup &RFP_Options ITEMS>;
              /*empty*/;
            } :: e.items,
            <Bind &RFP_Options (ITEMS) (e.items <Make_Name v.arg>)>;
          ENTRY =
            {
              <Lookup &RFP_Options ENTRIES>;
              /*empty*/;
            } :: e.entries,
            <Bind &RFP_Options (ENTRIES) (e.entries <Make_Name v.arg>)>;
          TRACE =
            <Bind &RFP_Trace (<Make_Name v.arg>) ()>;
          NAME =
            {
              v.arg : '-' = &StdOut;
              v.arg;
            } :: v.arg,
            <Bind &RFP_Options (NAME) (v.arg)>;
          PACKAGE =
            <Bind &RFP_Options (PACKAGE) (v.arg)>;
          INT =
            <Bind &RFP_Options (INT) (v.arg)>;
          "REPLACE-MODULE" = "REPLACE-MODULE-2" v.arg;
          "REPLACE-MODULE-2" e.mod1 =
            <Bind &RFP_Module_Subst (e.mod1) (v.arg)>;
        } :: e.prevarg,
        <Parse_Args (e.files) (e.prevarg) s.index>;
      v.arg : '-' e.opt =
        {
          \{
            <Get &Options> : e ((e (e.opt) e) t.action e) e = t.action;
            e.opt : '-' e.o,
              <Get &Options> : e ((e (e.o) e) t.action e) e = t.action;
          } : {
            (BIND s.option) = <Bind &RFP_Options (s.option) ()>;
            HELP = <Bind &RFP_Options (HELP) ()>, <Display_Help>;
            s.other = s.other;
          } :: e.prevarg,
            <Parse_Args (e.files) (e.prevarg) s.index>;
          <PrintLnCh &StdErr "Unknown option \"-" e.opt "\"">,
            <Parse_Args (e.files) () s.index>;
        };
      <Parse_Args (e.files (v.arg)) () s.index>;
    };
  e.prevarg : v =
    <PrintLnCh &StdErr "Last option requires parameter">,
    <Exit 1>;
  {
    <Any &IsInTable &RFP_Options (CC HH TPP JAVA JBC "AS-REFAL" "AS-TRANSFORMED" "AS-AIL" CHECK)>;
    <Bind &RFP_Options (CC) ()> <Bind &RFP_Options (HH) ()>;
  },
    e.files;
};

Set_Path =
  <Store &RFP_Boot_Path <MapIn &Append (<Get &DirSeparator>) (<Get &RFP_Boot_Path> &RFP_Default_Boot_Path)>>,
  <Store &RFP_Include_Path <MapIn &Append (<Get &DirSeparator>) (<Get &RFP_Include_Path>)>>;

Get_Ready_For_Compilation e.Items =
  <ClearTable &Fun>,
  <ClearTable &IsFun>,
  <ClearTable &Const>,
  <ClearTable &Object>,
  {
    e.Items : e t.Item e, t.Item : \{
      (s.Linkage s.ItemType t.Pragma t.ItemName e.ItemBody),
        s.ItemType : {
          FUNC = 
            <Left 0 2 e.ItemBody> : (e.in) (e.out),
            &Fun (<Format_Exp e.in>) (<Format_Exp e.out>);
          TFUNC = 
            <Left 0 2 e.ItemBody> : (e.in) (e.out),
            &Fun (<Format_Exp e.in>) (<Format_Exp e.out>);
          "FUNC?" =
            <Left 0 2 e.ItemBody> : (e.in) (e.out),
            &IsFun (<Format_Exp e.in>) (<Format_Exp e.out>);
          CONST = &Const e.ItemBody;
          s = &Object e.ItemBody;
        } :: s.tab e.ItemDef,
        <Bind s.tab (t.ItemName) (s.Linkage s.ItemType t.Pragma e.ItemDef)>;
      (EXTERN t.Pragma t.FName) =
        <Bind &IsFun (t.FName) (IMPORT "FUNC?" t.Pragma ((EVAR)) ((EVAR)))>;
    },
      $fail;
    {
      <IsInTable &RFP_Options DBG> =
        <Bind &IsFun ((Debug "Stop?")) (IMPORT "FUNC?" (PRAGMA) ((EVAR)) ())>,
        <Bind &Fun  ((Debug Debug)) (IMPORT FUNC  (PRAGMA) ((EVAR)) ())>;;
    };
  };

RFP_Pretty_Print s.channel (e.indent) e.expr = e.expr :
  {
    e0 (e1) e2 =
      <WriteCh s.channel e0>,
      { e.indent : v = <PrintLnCh s.channel>;; },
      <PrintCh s.channel e.indent '('>,
      <RFP_Pretty_Print s.channel (e.indent '  ') e1>,
      {
        e1 : e (e) e =
          <PrintLnCh s.channel>,
          <PrintCh s.channel e.indent ')'>;
        <PrintCh s.channel ')'>;
      },
      {
        e2 : (e) e = ;
        e2 : , e.indent : v = ;
        <PrintLnCh s.channel>, <PrintCh s.channel e.indent>;
      },
      <RFP_Pretty_Print s.channel (e.indent) e2>;
    v1 =
      <WriteCh s.channel v1>;
    =;
  };

$const Tab = '  ';

CPP_Pretty_Print s.Isinner_call s.channel (e.indent) e.expr, e.expr : {
  e0 (e1) e2 =
    { s.Isinner_call : 0 = <PrintLnCh s.channel>;; },
    {
      e0 : /*empty*/, {
        e1 : LABEL e.label =
          e.indent : e.ind &Tab,
          <PrintLnCh s.channel e.ind e.label>;
        e1 : /*empty*/ =
          <PrintLnCh s.channel>;
        <CPP_Pretty_Print 1 s.channel (e.indent) e1>;
      };
      <PrintLnCh s.channel e.indent e0>,
        <CPP_Pretty_Print 1 s.channel (e.indent &Tab) (e1)>;
    },
    <CPP_Pretty_Print s.Isinner_call s.channel (e.indent) e2>;
  v1 = <PrintLnCh s.channel e.indent v1>;
  /*empty*/ = /*empty*/;
};

Verbose e.string, {
  <IsInTable &RFP_Options VERBOSE> =
    <PrintLn <Time> ": " e.string>;;
};

Open_Channel {
  symbol (e), <IsChannel symbol> = symbol 0;
  e.name (e.ext) =
    <Channel> :: s.channel,
    {
      <OpenFile s.channel e.name e.ext W> =
        s.channel 1;
      <PrintLnCh &StdErr "Error: cannot open file " e.name e.ext " for writing">,
        <Exit 1>, $fail;
    };
};

Compilation_Failed = <Exit 1>;

Version = {
  &RevDate : (e ' ' v.rev ' ' e) (e ' ' v.date ' ' e) = '2.0-beta-' v.rev ', ' v.date;
  '2.0-unknown-beta';
};