⟦0162277a8⟧

TextFile

with ASA_DEFINITIONS;
with GATEWAY_OBJECT;
with JOB_SEGMENT;
with OBJECT_CLASS;
with SIMPLE_STATUS;
with STRING_UTILITIES;
with SYSTEM;
with TABLE_SORT_GENERIC;
with UNCHECKED_CONVERSION;
package body REQUIREMENTS is

   package ASAP renames ASA_DEFINITIONS.PROPERTIES;
   package DTR renames DIRECTORY.TRAVERSAL;
   package DST renames DIRECTORY.STATISTICS;
   package GWO renames GATEWAY_OBJECT;
   package SS renames SIMPLE_STATUS;


   --                    ---------------------------------------------
   --                    ( ) Declarations for permanent representation
   --                    ---------------------------------------------


   type RECORD_PERMANENT_REPRESENTATION is
      record
         KIND : REQUIREMENT_KIND;
         OBJECT : DIR.OBJECT;
         ID : FUNCTIONAL_REQUIREMENT_NUMBER;
      end record;

   --
   -- It is necessary to use a 31-bit integer internally, because
   -- unchecked conversion to a 30-bit integer may yield -2**31,
   -- which is the uninitialized value, and will raise NUMERIC_ERROR
   -- when read.
   --
   type INTEGER31 is range -2 ** 30 .. 2 ** 30 - 1;  
   for INTEGER31'SIZE use 31;

   pragma ASSERT (RECORD_PERMANENT_REPRESENTATION'SIZE <=
                  PERMANENT_REPRESENTATION'LENGTH * INTEGER31'SIZE);

   type INTEGER31_PERMANENT_REPRESENTATION is
      array (PERMANENT_REPRESENTATION'RANGE) of INTEGER31;

   function TO_RECORD is new UNCHECKED_CONVERSION
                                (SOURCE => INTEGER31_PERMANENT_REPRESENTATION,
                                 TARGET => RECORD_PERMANENT_REPRESENTATION);

   function FROM_RECORD is
      new UNCHECKED_CONVERSION (SOURCE => RECORD_PERMANENT_REPRESENTATION,
                                TARGET => INTEGER31_PERMANENT_REPRESENTATION);


   --                    ------------------
   --                    ( ) Error handling
   --                    ------------------


   function DIAGNOSIS (ERROR : in STATUS) return STRING is
   begin
      case ERROR.KIND is

         when MODULE_ID_ERROR =>
            return "the specified requirement id could not be found";

         when DIRECTORY_ERROR =>
            return STRING_UTILITIES.LOWER_CASE
                      (DIR.ERROR_STATUS'IMAGE (ERROR.ERROR_STATUS));

         when DIRECTORY_NAMING_ERROR =>
            return STRING_UTILITIES.LOWER_CASE
                      (DNA.NAME_STATUS'IMAGE (ERROR.NAME_STATUS));

         when GENERAL_ERROR =>
            return SS.DISPLAY_MESSAGE (ERROR.CONDITION);
      end case;
   end DIAGNOSIS;


   function MODULE_ID_ERROR return REQUIREMENT is
   begin
      return (KIND => NOT_A_REQUIREMENT,
              ERROR => (KIND => STATUS_KIND'(MODULE_ID_ERROR)));
   end MODULE_ID_ERROR;

   function DIRECTORY_ERROR (E : in DIR.ERROR_STATUS) return REQUIREMENT is
   begin
      return (KIND => NOT_A_REQUIREMENT,
              ERROR => (KIND => DIRECTORY_ERROR, ERROR_STATUS => E));
   end DIRECTORY_ERROR;

   function DIRECTORY_ERROR (E : in DIR.ERROR_STATUS) return DEPENDENTS is
   begin
      return (IS_BAD => TRUE,
              ERROR => (KIND => DIRECTORY_ERROR, ERROR_STATUS => E));
   end DIRECTORY_ERROR;

   function DIRECTORY_NAMING_ERROR
               (N : in DNA.NAME_STATUS) return REQUIREMENT is
   begin
      return (KIND => NOT_A_REQUIREMENT,
              ERROR => (KIND => DIRECTORY_NAMING_ERROR, NAME_STATUS => N));
   end DIRECTORY_NAMING_ERROR;

   function DIRECTORY_NAMING_ERROR (N : in DNA.NAME_STATUS) return DEPENDENTS is
   begin
      return (IS_BAD => TRUE,
              ERROR => (KIND => DIRECTORY_NAMING_ERROR, NAME_STATUS => N));
   end DIRECTORY_NAMING_ERROR;

   function GENERAL_ERROR (S : in SS.CONDITION) return REQUIREMENT is
   begin
      return (KIND => NOT_A_REQUIREMENT,
              ERROR => (KIND => GENERAL_ERROR, CONDITION => S));
   end GENERAL_ERROR;

   function GENERAL_ERROR (S : in SS.CONDITION) return DEPENDENTS is
   begin
      return (IS_BAD => TRUE, ERROR => (KIND => GENERAL_ERROR, CONDITION => S));
   end GENERAL_ERROR;


   --                    -------------
   --                    ( ) Utilities
   --                    -------------


   function NAME (OBJECTS : in OBJECT_LIST; BEFORE : in STRING) return STRING is
   begin
      if OBJECTS'FIRST > OBJECTS'LAST then
         return BEFORE;
      elsif BEFORE = "" then
         return NAME (OBJECTS => OBJECTS (OBJECTS'FIRST + 1 .. OBJECTS'LAST),
                      BEFORE => DNA.GET_FULL_NAME (OBJECTS (OBJECTS'FIRST)));
      else
         return NAME (OBJECTS => OBJECTS (OBJECTS'FIRST + 1 .. OBJECTS'LAST),
                      BEFORE => BEFORE & ',' & DNA.GET_FULL_NAME
                                                  (OBJECTS (OBJECTS'FIRST)));
      end if;
   end NAME;

   procedure SEARCH_BY_ID (ROOT : in DIR.OBJECT;
                           ID : in POSITIVE;
                           ACTION_ID : in ACTION.ID;
                           FOUND : out BOOLEAN;
                           OBJECT : out DIR.OBJECT) is
      E : DIR.ERROR_STATUS;
      FOUND_IN_SUBOBJECT : BOOLEAN;
      OBJECT_IN_SUBOBJECT : DIR.OBJECT;
      GATEWAY : GWO.HANDLE;
      N : DNA.NAME_STATUS;  
      S : SS.CONDITION;  
      SUBOBJECT : DIR.OBJECT;
      SUBOBJECTS : DNA.ITERATOR;
      use DIR;
      use DNA;
   begin
      GWO.OPEN_MAIN_OBJECT (OBJECT => ROOT,  
                            H => GATEWAY,
                            UPDATE => FALSE,
                            ERRORS => S);
      if SS.ERROR (S) then
         FOUND := FALSE;
         OBJECT := DIR.NIL;
         return;
      end if;

      if ASAP.ASA_ID (GATEWAY) = ID then
         GWO.CLOSE (GATEWAY);
         FOUND := TRUE;
         OBJECT := ROOT;
         return;
      else
         GWO.CLOSE (GATEWAY);

         DNA.RESOLVE (ITER => SUBOBJECTS,
                      SOURCE => DNA.GET_FULL_NAME (ROOT) & ".@'C(~TEXT)",
                      STATUS => N,
                      ACTION_ID => ACTION_ID);
         if N = DNA.SUCCESSFUL then
            while not DNA.DONE (SUBOBJECTS) loop
               DNA.GET_OBJECT (ITER => SUBOBJECTS,  
                               THE_OBJECT => SUBOBJECT,
                               STATUS => E);
               if E /= DIR.SUCCESSFUL then
                  FOUND := FALSE;
                  OBJECT := DIR.NIL;
                  return;
               end if;

               SEARCH_BY_ID (ROOT => SUBOBJECT,
                             ID => ID,
                             ACTION_ID => ACTION_ID,
                             FOUND => FOUND_IN_SUBOBJECT,
                             OBJECT => OBJECT_IN_SUBOBJECT);
               if FOUND_IN_SUBOBJECT then
                  FOUND := FOUND_IN_SUBOBJECT;
                  OBJECT := OBJECT_IN_SUBOBJECT;
                  return;
               end if;
               DNA.NEXT (SUBOBJECTS);
            end loop;
         end if;
         FOUND := FALSE;
         OBJECT := DIR.NIL;
      end if;
   end SEARCH_BY_ID;


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


   --                    -----------------------------
   --                    ( . ) Individual requirements
   --                    -----------------------------


   function RESOLVE (MODEL_GATEWAY_NAME : in STRING;
                     MODULE_ID : in POSITIVE;  
                     REQUIREMENT_ID : in REQUIREMENT_NUMBER;
                     ACTION_ID : in ACTION.ID) return REQUIREMENT is
      E : DIR.ERROR_STATUS;
      FOUND : BOOLEAN;
      GATEWAY : GWO.HANDLE;
      N : DNA.NAME_STATUS;  
      S : SS.CONDITION;  
      THE_MODULE : DIR.OBJECT;
      THE_OBJECT : DIR.OBJECT;  
      THE_REQUIREMENT : DIR.OBJECT;
      THE_REQUIREMENTS : DNA.ITERATOR;
      use ASA_DEFINITIONS;
      use DIR;
      use DNA;
   begin
      DNA.RESOLVE (NAME => MODEL_GATEWAY_NAME,
                   THE_OBJECT => THE_OBJECT,
                   STATUS => N);
      if N /= DNA.SUCCESSFUL then  
         return DIRECTORY_NAMING_ERROR (N);
      end if;

      SEARCH_BY_ID (ROOT => THE_OBJECT,
                    ID => MODULE_ID,
                    ACTION_ID => ACTION_ID,
                    FOUND => FOUND,
                    OBJECT => THE_MODULE);

      if FOUND then
         case REQUIREMENT_ID is

            when FUNCTIONAL_REQUIREMENT_NUMBER =>
               return (KIND => FUNCTIONAL,
                       ACTION_ID => ACTION_ID,
                       OBJECT => THE_MODULE,
                       ID => REQUIREMENT_ID);

            when NON_FUNCTIONAL_REQUIREMENT_NUMBER =>
               DNA.RESOLVE (ITER => THE_REQUIREMENTS,
                            SOURCE => DNA.GET_FULL_NAME (THE_MODULE) &
                                         ".@'C(TEXT)",
                            STATUS => N,
                            ACTION_ID => ACTION_ID);
               if N = DNA.SUCCESSFUL then

                  while not DNA.DONE (THE_REQUIREMENTS) loop
                     DNA.GET_OBJECT (ITER => THE_REQUIREMENTS,  
                                     THE_OBJECT => THE_REQUIREMENT,
                                     STATUS => E);
                     if E /= DIR.SUCCESSFUL then
                        return DIRECTORY_ERROR (E);
                     end if;

                     GWO.OPEN_MAIN_OBJECT (OBJECT => THE_REQUIREMENT,  
                                           H => GATEWAY,
                                           UPDATE => FALSE,
                                           ERRORS => S);
                     if SS.ERROR (S) then
                        return GENERAL_ERROR (S);
                     end if;

                     if REQUIREMENT_NUMBER (ASAP.ASA_ID (GATEWAY)) =
                        REQUIREMENT_ID then

                        declare
                           RESULT : REQUIREMENT
                                       (ASAP.ASA_REQUIREMENT_KIND (GATEWAY));
                        begin
                           RESULT.ACTION_ID := ACTION_ID;
                           RESULT.OBJECT := THE_REQUIREMENT;
                           GWO.CLOSE (GATEWAY);
                           return RESULT;
                        end;
                     end if;

                     GWO.CLOSE (GATEWAY);
                     DNA.NEXT (THE_REQUIREMENTS);
                  end loop;
               else
                  return DIRECTORY_NAMING_ERROR (N);
               end if;
         end case;
      else
         return MODULE_ID_ERROR;
      end if;
   end RESOLVE;

   function COMMENT (ASA_GATEWAY_NAME : in STRING;  
                     ACTION_ID : in ACTION.ID) return STRING is
      GATEWAY : GWO.HANDLE;
      GATEWAY_OBJECT : DIR.OBJECT;
      S : SS.CONDITION;
   begin
      GWO.OPEN_MAIN_OBJECT (OBJECT => ASA_GATEWAY_NAME,
                            H => GATEWAY,
                            UPDATE => FALSE,
                            ACTION_ID => ACTION_ID,
                            ERRORS => S);  
      if SS.ERROR (S) then
         return "";
      end if;

      declare
         COMMENT : constant STRING := ASAP.ASA_COMMENT (GATEWAY);
      begin
         if COMMENT = "" then
            GATEWAY_OBJECT := GWO.DIRECTORY_OBJECT (GATEWAY);
            GWO.CLOSE (GATEWAY);
            return DNA.GET_SIMPLE_NAME (GATEWAY_OBJECT);
         else
            GWO.CLOSE (GATEWAY);
            return COMMENT;
         end if;
      end;

   end COMMENT;

   function DIAGNOSIS (REQ : in REQUIREMENT) return STRING is
   begin
      case REQ.KIND is

         when NOT_A_REQUIREMENT =>
            return DIAGNOSIS (REQ.ERROR);

         when FUNCTIONAL | NON_FUNCTIONAL =>
            return "";
      end case;
   end DIAGNOSIS;

   function GATEWAY_FULL_NAME (REQ : in REQUIREMENT) return STRING is
   begin
      return DNA.GET_FULL_NAME (REQ.OBJECT);
   end GATEWAY_FULL_NAME;

   function UNIQUE_ID (REQ : in REQUIREMENT) return STRING is
      DATA : DST.OBJECT_DATA;
      E : DIR.ERROR_STATUS;
      GATEWAY : GWO.HANDLE;
      ID : POSITIVE;
      MODULE_ID : POSITIVE;
      S : SS.CONDITION;
      use DIR;
   begin
      case REQ.KIND is

         when NOT_A_REQUIREMENT =>
            raise REQUIREMENT_ERROR;

         when FUNCTIONAL =>

            GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,  
                                  H => GATEWAY,
                                  UPDATE => FALSE,
                                  ACTION_ID => REQ.ACTION_ID,
                                  ERRORS => S);
            if SS.ERROR (S) then
               raise REQUIREMENT_ERROR;
            end if;

            MODULE_ID := ASAP.ASA_ID (GATEWAY);
            GWO.CLOSE (GATEWAY);

            declare
               MODULE_ID_IMAGE : constant STRING := POSITIVE'IMAGE (MODULE_ID);  
               ID_IMAGE : constant STRING :=
                  FUNCTIONAL_REQUIREMENT_NUMBER'IMAGE (REQ.ID);  
            begin
               return MODULE_ID_IMAGE (MODULE_ID_IMAGE'FIRST + 1 ..
                                          MODULE_ID_IMAGE'LAST) & '.' &
                      ID_IMAGE (ID_IMAGE'FIRST + 1 .. ID_IMAGE'LAST);
            end;

         when NON_FUNCTIONAL =>
            DST.GET_OBJECT_DATA (THE_OBJECT => REQ.OBJECT,  
                                 THE_DATA => DATA,
                                 ACTION_ID => REQ.ACTION_ID,
                                 STATUS => E);
            if E /= DIR.SUCCESSFUL then
               raise REQUIREMENT_ERROR;
            end if;
            GWO.OPEN_MAIN_OBJECT (OBJECT => DST.OBJECT_PARENT (DATA),  
                                  H => GATEWAY,
                                  UPDATE => FALSE,
                                  ACTION_ID => REQ.ACTION_ID,
                                  ERRORS => S);
            if SS.ERROR (S) then
               raise REQUIREMENT_ERROR;
            end if;

            MODULE_ID := ASAP.ASA_ID (GATEWAY);
            GWO.CLOSE (GATEWAY);

            GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,  
                                  H => GATEWAY,
                                  UPDATE => FALSE,
                                  ACTION_ID => REQ.ACTION_ID,
                                  ERRORS => S);
            if SS.ERROR (S) then
               raise REQUIREMENT_ERROR;
            end if;

            ID := ASAP.ASA_ID (GATEWAY);
            GWO.CLOSE (GATEWAY);

            declare
               MODULE_ID_IMAGE : constant STRING := POSITIVE'IMAGE (MODULE_ID);  
               ID_IMAGE : constant STRING := POSITIVE'IMAGE (ID);  
            begin
               return MODULE_ID_IMAGE (MODULE_ID_IMAGE'FIRST + 1 ..
                                          MODULE_ID_IMAGE'LAST) & '.' &
                      ID_IMAGE (ID_IMAGE'FIRST + 1 .. ID_IMAGE'LAST);
            end;

      end case;
   end UNIQUE_ID;

   function TEXT (REQ : in REQUIREMENT) return STRING is
      GATEWAY : GWO.HANDLE;
      S : SS.CONDITION;
   begin
      GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,  
                            H => GATEWAY,
                            UPDATE => FALSE,
                            ACTION_ID => REQ.ACTION_ID,
                            ERRORS => S);
      if SS.ERROR (S) then
         raise REQUIREMENT_ERROR;
      end if;  
      case REQ.KIND is

         when NOT_A_REQUIREMENT =>
            raise REQUIREMENT_ERROR;

         when FUNCTIONAL =>

            declare
               THE_TEXT : constant STRING :=
                  ASAP.ASA_REQUIREMENT (GATEWAY, NUMBER => REQ.ID);
            begin
               GWO.CLOSE (GATEWAY);
               return THE_TEXT;
            end;

         when NON_FUNCTIONAL =>

            declare
               THE_TEXT : constant STRING :=
                  ASAP.ASA_REQUIREMENT_TEXT (GATEWAY);
            begin
               GWO.CLOSE (GATEWAY);
               return THE_TEXT;
            end;

      end case;
   end TEXT;

   function CONVERT (REQ : in REQUIREMENT) return PERMANENT_REPRESENTATION is
      IREP : INTEGER31_PERMANENT_REPRESENTATION := (others => 0);
      REP : PERMANENT_REPRESENTATION;
   begin
      case REQ.KIND is

         when NOT_A_REQUIREMENT =>
            raise REQUIREMENT_ERROR;

         when FUNCTIONAL =>
            IREP := FROM_RECORD
                       ((KIND => REQ.KIND, OBJECT => REQ.OBJECT, ID => REQ.ID));

         when NON_FUNCTIONAL =>
            IREP := FROM_RECORD
                       ((KIND => REQ.KIND, OBJECT => REQ.OBJECT, ID => 1));
      end case;
      for I in REP'RANGE loop
         REP (I) := INTEGER (IREP (I));
      end loop;
      return REP;
   end CONVERT;

   function CONVERT (REP : in PERMANENT_REPRESENTATION;
                     ACTION_ID : in ACTION.ID) return REQUIREMENT is
      IREP : INTEGER31_PERMANENT_REPRESENTATION;
      RREP : RECORD_PERMANENT_REPRESENTATION;
   begin  
      for I in REP'RANGE loop
         IREP (I) := INTEGER31 (REP (I));
      end loop;

      RREP := TO_RECORD (IREP);

      declare
         RESULT : REQUIREMENT (RREP.KIND);
      begin
         case RESULT.KIND is

            when NOT_A_REQUIREMENT =>
               raise REQUIREMENT_ERROR;

            when FUNCTIONAL =>
               RESULT.ACTION_ID := ACTION_ID;
               RESULT.OBJECT := RREP.OBJECT;
               RESULT.ID := RREP.ID;

            when NON_FUNCTIONAL =>
               RESULT.ACTION_ID := ACTION_ID;
               RESULT.OBJECT := RREP.OBJECT;
         end case;
         return RESULT;
      end;

   end CONVERT;


   --                    ----------------------------
   --                    ( . ) Requirements hierarchy
   --                    ----------------------------


   function RESOLVE (ASA_GATEWAY_NAME : in STRING;  
                     KIND : in REQUIREMENT_KIND;
                     ACTION_ID : ACTION.ID) return REQUIREMENT_ITERATOR is

      type OBJECT_AND_ID is
         record
            OBJECT : DIR.OBJECT;
            ID : POSITIVE;
         end record;

      type OBJECTS_AND_IDS is array (COUNT range <>) of OBJECT_AND_ID;

      E : DIR.ERROR_STATUS;
      GATEWAY : GWO.HANDLE;
      GATEWAY_OBJECT : DIR.OBJECT;
      GATEWAY_OBJECTS : DNA.ITERATOR;
      N : DNA.NAME_STATUS;  
      RESULT : REQUIREMENT_ITERATOR;
      S : SS.CONDITION;
      SIZE : COUNT := 0;
      THE_OBJECTS : OBJECTS_AND_IDS (COUNT range 1 .. COUNT'LAST);

      function "<" (LEFT : in OBJECT_AND_ID; RIGHT : in OBJECT_AND_ID)
                   return BOOLEAN is
      begin
         return LEFT.ID < RIGHT.ID;
      end "<";

      procedure SORT_BY_ID is
         new TABLE_SORT_GENERIC (ELEMENT => OBJECT_AND_ID,
                                 INDEX => COUNT,
                                 ELEMENT_ARRAY => OBJECTS_AND_IDS);

      use DIR;
      use DNA;
   begin
      case KIND is

         when NOT_A_REQUIREMENT =>
            raise REQUIREMENT_ERROR;

         when FUNCTIONAL =>
            DNA.RESOLVE (NAME => ASA_GATEWAY_NAME,
                         THE_OBJECT => GATEWAY_OBJECT,
                         STATUS => N,
                         ACTION_ID => ACTION_ID);
            if N /= DNA.SUCCESSFUL then
               raise REQUIREMENT_ERROR;
            end if;  
            GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_OBJECT,  
                                  H => GATEWAY,
                                  UPDATE => FALSE,
                                  ACTION_ID => ACTION_ID,
                                  ERRORS => S);
            if SS.ERROR (S) then
               raise REQUIREMENT_ERROR;
            end if;
            for R in reverse FUNCTIONAL_REQUIREMENT_NUMBER loop
               if ASAP.ASA_REQUIREMENT (GATEWAY, NUMBER => R) /= "" then
                  SIZE := COUNT (R);
                  exit;  
               end if;
            end loop;  
            GWO.CLOSE (GATEWAY);  
            RESULT := (SIZE => SIZE,
                       POS => 1,
                       CONTENTS => (others => (KIND => FUNCTIONAL,
                                               ACTION_ID => ACTION_ID,
                                               OBJECT => GATEWAY_OBJECT,
                                               ID => 1)));
            for I in RESULT.CONTENTS'RANGE loop
               RESULT.CONTENTS (I).ID := FUNCTIONAL_REQUIREMENT_NUMBER (I);
            end loop;  
            return RESULT;

         when NON_FUNCTIONAL =>
            DNA.RESOLVE (SOURCE => ASA_GATEWAY_NAME & ".@'C(Text)",
                         ITER => GATEWAY_OBJECTS,
                         STATUS => N,
                         ACTION_ID => ACTION_ID);
            if N /= DNA.UNDEFINED then
               if N /= DNA.SUCCESSFUL then
                  raise REQUIREMENT_ERROR;
               end if;
               while not DNA.DONE (GATEWAY_OBJECTS) loop
                  DNA.GET_OBJECT (ITER => GATEWAY_OBJECTS,
                                  THE_OBJECT => GATEWAY_OBJECT,
                                  STATUS => E);
                  if E /= DIR.SUCCESSFUL then
                     raise REQUIREMENT_ERROR;
                  end if;  
                  GWO.OPEN_MAIN_OBJECT (OBJECT => GATEWAY_OBJECT,  
                                        H => GATEWAY,
                                        UPDATE => FALSE,
                                        ACTION_ID => ACTION_ID,
                                        ERRORS => S);
                  if SS.ERROR (S) then
                     raise REQUIREMENT_ERROR;
                  end if;
                  if ASAP.ASA_REQUIREMENT_KIND (GATEWAY) = KIND then
                     SIZE := SIZE + 1;
                     THE_OBJECTS (SIZE) := (OBJECT => GATEWAY_OBJECT,
                                            ID => ASAP.ASA_ID (GATEWAY));
                  end if;
                  GWO.CLOSE (GATEWAY);
                  DNA.NEXT (GATEWAY_OBJECTS);
               end loop;
            end if;

            SORT_BY_ID (THE_OBJECTS (THE_OBJECTS'FIRST .. SIZE));

            declare
               NULL_REQUIREMENT : REQUIREMENT (KIND);
            begin  
               NULL_REQUIREMENT.ACTION_ID := ACTION_ID;
               NULL_REQUIREMENT.OBJECT := DIR.NIL;
               RESULT := (SIZE => SIZE,
                          POS => 1,
                          CONTENTS => (others => NULL_REQUIREMENT));
            end;

            for I in RESULT.CONTENTS'RANGE loop
               RESULT.CONTENTS (I).OBJECT := THE_OBJECTS (I).OBJECT;
            end loop;  
            return RESULT;
      end case;
   end RESOLVE;

   function VALUE (REQS : in REQUIREMENT_ITERATOR) return REQUIREMENT is
   begin  
      return REQS.CONTENTS (REQS.POS);
   end VALUE;

   function DONE (REQS : in REQUIREMENT_ITERATOR) return BOOLEAN is
   begin
      return REQS.POS > REQS.SIZE;
   end DONE;

   procedure NEXT (REQS : in out REQUIREMENT_ITERATOR) is
   begin
      REQS.POS := REQS.POS + 1;
   end NEXT;

   procedure ADD (REQ : in REQUIREMENT; REQS : in out REQUIREMENT_ITERATOR) is
      RESULT : REQUIREMENT_ITERATOR (REQS.SIZE + 1);
   begin
      RESULT.POS := REQS.POS;
      RESULT.CONTENTS := REQS.CONTENTS & REQ;
      REQS := RESULT;
   end ADD;

   procedure REMOVE (REQ : in REQUIREMENT;
                     REQS : in out REQUIREMENT_ITERATOR) is
      RESULT : REQUIREMENT_ITERATOR (REQS.SIZE - 1);
   begin
      for I in REQS.CONTENTS'RANGE loop
         if REQS.CONTENTS (I) = REQ then
            RESULT.CONTENTS := REQS.CONTENTS (1 .. I - 1) &
                                  REQS.CONTENTS (I + 1 .. REQS.SIZE);
         end if;
      end loop;
      REQS := RESULT;
   end REMOVE;


   --                    ----------------
   --                    ( ) Dependencies
   --                    ----------------


   function GET_DEPENDENTS (REQ : in REQUIREMENT) return DEPENDENTS is
      DEPENDENT_OBJECTS : DNA.ITERATOR;
      E : DIR.ERROR_STATUS;
      GATEWAY : GWO.HANDLE;  
      N : DNA.NAME_STATUS;
      S : SS.CONDITION;
      SIZE : COUNT := 0;
      THE_OBJECTS : OBJECT_LIST (COUNT);

      function ASA_DEPENDENTS (REQ : in REQUIREMENT) return STRING is
      begin
         case REQ.KIND is

            when NOT_A_REQUIREMENT =>
               raise REQUIREMENT_ERROR;

            when FUNCTIONAL =>
               return ASAP.ASA_DEPENDENTS (GATEWAY, NUMBER => REQ.ID);

            when NON_FUNCTIONAL =>
               return ASAP.ASA_DEPENDENTS (GATEWAY);
         end case;
      end ASA_DEPENDENTS;

      use DIR;
      use DNA;
   begin
      GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,  
                            H => GATEWAY,
                            UPDATE => FALSE,
                            ACTION_ID => REQ.ACTION_ID,
                            ERRORS => S);
      if SS.ERROR (S) then
         return GENERAL_ERROR (S);
      end if;

      declare
         THE_DEPENDENTS : constant STRING := ASA_DEPENDENTS (REQ);
      begin

         GWO.CLOSE (GATEWAY, S);
         if SS.ERROR (S) then
            return GENERAL_ERROR (S);
         end if;

         if THE_DEPENDENTS = "" then
            return (IS_BAD => FALSE,
                    OBJECTS => new OBJECT_LIST'(1 .. 0 => DIR.NIL));
            pragma HEAP (JOB_SEGMENT.GET);
         end if;

         DNA.RESOLVE (ITER => DEPENDENT_OBJECTS,
                      SOURCE => '[' & THE_DEPENDENTS & "]'S(Installed,Coded)",
                      STATUS => N,
                      OBJECTS_ONLY => FALSE,
                      ACTION_ID => REQ.ACTION_ID);
      end;

      if N = DNA.UNDEFINED then
         return (IS_BAD => FALSE,
                 OBJECTS => new OBJECT_LIST'(1 .. 0 => DIR.NIL));
         pragma HEAP (JOB_SEGMENT.GET);
      elsif N /= DNA.SUCCESSFUL then
         return DIRECTORY_NAMING_ERROR (N);
      end if;

      while not DNA.DONE (DEPENDENT_OBJECTS) loop
         SIZE := SIZE + 1;  
         DNA.GET_OBJECT (ITER => DEPENDENT_OBJECTS,
                         THE_OBJECT => THE_OBJECTS (SIZE),
                         STATUS => E);
         if E /= DIR.SUCCESSFUL then
            return DIRECTORY_ERROR (E);
         end if;
         DNA.NEXT (DEPENDENT_OBJECTS);
      end loop;

      return (IS_BAD => FALSE,
              OBJECTS => new OBJECT_LIST'(THE_OBJECTS (1 .. SIZE)));
      pragma HEAP (JOB_SEGMENT.GET);
   end GET_DEPENDENTS;

   procedure SET_DEPENDENTS (REQ : in REQUIREMENT;  
                             DEP : in DEPENDENTS) is
      DEPENDENT_OBJECTS : DNA.ITERATOR;
      GATEWAY : GWO.HANDLE;
      S : SS.CONDITION;
      SIZE : COUNT := 0;
      THE_OBJECTS : OBJECT_LIST (COUNT);
   begin
      if DEP.IS_BAD then
         raise DEPENDENT_ERROR;
      end if;
      GWO.OPEN_MAIN_OBJECT (OBJECT => REQ.OBJECT,  
                            H => GATEWAY,
                            UPDATE => FALSE,
                            ACTION_ID => REQ.ACTION_ID,
                            ERRORS => S);
      if SS.ERROR (S) then
         raise REQUIREMENT_ERROR;
      end if;

      case REQ.KIND is

         when NOT_A_REQUIREMENT =>
            raise REQUIREMENT_ERROR;

         when FUNCTIONAL =>
            ASAP.SET_ASA_DEPENDENTS
               (GATEWAY,
                NUMBER => REQ.ID,
                VALUE => NAME (OBJECTS => DEP.OBJECTS.all, BEFORE => ""));

         when NON_FUNCTIONAL =>
            ASAP.SET_ASA_DEPENDENTS
               (GATEWAY,
                VALUE => NAME (OBJECTS => DEP.OBJECTS.all, BEFORE => ""));
      end case;

      GWO.CLOSE (GATEWAY);
   end SET_DEPENDENTS;

   procedure ADD (DEP : in out DEPENDENTS;  
                  ONTO : in STRING) is
      N : DNA.NAME_STATUS;
      THE_OBJECT : DIR.OBJECT;
      use DNA;
   begin
      if DEP.IS_BAD then
         raise DEPENDENT_ERROR;
      end if;
      DNA.RESOLVE (NAME => ONTO,
                   THE_OBJECT => THE_OBJECT,
                   STATUS => N,
                   ACTION_ID => ACTION.NULL_ID);
      DEP := (IS_BAD => FALSE,
              OBJECTS => new OBJECT_LIST'(DEP.OBJECTS.all & THE_OBJECT));
      pragma HEAP (JOB_SEGMENT.GET);
   end ADD;

   procedure REMOVE (DEP : in out DEPENDENTS;  
                     ONTO : in STRING) is
      N : DNA.NAME_STATUS;
      THE_OBJECT : DIR.OBJECT;
      use DIR;
   begin
      if DEP.IS_BAD then
         raise DEPENDENT_ERROR;
      end if;
      DNA.RESOLVE (NAME => ONTO,
                   THE_OBJECT => THE_OBJECT,
                   STATUS => N,
                   ACTION_ID => ACTION.NULL_ID);
      for I in DEP.OBJECTS'RANGE loop
         if THE_OBJECT = DEP.OBJECTS (I) then

            DEP := (IS_BAD => FALSE,
                    OBJECTS => new
                                  OBJECT_LIST'
                                     (DEP.OBJECTS (DEP.OBJECTS'FIRST .. I - 1) &
                                      DEP.OBJECTS (I + 1 .. DEP.OBJECTS'LAST)));
            pragma HEAP (JOB_SEGMENT.GET);

         end if;
      end loop;
   end REMOVE;

   function DIAGNOSIS (DEP : in DEPENDENTS) return STRING is
   begin
      case DEP.IS_BAD is

         when FALSE =>
            return "";

         when TRUE =>
            return DIAGNOSIS (DEP.ERROR);
      end case;
   end DIAGNOSIS;

end REQUIREMENTS;
DataMuseum.dk

Rational R1000/400 Tapes

⟦0162277a8⟧ TextFile

Derivation

TextFile
