⟦8ceea05bb⟧

TextFile

with ASA_DEFINITIONS;
with ASAOPEN;
with JOB_SEGMENT;
with LOGGER;
with REMOTE_OPERATIONS;
with SIMPLE_STATUS;
with TIME_UTILITIES;
with UNIX_DEFINITIONS;
package body HIERARCHY is

   package RO renames REMOTE_OPERATIONS;
   package SS renames SIMPLE_STATUS;


   --                    ----------
   --                    ( ) Naming
   --                    ----------


   HIERARCHY : constant STRING :=
      ASA_DEFINITIONS.MAIN_CLASS_DIRECTORY & ".HIERARCHY";

   function ADA_NAME (S : in STRING) return STRING is
      OFFSET : constant := CHARACTER'POS ('A') - CHARACTER'POS ('a');
      RESULT : STRING (S'RANGE);
      NEXT : NATURAL := S'FIRST;
   begin
      for I in S'RANGE loop
         case S (I) is

            when 'A' .. 'Z' =>
               RESULT (NEXT) := S (I);
               NEXT := NEXT + 1;

            when 'a' .. 'z' =>
               RESULT (NEXT) := CHARACTER'VAL (CHARACTER'POS (S (I)) + OFFSET);
               NEXT := NEXT + 1;

            when '0' .. '9' =>
               if NEXT = S'FIRST then

                  -- An Ada name cannot start with a digit.
                  null;
               else
                  RESULT (NEXT) := S (I);
                  NEXT := NEXT + 1;
               end if;

            when others =>
               if NEXT = S'FIRST then

                  -- An Ada name cannot start with an underscore.
                  null;
               elsif RESULT (NEXT - 1) = '_' then

                  -- An Ada name cannot have two consecutive
                  -- underscores.
                  null;

               else
                  RESULT (NEXT) := '_';
                  NEXT := NEXT + 1;
               end if;
         end case;
      end loop;
      if NEXT > S'FIRST and then RESULT (NEXT - 1) = '_' then

         -- An Ada name cannot end with an underscore.
         return RESULT (S'FIRST .. NEXT - 2);
      else
         return RESULT (S'FIRST .. NEXT - 1);
      end if;
   end ADA_NAME;

   --[bug]
   -- Due to a bug in asaopen, the requirements arrive here with
   -- underscores instead of blanks.  They must be converted back.
   --
   function UNDERLINES_TO_SPACES (S : in STRING) return STRING is
      RESULT : STRING (S'RANGE);
   begin
      for I in S'RANGE loop
         if S (I) = '_' then
            RESULT (I) := ' ';
         else
            RESULT (I) := S (I);
         end if;
      end loop;
      return RESULT;
   end UNDERLINES_TO_SPACES;


   --                    ----------------------------------
   --                    ( ) Bodies of external subprograms
   --                    ----------------------------------


   procedure BUILD (MODEL : in STRING;  
                    HOST : in STRING;
                    ROOT : out MODULE;
                    BUILD_TIME : out CALENDAR.TIME) is
      C : RO.CONTEXT;
      S : SIMPLE_STATUS.CONDITION;
   begin

      --
      -- Acquire a connection.
      --
      RO.ACQUIRE (A_CONTEXT => C,
                  STATUS => S,
                  MACHINE => HOST,
                  INSTANCE => ASA_DEFINITIONS.ASA);
      LOGGER.STATUS (S);

      --
      -- Do the actual build.
      --
      BUILD (MODEL => MODEL,
             IN_CONTEXT => C,
             ROOT => ROOT,
             BUILD_TIME => BUILD_TIME);

      --
      -- Release the connection.
      --
      RO.RELEASE (A_CONTEXT => C, STATUS => S);
      LOGGER.STATUS (S);
   end BUILD;

   procedure BUILD (MODEL : in STRING;  
                    IN_CONTEXT : in REMOTE_OPERATIONS.CONTEXT;
                    ROOT : out MODULE;
                    BUILD_TIME : out CALENDAR.TIME) is

      S : SS.CONDITION;

      type LINE_KIND is (IDENTIFIER,  
                         NODE,  
                         COMMENT,  
                         REQUIREMENT_1,  
                         REQUIREMENT_2,  
                         REQUIREMENT_3,  
                         REQUIREMENT_4,  
                         REQUIREMENT_5,  
                         REQUIREMENT_6,  
                         REQUIREMENT_7,  
                         REQUIREMENT_8,  
                         REQUIREMENT_9,  
                         CHILDREN);

      type STATE_RECORD is
         record
            CURRENT : MODULE;  
            EXPECTED : LINE_KIND;
         end record;

      MY_STATE : STATE_RECORD := (CURRENT => null,  
                                  EXPECTED => IDENTIFIER);

      procedure PROCESS (STATE : in out STATE_RECORD; LINE : in STRING) is
         NEW_MODULE : MODULE;
         NB_OF_CHILDREN : NATURAL;
      begin
         case STATE.EXPECTED is

            when IDENTIFIER =>  
               if STATE.CURRENT /= null then

                  NEW_MODULE := new MODULE_RECORD'(IDENTIFIER =>
                                                      new STRING'(LINE),
                                                   NODE_NUMBER => null,
                                                   COMMENT => null,
                                                   REQUIREMENTS =>
                                                      (others => null),
                                                   PARENT => STATE.CURRENT,
                                                   FIRST_CHILD => null,
                                                   NEXT_SIBLING =>
                                                      STATE.CURRENT.FIRST_CHILD,
                                                   REMAINING_CHILDREN => 0);
                  pragma HEAP (JOB_SEGMENT.GET);

                  STATE.CURRENT.REMAINING_CHILDREN :=
                     STATE.CURRENT.REMAINING_CHILDREN - 1;
                  STATE.CURRENT.FIRST_CHILD := NEW_MODULE;
                  STATE.CURRENT := NEW_MODULE;
               else

                  STATE.CURRENT :=
                     new MODULE_RECORD'(IDENTIFIER => new STRING'(LINE),
                                        NODE_NUMBER => null,  
                                        COMMENT => null,
                                        REQUIREMENTS => (others => null),
                                        PARENT => null,
                                        FIRST_CHILD => null,
                                        NEXT_SIBLING => null,
                                        REMAINING_CHILDREN => 0);
                  pragma HEAP (JOB_SEGMENT.GET);

               end if;

            when NODE =>
               STATE.CURRENT.NODE_NUMBER := new STRING'(LINE);
               pragma HEAP (JOB_SEGMENT.GET);

            when COMMENT =>

               --
               -- Asaopen says "(null)" if there is no comment.
               --
               if LINE = "(null)" then
                  STATE.CURRENT.COMMENT := new STRING'("");
                  pragma HEAP (JOB_SEGMENT.GET);
               else
                  STATE.CURRENT.COMMENT := new STRING'(LINE);
                  pragma HEAP (JOB_SEGMENT.GET);
               end if;

            when REQUIREMENT_1 .. REQUIREMENT_9 =>  
               if LINE /= "" then
                  STATE.CURRENT.REQUIREMENTS
                     (REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER
                         (LINE_KIND'POS (STATE.EXPECTED) -
                          LINE_KIND'POS (LINE_KIND'PRED (REQUIREMENT_1)))) :=
                     new STRING'(UNDERLINES_TO_SPACES (LINE));
                  pragma HEAP (JOB_SEGMENT.GET);
               end if;

            when CHILDREN =>
               NB_OF_CHILDREN := NATURAL'VALUE (LINE);
               case NB_OF_CHILDREN is

                  when 0 =>
                     while STATE.CURRENT.REMAINING_CHILDREN = 0 and then
                              STATE.CURRENT.PARENT /= null loop
                        STATE.CURRENT := STATE.CURRENT.PARENT;
                     end loop;

                  when POSITIVE =>
                     STATE.CURRENT.REMAINING_CHILDREN := NB_OF_CHILDREN;
               end case;
         end case;

         if STATE.EXPECTED = LINE_KIND'LAST then
            STATE.EXPECTED := LINE_KIND'FIRST;
         else
            STATE.EXPECTED := LINE_KIND'SUCC (STATE.EXPECTED);
         end if;
      end PROCESS;

      procedure EXECUTE_SCRIPT is
         new ASAOPEN.EXECUTE (STATE_RECORD => STATE_RECORD, PROCESS => PROCESS);

   begin

      --
      -- Get the remote model's update time.
      --
      RO.UPDATE_TIME (OF_FILE => MODEL,  
                      IN_CONTEXT => IN_CONTEXT,
                      RESULT => BUILD_TIME,
                      STATUS => S);
      if SS.ERROR (S) then
         LOGGER.ERROR ("Unable to open remote model " & MODEL,
                       RAISE_ERROR => FALSE);
         LOGGER.STATUS (S);
      end if;

      --
      -- Execute the script to extract the hierarchy information.
      --
      EXECUTE_SCRIPT (IN_CONTEXT => IN_CONTEXT,
                      MODEL => MODEL,
                      TEMPLATE_NAME => HIERARCHY,
                      STATE => MY_STATE,
                      STATUS => S);
      LOGGER.STATUS (S);

      ROOT := MY_STATE.CURRENT;  
   end BUILD;

   function MAKE (IDENTIFIER : in STRING) return MODULE is
   begin
      return new MODULE_RECORD'(IDENTIFIER => new STRING'(IDENTIFIER),
                                NODE_NUMBER => new STRING'("M"),
                                COMMENT => new STRING'(""),
                                REQUIREMENTS => (others => null),
                                PARENT => null,
                                FIRST_CHILD => null,
                                NEXT_SIBLING => null,
                                REMAINING_CHILDREN => 0);
      pragma HEAP (JOB_SEGMENT.GET);
   end MAKE;

   function CHILDREN_OF (M : in MODULE) return MODULE_ITERATOR is
   begin
      return MODULE_ITERATOR (M.FIRST_CHILD);
   end CHILDREN_OF;

   function PARENT_OF (M : in MODULE) return MODULE is
   begin
      return M.PARENT;
   end PARENT_OF;

   function IDENTIFIER (M : in MODULE) return STRING is
   begin
      return M.IDENTIFIER.all;
   end IDENTIFIER;

   function SIMPLE_NAME (M : in MODULE) return STRING is
   begin
      return ADA_NAME (M.IDENTIFIER.all);
   end SIMPLE_NAME;

   function FULL_NAME (M : in MODULE) return STRING is
   begin
      if M.PARENT = null then
         return ADA_NAME (M.IDENTIFIER.all);
      else
         return FULL_NAME (M.PARENT) & '.' & ADA_NAME (M.IDENTIFIER.all);
      end if;
   end FULL_NAME;

   function NODE_NUMBER (M : in MODULE) return STRING is
   begin
      return M.NODE_NUMBER.all;
   end NODE_NUMBER;

   function COMMENT (M : in MODULE) return STRING is
   begin
      return M.COMMENT.all;
   end COMMENT;

   function REQUIREMENT (M : in MODULE;  
                         NUMBER : in REQUIREMENTS.FUNCTIONAL_REQUIREMENT_NUMBER)
                        return STRING is
   begin  
      if M.REQUIREMENTS (NUMBER) = null then
         return "";
      else
         return M.REQUIREMENTS (NUMBER).all;
      end if;
   end REQUIREMENT;

   function DONE (M : in MODULE_ITERATOR) return BOOLEAN is
   begin
      return M = null;
   end DONE;

   function VALUE (M : in MODULE_ITERATOR) return MODULE is
   begin
      return MODULE (M);
   end VALUE;

   procedure NEXT (M : in out MODULE_ITERATOR) is
   begin
      M := MODULE_ITERATOR (M.NEXT_SIBLING);
   end NEXT;

   function SIZE (M : in MODULE_ITERATOR) return NATURAL is
      ITER : MODULE_ITERATOR := M;  
      RESULT : NATURAL := 0;
   begin
      while ITER /= null loop
         RESULT := RESULT + 1;
         ITER := MODULE_ITERATOR (ITER.NEXT_SIBLING);
      end loop;
      return RESULT;
   end SIZE;

   function MAKE (M : in MODULE) return MODULE_ITERATOR is
   begin
      return MODULE_ITERATOR (M);
   end MAKE;

end HIERARCHY;
DataMuseum.dk

Rational R1000/400 Tapes

⟦8ceea05bb⟧ TextFile

Derivation

TextFile
