--| --|Item: Ada PCTE Binding --|$Revision: 0.2 $ --|$State: Prototype $ --| --|The Version Description Document (VDD) included with this release provides --|detailed information regarding the condition of the software. The "User --|Feedback" section of the VDD describes how to obtain additional information. --| --|Distribution Statement "A", per DoD Directive 5230.24 --|Authorized for public release; distribution is unlimited. --| --|Copyright (c) 1992, Paramax Systems Corporation, Reston, Virginia --|Copyright is assigned to the U.S. Government, upon delivery thereto, --|in accordance with the DFAR Special Works Clause. --| --|Developed by: Paramax Systems Corporation, --| --|This software, developed under the Software Technology for Adaptable, --|Reliable Systems (STARS) program, is approved for release under --|Distribution "A" of the Scientific and Technical Information Program --|Classification Scheme (DoD Directive 5230.24) unless otherwise indicated. --|Sponsored by the U.S. Defense Advanced Research Projects Agency (DARPA) --|under contract F19628-88-D-0031, the STARS program is supported by the --|military services, SEI, and MITRE, with the U.S. Air Force as the executive --|contracting agent. --| --|Permission to use, copy, modify, and comment on this software and its --|documentation for purposes stated under Distribution "A" and without fee --|is hereby granted, provided that this notice appears in each whole or --|partial copy. This software retains Contractor indemnification to --|the Government regarding copyrights pursuant to the above referenced --|STARS contract. The Government disclaims all responsibility against --|liability, including costs and expenses for violation of proprietary --|rights, or copyrights arising out of the creation or use of this --|software. --| --|In addition, the Government, Paramax, and its subcontractors disclaim all --|warranties with regard to this software, including all implied warranties --|of merchantability and fitness, and in no event shall the Government, --|Paramax, or its subcontractor(s) be liable for any special, indirect or --|consequential damages or any damages whatsoever resulting from the loss of --|use, data, or profits, whether in action of contract, negligence or other --|tortious action, arising in connection with the use or performance of this --|software. --| --|$Log $ --| -- Version Information -- ^^^^^^^^^^^^^^^^^^^ -- -- PCTE - Ada Language Interface. -- Version: 0.2. -- Release Date: November 30, 1992. -- Compiled under SUN OS 4.1.2 using SunAda 1.0 -- -- -- General Information -- ^^^^^^^^^^^^^^^^^^^ -- -- This is an alpha release of the Paramax STARS Ada binding to Emeraude's -- PCTE 1.5 using the ECMA PCTE Ada binding specifications. The binding -- is incomplete in this release. See the Version Description Document -- provided with this alpha release for information on which interfaces -- have been implemented. It is expected that future releases will -- expand the number of interfaces implemented. The interfaces defined -- herein are subject to change. -- -- For further information, contact the authors: -- -- -- Robert Smith -- Paramax Systems Corp. -- Valley Forge Labs -- 70 E. Swedesford Road -- Paoli, PA. 19301 -- smith@prc.unisys.com (current) -- smith@vfl.paramax.com (future) -- +1 215 648-2402 -- -- Michael Horton -- Paramax Systems Corp. -- Valley Forge Labs -- 70 E. Swedesford Road -- Paoli, PA. 19301 -- horton@prc.unisys.com (current) -- horton@vfl.paramax.com (future) -- +1 215 648-2527 -- -- with pcte_1_5_int; with errors_c; with error; with unchecked_deallocation; package body Pcte is --8.2.5 Time package body calendar is function clock return Pcte.calendar.time is dummy : time := DEFAULT_TIME; begin return dummy; -- STUB end clock; function year (date : Pcte.calendar.time) return Pcte.calendar.year_number is dummy : year_number := year_number'last; begin return dummy; -- STUB end year; function month (date : Pcte.calendar.time) return Pcte.calendar.month_number is dummy : month_number := month_number'last; begin return dummy; -- STUB end month; --96- function day (date: Pcte.calendar.time) return Pcte.calendar.day_number is dummy : day_number := day_number'last; begin return dummy; -- STUB end day; function seconds (date : Pcte.calendar.time) return Pcte.calendar.duration is dummy : Pcte.calendar.duration := duration'last; begin return dummy; -- STUB end seconds; function time_of ( year : Pcte.calendar.year_number; month : Pcte.calendar.month_number; day : Pcte.calendar.day_number; seconds : Pcte.calendar.duration := 0.0) return Pcte.calendar.time is dummy : time := DEFAULT_TIME; begin return dummy; -- STUB end time_of; procedure split ( date : in Pcte.calendar.time; year : out Pcte.calendar.year_number; month : out Pcte.calendar.month_number; day : out Pcte.calendar.day_number; seconds : out Pcte.calendar.duration) is begin null; -- STUB end split; function "+" ( left : Pcte.calendar.duration; right : Pcte.calendar.time) return Pcte.calendar.time is dummy : time := DEFAULT_TIME; begin return dummy; -- STUB end "+"; function "+" ( left : Pcte.calendar.time; right : Pcte.calendar.duration) return Pcte.calendar.time is dummy : time := DEFAULT_TIME; begin return dummy; -- STUB end "+"; function "-" ( left : Pcte.calendar.time; right : Pcte.calendar.duration) return Pcte.calendar.time is dummy : time := DEFAULT_TIME; begin return dummy; -- STUB end "-"; function "-" ( left : Pcte.calendar.time; right : Pcte.calendar.time) return Pcte.calendar.duration is dummy : duration := duration'last; begin return dummy; -- STUB end "-"; function "<" ( left : Pcte.calendar.time; right : Pcte.calendar.time) return Pcte.boolean is dummy : boolean := false; begin return dummy; -- STUB end "<"; function "<=" ( left : Pcte.calendar.time; right : Pcte.calendar.time) return Pcte.boolean is dummy : boolean := false; begin return dummy; -- STUB end "<="; function ">" ( left : Pcte.calendar.time; right : Pcte.calendar.time) return Pcte.boolean is dummy : boolean := false; begin return dummy; -- STUB end ">"; --97- function ">=" ( left : Pcte.calendar.time; right : Pcte.calendar.time) return Pcte.boolean is dummy : boolean := false; begin return dummy; -- STUB end ">="; function extend ( date : Pcte.calendar.time) return CALENDAR.TIME is -- Pcte.calendar.extend converts the value of the parameter -- date to the type CALENDAR.TIME. dummy : CALENDAR.TIME := calendar.time'last; begin return dummy; -- STUB end extend; function round ( date : CALENDAR.TIME) return Pcte.calendar.time is -- Pcte.calendar.round converts the value of the parameter -- date to the type Pcte.calendar.time. dummy : Pcte.calendar.time := DEFAULT_TIME; begin return dummy; -- STUB end round; end calendar; -- generic -- type element is limited private; package body sequence is procedure free is new unchecked_deallocation (sequence_info, sequence); procedure free is new unchecked_deallocation (element, element_ptr); function get ( list : Pcte.sequence.sequence; index : Pcte.positive := Pcte.positive'FIRST) return Pcte.sequence.element is -- Pcte.sequence.get returns the element with the given index in the -- given sequence. If the index is greater than the number of elements -- of the sequence, the subprogram returns the last element. begin if list = empty_sequence then raise pcte_error.ERROR_WITH_USAGE; end if; if natural (index) > list.max_index then return list.element_array (list.max_index).all; else return list.element_array (natural (index)).all; end if; end get; procedure put ( list : in out Pcte.sequence.sequence; item : in Pcte.sequence.element; index : in Pcte.positive := Pcte.positive'LAST) is -- Pcte.sequence.put inserts the given element in the given sequence -- immediately before the element with the given index, -- or if the index is greater than the number of elements of the -- sequence, the given element is appended after the last element. new_size : positive; tmp : sequence; tmp_index : Pcte.natural; begin if list = empty_sequence then -- inserting first element into list -- we ignore the index and place at the first position list := new sequence_info(Sequence_Increment_Size); list.max_index := natural (1); list.element_array (natural (1)) := new Pcte.sequence.element'(item); else -- go ahead and insert it if natural (index) > list.max_index then tmp_index := list.max_index + 1; -- insert at end else tmp_index := natural (index); end if; if list.max_index = list.element_array'last then -- extend the list tmp := new sequence_info(list.element_array'length + Sequence_Increment_Size); tmp.max_index := list.max_index + 1; tmp.element_array (1 .. tmp_index - 1) := list.element_array (1 .. tmp_index - 1); tmp.element_array (tmp_index) := new Pcte.sequence.element'(item); tmp.element_array (tmp_index + 1 .. tmp.max_index) := list.element_array (tmp_index .. list.max_index); free (list); -- free the list structure, but not the elements list := tmp; else list.element_array (tmp_index + 1 .. list.max_index + 1) := list.element_array (tmp_index .. list.max_index); list.element_array (tmp_index) := new Pcte.sequence.element'(item); list.max_index := list.max_index + 1; end if; -- max_index = 'last end if; -- list = null end put; procedure delete ( list : in out Pcte.sequence.sequence; index : in Pcte.positive := Pcte.positive'FIRST; count : in Pcte.positive := Pcte.positive'LAST) is -- Pcte.sequence.delete deletes up to the given count elements from -- the element with the given index from the given sequence. -- The number of elements deleted is the lesser of count -- and the number of elements from the element of list with -- the given index to the end. act_count : Pcte.positive; last_index : Pcte.natural; begin if list = empty_sequence then return; end if; if (list.max_index + 1) - natural (index) < natural (count) then last_index := list.max_index; act_count := positive (last_index) - index + 1; else last_index := natural ((index - 1) + count); act_count := count; end if; -- because we have to use pointers to elements we must free them. for i in natural (index) .. last_index loop free (list.element_array (i)); end loop; list.element_array (natural (index) .. list.max_index - natural (act_count)) := list.element_array (last_index + 1 .. list.max_index); -- now try and adjust the max_index list.max_index := list.max_index - natural (act_count); if list.max_index = 0 then free (list); end if; end delete; procedure copy ( into_list : in out Pcte.sequence.sequence; from_list : in Pcte.sequence.sequence; into_index : in Pcte.positive := Pcte.positive'LAST; from_index : in Pcte.positive := Pcte.positive'FIRST; count : in Pcte.positive := Pcte.positive'LAST) is -- Pcte.sequence.copy adds up to the given count elements from the -- element with index from_index of from_list to into_list. -- The elements are inserted immediately before the element -- of into_list with index into_index, or, if into_index is -- greater than the number of elements of into_list, are -- appended to the end of into_list. The number of -- elements added is the lesser of count and the number of -- elements from the element of from_list with index -- from_index to the end. in_start : Pcte.natural; from_end : Pcte.natural; real_count : Pcte.positive; tmp_seq : sequence; begin if from_list = empty_sequence or else natural (from_index) > from_list.max_index then raise pcte_error.ERROR_WITH_USAGE; end if; if natural (into_index) > into_list.max_index then in_start := into_list.max_index + 1; else in_start := natural (into_index); end if; if natural (from_index + count - 1) > from_list.max_index then from_end := from_list.max_index; real_count := positive (from_list.max_index) - from_index + 1; else from_end := natural (from_index + count - 1); real_count := count; end if; -- now do the copy for i in 0 .. real_count - 1 loop put (into_list, from_list.element_array (natural (from_index + i)).all, positive (in_start + natural (i))); end loop; end copy; function length_of ( list : Pcte.sequence.sequence) return Pcte.natural is -- Pcte.sequence.length_of returns the number of elements -- in the given sequence. begin if list = empty_sequence then return 0; end if; return list.max_index; end length_of; function index_of ( list : Pcte.sequence.sequence; item : Pcte.sequence.element) return Pcte.natural is begin if list = empty_sequence then return 0; end if; for i in 1 .. list.max_index loop if list.element_array (i).all = item then return i; end if; end loop; -- if we're here we haven't found it return 0; end index_of; function equal ( left : Pcte.sequence.sequence; right : Pcte.sequence.sequence) return Pcte.boolean is -- Pcte.sequence."=" returns TRUE if the two sequences -- left and right have the same number of elements and -- their corresponding elements are equal, and FALSE otherwise. begin if left = empty_sequence and right = empty_sequence then return true; end if; -- if only one is empty then not equal if left = empty_sequence or right = empty_sequence then return false; end if; -- both are non-empty at this point if left.max_index /= right.max_index then return false; end if; -- now check the elements for i in 1 .. left.max_index loop if left.element_array(i).all /= right.element_array(i).all then return false; end if; end loop; -- if we get here they must be equal return true; end equal; procedure normalize ( list : in out Pcte.sequence.sequence) is -- Pcte.sequence.normalize reorders the elements of -- the given sequence in an implementation-defined canonical -- order, and deletes any duplicate elements. tmp_seq : sequence; begin if list = empty_sequence then return; end if; for i in 1 .. list.max_index loop if index_of (tmp_seq, list.element_array (i).all) = 0 then put (tmp_seq, list.element_array (i).all); end if; end loop; delete (list); -- this should delete everything (free) list := tmp_seq; end normalize; end sequence; package body reference is procedure free is new unchecked_deallocation ( object => pathname, name => pathname_ptr); -- 23.2.1 REFERENCE_COPY procedure copy ( reference : in Pcte.reference.object; to : out Pcte.reference.object; evaluate : in Pcte.reference.evaluation_point; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin null; -- STUB end copy; -- 23.2.2 REFERENCE_GET_EVALUATION_POINT function get_evaluation_point ( reference : Pcte.reference.object; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.reference.evaluation_point is dummy : Pcte.reference.evaluation_point := NOW; begin return dummy; -- STUB end get_evaluation_point; -- 23.2.3 REFERENCE_GET_PATH function get_path ( reference : Pcte.reference.object; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.reference.pathname is -- Note: path_name will contain the trailing ascii.nul since -- its primary use will be to pass along to C. The trailing -- ascii.nul is not returned by get_path. begin if reference.status = INTERNAL then error.process_status_info ( status, pcte_error.OBJECT_REFERENCE_IS_INTERNAL ); -- no errno return ""; end if; error.process_status_info (status, pcte_error.NO_ERROR); return reference.path(reference.path'FIRST .. reference.path'LAST - 1); end get_path; -- 23.2.4 REFERENCE_GET_STATUS function get_status ( reference : Pcte.reference.object; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.reference.evaluation_status is dummy : Pcte.reference.evaluation_status := UNDEFINED; begin return dummy; -- STUB end get_status; -- 23.2.5 REFERENCE.SET_ABSOLUTE procedure set_absolute ( new_reference : out Pcte.reference.object; evaluate : in Pcte.reference.evaluation_point; path : in Pcte.reference.pathname; status : in Pcte_error.handle := EXCEPTION_ONLY) is exist : standard.integer := 0; errno : standard.integer; tmp_ref : pathname_ptr := new pathname'(path & ascii.nul); begin if evaluate = NOW then exist := pcte_1_5_int.obj_access ( tmp_ref(tmp_ref'FIRST)'ADDRESS, pcte_1_5_int.O_EXIST); if exist < 0 then -- we failed to find it errno := errors_c.get_errno; free (tmp_ref); -- if it's bad we don't need it error.process_status_info ( status, pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT, errno); return; end if; -- exist < 0 end if; -- evaluate = NOW error.process_status_info (status, pcte_error.NO_ERROR); new_reference.path := tmp_ref; -- contains ascii.null if evaluate = NOW then new_reference.status := EXTERNAL; else new_reference.status := UNDEFINED; end if; new_reference.eval_pt := evaluate; end set_absolute; -- 23.2.6 REFERENCE.SET_RELATIVE procedure set_relative ( new_reference : out Pcte.reference.object; reference : in Pcte.reference.object; evaluate : in Pcte.reference.evaluation_point; relative_path : in Pcte.reference.pathname; status : in Pcte_error.handle := EXCEPTION_ONLY) is exist : standard.integer := 0; errno : standard.integer; tmp_ref : pathname_ptr; begin if evaluate = NOW or reference.eval_pt = ON_EVERY_USE then -- evaluate the reference path first exist := pcte_1_5_int.obj_access ( reference.path(reference.path'FIRST)'ADDRESS, pcte_1_5_int.O_EXIST); if exist < 0 then -- we failed to find it errno := errors_c.get_errno; error.process_status_info ( status, pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT, errno); return; end if; -- exist < 0 end if; -- evaluate = NOW or ON_EVERY_USE -- build the new pathname tmp_ref := new pathname'(reference.path (reference.path'FIRST .. reference.path'LAST - 1) & "/" & relative_path & ascii.nul); -- check for valid path if required if evaluate = NOW then exist := pcte_1_5_int.obj_access ( tmp_ref(tmp_ref'FIRST)'ADDRESS, pcte_1_5_int.O_EXIST); if exist < 0 then -- we failed to find it errno := errors_c.get_errno; free (tmp_ref); -- if it's bad we don't need it error.process_status_info ( status, pcte_error.PATHNAME_DOES_NOT_DESIGNATE_AN_EXISTING_OBJECT, errno); return; end if; -- exist < 0 end if; -- evaluate = NOW -- haven't died yet so I must have a good pathname new_reference.path := tmp_ref; -- contains ascii.null if evaluate = NOW then new_reference.status := EXTERNAL; else new_reference.status := UNDEFINED; end if; new_reference.eval_pt := evaluate; end set_relative; -- 23.2.7 REFERENCE_UNSET procedure unset ( reference : in out Pcte.reference.object; status : in Pcte_error.handle := EXCEPTION_ONLY) is begin free (reference.path); end unset; -- 23.2.8 REFERENCES_ARE_EQUAL function are_equal ( left_reference : Pcte.reference.object; right_reference : Pcte.reference.object; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.reference.equality is dummy : Pcte.reference.equality := UNEVALUATED; begin return dummy; -- STUB end are_equal; procedure set_reference_id ( reference : in out Pcte.reference.object; id : in Pcte.integer) is begin reference.id := id; end set_reference_id; function get_reference_id (reference : in Pcte.reference.object) return Pcte.integer is begin return reference.id; end get_reference_id; end reference; -- 23.3.1 TYPE_NAME_CONVERT_TO_IDENTIFIER function convert ( name : Pcte.type_name; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.type_identifier is dummy : constant Pcte.type_identifier := ""; begin return dummy; -- STUB end convert; -- 23.3.2 TYPE_IDENTIFIER_CONVERT_TO_NAME function convert ( sds : Pcte.reference.object; identifier : Pcte.type_identifier; status : Pcte_error.handle := EXCEPTION_ONLY) return Pcte.type_name is dummy : constant Pcte.type_name := ""; begin return dummy; -- STUB end convert; end Pcte;