|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 29227 (0x722b)
Types: TextFile
Names: »B«
└─⟦a7d1ea751⟧ Bits:30000550 8mm tape, Rational 1000, !users!projects 94_04_11
└─⟦129cab021⟧ »DATA«
└─⟦bb25a46d4⟧
└─⟦f64eaa120⟧ Bits:30000752 8mm tape, Rational 1000, !projects 93 02 16
└─⟦6f12a12be⟧ »DATA«
└─⟦bb25a46d4⟧
└─⟦2f6cfab89⟧ Bits:30000547 8mm tape, Rational 1000, !projects 94-01-04
└─⟦d65440be7⟧ »DATA«
└─⟦bb25a46d4⟧
└─⟦this⟧
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;