------------------------------------------------------------------------------
-- Parser Aux (Parser Support)                                              --
--                                                                          --
-- Part of SparForte                                                        --
------------------------------------------------------------------------------
--                                                                          --
--            Copyright (C) 2001-2024 Free Software Foundation              --
--                                                                          --
-- This is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 2,  or (at your option) any later ver- --
-- sion.  This is distributed in the hope that it will be useful, but WITH- --
-- OUT 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  distributed with this;  see file COPYING.  If not, write --
-- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
-- MA 02111-1307, USA.                                                      --
--                                                                          --
-- This is maintained at http://www.pegasoft.ca                             --
--                                                                          --
------------------------------------------------------------------------------
-- TODO: break this up into more specific packages

with ada.text_io,
     Interfaces.C,
     gnat.source_info,
     pegasoft.strings,
     pegasoft.script_io,
     pegasoft.user_io,
     world.utf8,
     compiler,
     scanner,
     scanner.communications,
     parser_params,
     parser.decl.as;
use  ada.text_io,
     Interfaces.C,
     pegasoft,
     pegasoft.strings,
     pegasoft.script_io,
     pegasoft.user_io,
     world.utf8,
     compiler,
     scanner,
     scanner.communications,
     parser_params,
     parser.decl.as;


package body parser_aux is

use spar_os.HEptrs;


-----------------------------------------------------------------------------
--  MAKE TEMP FILE
--
-- Create a unique temporary filename
-----------------------------------------------------------------------------

procedure makeTempFile( s : out unbounded_string ) is
  LinuxPath : string := "/tmp/sparXXXXXX" & ASCII.NUL;
  result : aFileDescriptor;
  closeResult : int;
begin
  s := null_unbounded_string;
  mkstemp( result, LinuxPath );
  if result < 0 then
     err( contextNotes => +"in /tmp",
          subjectNotes => +"a temporary file",
          reason => +"could not be created because ",
          obstructorNotes => +"syscall mkstemp failed with " & em( OSError( C_errno ) ) );
     s := null_unbounded_string;
  else
<<retry1>> closeResult := close( result ); -- not the most secure
     if closeResult < 0 then
        if C_errno = EINTR then
           goto retry1;
        end if;
     end if;
     for i in aLinuxPath'range loop
         exit when LinuxPath( i ) = ASCII.NUL;
         s := s & LinuxPath( i );
     end loop;
  end if;
end makeTempFile;

--function isEOF( fd : aFileDescriptor ) return boolean is
-- true if the file descriptor is at the end of file
--  ch     : character;
--  result : long_integer;
--  seekResult : long_integer;
--begin
--  read( result, fd, ch, 1 );                 -- read a single character
--  if result > 0 then                         -- read something?
--     seekResult := lseek( fd, -1, WHENCE_SEEK_CUR); -- move back one character
--  end if;
--  return result < 1;                         -- return if read reported EOF
--end isEOF;


-----------------------------------------------------------------------------
--  STRING FIELD
--
-- same as string_util.stringField except uses an identifier's value
-----------------------------------------------------------------------------

function stringField( i : identifier; f : natural ) return unbounded_string is
begin
  return stringField( identifiers( i ).value.all, recSep, f );
end stringField;


-----------------------------------------------------------------------------
--  REPLACE FIELD
--
-- same as string_util.replaceField except users an identifier's value
-----------------------------------------------------------------------------

procedure replaceField( i : identifier; f : natural; field : string ) is
begin
  replaceField( identifiers( i ).value.all, recSep, f, field );
end replaceField;


-----------------------------------------------------------------------------
--  STRING FIELD
--
-- same as string_util.stringField except uses a reference
-----------------------------------------------------------------------------

function stringField( r : reference; f : natural ) return unbounded_string is
   tempStr : unbounded_string;
begin
  getParameterValue( r, tempStr );
  return stringField( tempStr, recSep, f );
end stringField;


-----------------------------------------------------------------------------
--  REPLACE FIELD
--
-- same as string_util.replaceField except users an identifier's value
-----------------------------------------------------------------------------

procedure replaceField( r : reference; f : natural; field : string ) is
   tempStr : unbounded_string;
begin
  getParameterValue( r, tempStr );
  replaceField( tempStr, recSep, f, field );
  assignParameter( r, tempStr );
end replaceField;


-----------------------------------------------------------------------------
--  OPEN SOCKET
--
-- Initialize a new TCP/IP socket
-----------------------------------------------------------------------------

function openSocket( serverName : unbounded_string; port : integer ) return aSocketFD is


  mySocket    : aSocketFD;     -- the socket
  myAddress   : aSocketAddr;   -- where it goes
  myServer    : aHEptr;        -- IP number of server
  myServerPtr : HEptrs.Object_Pointer;
  addrList    : addrListPtrs.Object_Pointer;
  Result      : int;

begin

  --Put_Line( "Initializing a TCP/IP socket" );
  --Put_Line( "Socket( " & PF_INET'img & ',' & SOCK_STREAM'img & ", 0 );" );

  mySocket := Socket( PF_INET, SOCK_STREAM, 0 );
  if mySocket = -1 then
     err( subjectNotes => +"a network socket",
          reason => +"could not be created because ",
          obstructorNotes => +"syscall Socket failed with " & em( OSError( C_errno ) ) );
     return -1;
  end if;
  --New_Line;

  -- Lookup the IP number for the server

  --Put_Line( "Looking for information on " & to_string( serverName ) );

  myServer := GetHostByName( to_string( serverName ) & ASCII.NUL );
  myServerPtr := HEptrs.To_Pointer( myServer );
  if myServerPtr = null then
     if C_errno = 0 then
        err( subjectNotes => +"a network socket",
             reason => +"could not be created because ",
             obstructorNotes => pl( "there is no host by the name " ) &
                em_value( serverName ) );
     else
        err( subjectNotes => +"a network socket",
             reason => +"could not be created because ",
             obstructorNotes => +"syscall GetHostByName failed with " & em( OSError( C_errno ) ) );
     end if;
     return -1;
  end if;

  --Put_Line( "IP number is" & myServerPtr.h_length'img & " bytes long" );
  addrList := addrlistPtrs.To_Pointer( myServerPtr.h_addr_list );
  --New_Line;

  -- Create the IP, port and protocol information

  --Put_Line( "Preparing connection destination information" );
  myAddress.family := AF_INET;
  myAddress.port   := htons( Interfaces.C.Unsigned_Short( port ) );
  memcpy( myAddress.ip'address, addrlist.all, myServerPtr.h_length );
  --New_Line;

  -- Open a connection to the server

  --Put_Line( "Connect( Result, Socket, Family/Address rec, F/A rec size )" );

<<retry1>> Connect( Result, mySocket, myAddress, myAddress'size/8 );

  --Put( "Connect( " & Result'img & "," );
  --Put(  myAddress.family'img & "/" );
  --PutIPNum( myAddress.ip );
  --Put(  "," & integer'image( myAddress'size / 8 ) & ")" );
  if Result /= 0 then
     if C_errno = EINTR then
        goto retry1;
     end if;
        err( subjectNotes => +"a network socket",
             reason => +"could not be connected because ",
             obstructorNotes => +"syscall connect failed with " & em( OSError( C_errno ) ) );
<<retry2>> Result := close( aFileDescriptor( mySocket ) );
     if Result < 0 then
        if C_errno = EINTR then
           goto retry2;
        end if;
     end if;
     return -1;
  end if;
  --New_Line;

  return mySocket;

end openSocket;


------------------------------------------------------------------------------
--  PROCESS TEMPLATE
--
-- Read a template and process embedded scripts.  This procedure is expected
-- to be invoked after the main script has run.
-- Exceptions: Caller should handle STATUS_ERROR, NAME_ERROR, MODE_ERROR, etc.
------------------------------------------------------------------------------

procedure processTemplate is
   f : file_type;
   ch : character;
   type aMode is ( noMode,                          -- shouldn't be used
                   gatheringStartTag,               -- looking for a start tag
                   gatheringScript,                 -- gathering script
                   gatheringEndTag,                 -- looking for end tag
                   outputTemplate                   -- writing out template
                  );
   mode : aMode := outputTemplate;                  -- what are we doing now
   bushStartTag   : constant string := "<?spar";    -- the start tag
   bushEndTag     : constant string := "?>";        -- the end tag
   tag            : unbounded_string;               -- possible tag text
   tagCount       : natural := 0;                   -- characters in p. tag
   uncompressedScript : unbounded_string;           -- script being gathered
   -- lineno         : natural := 1;
   startingLineNo : natural := 1;
   -- save_lineno    : aLineNumber;                    -- swap space for line no
   lastLine : Positive_Count := 1;
begin
   -- no longer force GCC-style errors.  That's handled in the err
   -- function now.
   -- gccOpt := true;

   -- Switch to a restricted shell and disable external commands
   -- for normal templates.

   if not unrestrictedTemplate then
      rshOpt := true;
      restriction_no_external_commands := true;
   end if;

   -- Write the HTTP header. If already written, nothing happens.

   if isExecutingCommand then
      putTemplateHeader( templateHeader );
   end if;

   -- Open the template file

   scriptFilePath := templatePath;
   open( f, in_file, to_string( templatePath ) );   -- open the template
   setTemplateName;

   -- Read the template, interpret tags and execute commands

   while not end_of_file( f ) loop                  -- while text to do
      get( f, ch );                                 -- get next character

      ----------------------------------------------------------------------
      -- Text_IO Automatically skips lines.  This should be rewritten.
      ----------------------------------------------------------------------

      if line( f ) - lastLine > 1 then
         for i in 1..line( f ) - lastLine -1 loop
             uncompressedScript := uncompressedScript & ASCII.LF;
         end loop;
      end if;
      lastLine := line( f );

      ----------------------------------------------------------------------
      -- Depending on the mode, interpret the template character
      ----------------------------------------------------------------------

      case mode is                                  -- are we searching for

      ----------------------------------------------------------------------
      -- Examining a possible script start tag?
      ----------------------------------------------------------------------

      when gatheringStartTag =>                     -- possible <?spar ?
-- put_line( "gst: read '" & ch & " at" & lineno'img & "', tag = '" & to_string( tag ) & "', tagCount = " & tagCount'img );
         tag := tag & ch;                           -- record in case not
         tagCount := tagCount + 1;                  -- count characters
         if tagCount < bushStartTag'length then     -- subset of tag?
            if ch /= bushStartTag(tagCount) then    -- match failed?
               mode := outputTemplate;              -- not a tag
               tagCount := 0;                       -- forget it
               if last_status = 0 then              -- we are outputting?
                  put_retry( to_string( tag ) );    -- output template text
               end if;
            end if;
            if end_of_line( f ) then                -- EOL?
              -- lineno := lineno + 1;              -- template line
              if last_status = 0 then               -- we are outputting?
                 new_line_retry;                    -- output a line feed
              end if;
            end if;
         elsif ch = bushStartTag( tagCount ) then   -- but if last matches
            mode := gatheringScript;                -- look for a script
            tagCount := 0;                          -- forget tag
            startingLineNo := integer( line( f ) );
         else
            mode := outputTemplate;                 -- not a tag
            tagCount := 0;                          -- forget it
            if last_status = 0 then                 -- we are outputting?
               put_retry( to_string( tag ) );       -- output template text
            end if;
            if end_of_line( f ) then                -- EOL?
              -- lineno := lineno + 1;              -- template line
              if last_status = 0 then               -- we are outputting?
                 new_line_retry;                    -- output a line feed
              end if;
            end if;
         end if;

      ----------------------------------------------------------------------
      -- Gathering a script?
      ----------------------------------------------------------------------

      when gatheringScript =>                       -- collecting text
--put_line( "read '" & ch & "', tag = '" & to_string( tag ) & "', tagCount = " & tagCount'img );
         if ch = bushEndTag(1) then                 -- possible end tag?
            tag := null_unbounded_string & ch;      -- record char
            tagCount := 1;                          -- first in tag
            mode := gatheringEndTag;                -- looking for tag
         else
            uncompressedScript := uncompressedScript & ch; -- add character
            if end_of_line( f ) then                -- EOL?
               -- lineno := lineno + 1;                -- template line
               uncompressedScript := uncompressedScript & ASCII.LF;
            end if;
         end if;

      ----------------------------------------------------------------------
      -- Examining a possible end tag?
      ----------------------------------------------------------------------

      when gatheringEndTag =>                       -- possible ?> ?
--put_line( "get: read '" & ch & "', tag = '" & to_string( tag ) & "', tagCount = " & tagCount'img );
         tag := tag & ch;                           -- record in case not
         tagCount := tagCount + 1;                  -- count characters
         if tagCount < bushEndTag'length then       -- subset of tag?
            if ch /= bushEndTag(tagCount) then      -- match failed?
               mode := gatheringScript;             -- continue w/script
               tagCount := 0;                       -- forget it
               uncompressedScript := uncompressedScript & tag; -- text is script
            end if;
         elsif ch = bushEndTag( tagCount ) then     -- but if last matches
            mode := outputTemplate;                 -- done, run scripts
            tagCount := 0;                          -- forget tag
         else
            mode := gatheringScript;                -- continue w/script
            tagCount := 0;                          -- forget it
            uncompressedScript := uncompressedScript & tag; -- text is script
         end if;
         if end_of_line( f ) then                   -- EOL?
            -- lineno := lineno + 1;                   -- template line
            uncompressedScript := uncompressedScript & ASCII.LF;
         end if;

      ----------------------------------------------------------------------
      -- We have a script.  Run it.
      ----------------------------------------------------------------------

         if mode = outputTemplate and not error_found then
            -- interpretCommand( uncompressedScript );
            -- there should be a proc for this
            compileTemplate( uncompressedScript, startingLineNo );
            inputMode := fromScriptFile;               -- running a script
            exit_block := false;                       -- not exit-ing a block
            -- The inputMode will be fromScriptFile and no syntax_check was
            -- done.  Therefore, force type checking.
            --type_checks_done := not (inputMode = interactive) and not syntax_check;
            type_checks_done := false;
            cmdpos := firstScriptCommandOffset;        -- start at first char
            token := identifiers'first;                -- dummy, replaced by g_n_t
            -- don't reset line number (for error msgs) lineno := 1;
            getNextToken;                              -- load first token
            -- save_lineno := lineno;                     -- save line
            loop                                       -- run commands
               ParseGeneralStatement;
            exit when done or token = eof_t;           -- continue until done
            end loop;                                  --  or eof hit
            if not done then                           -- not exiting?
               expect( eof_t );                        -- should be nothing else
            end if;
            -- lineno := save_lineno;                     -- restore template line
               --DoRunTimeStatements( identifiers( token ).value, );
            uncompressedScript := null_unbounded_string; -- clear script
         end if;

      ----------------------------------------------------------------------
      -- Examining a template.
      ----------------------------------------------------------------------

      when outputTemplate =>
         if ch = bushStartTag(1) then               -- possible start tag?
            tag := null_unbounded_string & ch;      -- record char
            tagCount := 1;                          -- first in tag
            mode := gatheringStartTag;              -- looking for tag
         elsif end_of_line( f ) then                -- otherwise EOL?
            if last_status = 0 then                 -- we are outputting?
               put_retry( ch );                     -- write character
            end if;
            -- lineno := lineno + 1;                   -- count template line
            if last_status = 0 then                 -- we are outputting?
               new_line_retry;                      -- output a line feed
            end if;
         else                                       -- not EOL?
            if last_status = 0 then                 -- we are outputting?
               put_retry( ch );                     -- write character
            end if;
         end if;

      when others =>                             -- unexpected mode
        err(
            contextNotes => pl( "At " & gnat.source_info.source_location &
               " while reading the template" ),
            subjectNotes => subjectInterpreter,
            reason => +"had an internal error because it entered",
            obstructorNotes => pl( "an unexpected template mode " & mode'img )
        );
      end case;

   end loop;                                     -- continue while text
   close( f );                                   -- close template file
   exception when end_error =>
   -- kludge: if a blank line is at the end of template, an end_error
   -- exception will be thrown.  I should fix the EOL handling...
      close( f );
end processTemplate;


---------------------------------------------------------
--
-- MISC PARSER UTILITIES
--
---------------------------------------------------------


------------------------------------------------------------------------------
--  DO QUIT
--
-- Quit a script
------------------------------------------------------------------------------

procedure DoQuit is
begin
  done := true;                             -- stop parsing
  exit_block := true;                       -- exit any block
  done_sub := false;                        -- only leaving subprogram
  if trace then                             -- tracing? explain
     put_trace( "Terminating" );
  end if;
end DoQuit;


------------------------------------------------------------------------------
--  DO RETURN
--
-- Quit a user-defined subprogram
------------------------------------------------------------------------------

procedure DoReturn is
begin
  done := true;                             -- stop parsing
  exit_block := true;                       -- exit any block
  done_sub := true;                         -- only leaving subprogram
  if trace then                             -- tracing? explain
     put_trace( "Returning" );
  end if;
end DoReturn;


------------------------------------------------------------------------------
--  DO START BREAKOUT
--
-- Start a breakout session
------------------------------------------------------------------------------

procedure DoStartBreakout( execution_position : out unbounded_string ) is
begin
  for i in 1..identifiers_top-1 loop
      if identifiers( i ).inspect then
         Put_Identifier( i );
      end if;
  end loop;
  execution_position :=  get_script_execution_position(
      inv( "Break: return to continue, logout to quit" ),
      utf_wristwatch ); -- show stop posn
  put_line_retry( standard_error, to_string( execution_position ) );
  error_found := true;
end DoStartBreakout;


------------------------------------------------------------------------------
--
-- Renaming Support
--
-- These will be refactored in the future to create cleaner renaming
-- support.
--
------------------------------------------------------------------------------


------------------------------------------------------------------------------
--  FIX RENAMED RECORD FIELDS
--
-- Given a renamed record, search for and adjust the record fields to
-- refer to the correct variables.
------------------------------------------------------------------------------

procedure FixRenamedRecordFields( canonicalRef : renamingReference;
  renamingRec : identifier ) is
  numFields : natural;
  canonicalField : identifier;
begin
  -- The renaming possibilities
  --
  -- canonicalRec      renamedRec       renamedRenamedRec
  --   canonicalField    renamedField     renamedRenamedField
  --                   renamed2Rec
  --                     renamed2Field
  --
  -- For a record renaming, also create renamings for each field of the
  -- record.  (A reference to the canonical record variable is not good
  -- enough.)  Each field must reference to the canonical record's
  -- fields (or the renaming target, in the cause of a double renaming).
  --
  -- SparForte currently treats record fields as regular variables.
  --
  -- 1. The field_of must point to the associated record, not
  --    the canonical record.
  -- 2. All values must point to the canonical record or field's
  --    value.
  -- 3. The variable referenced, even if a renaming, must have
  --    it's counter incremented.
  -- 4. Renaming of individual fields are treated as a regular
  --    variable renaming.
  --

-- put( "Mapping " & canonicalRef.id'img & ":" );
-- put( to_string( identifiers( canonicalRef.id ).name ) );
-- put_line( " to " & to_string( identifiers( id ).name ) );

  -- TODO: this search should be optimized.
  -- Why not stop when all fields are found?
  -- Skip namespaces.

  -- The canonical record/fields could be, of course, another
  -- renaming.
  -- Always a risk of an exception thrown here
  begin
    numFields := natural( to_numeric( identifiers( identifiers(
        canonicalRef.id ).kind ).value.all ) );
  exception when storage_error =>
    numFields := 0;
    err(
       contextNotes => pl( "At " & gnat.source_info.source_location &
          " while fixing a record" ),
       subjectNotes => subjectInterpreter,
       reason => pl( "had an internal error " &
          "while determining the number of fields because of "),
       obstructorNotes => +"a storage_error exception"
    );
  when constraint_error =>
    numFields := 0;
    err(
       contextNotes => pl( "At " & gnat.source_info.source_location &
          " while fixing a record" ),
       subjectNotes => subjectInterpreter,
       reason => pl( "had an internal error while determining " &
          "while determining the number of fields because of "),
       obstructorNotes => +"a constraint_error exception"
    );
  end;

  canonicalField := canonicalRef.id + 1;

  for fieldNumber in 1..numFields loop

      -- brutal search was...
      -- for canonicalField in reverse keywords_top..identifiers_top-1 loop
      --
      -- As an optimization, the fields are likely located immediately after
      -- the record itself is defined.  Also assumes they are stored
      -- sequentially.  In the future, records will be stored differently.

      while canonicalField < identifiers_top loop
        if identifiers( canonicalField ).field_of = canonicalRef.id then
           exit;
        end if;
        canonicalField := identifier( integer( canonicalField ) + 1 );
      end loop;

     -- no more identifiers means we didn't find it.
     if canonicalField = identifiers_top then
        err(
           contextNotes => pl( "At " & gnat.source_info.source_location &
              " while fixing a record" ),
           subjectNotes => subjectInterpreter,
           reason => pl( "had an internal error while determining " &
              "while determining the number of fields because "),
           obstructorNotes => +"a field was not found"
        );
        exit;
     end if;

     declare
        fieldName     : unbounded_string;
        renamingField : identifier;
        dotPos        : natural;
     begin
        -- construct a new field name using the renaming
        fieldName := identifiers( canonicalField ).name;
        dotPos := length( fieldName );
        while dotPos > 1 loop
           exit when element( fieldName, dotPos ) = '.';
           dotPos := dotPos - 1;
        end loop;
        fieldName := delete( fieldName, 1, dotPos );
        fieldName := identifiers( renamingRec ).name & "." & fieldName;

        -- Locate the field of the renaming record
        -- TODO: this is slow, as fields are likely stored sequentially after
        -- the record type, so there's no reason to do a brute-force lookup.
        findIdent( fieldName, renamingField );
        if renamingField = eof_t then
           err(
              contextNotes => pl( "At " & gnat.source_info.source_location &
                 " while fixing a record" ),
              subjectNotes => subjectInterpreter,
              reason => pl( "had an internal error when it " &
                 "could not find a field in the renaming record"),
              obstructorNotes => pl( "Identifier" & canonicalField'img &
                ": Canonical field " ) &
                name_em( canonicalField ) & pl( "/" &
                "Renaming Field " ) & unb_em( fieldName )
           );
        else
           -- The renaming is created by copying data.  Correct
           -- the fields to be owned
           -- by the renaming, not adding fields to the canonical
           -- record.
           identifiers( renamingField ).field_of := renamingRec;
           -- link the renaming field to the canonical field
           identifiers( canonicalField ).renamed_count :=
              identifiers( canonicalfield ).renamed_count + 1;
           identifiers( renamingField ).value :=
              identifiers( canonicalField ).value;
         end if;
     end;
     canonicalField := identifier( integer( canonicalField ) + 1 );
   end loop;
end FixRenamedRecordFields;


------------------------------------------------------------------------------
--  FIX RENAMED ARRAY
--
-- Given a renamed array set up by ParseRenamingPart, fix the attributes
-- for field type.
------------------------------------------------------------------------------

procedure FixRenamedArray( canonicalRef : renamingReference;
  renamingArray : identifier ) is
begin
  -- For full arrays, the code uses avalue directly.  avalue is a pointer
  -- which is copied when the renaming is created in ParseRenamesPart.  So
  -- nothing else should be done here.
  identifiers( renamingArray ).list := true;
  identifiers( renamingArray ).kind := canonicalRef.kind;
end FixRenamedArray;

end parser_aux;
