# Written by Ivan Levashew aka OCTAGRAM
# Barnaul, 2009

global Init_Id_Chars, Id_Chars, Whitespace, Case_Exceptions
global Dir_Trailer

procedure Init_Char_Sets ()
   Init_Id_Chars := &letters ++ '_'
   Id_Chars := Init_Id_Chars ++ &digits
   Whitespace := ' \t\r\n'
end

procedure Init_Case_Exceptions ()
   local s, id
   Case_Exceptions := table ()
   if s := Get_File_Contents ("case_except.txt") then
      every id := Find_Identifiers (s) do
         Case_Exceptions [Up_Case (id)] := id
end

procedure Init_Separator ()
   if find("UNIX", &features) then {
      Dir_Trailer := "/"
   }
   else if find("MS-DOS" | "MS Windows NT", &features) then {
      Dir_Trailer := "\\"
   }
   else stop("Init_Separator: OS not supported")
end

procedure Get_File_Contents (filename)
   local f, r, size
   if f := open (filename, "r") then {
      r := ""
      seek (f, 0)
      size := where (f)
      seek (f, 1)
      r := reads (f, size)
      close (f)
      return r
   }
end

procedure Put_File_Contents (filename, s)
   local f
   if f := open (filename, "w") then {
      writes (f, s)
      close (f)
      return
   }
end

procedure Match_Pascal_Identifier (s, i)
   # если в позиции i начинается идентификатор, возвращает позицию конца идентификатора
   if /s then {
      s := &subject; i := &pos
   } else /i := 1
   return ((not any (Id_Chars, s, i - 1),
            any (Init_Id_Chars, s, i),
            (many (Id_Chars, s, i + 1) | i + 1)))
end

procedure Match_Whitespace (s, i)
   if /s then {
      s := &subject; i := &pos
   } else /i := 1
   return many (Whitespace, s, i) | i
end

procedure Find_Identifiers (s, Arg_I)
   local id
   s ? {
      &pos := \Arg_I
      while
         (id := tab (Match_Pascal_Identifier ()), not suspend id) |
            tab (upto (Init_Id_Chars))
   }
end

procedure Up_Case (s)
   return map (s, &lcase, &ucase)
end

procedure Lo_Case (s)
   return map (s, &ucase, &lcase)
end

procedure Find_Chunks (Ident, Arg_I)
   local Chunk, j
   if /Ident then {
      Ident := &subject; Arg_I := &pos
   } else /Arg_I := 1

   Ident ? {
      &pos := Arg_I
      while
         if Chunk :=
           tab (many (&lcase)) |
           (tab (any (&ucase)) || tab (many (&lcase))) |
           tab ((j := many (&ucase),
                 if any (&lcase, &subject, j) then j - 1 else j )) |
           tab (many (&digits)) then not suspend Chunk
         else
           tab (many ('_'))
   }
end

procedure Chunk_To_Ada (Chunk)
   return \Case_Exceptions [Up_Case (Chunk)] |
     Up_Case (Chunk [1]) || Lo_Case (Chunk [2 : 0])
end

procedure Identifier_To_Ada (Ident)
   local Chunk, Result
   Result := ""
   every Chunk := Find_Chunks (Ident) do {
      *Result > 0 & Result ||:= "_";
      Result ||:= Chunk_To_Ada (Chunk)
   }
   return Result
end

procedure Unit_Id_To_Ada (Ident)
   Ident ? {
      if tab (match ("Jwa")) then
         return "Jwa." || Identifier_To_Ada (tab (0))
      else
         return Identifier_To_Ada (tab (0))
   }
end

record Rich_Token (i, j, Parsed)

global Input_Pas, Output_Ads, Output_Adb, Create_Adb,
       Pas_Unit_Name, Ada_Pkg_Name,
       Pas_Content, Ads_Content, Adb_Content

procedure otab (rtoken) # Если нужен старый контент
   return tab (rtoken.j)
end

procedure ntab (rtoken) # Если нужен новый контент
   if tab (rtoken.j) then
      return rtoken.Parsed
end

procedure Rich_Line (s, i) # В Parsed не будет \n
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      if pos (0) then fail
      if r.Parsed := tab (upto ('\n')) then
         ="\n"
      else
         r.Parsed := tab (0)
      r.j := &pos
   }
   return r
end

procedure Rich_Whitespace_Line (s, i) # В Parsed не будет \n
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      r.Parsed := tab (many (' \t'))
      ="\n" | pos (0) | fail
      r.j := &pos
   }
   return r
end

procedure Rich_EOL (s, i) # успешно в конце строки или конце фрагмента
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      ="\n" | pos (0) | fail
      r.j := &pos
   }
   return r
end

procedure Rich_Ignored_Lines (s, i)
   local r, line, line2
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      while
         r.Parsed ||:= "--%%" ||
           (line := Rich_Line (),
            if *(line.Parsed) > 0 then " " else "") || otab (line)
      r.j := &pos
   }
   return r
end

procedure Rich_Pas_To_Ads_Ignore (s, i)
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      if not pos (0) then r.Parsed := "--%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%\n"
      while not pos (0) do {
         r.Parsed ||:= ntab (Rich_Ignored_Lines ())
      }
      r.j := &pos
   }
   return r
end

procedure Rich_Pas_To_Ads_Initial_Comments (s, i)
   local r, line, j, text1, text2
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   text1 := "Unit for Object Pascal"
   text2 := "Package for Ada 2005"
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      while
         r.Parsed ||:= (="{" & "--") ||
           (map (tab (many ('*')), "*", "-") | {
              line := tab (upto ('}'))
              while j := find (text1, line) do {
                 line [j +: *text1] := text2
                 line ||:= repl (" ", *text1 - *text2)
              }
              line
           }) ||
           (="}" & "--") || otab (Rich_EOL ())
      r.j := &pos
   }
   return r
end

procedure Rich_Pas_To_Ads_Initial_Version (s, i)
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      r.Parsed ||:=
         tab (Match_Whitespace ()) ||
         (="// $Id: " & "--  $Id: ") ||
         (=Pas_Unit_Name & =".pas" & Ada_Pkg_Name || ".ads") ||
         ="," || otab (Rich_Line ()) | fail
      r.j := &pos
   }
   return r
end

procedure Rich_Pas_To_Ads_Jwa_Prolog_Trash (s, i)
   local r, lastwhitespace
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      while
         tab (Match_Whitespace ()) &
          (
           ="{$IFNDEF JWA_OMIT_SECTIONS}" |
           ="{$ENDIF JWA_OMIT_SECTIONS}" |
           ="{$WEAKPACKAGEUNIT}" |
           (="{$STACKFRAMES ON} //" & tab (find ('\n'))) |
           (="{$HPPEMIT '" & tab (find ("'")) & ="'}") |
           ="{$I jediapilib.inc}"
          ) & { tab (many(' \t')); ="\n"; &null }
      r.j := &pos
   }
   return r
end

procedure Rich_Pas_To_Ads_Jwa_Prolog (s, i)
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      r.Parsed ||:=
         tab (Match_Whitespace ()) ||
         ntab (Rich_Pas_To_Ads_Jwa_Prolog_Trash ()) ||
         (="unit " & "package ") ||
         (=Pas_Unit_Name & Ada_Pkg_Name) || (=";" & " is") ||
         otab (Rich_Whitespace_Line ()) ||
         ntab (Rich_Pas_To_Ads_Jwa_Prolog_Trash ()) ||
         otab (Rich_Whitespace_Line ())
      r.j := &pos
   }
   return r
end

procedure Rich_Pas_To_Ads (s, i)
   local r
   if /s then {
      s := &subject; /i := &pos
   } else /i := 1
   s ? {
      tab (i)
      r := Rich_Token (&pos, *&subject + 1, "")
      repeat {
         r.Parsed ||:= ntab (Rich_Pas_To_Ads_Initial_Comments ()) | break
         r.Parsed ||:= ntab (Rich_Pas_To_Ads_Initial_Version ()) | break
         r.Parsed ||:= ntab (Rich_Pas_To_Ads_Jwa_Prolog ()) | break
      break }
      r.Parsed ||:= ntab (Rich_Pas_To_Ads_Ignore ())
      r.j := &pos
   }
   return r
end

procedure Command_Process (dirname, unitname)
   Pas_Unit_Name := unitname
   Ada_Pkg_Name := Unit_Id_To_Ada (unitname)
   Input_Pas := dirname || Dir_Trailer || Pas_Unit_Name || ".pas"
   Output_Ads := dirname || "_out" || Dir_Trailer || Ada_Pkg_Name || ".ads"
   Output_Adb := dirname || "_out" || Dir_Trailer || Ada_Pkg_Name || ".adb"
   write ("Processing: " || Input_Pas || " => " || Output_Ads)
   Pas_Content := Get_File_Contents (Input_Pas)
   Ads_Content := ""
   Adb_Content := ""

   Ads_Content := (Pas_Content ? ntab (Rich_Pas_To_Ads ()))
   Put_File_Contents (Output_Ads, Ads_Content)
end

procedure main ()
   local drive, command, commandname, dirname, unitname
   Init_Char_Sets ()
   Init_Case_Exceptions ()
   Init_Separator ()
   drive := open ("drive.txt", "r") & {
      while command := read (drive) do command ? {
         tab (Match_Whitespace ()) &
         if commandname := tab (Match_Pascal_Identifier ()) then
            case Lo_Case (commandname) of {
               "process" : {
                  if tab (Match_Whitespace ()) &
                     dirname := tab (Match_Pascal_Identifier ()) &
                     tab (Match_Whitespace ()) &
                     unitname := tab (Match_Pascal_Identifier ()) &
                     tab (Match_Whitespace ()) & pos (0) then {
                     Command_Process (dirname, unitname)
                  } else
                     stop ("Syntax error", "Line: " || command)
               }
               "debug" : { }
               default : stop ("Unknown command name: " || commandname)
            }
         else
            stop ("Syntax error",
                  "Expected command name",
                  "Found: " || command)
      }
      close (drive)
   }
end
