// $Id$

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

$use "rfpc" "rfp_src" "rfp_lex" "rfp_parse" "rfp_helper";

// information about available options
$box Options;

// put information about 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 Build_Substs e.items = ;

$func Find_Defs e.items = ;

$func Find_Dupls = e.dupls;

$func Convert e.name = e.name;
$func ConvertSym s.sym = e;

$func? Is_IdentReally e.expr = ;
$func? IsIdentSymbol s.sym = ;

$table Renamings;
$table Def_Pos;
$table QNames;
$table Uses;
$table Dupls;

$box Parse;

$box Substs;

$const Std_Renamings =
  ((Arithm "-")                 (Arithm Sub))
  ((Arithm "Div-Rem")           (Arithm DivRem))
  ((Box "?")                    (Box Get))
  ((Compare ">=")               (Compare Ge))
  ((Compare ">")                (Compare Gt))
  ((Compare "<=")               (Compare Le))
  ((Compare "<")                (Compare Lt))
  ((Compare "/=")               (Compare Ne))
  ((Compare "=")                (Compare Eq))
  ((Convert "To-Lower")         (Convert ToLower))
  ((Convert "To-Upper")         (Convert ToUpper))
  ((Convert "Chars-To-Bytes")   (Convert CharsToBytes))
  ((Convert "Bytes-To-Chars")   (Convert BytesToChars))
  ((Convert "To-Chars")         (Convert ToChars))
  ((Convert "To-Word")          (Convert ToWord))
  ((Convert "To-Int")           (Convert ToInt))
  ((StdIO "Open-File")          (StdIO OpenFile))
  ((StdIO "Close-Channel")      (StdIO CloseChannel))
  ((StdIO "Erase-File")         (StdIO EraseFile))
  ((StdIO "Parse-File-Name")    (StdIO ParseFileName))
  ((StdIO "EOF?")               (StdIO IsEof))
  ((StdIO "Read-Char")          (StdIO ReadChar))
  ((StdIO "Read-Line")          (StdIO ReadLine))
  ((StdIO "Read!")              (StdIO ReadCh))
  ((StdIO "Read-Char!")         (StdIO ReadCharCh))
  ((StdIO "Read-Line!")         (StdIO ReadLineCh))
  ((StdIO WriteLN)              (StdIO WriteLn))
  ((StdIO "Write!")             (StdIO WriteCh))
  ((StdIO "WriteLN!")           (StdIO WriteLnCh))
  ((StdIO PrintLN)              (StdIO PrintLn))
  ((StdIO "Print!")             (StdIO PrintCh))
  ((StdIO "PrintLN!")           (StdIO PrintLnCh))
  ((StdIO "Flush!")             (StdIO Flush))
  ((StdIO "Prim-Open-File")     (StdIO PrimOpenFile))
  ((StdIO "Prim-Close-Channel") (StdIO PrimCloseChannel))
  ((StdIO "Prim-Read")          (StdIO PrimRead))
  ((StdIO "Read-Chunk-Size")    (StdIO ReadChunkSize))
  ((String "String-Init")       (String StringInit))
  ((String "String-Fill")       (String StringFill))
  ((String "String-Length")     (String StringLength))
  ((String "String-Ref")        (String StringRef))
  ((String "String-Set")        (String StringSet))
  ((String "String-Replace")    (String StringReplace))
  ((String "Substring-Fill")    (String SubstringFill))
  ((Table "Table-Copy")         (Table TableCopy))
  ((Table "Replace-Table")      (Table ReplaceTable))
  ((Table "Clear-Table")        (Table ClearTable))
  ((Table "In-Table?")          (Table IsInTable))
  ((Table "Table-Size")         (Table TableSize))
  ((Vector "Vector-To-Exp")     (Vector VectorToExp))
  ((Vector "Vector-Init")       (Vector VectorInit))
  ((Vector "Vector-Fill")       (Vector VectorFill))
  ((Vector "Vector-Length")     (Vector VectorLength))
  ((Vector "Vector-Ref")        (Vector VectorRef))
  ((Vector "Vector-Set")        (Vector VectorSet))
  ((Vector "Vector-Replace")    (Vector VectorReplace))
  ((Vector "Subvector-Fill")    (Vector SubvectorFill))
  ((Dir "Open-Dir")             (Dir OpenDir))
  ((Dir "Close-Dir")            (Dir CloseDir))
  ((Dir "Read-Dir")             (Dir ReadDir))
  ((File "Path-Separator")      (File PathSeparator))
  ((File "Dir-Separator")       (File DirSeparator))
  ((File "Exists?")             (File Exists))
  ((File "Can-Read?")           (File CanRead))
  ((File "Can-Write?")          (File CanWrite))
  ((File "Can-Exec?")           (File CanExec))
  ((File "Is-Directory?")       (File IsDirectory))
  ((File "Is-File?")            (File IsFile))
  ((File "Last-Modified")       (File LastModified))
  ((List "Map!")                (List MapIn))
  ((Bit "Bit-Or")               (Bit BitOr))
  ((Bit "Bit-And")              (Bit BitAnd))
  ((Bit "Bit-Xor")              (Bit BitXor))
  ((Bit "Bit-Not")              (Bit BitNot))
  ((Bit "Bit-Left")             (Bit BitLeft))
  ((Bit "Bit-Right")            (Bit BitRight))
  ((Bit "Bit-Test")             (Bit BitTest))
  ((Bit "Bit-Set")              (Bit BitSet))
  ((Bit "Bit-Clear")            (Bit BitClear))
  ((Bit "Bit-Print")            (Bit BitPrint))
  ((Bit "Bit-Length")           (Bit BitLength))
/* End of Std-Renamings */;

$channel In Out;

Main = //<SetArgs ('-asr') ('-nc') ('-o') ('...')> <"rfpc.Main">;
  <Init_Options>,
  <Parse_Args () () 1> :: e.files,
  <Bind &RFP_Options ("IDENT-COMPATIBILITY") ()>,
  {
    # <IsInTable &RFP_Options OUT> =
      <PrintLn "Please set output directory with -o option.">,
      <Exit 1>;;
  },
  {
    &Std_Renamings : e1 ((e s.old) (e.mod s.new)) e2,
      {
        <IsInTable &RFP_Options "CASE-INSENSITIVE"> =
          <Bind &Renamings (<ToUpper <ToChars s.old>>) (e.mod s.new)>;
        <Bind &Renamings (<ToChars s.old>) (e.mod s.new)>;
      },
      $fail;;
  },
  <Get &DirSeparator> : s.dir_separator,
  {
    e.files : e (e.file) e \?
      e.file : {
        $r e.dir s.dir_separator e.name '.' e.ext = e.name (<ToLower e.ext>);
        $r e.name '.' e.ext = e.name (<ToLower e.ext>);
      } :: e.name (e.ext),
      <ToWord e.name> :: s.name,
      e.ext : {
        'rf' =
          <GetImplementationReader (e.file)> :: (e.qname) (e.interf_reader) (e.implem_reader),
          {
            e.interf_reader : /*empty*/;
            <RFP_Lexer e.interf_reader> :: (e.interf_tokens) e,
              <Find_Defs <RFP_Parse_Tokens (e.qname) e.interf_tokens>>,
              <Build_Substs e.interf_tokens>;
          },
          <RFP_Lexer e.implem_reader> :: (e.tokens) e,
          e.tokens;
        'rfi' = <RFP_Lexer <GetInterfaceReader s.name>> :: (e.tokens) e = e.tokens;
      } :: e.tokens,
      <Store &Substs /*empty*/>,
      <Find_Defs <RFP_Parse_Tokens (s.name) e.tokens>>,
      <Build_Substs e.tokens>,
      <Find_Dupls> :: e.dupls,
      <WriteLn e.dupls>,
      <OpenFile &In e.file R>,
      <OpenFile &Out <Lookup &RFP_Options OUT> s.dir_separator s.name '.' e.ext W>,
      1 $iter
        <Add s.line 1> :: s.line
      # \{
        <ReadLineCh &In> :: e.line,
          1 e.line $iter {
            e.line : s.ch e.rest_line,
              {
                <Get &Substs> : (s.tag s.line s.col s.len e.subst) e.rest_subst =
                  <Store &Substs e.rest_subst>,
                  {
                    s.tag : \{
                      Ref = <Print_Name { <Lookup &Dupls e.subst>; <R 0 e.subst>; }>;
                      Def = <ToChars <R 0 e.subst>>;
                    } :: e.subst,
                      {
                        <Is_IdentReally e.subst> = e.subst;
                        '"' e.subst '"';
                      };
                    e.subst;
                  } :: e.subst,
                  <PrintCh &Out e.subst>,
                  <Add s.col s.len> <Middle s.len 0 e.line>;
                <PrintCh &Out s.ch>,
                  <Add s.col 1> e.rest_line;
              };
          } :: s.col e.line,
          e.line : /*empty*/ =
          <PrintLnCh &Out>;
      },
      <CloseChannel &In>,
      <CloseChannel &Out> \!
      $fail;;
  };

Convert e.name =
  {
    <ToLower e.name> : 'is' e = e.name;
    e.name : e.n '?' = 'Is' e.n;
    e.name;
  } :: e.name,
  <Map &ConvertSym (e.name)>;

ConvertSym {
  '-' = '_';
  '+' = 'Add';
  '*' = 'Mult';
  '/' = 'Div';
  '%' = 'Rem';
  '@' = 'At';
  ' ' = '_';
  '.' = '_';
  '?' = 'Really';
  '!' = 'Yeah';
  s1  = s1;
};

Is_IdentReally s.first e.rest =
  \{
    <IsLetter s.first>, <Eq (<ToUpper s.first>) (s.first)>;
    '_' : s.first;
  },
  <All &IsIdentSymbol (e.rest)>;

IsIdentSymbol s.sym =
  \{
    <IsLetter s.sym>;
    <IsDigit s.sym>;
    '_.' : e s.sym e;
  };

Build_Substs e.tokens =
  e.tokens $iter {
    e.tokens : t.first e.rest = t.first : {
      (((s.line s.col) t) (s.tag e.val)),
        s.tag : \{ WORD = 0; QWORD = 2; } :: s.extra =
        {
          <Get &Parse> : \{
            Ref = <Store &Parse /*empty*/>, Ref;
            "Object-Decl" = Def;
            "Func-Decl" = <Store &Parse /*empty*/>, Def;
            "Const-Decl" = <Store &Parse "Const-Processing">, Def;
          } :: s.is_def =
            {
              <IsInTable &RFP_Options "CASE-INSENSITIVE"> = <ToUpper e.val>;
              e.val;
            } :: e.val,
            {
              <Lookup &Renamings e.val>;
              <Lookup &QNames e.val> : e.mod (e.name),
                <Convert e.name> :: e.new_name,
                e.mod <ToWord e.new_name> :: e.new_name,
                <Bind &Renamings (e.val) (e.new_name)>,
                e.new_name;
              $error "Can't find qualified name for " e.val;
            } :: e.new_name,
            <Put &Substs (s.is_def s.line s.col <Add <Length e.val> s.extra> e.new_name)>;
          <IsInTable &Def_Pos s.line s.col> =
            {
              <IsInTable &RFP_Options "CASE-INSENSITIVE"> = <ToUpper e.val>;
              e.val;
            } :: e.val,
            {
              <Put &Substs (Def s.line s.col <Add <Length e.val> s.extra>
                <Lookup &Renamings e.val>)>;
              <ToLower e.val> : 'main' =
                <Put &Substs (Def s.line s.col <Add <Length e.val> s.extra> Main)>;
            };
          s.tag : QWORD;
          <IsInTable &RFP_Options "CASE-INSENSITIVE"> =
            <ToUpper e.val> :: e.val,
            {
              <Get &Parse> : Use = {
                <Lookup &Uses e.val>;
                $error "Can't find module " e.val;
              };
              e.val;
            } :: e.val,
            {
              <Is_IdentReally e.val> = e.val;
              '"' e.val '"';
            } :: e.val,
            <Put &Substs (Word s.line s.col <Length e.val> e.val)>;
          <Is_IdentReally e.val>;
          <Put &Substs (Word s.line s.col <Length e.val> '"' e.val '"')>;
        };
      (((s.line s.col) (s.e_line s.e_col)) (s.type e.name)),
        s.type : \{ SVAR; TVAR; VVAR; EVAR; },
        # \{
          <All &IsIdentSymbol (e.name)> # <IsInTable &RFP_Options "CASE-INSENSITIVE">;
          e.name : '$' e;
        } =
        <Length e.name> :: s.len,
        {
          <Arithm.Sub <Arithm.Sub s.e_col s.col> 1> : s.len = <Convert e.name> s.len;
          '.' <Convert e.name> <Add s.len 1>;
        } :: e.new_name s.len,
        <Put &Substs (Var s.line <Add s.col 1> s.len e.new_name)>;
      (t (SEMICOLON)) = 
        <Store &Parse /*empty*/>;
      (((s.line s.col) t) (s.keyword)),
        s.keyword : \{
          USE = <Store &Parse Use>;
          \{ BOX; CHANNEL; STRING; TABLE; VECTOR; } = <Store &Parse "Object-Decl">;
          CONST = <Store &Parse "Const-Decl">;
          \{ FUNC; "FUNC?"; } = <Store &Parse "Func-Decl">;
          \{ ERROR; FAIL; EXTERN; ITER; L; R; MODULE; TRACE; TRACEALL; TRAP; USE; IMPORT; WITH; };
        } =
        '$' <ToLower <ToChars s.keyword>> :: e.keyw,
        <Put &Substs (Keyword s.line s.col <Length e.keyw> e.keyw)>;
      (t (COMMA)) =
        {
          <Get &Parse> : "Const-Processing" = <Store &Parse "Const-Decl">;;
        };
      \{ (t (REF)); (t (LBRACKET)); } =
        <Store &Parse Ref>;
      (((s.line s.col) (s.e_line s.e_col)) (COMMENT e.comment)),
        # \{ e.comment : e (e) e; } =
        <Put &Substs (Comment s.line s.col <Arithm.Sub s.e_col s.col> '//' e.comment)>;
      t = ;
    },
      e.rest;
  } :: e.tokens,
  e.tokens : /*empty*/;

Find_Defs {
  e t.item e, t.item : \{
    (s.linkage s.type t.pragma (e.mod s.name) t.in t.out (BRANCH (PRAGMA t.file (LINE s.line s.col)) e)),
      s.linkage : \{ LOCAL; EXPORT; },
      <Bind &Def_Pos (s.line s.col) ()>,
      $fail;
    (s.linkage s.type t.pragma (e.mod s.name) e),
      <ToChars s.name> :: e.name,
      {
        <IsInTable &RFP_Options "CASE-INSENSITIVE"> = <ToUpper e.name>;
        e.name;
      } :: e.key,
      <Bind &QNames (e.key) (e.mod (e.name))>,
      <ToChars <R 0 e.mod>> :: e.mod,
      <Bind &Uses (<ToUpper e.mod>) (e.mod)>;
  },
    $fail;
  e = ;
};

Find_Dupls =
  <Entries &Renamings> () $iter {
    e.renamings : e ((e.n1) (e.m1 v.s)) e1 ((e.n2) (e.m2 v.s)) e2 =
      {
        e.m1 e.m2 : e.m2 e.m1 = $error "Names '"e.n1"' and '"e.n2"' are both converted to '"e.m1 v.s"'";;
      },
      <Bind &Dupls (e.m1 v.s) (<R 0 e.m1> v.s)>,
      <Bind &Dupls (e.m2 v.s) (<R 0 e.m2> v.s)>,
      e1 e2 (e.dupls ((e.n1 (e.m1)) (e.n2 (e.m2)) v.s));
    (e.dupls);
  } :: e.renamings (e.dupls),
  e.renamings : /*empty*/ =
  e.dupls;

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")
  ((('ci') ('case-insensitive')) (BIND "CASE-INSENSITIVE")
    "convert words without surrounding quotes to upper case")
  ((('h') ('help')) HELP /*"display this help screen"*/)
  ((('o')) OUT
    ("dir") "place output in the directory <dir>")
  ((('p') ('package')) PACKAGE
    ("pack") "place output in the package <pack>")
  ((('d') ('debug')) (BIND DEBUG))
>;

Display_Help =
  <Box> :: s.line,
  ' ' :: e.start1,
  29 :: s.2nd_col,
  <Replicate s.2nd_col ' '> :: e.start2,
  <PrintLn "Converter from Refal Plus - 1991 to Refal+'07 ">,
  <PrintLn>,
  <PrintLn "Usage: RfpUpgrader [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, <Add s.index 1> :: s.index =
    {
      e.prevarg : v, e.prevarg :
        {
          IPATH =
            <Store &RFP_Include_Path <Get &RFP_Include_Path> (v.arg <Get &DirSeparator>)>;
          BPATH =
            <Store &RFP_Boot_Path <Get &RFP_Boot_Path> (v.arg <Get &DirSeparator>)>;
          OUT =
            <Bind &RFP_Options (OUT) (v.arg)>;
          PACKAGE =
            <Bind &RFP_Options (PACKAGE) (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>;
  e.files;
};