//
// 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
//
// $Source$
// $Revision$
// $Date$

// rfpc.rfi
$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"; //rfp_asail.rfi
$use "rfp_as2as";
$use "rfp_check";
$use "rfp_helper";
$use "rfp_format";
$use "rfp_asail_optim"; //rfp_asail_optim.rfi

$use StdIO;
$use Box;
$use Dos;
$use Arithm;
$use Table;
$use Convert;
$use Class;
$use Access;
$use Compare;

// 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 RFP-Parse-Args (e.files) (e.prevarg) s.index = e.files;
$func RFP-Set-Path = ;

// initialize tables
$func Get-Ready-To-Work e.Items = ;

$func CPP-Pretty-Print s.inner-call? s.channel (e.indent) e.expr = ;

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

$func Open-Channel e.name (e.ext) = s.channel s.need-close?;

$func Find-Includes = e.includes;


Main =
  <Init-Options>,
  <RFP-Parse-Args () () 1> :: e.files,
  <RFP-Set-Path>,
  <Store &Error-Counter 0>,
  <Store &Warning-Counter 0>,
//  <PrintLN e.files>,
  e.files : {
    /*empty*/ =
      {
        <In-Table? &RFP-Options HELP>;
        <PrintLN 'Refal+ compiler bla-bla-bla'>,
          'Usage: rfpc' :: e.start,
          <Length e.start> :: s.st-len,
          <Print e.start>,
          <Box> :: s.len,
          <Store s.len s.st-len>,
          {
            <? &Options> : e (((e.next) e) t e.descr) e,
              {
                e.descr : (e.arg) e = ' [-' e.next ' <' e.arg '>]';
                ' [-' e.next ']';
              } :: e.next,
              <Length e.next> :: s.n-len,
              <"+" <To-Int <? s.len>> s.n-len> :: s.new,
              {
                <">" (s.new) (70)> =
                  <Store s.len <"+" s.st-len s.n-len>>,
                  <PrintLN>,
                  <Print <Repeat s.st-len ' '>>;
                <Store s.len s.new>;
              },
              <Print e.next>,
              $fail;
            <PrintLN ' file ...'>;
          },
          <PrintLN>,
          <PrintLN! &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,
      {
        <Channel? e.basename> = e.in-basename;
        e.basename;
      } :: e.headname,
      <RFP-File-Name e.headname> :: e.headname,
      {
        e.ext : \{ ' .rf'; ' .rfi'; } =
          <Verbose "parsing started">,
          <RFP-Lexer e.file> :: e.tokens,
          <Store &RFP-Token-Stack e.tokens>,
          <RFP-Parser> :: t.as,
          <Verbose "parsing finished">,
          AS-REFAL t.as;
        e.ext : ' .asr' =
          <Channel> :: s.channel,
          <Open-File s.channel e.file R>,
          AS-REFAL <Read! s.channel>;
        e.ext : ' .ast' =
          <Channel> :: s.channel,
          <Open-File s.channel e.file R>,
          AS-TRANSFORMED <Read! s.channel>;
        e.ext : ' .asi' =
          <Channel> :: s.channel,
          <Open-File s.channel e.file R>,
          AS-AIL (AS-AIL AS-AIL <Read! s.channel> <Read! s.channel>);
        <PrintLN! &StdErr "Error: unknown extension" e.ext " in " e.file> = $fail;
      } : s.type (s.tag t.ModuleName e.Items),
      {
        s.type : AS-AIL;
        <Get-Ready-To-Work e.Items>;
      },
      s.type e.Items $iter s.type : {
        AS-REFAL =
          {
            <In-Table? &RFP-Options AS-REFAL> =
              <Open-Channel e.basename ('.asr')> :: s.channel s.need-close?,
              <RFP-Pretty-Print s.channel () (s.tag t.ModuleName e.Items)>,
              { s.need-close? : 1 = <Close-Channel s.channel>;; };;
          },
          <? &Error-Counter> : 0,
          {
            <In-Table? &RFP-Options NO-CHECK>;
            <Verbose "syntax check started">,
              <RFP-Check e.Items>,
              <Verbose "syntax check finished"> =
              <? &Error-Counter> : 0;
          },
          \{
            <In-Table? &RFP-Options CC>;
            <In-Table? &RFP-Options AS-AIL>;
            <In-Table? &RFP-Options AS-TRANSFORMED>;
            <In-Table? &RFP-Options HH>;
          },
          {
            <In-Table? &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 =
          {
            <In-Table? &RFP-Options AS-TRANSFORMED> =
              <Open-Channel e.basename ('.ast')> :: s.channel s.need-close?,
              <RFP-Pretty-Print s.channel () (s.tag t.ModuleName e.Items)>,
              { s.need-close? : 1 = <Close-Channel s.channel>;; };;
          },
          \{
            <In-Table? &RFP-Options CC>;
            <In-Table? &RFP-Options AS-AIL>;
            <In-Table? &RFP-Options HH>;
          },
          <Verbose "compilation to abstract imperative language started">,
          <RFP-Compile e.Items> : (INTERFACE e.interf) (MODULE e.module),
          <Verbose "compilation to abstract imperative language finished">,
          AS-AIL
          (INTERFACE t.ModuleName e.interf) (MODULE t.ModuleName e.module);
        AS-AIL =
          {
            <In-Table? &RFP-Options AS-AIL> =
              <Open-Channel e.basename ('.asi')> :: s.channel s.need-close?,
              {
                e.Items : e t.item e,
                  <RFP-Pretty-Print s.channel () t.item>,
                  $fail;;
              },
              { s.need-close? : 1 = <Close-Channel s.channel>;; };;
          },
          \{
            <In-Table? &RFP-Options HH>,
              e.Items : (INTERFACE t.asail-mod-name v.headers) e,
              <Verbose "headers generation started">,
              <RFP-ASAIL-To-CPP t.asail-mod-name v.headers> :: e.headers,
              <Verbose "headers generation finished">,
              <Open-Channel e.basename ('.hh')> :: s.channel s.need-close?,
              <PrintLN! s.channel '#ifndef __' e.headname '_hh__'>,
              <PrintLN! s.channel '#define __' e.headname '_hh__'>,
              <PrintLN! s.channel '\n#include <rf_core.hh>'>,
              <CPP-Pretty-Print 0 s.channel () e.headers>,
              <PrintLN! s.channel '\n#endif // __' e.headname '_hh__'>,
              { s.need-close? : 1 = <Close-Channel s.channel>;; },
              $fail;
            <In-Table? &RFP-Options CC>,
              e.Items : e (MODULE t.asail-mod-name v.module),
              {
                <In-Table? &RFP-Options NO-OPTIM> = v.module; 
                <Verbose "optimization as-ail started">,
                  <ASAIL-Optim v.module> :: e.module,
                  <Verbose "optimization as-ail finished"> =
                  e.module;
              } :: e.module , 
              <Verbose "compilation from as-ail to c++ started">,
              <RFP-ASAIL-To-CPP t.asail-mod-name e.module> :: e.module,
              <Verbose "compilation from as-ail to c++ finished">,
              <Open-Channel e.basename ('.cc')> :: s.channel s.need-close?,
              <PrintLN! s.channel '#include <rf_core.hh>'>,
              {
                <Find-Includes> : e (e.include) e,
                  <PrintLN! s.channel '#include ' e.include>,
                  $fail;;
              },
              <CPP-Pretty-Print 0 s.channel () e.module>,
              { s.need-close? : 1 = <Close-Channel s.channel>;; },
              $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")
  ((('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")
  ((('ci') ('comp-item')) COMP-ITEM
    ('item') "compile <item> only, not the whole source" "(may be used several times)")
  ((('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")
  ((('o')) NAME
    ('name| - ') "place outputs for file1 into files <name>.* or send" "them to stdout")
  ((('cc')) (BIND CC)
    "output C++ code")
  ((('hh')) (BIND HH)
    "generate header files")
  ((('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")
  ((('d') ('debug')) (BIND DEBUG))
  ((('no') ('no-optim')) (BIND NO-OPTIM) "don't perform ASAIL-optimization")
>;

Display-Help =
  <Box> :: s.line,
  '  ' :: e.start1,
  27 :: s.2nd-col,
  <Repeat s.2nd-col ' '> :: e.start2,
  <PrintLN "Refal+ compiler bla-bla-bla">,
  <PrintLN "Copyright bla-bla-bla">,
  <PrintLN>,
  <PrintLN "Usage: rfpc [options] file1 [file2 ...]">,
  <PrintLN "Options:">,
  {
    <? &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.param) e.rest =
          <Put s.line ' <' e.param '>'>,
          e.rest;
        e.descr;
      } : \{
        s.phrase e,
          <PrintLN
            <? s.line>
            <Repeat <"-" s.2nd-col <Length <? s.line>>> ' '>
            s.phrase
          >,
          $fail;
        e s s.phrase e,
          <PrintLN e.start2 s.phrase>,
          $fail;
      };;
  };

RFP-Parse-Args (e.files) (e.prevarg) s.index =
{
  <Arg s.index> : v.arg, <"+" s.index 1> :: s.index =
    {
      e.prevarg : v, e.prevarg :
        {
          IPATH = <Store &RFP-Include-Path <? &RFP-Include-Path> (v.arg)>;
          COMP-ITEM =
            {
              <Lookup &RFP-Options ITEMS>;
              /*empty*/;
            } :: e.items,
            <Bind &RFP-Options (ITEMS) (e.items <Make-Name v.arg>)>;
          NAME =
            {
              v.arg : '-' = &StdOut;
              v.arg;
            } :: v.arg,
            <Bind &RFP-Options (NAME) (v.arg)>;
        },
        <RFP-Parse-Args (e.files) () s.index>;
      v.arg : '-' e.opt =
        {
          \{
            <? &Options> : e ((e (e.opt) e) t.action e) e = t.action;
            e.opt : '-' e.o,
              <? &Options> : e ((t 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,
            <RFP-Parse-Args (e.files) (e.prevarg) s.index>;
          <PrintLN! &StdErr "Unknown option \"-" e.opt "\"">,
            <RFP-Parse-Args (e.files) () s.index>;
        };
      <RFP-Parse-Args (e.files (v.arg)) () s.index>;
    };
  {
    \{
      <In-Table? &RFP-Options CC>;
      <In-Table? &RFP-Options HH>;
      <In-Table? &RFP-Options AS-REFAL>;
      <In-Table? &RFP-Options AS-TRANSFORMED>;
      <In-Table? &RFP-Options AS-AIL>;
      <In-Table? &RFP-Options CHECK>;
    };
    <Bind &RFP-Options (CC) ()> <Bind &RFP-Options (HH) ()>;
  },
    e.files;
};

RFP-Set-Path =
  {
    <In-Table? &RFP-Options CASE-INSENSITIVE> = &RFP-Default-Ci-Include-Path;
    &RFP-Default-Include-Path;
  } :: t.def-path,
  <Store &RFP-Include-Path t.def-path <? &RFP-Include-Path>>;

Get-Ready-To-Work e.Items =
  <RFP-Clear-Table &Fun>,
  <RFP-Clear-Table &Fun?>,
  <RFP-Clear-Table &Const>,
  <RFP-Clear-Table &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>);
        FUNC? =
          <Left 0 2 e.ItemBody> : (e.in) (e.out),
          &Fun? (<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)>,
      $fail;;
  };

RFP-Pretty-Print s.channel (e.indent) e.expr = e.expr :
  {
    e0 (e1) e2 =
      <Write! s.channel e0>,
      { e.indent : v = <PrintLN! s.channel>;; },
      <Print! s.channel e.indent '('>,
      <RFP-Pretty-Print s.channel (e.indent '  ') e1>,
      {
        e1 : e (e) e =
          <PrintLN! s.channel>,
          <Print! s.channel e.indent ')'>;
        <Print! s.channel ')'>;
      },
      {
        e2 : (e) e = ;
        e2 : , e.indent : v = ;
        <PrintLN! s.channel>, <Print! s.channel e.indent>;
      },
      <RFP-Pretty-Print s.channel (e.indent) e2>;
    v1 =
      <Write! s.channel v1>;
    =;
  };

$const Tab = '  ';

CPP-Pretty-Print s.inner-call? s.channel (e.indent) e.expr, e.expr : {
  e0 (e1) e2 =
    { s.inner-call? : 0 = <PrintLN! s.channel>;; },
    {
      e0 : /*empty*/, {
        e1 : LABEL e.label =
          e.indent : e.ind &Tab,
          <PrintLN! s.channel e.ind e.label>;
        <CPP-Pretty-Print 1 s.channel (e.indent) e1>;
      };
      <PrintLN! s.channel e.indent e0>,
        <CPP-Pretty-Print 1 s.channel (e.indent &Tab) (e1)>;
    },
    <CPP-Pretty-Print s.inner-call? s.channel (e.indent) e2>;
  v1 = <PrintLN! s.channel e.indent v1>;
  /*empty*/ = /*empty*/;
};

Verbose e.string, {
  <In-Table? &RFP-Options VERBOSE> =
    <PrintLN <Time> ": " e.string>;;
};

Open-Channel {
  symbol (e), <Channel? symbol> = symbol 0;
  e.name (e.ext) =
    <Channel> :: s.channel,
    {
      <Open-File s.channel e.name e.ext W> =
        s.channel 0; // When we need to close channel ???
      <PrintLN! &StdErr "Error: cannot open file " e.name e.ext " for writing">,
        <Exit 1>, $fail;
    };
};

Find-Includes =
  <Box> :: s.includes,
  {
    <Domain &RFP-Sources> : e (s.idx) e,
      <Lookup &RFP-Sources s.idx> : e.full-name '.rfi',
      {
        <? &RFP-Include-Path> : e (e.path) e,
          e.full-name : e.path &RFP-Dir-Separator e.name =
          <Put s.includes ('<refal/' e.name '.hh>')>;
        <RFP-Dir-Name <RFP-Source-File-Name 1>> : e.path,
          e.full-name : e.path &RFP-Dir-Separator e.name =
          <Put s.includes ('"' e.name '.hh"')>;
        <Put s.includes ('"' e.full-name '.hh"')>;
      },
      $fail;;
  },
  <? s.includes>;