diff options
56 files changed, 46 insertions, 19684 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index deed861a34c..488e7595aed 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,34 @@ 2014-07-31 Robert Dewar <dewar@adacore.com> + * sem_ch3.adb, sem_ch13.adb: Minor reformatting. + +2014-07-31 Arnaud Charlet <charlet@adacore.com> + + * a-intnam-linux.ads: Minor: update obsolete comments. + * s-taasde.adb: Minor: fix comment header. + +2014-07-31 Arnaud Charlet <charlet@adacore.com> + + * s-auxdec-vms-ia64.adb, s-parame-vms-alpha.ads, s-asthan-vms-alpha.adb, + s-tpopde-vms.adb, s-mastop-vms.adb, s-tpopde-vms.ads, s-taprop-vms.adb, + mlib-tgt-vms_common.adb, mlib-tgt-vms_common.ads, s-inmaop-vms.adb, + g-enblsp-vms-alpha.adb, s-ransee-vms.adb, s-osprim-vms.adb, + s-osprim-vms.ads, g-socthi-vms.adb, g-socthi-vms.ads, system-vms_64.ads, + s-osinte-vms.adb, s-osinte-vms.ads, g-eacodu-vms.adb, + s-vaflop-vms-alpha.adb, s-parame-vms-ia64.ads, a-dirval-vms.adb, + a-caldel-vms.adb, mlib-tgt-specific-vms-alpha.adb, s-tasdeb-vms.adb, + symbols-vms.adb, a-intnam-vms.ads, g-expect-vms.adb, + symbols-processing-vms-alpha.adb, mlib-tgt-specific-vms-ia64.adb, + s-traent-vms.adb, s-traent-vms.ads, i-cstrea-vms.adb, a-numaux-vms.ads, + symbols-processing-vms-ia64.adb, s-interr-vms.adb, s-memory-vms_64.adb, + s-memory-vms_64.ads, g-enblsp-vms-ia64.adb, s-taspri-vms.ads, + s-auxdec-vms_64.ads, s-intman-vms.adb, s-intman-vms.ads, + s-tpopsp-vms.adb, s-asthan-vms-ia64.adb, a-calend-vms.adb, + a-calend-vms.ads, system-vms-ia64.ads, s-auxdec-vms-alpha.adb: Removed. + * namet.h (Is_Non_Ada_Error): Remove. + +2014-07-31 Robert Dewar <dewar@adacore.com> + * exp_util.adb, lib-writ.adb, sem_ch12.adb, s-direio.adb: Minor reformatting. diff --git a/gcc/ada/a-caldel-vms.adb b/gcc/ada/a-caldel-vms.adb deleted file mode 100644 index 1cf6f00d974..00000000000 --- a/gcc/ada/a-caldel-vms.adb +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . C A L E N D A R . D E L A Y S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version - -with System.OS_Primitives; -with System.Soft_Links; - -package body Ada.Calendar.Delays is - - package OSP renames System.OS_Primitives; - package TSL renames System.Soft_Links; - - use type TSL.Timed_Delay_Call; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Timed_Delay_NT (Time : Duration; Mode : Integer); - -- Timed delay procedure used when no tasking is active - - --------------- - -- Delay_For -- - --------------- - - procedure Delay_For (D : Duration) is - begin - TSL.Timed_Delay.all - (Duration'Min (D, OSP.Max_Sensible_Delay), OSP.Relative); - end Delay_For; - - ----------------- - -- Delay_Until -- - ----------------- - - procedure Delay_Until (T : Time) is - begin - TSL.Timed_Delay.all (To_Duration (T), OSP.Absolute_Calendar); - end Delay_Until; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - Safe_Ada_High : constant Time := Time_Of (2250, 1, 1, 0.0); - -- A value distant enough to emulate "end of time" but which does not - -- cause overflow. - - Safe_T : constant Time := - (if T > Safe_Ada_High then Safe_Ada_High else T); - - begin - return OSP.To_Duration (OSP.OS_Time (Safe_T), OSP.Absolute_Calendar); - end To_Duration; - - -------------------- - -- Timed_Delay_NT -- - -------------------- - - procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is - begin - OSP.Timed_Delay (Time, Mode); - end Timed_Delay_NT; - -begin - -- Set up the Timed_Delay soft link to the non tasking version if it has - -- not been already set. If tasking is present, Timed_Delay has already set - -- this soft link, or this will be overridden during the elaboration of - -- System.Tasking.Initialization - - if TSL.Timed_Delay = null then - TSL.Timed_Delay := Timed_Delay_NT'Access; - end if; -end Ada.Calendar.Delays; diff --git a/gcc/ada/a-calend-vms.adb b/gcc/ada/a-calend-vms.adb deleted file mode 100644 index bb878cbfe45..00000000000 --- a/gcc/ada/a-calend-vms.adb +++ /dev/null @@ -1,1317 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version - -with Ada.Unchecked_Conversion; - -with System.Aux_DEC; use System.Aux_DEC; -with System.OS_Primitives; use System.OS_Primitives; - -package body Ada.Calendar is - - -------------------------- - -- Implementation Notes -- - -------------------------- - - -- Variables of type Ada.Calendar.Time have suffix _S or _M to denote - -- units of seconds or milis. - - -- Because time is measured in different units and from different origins - -- on various targets, a system independent model is incorporated into - -- Ada.Calendar. The idea behind the design is to encapsulate all target - -- dependent machinery in a single package, thus providing a uniform - -- interface to all existing and potential children. - - -- package Ada.Calendar - -- procedure Split (5 parameters) -------+ - -- | Call from local routine - -- private | - -- package Formatting_Operations | - -- procedure Split (11 parameters) <--+ - -- end Formatting_Operations | - -- end Ada.Calendar | - -- | - -- package Ada.Calendar.Formatting | Call from child routine - -- procedure Split (9 or 10 parameters) -+ - -- end Ada.Calendar.Formatting - - -- The behaviour of the interfacing routines is controlled via various - -- flags. All new Ada 2005 types from children of Ada.Calendar are - -- emulated by a similar type. For instance, type Day_Number is replaced - -- by Integer in various routines. One ramification of this model is that - -- the caller site must perform validity checks on returned results. - -- The end result of this model is the lack of target specific files per - -- child of Ada.Calendar (a-calfor, a-calfor-vms, a-calfor-vxwors, etc). - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Within_Time_Bounds (T : OS_Time); - -- Ensure that a time representation value falls withing the bounds of Ada - -- time. Leap seconds support is taken into account. - - procedure Cumulative_Leap_Seconds - (Start_Date : OS_Time; - End_Date : OS_Time; - Elapsed_Leaps : out Natural; - Next_Leap_Sec : out OS_Time); - -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or - -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec - -- represents the next leap second occurrence on or after End_Date. If - -- there are no leaps seconds after End_Date, End_Of_Time is returned. - -- End_Of_Time can be used as End_Date to count all the leap seconds that - -- have occurred on or after Start_Date. - -- - -- Note: Any sub seconds of Start_Date and End_Date are discarded before - -- the calculations are done. For instance: if 113 seconds is a leap - -- second (it isn't) and 113.5 is input as an End_Date, the leap second - -- at 113 will not be counted in Leaps_Between, but it will be returned - -- as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is - -- a leap second, the comparison should be: - -- - -- End_Date >= Next_Leap_Sec; - -- - -- After_Last_Leap is designed so that this comparison works without - -- having to first check if Next_Leap_Sec is a valid leap second. - - function To_Duration (T : Time) return Duration; - function To_Relative_Time (D : Duration) return Time; - -- It is important to note that duration's fractional part denotes nano - -- seconds while the units of Time are 100 nanoseconds. If a regular - -- Unchecked_Conversion was employed, the resulting values would be off - -- by 100. - - -------------------------- - -- Leap seconds control -- - -------------------------- - - Flag : Integer; - pragma Import (C, Flag, "__gl_leap_seconds_support"); - -- This imported value is used to determine whether the compilation had - -- binder flag "-y" present which enables leap seconds. A value of zero - -- signifies no leap seconds support while a value of one enables the - -- support. - - Leap_Support : constant Boolean := Flag = 1; - -- The above flag controls the usage of leap seconds in all Ada.Calendar - -- routines. - - Leap_Seconds_Count : constant Natural := 25; - - --------------------- - -- Local Constants -- - --------------------- - - -- The range of Ada time expressed as milis since the VMS Epoch - - Ada_Low : constant OS_Time := (10 * 366 + 32 * 365 + 45) * Milis_In_Day; - Ada_High : constant OS_Time := (131 * 366 + 410 * 365 + 45) * Milis_In_Day; - - -- Even though the upper bound of time is 2399-12-31 23:59:59.9999999 - -- UTC, it must be increased to include all leap seconds. - - Ada_High_And_Leaps : constant OS_Time := - Ada_High + OS_Time (Leap_Seconds_Count) * Mili; - - -- Two constants used in the calculations of elapsed leap seconds. - -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time - -- is earlier than Ada_Low in time zone +28. - - End_Of_Time : constant OS_Time := Ada_High + OS_Time (3) * Milis_In_Day; - Start_Of_Time : constant OS_Time := Ada_Low - OS_Time (3) * Milis_In_Day; - - -- The following table contains the hard time values of all existing leap - -- seconds. The values are produced by the utility program xleaps.adb. - - Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of OS_Time := - (35855136000000000, - 36014112010000000, - 36329472020000000, - 36644832030000000, - 36960192040000000, - 37276416050000000, - 37591776060000000, - 37907136070000000, - 38222496080000000, - 38695104090000000, - 39010464100000000, - 39325824110000000, - 39957408120000000, - 40747104130000000, - 41378688140000000, - 41694048150000000, - 42166656160000000, - 42482016170000000, - 42797376180000000, - 43271712190000000, - 43744320200000000, - 44218656210000000, - 46427904220000000, - 47374848230000000, - 48478176240000000); - - --------- - -- "+" -- - --------- - - function "+" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Left + To_Relative_Time (Right); - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - function "+" (Left : Duration; Right : Time) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Right + Left; - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - begin - return Left - To_Relative_Time (Right); - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - function "-" (Left : Time; Right : Time) return Duration is - pragma Unsuppress (Overflow_Check); - - -- The bound of type Duration expressed as time - - Dur_High : constant OS_Time := - OS_Time (To_Relative_Time (Duration'Last)); - Dur_Low : constant OS_Time := - OS_Time (To_Relative_Time (Duration'First)); - - Res_M : OS_Time; - - begin - Res_M := OS_Time (Left) - OS_Time (Right); - - -- Due to the extended range of Ada time, "-" is capable of producing - -- results which may exceed the range of Duration. In order to prevent - -- the generation of bogus values by the Unchecked_Conversion, we apply - -- the following check. - - if Res_M < Dur_Low - or else Res_M >= Dur_High - then - raise Time_Error; - - -- Normal case, result fits - - else - return To_Duration (Time (Res_M)); - end if; - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) < OS_Time (Right); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) <= OS_Time (Right); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) > OS_Time (Right); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : Time) return Boolean is - begin - return OS_Time (Left) >= OS_Time (Right); - end ">="; - - ------------------------------ - -- Check_Within_Time_Bounds -- - ------------------------------ - - procedure Check_Within_Time_Bounds (T : OS_Time) is - begin - if Leap_Support then - if T < Ada_Low or else T > Ada_High_And_Leaps then - raise Time_Error; - end if; - else - if T < Ada_Low or else T > Ada_High then - raise Time_Error; - end if; - end if; - end Check_Within_Time_Bounds; - - ----------- - -- Clock -- - ----------- - - function Clock return Time is - Elapsed_Leaps : Natural; - Next_Leap_M : OS_Time; - Res_M : constant OS_Time := OS_Clock; - - begin - -- Note that on other targets a soft-link is used to get a different - -- clock depending whether tasking is used or not. On VMS this isn't - -- needed since all clock calls end up using SYS$GETTIM, so call the - -- OS_Primitives version for efficiency. - - -- If the target supports leap seconds, determine the number of leap - -- seconds elapsed until this moment. - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); - - -- The system clock may fall exactly on a leap second - - if Res_M >= Next_Leap_M then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - return Time (Res_M + OS_Time (Elapsed_Leaps) * Mili); - end Clock; - - ----------------------------- - -- Cumulative_Leap_Seconds -- - ----------------------------- - - procedure Cumulative_Leap_Seconds - (Start_Date : OS_Time; - End_Date : OS_Time; - Elapsed_Leaps : out Natural; - Next_Leap_Sec : out OS_Time) - is - End_Index : Positive; - End_T : OS_Time := End_Date; - Start_Index : Positive; - Start_T : OS_Time := Start_Date; - - begin - pragma Assert (Leap_Support and then End_Date >= Start_Date); - - Next_Leap_Sec := End_Of_Time; - - -- Make sure that the end date does not exceed the upper bound - -- of Ada time. - - if End_Date > Ada_High then - End_T := Ada_High; - end if; - - -- Remove the sub seconds from both dates - - Start_T := Start_T - (Start_T mod Mili); - End_T := End_T - (End_T mod Mili); - - -- Some trivial cases: - -- Leap 1 . . . Leap N - -- ---+========+------+############+-------+========+----- - -- Start_T End_T Start_T End_T - - if End_T < Leap_Second_Times (1) then - Elapsed_Leaps := 0; - Next_Leap_Sec := Leap_Second_Times (1); - return; - - elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then - Elapsed_Leaps := 0; - Next_Leap_Sec := End_Of_Time; - return; - end if; - - -- Perform the calculations only if the start date is within the leap - -- second occurrences table. - - if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then - - -- 1 2 N - 1 N - -- +----+----+-- . . . --+-------+---+ - -- | T1 | T2 | | N - 1 | N | - -- +----+----+-- . . . --+-------+---+ - -- ^ ^ - -- | Start_Index | End_Index - -- +-------------------+ - -- Leaps_Between - - -- The idea behind the algorithm is to iterate and find two closest - -- dates which are after Start_T and End_T. Their corresponding - -- index difference denotes the number of leap seconds elapsed. - - Start_Index := 1; - loop - exit when Leap_Second_Times (Start_Index) >= Start_T; - Start_Index := Start_Index + 1; - end loop; - - End_Index := Start_Index; - loop - exit when End_Index > Leap_Seconds_Count - or else Leap_Second_Times (End_Index) >= End_T; - End_Index := End_Index + 1; - end loop; - - if End_Index <= Leap_Seconds_Count then - Next_Leap_Sec := Leap_Second_Times (End_Index); - end if; - - Elapsed_Leaps := End_Index - Start_Index; - - else - Elapsed_Leaps := 0; - end if; - end Cumulative_Leap_Seconds; - - --------- - -- Day -- - --------- - - function Day (Date : Time) return Day_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, M, S); - begin - Split (Date, Y, M, D, S); - return D; - end Day; - - ------------- - -- Is_Leap -- - ------------- - - function Is_Leap (Year : Year_Number) return Boolean is - begin - -- Leap centennial years - - if Year mod 400 = 0 then - return True; - - -- Non-leap centennial years - - elsif Year mod 100 = 0 then - return False; - - -- Regular years - - else - return Year mod 4 = 0; - end if; - end Is_Leap; - - ----------- - -- Month -- - ----------- - - function Month (Date : Time) return Month_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, D, S); - begin - Split (Date, Y, M, D, S); - return M; - end Month; - - ------------- - -- Seconds -- - ------------- - - function Seconds (Date : Time) return Day_Duration is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, M, D); - begin - Split (Date, Y, M, D, S); - return S; - end Seconds; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration) - is - H : Integer; - M : Integer; - Se : Integer; - Ss : Duration; - Le : Boolean; - - begin - -- Use UTC as the local time zone on VMS, the status of flag Use_TZ is - -- irrelevant in this case. - - Formatting_Operations.Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => Le, - Use_TZ => False, - Is_Historic => True, - Time_Zone => 0); - - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Seconds'Valid - then - raise Time_Error; - end if; - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time - is - -- The values in the following constants are irrelevant, they are just - -- placeholders; the choice of constructing a Day_Duration value is - -- controlled by the Use_Day_Secs flag. - - H : constant Integer := 1; - M : constant Integer := 1; - Se : constant Integer := 1; - Ss : constant Duration := 0.1; - - begin - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Seconds'Valid - then - raise Time_Error; - end if; - - -- Use UTC as the local time zone on VMS, the status of flag Use_TZ is - -- irrelevant in this case. - - return - Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => False, - Use_Day_Secs => True, - Use_TZ => False, - Is_Historic => True, - Time_Zone => 0); - end Time_Of; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - function Time_To_Duration is - new Ada.Unchecked_Conversion (Time, Duration); - begin - return Time_To_Duration (T * 100); - end To_Duration; - - ---------------------- - -- To_Relative_Time -- - ---------------------- - - function To_Relative_Time (D : Duration) return Time is - function Duration_To_Time is - new Ada.Unchecked_Conversion (Duration, Time); - begin - return Duration_To_Time (D / 100.0); - end To_Relative_Time; - - ---------- - -- Year -- - ---------- - - function Year (Date : Time) return Year_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (M, D, S); - begin - Split (Date, Y, M, D, S); - return Y; - end Year; - - -- The following packages assume that Time is a Long_Integer, the units - -- are 100 nanoseconds and the starting point in the VMS Epoch. - - --------------------------- - -- Arithmetic_Operations -- - --------------------------- - - package body Arithmetic_Operations is - - --------- - -- Add -- - --------- - - function Add (Date : Time; Days : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Date_M : constant OS_Time := OS_Time (Date); - begin - return Time (Date_M + OS_Time (Days) * Milis_In_Day); - exception - when Constraint_Error => - raise Time_Error; - end Add; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Left : Time; - Right : Time; - Days : out Long_Integer; - Seconds : out Duration; - Leap_Seconds : out Integer) - is - Diff_M : OS_Time; - Diff_S : OS_Time; - Earlier : OS_Time; - Elapsed_Leaps : Natural; - Later : OS_Time; - Negate : Boolean := False; - Next_Leap : OS_Time; - Sub_Seconds : Duration; - - begin - -- This classification is necessary in order to avoid a Time_Error - -- being raised by the arithmetic operators in Ada.Calendar. - - if Left >= Right then - Later := OS_Time (Left); - Earlier := OS_Time (Right); - else - Later := OS_Time (Right); - Earlier := OS_Time (Left); - Negate := True; - end if; - - -- If the target supports leap seconds, process them - - if Leap_Support then - Cumulative_Leap_Seconds - (Earlier, Later, Elapsed_Leaps, Next_Leap); - - if Later >= Next_Leap then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - Diff_M := Later - Earlier - OS_Time (Elapsed_Leaps) * Mili; - - -- Sub second processing - - Sub_Seconds := Duration (Diff_M mod Mili) / Mili_F; - - -- Convert to seconds. Note that his action eliminates the sub - -- seconds automatically. - - Diff_S := Diff_M / Mili; - - Days := Long_Integer (Diff_S / Secs_In_Day); - Seconds := Duration (Diff_S mod Secs_In_Day) + Sub_Seconds; - Leap_Seconds := Integer (Elapsed_Leaps); - - if Negate then - Days := -Days; - Seconds := -Seconds; - - if Leap_Seconds /= 0 then - Leap_Seconds := -Leap_Seconds; - end if; - end if; - end Difference; - - -------------- - -- Subtract -- - -------------- - - function Subtract (Date : Time; Days : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Date_M : constant OS_Time := OS_Time (Date); - begin - return Time (Date_M - OS_Time (Days) * Milis_In_Day); - exception - when Constraint_Error => - raise Time_Error; - end Subtract; - end Arithmetic_Operations; - - --------------------------- - -- Conversion_Operations -- - --------------------------- - - package body Conversion_Operations is - - Epoch_Offset : constant OS_Time := 35067168000000000; - -- The difference between 1970-1-1 UTC and 1858-11-17 UTC expressed in - -- 100 nanoseconds. - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time (Unix_Time : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Unix_Rep : constant OS_Time := OS_Time (Unix_Time) * Mili; - begin - return Time (Unix_Rep + Epoch_Offset); - exception - when Constraint_Error => - raise Time_Error; - end To_Ada_Time; - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time - (tm_year : Integer; - tm_mon : Integer; - tm_day : Integer; - tm_hour : Integer; - tm_min : Integer; - tm_sec : Integer; - tm_isdst : Integer) return Time - is - pragma Unsuppress (Overflow_Check); - - Year_Shift : constant Integer := 1900; - Month_Shift : constant Integer := 1; - - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Second : Integer; - Leap : Boolean; - Result : OS_Time; - - begin - -- Input processing - - Year := Year_Number (Year_Shift + tm_year); - Month := Month_Number (Month_Shift + tm_mon); - Day := Day_Number (tm_day); - - -- Step 1: Validity checks of input values - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else tm_hour not in 0 .. 24 - or else tm_min not in 0 .. 59 - or else tm_sec not in 0 .. 60 - or else tm_isdst not in -1 .. 1 - then - raise Time_Error; - end if; - - -- Step 2: Potential leap second - - if tm_sec = 60 then - Leap := True; - Second := 59; - else - Leap := False; - Second := tm_sec; - end if; - - -- Step 3: Calculate the time value - - Result := - OS_Time - (Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => 0.0, -- Time is given in h:m:s - Hour => tm_hour, - Minute => tm_min, - Second => Second, - Sub_Sec => 0.0, -- No precise sub second given - Leap_Sec => Leap, - Use_Day_Secs => False, -- Time is given in h:m:s - Use_TZ => True, -- Force usage of explicit time zone - Is_Historic => True, - Time_Zone => 0)); -- Place the value in UTC - -- Step 4: Daylight Savings Time - - if tm_isdst = 1 then - Result := Result + OS_Time (3_600) * Mili; - end if; - - return Time (Result); - exception - when Constraint_Error => - raise Time_Error; - end To_Ada_Time; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration - (tv_sec : Long_Integer; - tv_nsec : Long_Integer) return Duration - is - pragma Unsuppress (Overflow_Check); - begin - return Duration (tv_sec) + Duration (tv_nsec) / Mili_F; - end To_Duration; - - ------------------------ - -- To_Struct_Timespec -- - ------------------------ - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Long_Integer; - tv_nsec : out Long_Integer) - is - pragma Unsuppress (Overflow_Check); - Secs : Duration; - Nano_Secs : Duration; - - begin - -- Seconds extraction, avoid potential rounding errors - - Secs := D - 0.5; - tv_sec := Long_Integer (Secs); - - -- 100 Nanoseconds extraction - - Nano_Secs := D - Duration (tv_sec); - tv_nsec := Long_Integer (Nano_Secs * Mili); - end To_Struct_Timespec; - - ------------------ - -- To_Struct_Tm -- - ------------------ - - procedure To_Struct_Tm - (T : Time; - tm_year : out Integer; - tm_mon : out Integer; - tm_day : out Integer; - tm_hour : out Integer; - tm_min : out Integer; - tm_sec : out Integer) - is - pragma Unsuppress (Overflow_Check); - Year : Year_Number; - Month : Month_Number; - Second : Integer; - Day_Secs : Day_Duration; - Sub_Sec : Duration; - Leap_Sec : Boolean; - - begin - -- Step 1: Split the input time - - Formatting_Operations.Split - (Date => T, - Year => Year, - Month => Month, - Day => tm_day, - Day_Secs => Day_Secs, - Hour => tm_hour, - Minute => tm_min, - Second => Second, - Sub_Sec => Sub_Sec, - Leap_Sec => Leap_Sec, - Use_TZ => True, - Is_Historic => False, - Time_Zone => 0); - - -- Step 2: Correct the year and month - - tm_year := Year - 1900; - tm_mon := Month - 1; - - -- Step 3: Handle leap second occurrences - - tm_sec := (if Leap_Sec then 60 else Second); - end To_Struct_Tm; - - ------------------ - -- To_Unix_Time -- - ------------------ - - function To_Unix_Time (Ada_Time : Time) return Long_Integer is - pragma Unsuppress (Overflow_Check); - Ada_OS_Time : constant OS_Time := OS_Time (Ada_Time); - begin - return Long_Integer ((Ada_OS_Time - Epoch_Offset) / Mili); - exception - when Constraint_Error => - raise Time_Error; - end To_Unix_Time; - end Conversion_Operations; - - --------------------------- - -- Formatting_Operations -- - --------------------------- - - package body Formatting_Operations is - - ----------------- - -- Day_Of_Week -- - ----------------- - - function Day_Of_Week (Date : Time) return Integer is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - - Day_Count : Long_Integer; - Midday_Date_S : Time; - - begin - Split (Date, Y, M, D, S); - - -- Build a time value in the middle of the same day and convert the - -- time value to seconds. - - Midday_Date_S := Time_Of (Y, M, D, 43_200.0) / Mili; - - -- Count the number of days since the start of VMS time. 1858-11-17 - -- was a Wednesday. - - Day_Count := Long_Integer (Midday_Date_S / Secs_In_Day) + 2; - - return Integer (Day_Count mod 7); - end Day_Of_Week; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) - is - -- Flags Use_TZ and Is_Historic are present for interfacing purposes - - pragma Unreferenced (Use_TZ, Is_Historic); - - procedure Numtim - (Status : out Unsigned_Longword; - Timbuf : out Unsigned_Word_Array; - Timadr : Time); - - pragma Import (External, Numtim); - - pragma Import_Valued_Procedure - (Numtim, "SYS$NUMTIM", - (Unsigned_Longword, Unsigned_Word_Array, Time), - (Value, Reference, Reference)); - - Status : Unsigned_Longword; - Timbuf : Unsigned_Word_Array (1 .. 7); - - Ada_Min_Year : constant := 1901; - Ada_Max_Year : constant := 2399; - - Date_M : OS_Time; - Elapsed_Leaps : Natural; - Next_Leap_M : OS_Time; - - begin - Date_M := OS_Time (Date); - - -- Step 1: Leap seconds processing - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Date_M, Elapsed_Leaps, Next_Leap_M); - - Leap_Sec := Date_M >= Next_Leap_M; - - if Leap_Sec then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - Leap_Sec := False; - end if; - - Date_M := Date_M - OS_Time (Elapsed_Leaps) * Mili; - - -- Step 2: Time zone processing - - if Time_Zone /= 0 then - Date_M := Date_M + OS_Time (Time_Zone) * 60 * Mili; - end if; - - -- After the leap seconds and time zone have been accounted for, - -- the date should be within the bounds of Ada time. - - if Date_M < Ada_Low - or else Date_M > Ada_High - then - raise Time_Error; - end if; - - -- Step 3: Sub second processing - - Sub_Sec := Duration (Date_M mod Mili) / Mili_F; - - -- Drop the sub seconds - - Date_M := Date_M - (Date_M mod Mili); - - -- Step 4: VMS system call - - Numtim (Status, Timbuf, Time (Date_M)); - - if Status mod 2 /= 1 - or else Timbuf (1) not in Ada_Min_Year .. Ada_Max_Year - then - raise Time_Error; - end if; - - -- Step 5: Time components processing - - Year := Year_Number (Timbuf (1)); - Month := Month_Number (Timbuf (2)); - Day := Day_Number (Timbuf (3)); - Hour := Integer (Timbuf (4)); - Minute := Integer (Timbuf (5)); - Second := Integer (Timbuf (6)); - - Day_Secs := Day_Duration (Hour * 3_600) + - Day_Duration (Minute * 60) + - Day_Duration (Second) + - Sub_Sec; - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time - is - -- Flag Is_Historic is present for interfacing purposes - - pragma Unreferenced (Is_Historic); - - procedure Cvt_Vectim - (Status : out Unsigned_Longword; - Input_Time : Unsigned_Word_Array; - Resultant_Time : out Time); - - pragma Import (External, Cvt_Vectim); - - pragma Import_Valued_Procedure - (Cvt_Vectim, "LIB$CVT_VECTIM", - (Unsigned_Longword, Unsigned_Word_Array, Time), - (Value, Reference, Reference)); - - Status : Unsigned_Longword; - Timbuf : Unsigned_Word_Array (1 .. 7); - - Y : Year_Number := Year; - Mo : Month_Number := Month; - D : Day_Number := Day; - H : Integer := Hour; - Mi : Integer := Minute; - Se : Integer := Second; - Su : Duration := Sub_Sec; - - Elapsed_Leaps : Natural; - Int_Day_Secs : Integer; - Next_Leap_M : OS_Time; - Res : Time; - Res_M : OS_Time; - Rounded_Res_M : OS_Time; - - begin - -- No validity checks are performed on the input values since it is - -- assumed that the called has already performed them. - - -- Step 1: Hour, minute, second and sub second processing - - if Use_Day_Secs then - - -- A day seconds value of 86_400 designates a new day - - if Day_Secs = 86_400.0 then - declare - Adj_Year : Year_Number := Year; - Adj_Month : Month_Number := Month; - Adj_Day : Day_Number := Day; - - begin - if Day < Days_In_Month (Month) - or else (Month = 2 - and then Is_Leap (Year)) - then - Adj_Day := Day + 1; - - -- The day adjustment moves the date to a new month - - else - Adj_Day := 1; - - if Month < 12 then - Adj_Month := Month + 1; - - -- The month adjustment moves the date to a new year - - else - Adj_Month := 1; - Adj_Year := Year + 1; - end if; - end if; - - Y := Adj_Year; - Mo := Adj_Month; - D := Adj_Day; - H := 0; - Mi := 0; - Se := 0; - Su := 0.0; - end; - - -- Normal case (not exactly one day) - - else - -- Sub second extraction - - Int_Day_Secs := - (if Day_Secs > 0.0 - then Integer (Day_Secs - 0.5) - else Integer (Day_Secs)); - - H := Int_Day_Secs / 3_600; - Mi := (Int_Day_Secs / 60) mod 60; - Se := Int_Day_Secs mod 60; - Su := Day_Secs - Duration (Int_Day_Secs); - end if; - end if; - - -- Step 2: System call to VMS - - Timbuf (1) := Unsigned_Word (Y); - Timbuf (2) := Unsigned_Word (Mo); - Timbuf (3) := Unsigned_Word (D); - Timbuf (4) := Unsigned_Word (H); - Timbuf (5) := Unsigned_Word (Mi); - Timbuf (6) := Unsigned_Word (Se); - Timbuf (7) := 0; - - Cvt_Vectim (Status, Timbuf, Res); - - if Status mod 2 /= 1 then - raise Time_Error; - end if; - - -- Step 3: Sub second adjustment - - Res_M := OS_Time (Res) + OS_Time (Su * Mili_F); - - -- Step 4: Bounds check - - Check_Within_Time_Bounds (Res_M); - - -- Step 5: Time zone processing - - if Time_Zone /= 0 then - Res_M := Res_M - OS_Time (Time_Zone) * 60 * Mili; - end if; - - -- Step 6: Leap seconds processing - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_M, Elapsed_Leaps, Next_Leap_M); - - Res_M := Res_M + OS_Time (Elapsed_Leaps) * Mili; - - -- An Ada 2005 caller requesting an explicit leap second or an - -- Ada 95 caller accounting for an invisible leap second. - - if Leap_Sec - or else Res_M >= Next_Leap_M - then - Res_M := Res_M + OS_Time (1) * Mili; - end if; - - -- Leap second validity check - - Rounded_Res_M := Res_M - (Res_M mod Mili); - - if Use_TZ - and then Leap_Sec - and then Rounded_Res_M /= Next_Leap_M - then - raise Time_Error; - end if; - end if; - - return Time (Res_M); - end Time_Of; - end Formatting_Operations; - - --------------------------- - -- Time_Zones_Operations -- - --------------------------- - - package body Time_Zones_Operations is - - --------------------- - -- UTC_Time_Offset -- - --------------------- - - function UTC_Time_Offset (Date : Time) return Long_Integer is - -- Formal parameter Date is here for interfacing, but is never - -- actually used. - - pragma Unreferenced (Date); - - function get_gmtoff return Long_Integer; - pragma Import (C, get_gmtoff, "get_gmtoff"); - - begin - -- VMS is not capable of determining the time zone in some past or - -- future point in time denoted by Date, thus the current time zone - -- is retrieved. - - return get_gmtoff; - end UTC_Time_Offset; - end Time_Zones_Operations; -end Ada.Calendar; diff --git a/gcc/ada/a-calend-vms.ads b/gcc/ada/a-calend-vms.ads deleted file mode 100644 index 744011ae008..00000000000 --- a/gcc/ada/a-calend-vms.ads +++ /dev/null @@ -1,310 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version - -with System.OS_Primitives; - -package Ada.Calendar is - - type Time is private; - - -- Declarations representing limits of allowed local time values. Note that - -- these do NOT constrain the possible stored values of time which may well - -- permit a larger range of times (this is explicitly allowed in Ada 95). - - subtype Year_Number is Integer range 1901 .. 2399; - subtype Month_Number is Integer range 1 .. 12; - subtype Day_Number is Integer range 1 .. 31; - - subtype Day_Duration is Duration range 0.0 .. 86_400.0; - -- Note that a value of 86_400.0 is the start of the next day - - function Clock return Time; - -- The returned time value is the number of nanoseconds since the start - -- of Ada time (1901-01-01 00:00:00.0 UTC). If leap seconds are enabled, - -- the result will contain all elapsed leap seconds since the start of - -- Ada time until now. - - function Year (Date : Time) return Year_Number; - function Month (Date : Time) return Month_Number; - function Day (Date : Time) return Day_Number; - function Seconds (Date : Time) return Day_Duration; - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration); - -- Break down a time value into its date components set in the current - -- time zone. If Split is called on a time value created using Ada 2005 - -- Time_Of in some arbitrary time zone, the input value will always be - -- interpreted as relative to the local time zone. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time; - -- GNAT Note: Normally when procedure Split is called on a Time value - -- result of a call to function Time_Of, the out parameters of procedure - -- Split are identical to the in parameters of function Time_Of. However, - -- when a non-existent time of day is specified, the values for Seconds - -- may or may not be different. This may happen when Daylight Saving Time - -- (DST) is in effect, on the day when switching to DST, if Seconds - -- specifies a time of day in the hour that does not exist. For example, - -- in New York: - -- - -- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0) - -- - -- will return a Time value T. If Split is called on T, the resulting - -- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being - -- a time that not exist). - - function "+" (Left : Time; Right : Duration) return Time; - function "+" (Left : Duration; Right : Time) return Time; - function "-" (Left : Time; Right : Duration) return Time; - function "-" (Left : Time; Right : Time) return Duration; - -- The first three functions will raise Time_Error if the resulting time - -- value is less than the start of Ada time in UTC or greater than the - -- end of Ada time in UTC. The last function will raise Time_Error if the - -- resulting difference cannot fit into a duration value. - - function "<" (Left, Right : Time) return Boolean; - function "<=" (Left, Right : Time) return Boolean; - function ">" (Left, Right : Time) return Boolean; - function ">=" (Left, Right : Time) return Boolean; - - Time_Error : exception; - -private - pragma Inline (Clock); - - pragma Inline (Year); - pragma Inline (Month); - pragma Inline (Day); - - pragma Inline ("+"); - pragma Inline ("-"); - - pragma Inline ("<"); - pragma Inline ("<="); - pragma Inline (">"); - pragma Inline (">="); - - -- Although the units are 100 nanoseconds, for the purpose of better - -- readability, this unit will be called "mili". - - Mili : constant := 10_000_000; - Mili_F : constant := 10_000_000.0; - Milis_In_Day : constant := 864_000_000_000; - Secs_In_Day : constant := 86_400; - - -- Time is represented as the number of 100-nanosecond (ns) units from the - -- system base date and time 1858-11-17 0.0 (the Smithsonian base date and - -- time for the astronomic calendar). - - -- The time value stored is typically a UTC value, as provided in standard - -- Unix environments. If this is the case then Split and Time_Of perform - -- required conversions to and from local times. - - -- Notwithstanding this definition, Time is not quite the same as OS_Time. - -- Relative Time is positive, whereas relative OS_Time is negative, - -- but this declaration makes for easier conversion. - - type Time is new System.OS_Primitives.OS_Time; - - Days_In_Month : constant array (Month_Number) of Day_Number := - (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); - -- Days in month for non-leap year, leap year case is adjusted in code - - Invalid_Time_Zone_Offset : Long_Integer; - pragma Import (C, Invalid_Time_Zone_Offset, "__gnat_invalid_tzoff"); - - function Is_Leap (Year : Year_Number) return Boolean; - -- Determine whether a given year is leap - - ---------------------------------------------------------- - -- Target-Independent Interface to Children of Calendar -- - ---------------------------------------------------------- - - -- The following packages provide a target-independent interface to the - -- children of Calendar - Arithmetic, Conversions, Delays, Formatting and - -- Time_Zones. - - -- NOTE: Delays does not need a target independent interface because - -- VMS already has a target specific file for that package. - - --------------------------- - -- Arithmetic_Operations -- - --------------------------- - - package Arithmetic_Operations is - - function Add (Date : Time; Days : Long_Integer) return Time; - -- Add a certain number of days to a time value - - procedure Difference - (Left : Time; - Right : Time; - Days : out Long_Integer; - Seconds : out Duration; - Leap_Seconds : out Integer); - -- Calculate the difference between two time values in terms of days, - -- seconds and leap seconds elapsed. The leap seconds are not included - -- in the seconds returned. If Left is greater than Right, the returned - -- values are positive, negative otherwise. - - function Subtract (Date : Time; Days : Long_Integer) return Time; - -- Subtract a certain number of days from a time value - - end Arithmetic_Operations; - - --------------------------- - -- Conversion_Operations -- - --------------------------- - - package Conversion_Operations is - - function To_Ada_Time (Unix_Time : Long_Integer) return Time; - -- Unix to Ada Epoch conversion - - function To_Ada_Time - (tm_year : Integer; - tm_mon : Integer; - tm_day : Integer; - tm_hour : Integer; - tm_min : Integer; - tm_sec : Integer; - tm_isdst : Integer) return Time; - -- Struct tm to Ada Epoch conversion - - function To_Duration - (tv_sec : Long_Integer; - tv_nsec : Long_Integer) return Duration; - -- Struct timespec to Duration conversion - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Long_Integer; - tv_nsec : out Long_Integer); - -- Duration to struct timespec conversion - - procedure To_Struct_Tm - (T : Time; - tm_year : out Integer; - tm_mon : out Integer; - tm_day : out Integer; - tm_hour : out Integer; - tm_min : out Integer; - tm_sec : out Integer); - -- Time to struct tm conversion - - function To_Unix_Time (Ada_Time : Time) return Long_Integer; - -- Ada to Unix Epoch conversion - - end Conversion_Operations; - - --------------------------- - -- Formatting_Operations -- - --------------------------- - - package Formatting_Operations is - - function Day_Of_Week (Date : Time) return Integer; - -- Determine which day of week Date falls on. The returned values are - -- within the range of 0 .. 6 (Monday .. Sunday). - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer); - pragma Export (Ada, Split, "__gnat_split"); - -- Split a time value into its components. If flag Is_Historic is set, - -- this routine would try to use to the best of the OS's abilities the - -- time zone offset that was or will be in effect on Date. Set Use_TZ - -- to use the local time zone (the value in Time_Zone is ignored) when - -- splitting a time value. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time; - pragma Export (Ada, Time_Of, "__gnat_time_of"); - -- Given all the components of a date, return the corresponding time - -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the - -- day duration will be calculated from Hour, Minute, Second and Sub_ - -- Sec. If flag Is_Historic is set, this routine would try to use to the - -- best of the OS's abilities the time zone offset that was or will be - -- in effect on the input date. Set Use_TZ to use the local time zone - -- (the value in formal Time_Zone is ignored) when building a time value - -- and to verify the validity of a requested leap second. - - end Formatting_Operations; - - --------------------------- - -- Time_Zones_Operations -- - --------------------------- - - package Time_Zones_Operations is - - function UTC_Time_Offset (Date : Time) return Long_Integer; - -- Return (in seconds) the difference between the local time zone and - -- UTC time at a specific historic date. - - end Time_Zones_Operations; - -end Ada.Calendar; diff --git a/gcc/ada/a-dirval-vms.adb b/gcc/ada/a-dirval-vms.adb deleted file mode 100644 index c9a08310d74..00000000000 --- a/gcc/ada/a-dirval-vms.adb +++ /dev/null @@ -1,200 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (VMS Version) -- --- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version of this package - -package body Ada.Directories.Validity is - - Max_Number_Of_Characters : constant := 39; - Max_Path_Length : constant := 1_024; - - Invalid_Character : constant array (Character) of Boolean := - ('a' .. 'z' => False, - 'A' .. 'Z' => False, - '0' .. '9' => False, - '_' | '$' | '-' | '.' => False, - others => True); - - --------------------------------- - -- Is_Path_Name_Case_Sensitive -- - --------------------------------- - - function Is_Path_Name_Case_Sensitive return Boolean is - begin - return False; - end Is_Path_Name_Case_Sensitive; - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - First : Positive := Name'First; - Last : Positive; - Dot_Found : Boolean := False; - - begin - -- A valid path (directory) name cannot be empty, and cannot contain - -- more than 1024 characters. Directories can be ".", ".." or be simple - -- name without extensions. - - if Name'Length = 0 or else Name'Length > Max_Path_Length then - return False; - - else - loop - -- Look for the start of the next directory or file name - - while First <= Name'Last and then Name (First) = '/' loop - First := First + 1; - end loop; - - -- If all directories/file names are OK, return True - - exit when First > Name'Last; - - Last := First; - Dot_Found := False; - - -- Look for the end of the directory/file name - - while Last < Name'Last loop - exit when Name (Last + 1) = '/'; - Last := Last + 1; - - if Name (Last) = '.' then - Dot_Found := True; - end if; - end loop; - - -- If name include a dot, it can only be ".", ".." or the last - -- file name. - - if Dot_Found then - if Name (First .. Last) /= "." and then - Name (First .. Last) /= ".." - then - return Last = Name'Last - and then Is_Valid_Simple_Name (Name (First .. Last)); - - end if; - - -- Check if the directory/file name is valid - - elsif not Is_Valid_Simple_Name (Name (First .. Last)) then - return False; - end if; - - -- Move to the next name - - First := Last + 1; - end loop; - end if; - - -- If Name follows the rules, then it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - In_Extension : Boolean := False; - Number_Of_Characters : Natural := 0; - - begin - -- A file name cannot be empty, and cannot have more than 39 characters - -- before or after a single '.'. - - if Name'Length = 0 then - return False; - - else - -- Check each character for validity - - for J in Name'Range loop - if Invalid_Character (Name (J)) then - return False; - - elsif Name (J) = '.' then - - -- Name cannot contain several dots - - if In_Extension then - return False; - - else - -- Reset the number of characters to count the characters - -- of the extension. - - In_Extension := True; - Number_Of_Characters := 0; - end if; - - else - -- Check that the number of character is not too large - - Number_Of_Characters := Number_Of_Characters + 1; - - if Number_Of_Characters > Max_Number_Of_Characters then - return False; - end if; - end if; - end loop; - end if; - - -- If the rules are followed, then it is valid - - return True; - end Is_Valid_Simple_Name; - - ------------- - -- OpenVMS -- - ------------- - - function OpenVMS return Boolean is - begin - return True; - end OpenVMS; - - ------------- - -- Windows -- - ------------- - - function Windows return Boolean is - begin - return False; - end Windows; - -end Ada.Directories.Validity; diff --git a/gcc/ada/a-intnam-linux.ads b/gcc/ada/a-intnam-linux.ads index 5003c20461a..9bbff6b8323 100644 --- a/gcc/ada/a-intnam-linux.ads +++ b/gcc/ada/a-intnam-linux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1991-2014, Free Software Foundation, Inc. -- -- -- -- GNARL 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- -- @@ -31,12 +31,7 @@ -- This is a GNU/Linux version of this package --- The following signals are reserved by the run time (FSU threads): - --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGALRM, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL - --- The following signals are reserved by the run time (LinuxThreads): +-- The following signals are reserved by the run time: -- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, -- SIGUSR1, SIGUSR2, SIGVTALRM, SIGUNUSED, SIGSTOP, SIGKILL diff --git a/gcc/ada/a-intnam-vms.ads b/gcc/ada/a-intnam-vms.ads deleted file mode 100644 index 30f98d33466..00000000000 --- a/gcc/ada/a-intnam-vms.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . I N T E R R U P T S . N A M E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - --- This target-dependent package spec contains names of interrupts --- supported by the local system. - -with System.OS_Interface; - -package Ada.Interrupts.Names is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - package OS renames System.OS_Interface; - - Interrupt_ID_0 : constant Interrupt_ID := OS.Interrupt_ID_0; - Interrupt_ID_1 : constant Interrupt_ID := OS.Interrupt_ID_1; - Interrupt_ID_2 : constant Interrupt_ID := OS.Interrupt_ID_2; - Interrupt_ID_3 : constant Interrupt_ID := OS.Interrupt_ID_3; - Interrupt_ID_4 : constant Interrupt_ID := OS.Interrupt_ID_4; - Interrupt_ID_5 : constant Interrupt_ID := OS.Interrupt_ID_5; - Interrupt_ID_6 : constant Interrupt_ID := OS.Interrupt_ID_6; - Interrupt_ID_7 : constant Interrupt_ID := OS.Interrupt_ID_7; - Interrupt_ID_8 : constant Interrupt_ID := OS.Interrupt_ID_8; - Interrupt_ID_9 : constant Interrupt_ID := OS.Interrupt_ID_9; - Interrupt_ID_10 : constant Interrupt_ID := OS.Interrupt_ID_10; - Interrupt_ID_11 : constant Interrupt_ID := OS.Interrupt_ID_11; - Interrupt_ID_12 : constant Interrupt_ID := OS.Interrupt_ID_12; - Interrupt_ID_13 : constant Interrupt_ID := OS.Interrupt_ID_13; - Interrupt_ID_14 : constant Interrupt_ID := OS.Interrupt_ID_14; - Interrupt_ID_15 : constant Interrupt_ID := OS.Interrupt_ID_15; - Interrupt_ID_16 : constant Interrupt_ID := OS.Interrupt_ID_16; - Interrupt_ID_17 : constant Interrupt_ID := OS.Interrupt_ID_17; - Interrupt_ID_18 : constant Interrupt_ID := OS.Interrupt_ID_18; - Interrupt_ID_19 : constant Interrupt_ID := OS.Interrupt_ID_19; - Interrupt_ID_20 : constant Interrupt_ID := OS.Interrupt_ID_20; - Interrupt_ID_21 : constant Interrupt_ID := OS.Interrupt_ID_21; - Interrupt_ID_22 : constant Interrupt_ID := OS.Interrupt_ID_22; - Interrupt_ID_23 : constant Interrupt_ID := OS.Interrupt_ID_23; - Interrupt_ID_24 : constant Interrupt_ID := OS.Interrupt_ID_24; - Interrupt_ID_25 : constant Interrupt_ID := OS.Interrupt_ID_25; - Interrupt_ID_26 : constant Interrupt_ID := OS.Interrupt_ID_26; - Interrupt_ID_27 : constant Interrupt_ID := OS.Interrupt_ID_27; - Interrupt_ID_28 : constant Interrupt_ID := OS.Interrupt_ID_28; - Interrupt_ID_29 : constant Interrupt_ID := OS.Interrupt_ID_29; - Interrupt_ID_30 : constant Interrupt_ID := OS.Interrupt_ID_30; - Interrupt_ID_31 : constant Interrupt_ID := OS.Interrupt_ID_31; - -end Ada.Interrupts.Names; diff --git a/gcc/ada/a-numaux-vms.ads b/gcc/ada/a-numaux-vms.ads deleted file mode 100644 index f6d1dfa9081..00000000000 --- a/gcc/ada/a-numaux-vms.ads +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (VMS Version) -- --- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. - --- This is the VMS version - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is digits 15; - pragma Float_Representation (IEEE_Float, Double); - -- Type Double is the type used to call the C routines. Note that this - -- is IEEE format even when running on VMS with VAX_Native representation - -- since we use the IEEE version of the C library with VMS. - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "MATH$SIN_T"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "MATH$COS_T"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "MATH$TAN_T"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "MATH$EXP_T"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "MATH$SQRT_T"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "DECC$TLOG_2"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "MATH$ACOS_T"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "MATH$ASIN_T"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "MATH$ATAN_T"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "MATH$SINH_T"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "MATH$COSH_T"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "MATH$TANH_T"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "DECC$TPOW_2"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/g-eacodu-vms.adb b/gcc/ada/g-eacodu-vms.adb deleted file mode 100644 index ceff6e98c09..00000000000 --- a/gcc/ada/g-eacodu-vms.adb +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ A C T I O N S . C O R E _ D U M P -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version - -with System; -with System.Aux_DEC; -separate (GNAT.Exception_Actions) -procedure Core_Dump (Occurrence : Exception_Occurrence) is - - use System; - use System.Aux_DEC; - - pragma Unreferenced (Occurrence); - - SS_IMGDMP : constant := 1276; - - subtype Cond_Value_Type is Unsigned_Longword; - subtype Access_Mode_Type is - Unsigned_Word range 0 .. 3; - Access_Mode_Zero : constant Access_Mode_Type := 0; - - Status : Cond_Value_Type; - - procedure Setexv ( - Status : out Cond_Value_Type; - Vector : Unsigned_Longword := 0; - Addres : Address := Address_Zero; - Acmode : Access_Mode_Type := Access_Mode_Zero; - Prvhnd : Unsigned_Longword := 0); - pragma Import (External, Setexv); - pragma Import_Valued_Procedure (Setexv, "SYS$SETEXV", - (Cond_Value_Type, Unsigned_Longword, Address, Access_Mode_Type, - Unsigned_Longword), - (Value, Value, Value, Value, Value)); - - procedure Lib_Signal (I : Integer); - pragma Import (C, Lib_Signal); - pragma Import_Procedure (Lib_Signal, "LIB$SIGNAL", Mechanism => (Value)); -begin - Setexv (Status, 1, Address_Zero, 3); - Lib_Signal (SS_IMGDMP); -end Core_Dump; diff --git a/gcc/ada/g-enblsp-vms-alpha.adb b/gcc/ada/g-enblsp-vms-alpha.adb deleted file mode 100644 index f932a075b88..00000000000 --- a/gcc/ada/g-enblsp-vms-alpha.adb +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent non-blocking spawn function --- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package --- should not be directly with'ed by an application program. - --- This version is for Alpha/VMS - -separate (GNAT.Expect) -procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) -is - function Alloc_Vfork_Blocks return Integer; - pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); - - function Get_Vfork_Jmpbuf return System.Address; - pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); - - function Get_Current_Invo_Context - (Addr : System.Address) return Process_Id; - pragma Import (C, Get_Current_Invo_Context, - "LIB$GET_CURRENT_INVO_CONTEXT"); - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - -begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - Command_With_Path := Locate_Exec_On_Path (Command); - - if Command_With_Path = null then - raise Invalid_Process; - end if; - - -- Fork a new process (it is not possible to do this in a subprogram) - - Descriptor.Pid := - (if Alloc_Vfork_Blocks >= 0 - then Get_Current_Invo_Context (Get_Vfork_Jmpbuf) else -1); - - -- Are we now in the child - - if Descriptor.Pid = Null_Pid then - - -- Prepare an array of arguments to pass to C - - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (1) := Arg.all'Address; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (J + 2 - Args'First) := Arg.all'Address; - end loop; - - Arg_List (Arg_List'Last) := System.Null_Address; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - Arg_List'Address); - end if; - - Free (Command_With_Path); - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - raise Invalid_Process; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; -end Non_Blocking_Spawn; diff --git a/gcc/ada/g-enblsp-vms-ia64.adb b/gcc/ada/g-enblsp-vms-ia64.adb deleted file mode 100644 index fa024474731..00000000000 --- a/gcc/ada/g-enblsp-vms-ia64.adb +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X P E C T . N O N _ B L O C K I N G _ S P A W N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent non-blocking spawn function --- for use by the VMS GNAT.Expect package (g-expect-vms.adb). This package --- should not be directly with'ed by an application program. - --- This version is for IA64/VMS - -separate (GNAT.Expect) -procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) -is - function Alloc_Vfork_Blocks return Integer; - pragma Import (C, Alloc_Vfork_Blocks, "decc$$alloc_vfork_blocks"); - - function Get_Vfork_Jmpbuf return System.Address; - pragma Import (C, Get_Vfork_Jmpbuf, "decc$$get_vfork_jmpbuf"); - - function Setjmp1 (Addr : System.Address) return Process_Id; - pragma Import (C, Setjmp1, "decc$setjmp1"); - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - -begin - -- Create the rest of the pipes - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - Command_With_Path := Locate_Exec_On_Path (Command); - - if Command_With_Path = null then - raise Invalid_Process; - end if; - - -- Fork a new process (it is not possible to do this in a subprogram) - - Descriptor.Pid := - (if Alloc_Vfork_Blocks >= 0 then Setjmp1 (Get_Vfork_Jmpbuf) else -1); - - -- Are we now in the child - - if Descriptor.Pid = Null_Pid then - - -- Prepare an array of arguments to pass to C - - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (1) := Arg.all'Address; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (J + 2 - Args'First) := Arg.all'Address; - end loop; - - Arg_List (Arg_List'Last) := System.Null_Address; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - Arg_List'Address); - end if; - - Free (Command_With_Path); - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - raise Invalid_Process; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; -end Non_Blocking_Spawn; diff --git a/gcc/ada/g-expect-vms.adb b/gcc/ada/g-expect-vms.adb deleted file mode 100644 index aa1f8038b2f..00000000000 --- a/gcc/ada/g-expect-vms.adb +++ /dev/null @@ -1,1306 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2014, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version - --- Note: there is far too much code duplication wrt g-expect.adb (the --- standard version). This should be factored out ??? - -with System; use System; -with Ada.Calendar; use Ada.Calendar; - -with GNAT.IO; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Regpat; use GNAT.Regpat; - -with Ada.Unchecked_Deallocation; - -package body GNAT.Expect is - - type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; - - Save_Input : File_Descriptor; - Save_Output : File_Descriptor; - Save_Error : File_Descriptor; - - Expect_Process_Died : constant Expect_Match := -100; - Expect_Internal_Error : constant Expect_Match := -101; - -- Additional possible outputs of Expect_Internal. These are not visible in - -- the spec because the user will never see them. - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean); - -- Internal function used to read from the process Descriptor. - -- - -- Several outputs are possible: - -- Result=Expect_Timeout, if no output was available before the timeout - -- expired. - -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters - -- had to be discarded from the internal buffer of Descriptor. - -- Result=Express_Process_Died if one of the processes was terminated. - -- That process's Input_Fd is set to Invalid_FD - -- Result=Express_Internal_Error - -- Result=<integer>, indicates how many characters were added to the - -- internal buffer. These characters are from indexes - -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index - -- Process_Died is raised if the process is no longer valid. - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class); - -- Reinitialize the internal buffer. - -- The buffer is deleted up to the end of the last match. - - procedure Free is new Ada.Unchecked_Deallocation - (Pattern_Matcher, Pattern_Matcher_Access); - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type); - -- Call all the filters that have the appropriate type. - -- This function does nothing if the filters are locked - - ------------------------------ - -- Target dependent section -- - ------------------------------ - - function Dup (Fd : File_Descriptor) return File_Descriptor; - pragma Import (C, Dup, "decc$dup"); - - procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); - pragma Import (C, Dup2, "decc$dup2"); - - procedure Kill (Pid : Process_Id; Sig_Num : Integer); - pragma Import (C, Kill, "decc$kill"); - - function Create_Pipe (Pipe : not null access Pipe_Type) return Integer; - pragma Import (C, Create_Pipe, "__gnat_pipe"); - - function Poll - (Fds : System.Address; - Num_Fds : Integer; - Timeout : Integer; - Is_Set : System.Address) return Integer; - pragma Import (C, Poll, "__gnat_expect_poll"); - -- Check whether there is any data waiting on the file descriptor - -- Out_fd, and wait if there is none, at most Timeout milliseconds - -- Returns -1 in case of error, 0 if the timeout expired before - -- data became available. - -- - -- Out_Is_Set is set to 1 if data was available, 0 otherwise. - - function Waitpid (Pid : Process_Id) return Integer; - pragma Import (C, Waitpid, "__gnat_waitpid"); - -- Wait for a specific process id, and return its exit code - - --------- - -- "+" -- - --------- - - function "+" (S : String) return GNAT.OS_Lib.String_Access is - begin - return new String'(S); - end "+"; - - --------- - -- "+" -- - --------- - - function "+" - (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access - is - begin - return new GNAT.Regpat.Pattern_Matcher'(P); - end "+"; - - ---------------- - -- Add_Filter -- - ---------------- - - procedure Add_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function; - Filter_On : Filter_Type := Output; - User_Data : System.Address := System.Null_Address; - After : Boolean := False) - is - Current : Filter_List := Descriptor.Filters; - - begin - if After then - while Current /= null and then Current.Next /= null loop - Current := Current.Next; - end loop; - - if Current = null then - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - else - Current.Next := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - end if; - - else - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => Descriptor.Filters); - end if; - end Add_Filter; - - ------------------ - -- Call_Filters -- - ------------------ - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type) - is - Current_Filter : Filter_List; - - begin - if Pid.Filters_Lock = 0 then - Current_Filter := Pid.Filters; - - while Current_Filter /= null loop - if Current_Filter.Filter_On = Filter_On then - Current_Filter.Filter - (Pid, Str, Current_Filter.User_Data); - end if; - - Current_Filter := Current_Filter.Next; - end loop; - end if; - end Call_Filters; - - ----------- - -- Close -- - ----------- - - procedure Close - (Descriptor : in out Process_Descriptor; - Status : out Integer) - is - begin - if Descriptor.Input_Fd /= Invalid_FD then - Close (Descriptor.Input_Fd); - end if; - - if Descriptor.Error_Fd /= Descriptor.Output_Fd then - Close (Descriptor.Error_Fd); - end if; - - Close (Descriptor.Output_Fd); - - -- ??? Should have timeouts for different signals - - if Descriptor.Pid > 0 then -- see comment in Send_Signal - Kill (Descriptor.Pid, Sig_Num => 9); - end if; - - GNAT.OS_Lib.Free (Descriptor.Buffer); - Descriptor.Buffer_Size := 0; - - -- Check process id (see comment in Send_Signal) - - if Descriptor.Pid > 0 then - Status := Waitpid (Descriptor.Pid); - else - raise Invalid_Process; - end if; - end Close; - - procedure Close (Descriptor : in out Process_Descriptor) is - Status : Integer; - begin - Close (Descriptor, Status); - end Close; - - ------------ - -- Expect -- - ------------ - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - begin - if Regexp = "" then - Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); - else - Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - begin - pragma Assert (Matched'First = 0); - if Regexp = "" then - Expect - (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); - else - Expect - (Descriptor, Result, Compile (Regexp), Matched, Timeout, - Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; - Timeout_Tmp : Integer := Timeout; - - begin - pragma Assert (Matched'First = 0); - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - - -- Else try to read new input - - Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - - case N is - when Expect_Internal_Error | Expect_Process_Died => - raise Process_Died; - - when Expect_Timeout | Expect_Full_Buffer => - Result := N; - return; - - when others => - null; -- See below - end case; - - -- Calculate the timeout for the next turn - - -- Note that Timeout is, from the caller's perspective, the maximum - -- time until a match, not the maximum time until some output is - -- read, and thus cannot be reused as is for Expect_Internal. - - if Timeout /= -1 then - Timeout_Tmp := Integer (Try_Until - Clock) * 1000; - - if Timeout_Tmp < 0 then - Result := Expect_Timeout; - exit; - end if; - end if; - end loop; - - -- Even if we had the general timeout above, we have to test that the - -- last test we read from the external process didn't match. - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - - begin - Expect (Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - begin - pragma Assert (Matched'First = 0); - - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - if Descriptor.Buffer /= null then - for J in Regexps'Range loop - Match - (Regexps (J).all, - Descriptor.Buffer (1 .. Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end loop; - end if; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - case N is - when Expect_Internal_Error | Expect_Process_Died => - raise Process_Died; - - when Expect_Timeout | Expect_Full_Buffer => - Result := N; - return; - - when others => - null; -- Continue - end case; - end loop; - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Descriptors'Range loop - Descriptors (J) := Regexps (J).Descriptor; - - if Descriptors (J) /= null then - Reinitialize_Buffer (Regexps (J).Descriptor.all); - end if; - end loop; - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - for J in Regexps'Range loop - if Regexps (J).Regexp /= null - and then Regexps (J).Descriptor /= null - then - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end if; - end loop; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - case N is - when Expect_Internal_Error | Expect_Process_Died => - raise Process_Died; - - when Expect_Timeout | Expect_Full_Buffer => - Result := N; - return; - - when others => - null; -- Continue - end case; - end loop; - end Expect; - - --------------------- - -- Expect_Internal -- - --------------------- - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean) - is - Num_Descriptors : Integer; - Buffer_Size : Integer := 0; - - N : Integer; - - type File_Descriptor_Array is - array (0 .. Descriptors'Length - 1) of File_Descriptor; - Fds : aliased File_Descriptor_Array; - Fds_Count : Natural := 0; - - Fds_To_Descriptor : array (Fds'Range) of Integer; - -- Maps file descriptor entries from Fds to entries in Descriptors. - -- They do not have the same index when entries in Descriptors are null. - - type Integer_Array is array (Fds'Range) of Integer; - Is_Set : aliased Integer_Array; - - begin - for J in Descriptors'Range loop - if Descriptors (J) /= null then - Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; - Fds_To_Descriptor (Fds'First + Fds_Count) := J; - Fds_Count := Fds_Count + 1; - - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); - end if; - end if; - end loop; - - declare - Buffer : aliased String (1 .. Buffer_Size); - -- Buffer used for input. This is allocated only once, not for - -- every iteration of the loop - - D : Integer; - -- Index in Descriptors - - begin - -- Loop until we match or we have a timeout - - loop - Num_Descriptors := - Poll (Fds'Address, Fds_Count, Timeout, Is_Set'Address); - - case Num_Descriptors is - - -- Error? - - when -1 => - Result := Expect_Internal_Error; - return; - - -- Timeout? - - when 0 => - Result := Expect_Timeout; - return; - - -- Some input - - when others => - for F in Fds'Range loop - if Is_Set (F) = 1 then - D := Fds_To_Descriptor (F); - - Buffer_Size := Descriptors (D).Buffer_Size; - - if Buffer_Size = 0 then - Buffer_Size := 4096; - end if; - - N := Read (Descriptors (D).Output_Fd, Buffer'Address, - Buffer_Size); - - -- Error or End of file - - if N <= 0 then - -- ??? Note that ddd tries again up to three times - -- in that case. See LiterateA.C:174 - - Descriptors (D).Input_Fd := Invalid_FD; - Result := Expect_Process_Died; - return; - - else - -- If there is no limit to the buffer size - - if Descriptors (D).Buffer_Size = 0 then - - declare - Tmp : String_Access := Descriptors (D).Buffer; - - begin - if Tmp /= null then - Descriptors (D).Buffer := - new String (1 .. Tmp'Length + N); - Descriptors (D).Buffer (1 .. Tmp'Length) := - Tmp.all; - Descriptors (D).Buffer - (Tmp'Length + 1 .. Tmp'Length + N) := - Buffer (1 .. N); - Free (Tmp); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer'Last; - - else - Descriptors (D).Buffer := - new String (1 .. N); - Descriptors (D).Buffer.all := - Buffer (1 .. N); - Descriptors (D).Buffer_Index := N; - end if; - end; - - else - -- Add what we read to the buffer - - if Descriptors (D).Buffer_Index + N > - Descriptors (D).Buffer_Size - then - -- If the user wants to know when we have - -- read more than the buffer can contain. - - if Full_Buffer then - Result := Expect_Full_Buffer; - return; - end if; - - -- Keep as much as possible from the buffer, - -- and forget old characters. - - Descriptors (D).Buffer - (1 .. Descriptors (D).Buffer_Size - N) := - Descriptors (D).Buffer - (N - Descriptors (D).Buffer_Size + - Descriptors (D).Buffer_Index + 1 .. - Descriptors (D).Buffer_Index); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer_Size - N; - end if; - - -- Keep what we read in the buffer - - Descriptors (D).Buffer - (Descriptors (D).Buffer_Index + 1 .. - Descriptors (D).Buffer_Index + N) := - Buffer (1 .. N); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer_Index + N; - end if; - - -- Call each of the output filter with what we - -- read. - - Call_Filters - (Descriptors (D).all, Buffer (1 .. N), Output); - - Result := Expect_Match (D); - return; - end if; - end if; - end loop; - end case; - end loop; - end; - end Expect_Internal; - - ---------------- - -- Expect_Out -- - ---------------- - - function Expect_Out (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); - end Expect_Out; - - ---------------------- - -- Expect_Out_Match -- - ---------------------- - - function Expect_Out_Match (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer - (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); - end Expect_Out_Match; - - ------------------------ - -- First_Dead_Process -- - ------------------------ - - function First_Dead_Process - (Regexp : Multiprocess_Regexp_Array) return Natural - is - begin - for R in Regexp'Range loop - if Regexp (R).Descriptor /= null - and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD - then - return R; - end if; - end loop; - - return 0; - end First_Dead_Process; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Descriptor : in out Process_Descriptor; - Timeout : Integer := 0) - is - Buffer_Size : constant Integer := 8192; - Num_Descriptors : Integer; - N : Integer; - Is_Set : aliased Integer; - Buffer : aliased String (1 .. Buffer_Size); - - begin - -- Empty the current buffer - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - Reinitialize_Buffer (Descriptor); - - -- Read everything from the process to flush its output - - loop - Num_Descriptors := - Poll (Descriptor.Output_Fd'Address, 1, Timeout, Is_Set'Address); - - case Num_Descriptors is - - -- Error ? - - when -1 => - raise Process_Died; - - -- Timeout => End of flush - - when 0 => - return; - - -- Some input - - when others => - if Is_Set = 1 then - N := Read (Descriptor.Output_Fd, Buffer'Address, - Buffer_Size); - - if N = -1 then - raise Process_Died; - elsif N = 0 then - return; - end if; - end if; - end case; - end loop; - end Flush; - - ---------- - -- Free -- - ---------- - - procedure Free (Regexp : in out Multiprocess_Regexp) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Process_Descriptor'Class, Process_Descriptor_Access); - begin - Unchecked_Free (Regexp.Descriptor); - Free (Regexp.Regexp); - end Free; - - ------------------------ - -- Get_Command_Output -- - ------------------------ - - function Get_Command_Output - (Command : String; - Arguments : GNAT.OS_Lib.Argument_List; - Input : String; - Status : not null access Integer; - Err_To_Out : Boolean := False) return String - is - use GNAT.Expect; - - Process : Process_Descriptor; - - Output : String_Access := new String (1 .. 1024); - -- Buffer used to accumulate standard output from the launched - -- command, expanded as necessary during execution. - - Last : Integer := 0; - -- Index of the last used character within Output - - begin - Non_Blocking_Spawn - (Process, Command, Arguments, Err_To_Out => Err_To_Out); - - if Input'Length > 0 then - Send (Process, Input); - end if; - - GNAT.OS_Lib.Close (Get_Input_Fd (Process)); - - declare - Result : Expect_Match; - - begin - -- This loop runs until the call to Expect raises Process_Died - - loop - Expect (Process, Result, ".+"); - - declare - NOutput : String_Access; - S : constant String := Expect_Out (Process); - pragma Assert (S'Length > 0); - - begin - -- Expand buffer if we need more space - - if Last + S'Length > Output'Last then - NOutput := new String (1 .. 2 * Output'Last); - NOutput (Output'Range) := Output.all; - Free (Output); - - -- Here if current buffer size is OK - - else - NOutput := Output; - end if; - - NOutput (Last + 1 .. Last + S'Length) := S; - Last := Last + S'Length; - Output := NOutput; - end; - end loop; - - exception - when Process_Died => - Close (Process, Status.all); - end; - - if Last = 0 then - return ""; - end if; - - declare - S : constant String := Output (1 .. Last); - begin - Free (Output); - return S; - end; - end Get_Command_Output; - - ------------------ - -- Get_Error_Fd -- - ------------------ - - function Get_Error_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Error_Fd; - end Get_Error_Fd; - - ------------------ - -- Get_Input_Fd -- - ------------------ - - function Get_Input_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Input_Fd; - end Get_Input_Fd; - - ------------------- - -- Get_Output_Fd -- - ------------------- - - function Get_Output_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Output_Fd; - end Get_Output_Fd; - - ------------- - -- Get_Pid -- - ------------- - - function Get_Pid - (Descriptor : Process_Descriptor) return Process_Id - is - begin - return Descriptor.Pid; - end Get_Pid; - - ----------------- - -- Has_Process -- - ----------------- - - function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is - begin - return Regexp /= (Regexp'Range => (null, null)); - end Has_Process; - - --------------- - -- Interrupt -- - --------------- - - procedure Interrupt (Descriptor : in out Process_Descriptor) is - SIGINT : constant := 2; - begin - Send_Signal (Descriptor, SIGINT); - end Interrupt; - - ------------------ - -- Lock_Filters -- - ------------------ - - procedure Lock_Filters (Descriptor : in out Process_Descriptor) is - begin - Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; - end Lock_Filters; - - ------------------------ - -- Non_Blocking_Spawn -- - ------------------------ - - procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) - is separate; - - ------------------------- - -- Reinitialize_Buffer -- - ------------------------- - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class) - is - begin - if Descriptor.Buffer_Size = 0 then - declare - Tmp : String_Access := Descriptor.Buffer; - - begin - Descriptor.Buffer := - new String - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); - - if Tmp /= null then - Descriptor.Buffer.all := Tmp - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - Free (Tmp); - end if; - end; - - Descriptor.Buffer_Index := Descriptor.Buffer'Last; - - else - Descriptor.Buffer - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := - Descriptor.Buffer - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - - if Descriptor.Buffer_Index > Descriptor.Last_Match_End then - Descriptor.Buffer_Index := - Descriptor.Buffer_Index - Descriptor.Last_Match_End; - else - Descriptor.Buffer_Index := 0; - end if; - end if; - - Descriptor.Last_Match_Start := 0; - Descriptor.Last_Match_End := 0; - end Reinitialize_Buffer; - - ------------------- - -- Remove_Filter -- - ------------------- - - procedure Remove_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function) - is - Previous : Filter_List := null; - Current : Filter_List := Descriptor.Filters; - - begin - while Current /= null loop - if Current.Filter = Filter then - if Previous = null then - Descriptor.Filters := Current.Next; - else - Previous.Next := Current.Next; - end if; - end if; - - Previous := Current; - Current := Current.Next; - end loop; - end Remove_Filter; - - ---------- - -- Send -- - ---------- - - procedure Send - (Descriptor : in out Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False) - is - Full_Str : constant String := Str & ASCII.LF; - Last : Natural; - Result : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - Discard : Natural; - - begin - if Empty_Buffer then - - -- Force a read on the process if there is anything waiting - - Expect_Internal (Descriptors, Result, - Timeout => 0, Full_Buffer => False); - - if Result = Expect_Internal_Error - or else Result = Expect_Process_Died - then - raise Process_Died; - end if; - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - - -- Empty the buffer - - Reinitialize_Buffer (Descriptor); - end if; - - Last := (if Add_LF then Full_Str'Last else Full_Str'Last - 1); - - Call_Filters (Descriptor, Full_Str (Full_Str'First .. Last), Input); - - Discard := - Write (Descriptor.Input_Fd, - Full_Str'Address, - Last - Full_Str'First + 1); - -- Shouldn't we at least have a pragma Assert on the result ??? - end Send; - - ----------------- - -- Send_Signal -- - ----------------- - - procedure Send_Signal - (Descriptor : Process_Descriptor; - Signal : Integer) - is - begin - -- A nonpositive process id passed to kill has special meanings. For - -- example, -1 means kill all processes in sight, including self, in - -- POSIX and Windows (and something slightly different in Linux). See - -- man pages for details. In any case, we don't want to do that. Note - -- that Descriptor.Pid will be -1 if the process was not successfully - -- started; we don't want to kill ourself in that case. - - if Descriptor.Pid > 0 then - Kill (Descriptor.Pid, Signal); - -- ??? Need to check process status here - else - raise Invalid_Process; - end if; - end Send_Signal; - - --------------------------------- - -- Set_Up_Child_Communications -- - --------------------------------- - - procedure Set_Up_Child_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : String; - Args : System.Address) - is - pragma Warnings (Off, Pid); - pragma Warnings (Off, Pipe1); - pragma Warnings (Off, Pipe2); - pragma Warnings (Off, Pipe3); - - begin - -- Since the code between fork and exec on VMS executes - -- in the context of the parent process, we need to - -- perform the following actions: - -- - save stdin, stdout, stderr - -- - replace them by our pipes - -- - create the child with process handle inheritance - -- - revert to the previous stdin, stdout and stderr. - - Save_Input := Dup (GNAT.OS_Lib.Standin); - Save_Output := Dup (GNAT.OS_Lib.Standout); - Save_Error := Dup (GNAT.OS_Lib.Standerr); - - -- Since we are still called from the parent process, there is no way - -- currently we can cleanly close the unneeded ends of the pipes, but - -- this doesn't really matter. - - -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input - - Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); - Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); - Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); - - Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); - end Set_Up_Child_Communications; - - --------------------------- - -- Set_Up_Communications -- - --------------------------- - - procedure Set_Up_Communications - (Pid : in out Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : not null access Pipe_Type; - Pipe2 : not null access Pipe_Type; - Pipe3 : not null access Pipe_Type) - is - begin - -- Create the pipes - - if Create_Pipe (Pipe1) /= 0 then - return; - end if; - - if Create_Pipe (Pipe2) /= 0 then - return; - end if; - - Pid.Input_Fd := Pipe1.Output; - Pid.Output_Fd := Pipe2.Input; - - if Err_To_Out then - Pipe3.all := Pipe2.all; - else - if Create_Pipe (Pipe3) /= 0 then - return; - end if; - end if; - - Pid.Error_Fd := Pipe3.Input; - end Set_Up_Communications; - - ---------------------------------- - -- Set_Up_Parent_Communications -- - ---------------------------------- - - procedure Set_Up_Parent_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type) - is - pragma Warnings (Off, Pid); - pragma Warnings (Off, Pipe1); - pragma Warnings (Off, Pipe2); - pragma Warnings (Off, Pipe3); - - begin - - Dup2 (Save_Input, GNAT.OS_Lib.Standin); - Dup2 (Save_Output, GNAT.OS_Lib.Standout); - Dup2 (Save_Error, GNAT.OS_Lib.Standerr); - - Close (Save_Input); - Close (Save_Output); - Close (Save_Error); - - Close (Pipe1.Input); - Close (Pipe2.Output); - Close (Pipe3.Output); - end Set_Up_Parent_Communications; - - ------------------ - -- Trace_Filter -- - ------------------ - - procedure Trace_Filter - (Descriptor : Process_Descriptor'Class; - Str : String; - User_Data : System.Address := System.Null_Address) - is - pragma Warnings (Off, Descriptor); - pragma Warnings (Off, User_Data); - begin - GNAT.IO.Put (Str); - end Trace_Filter; - - -------------------- - -- Unlock_Filters -- - -------------------- - - procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is - begin - if Descriptor.Filters_Lock > 0 then - Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; - end if; - end Unlock_Filters; - -end GNAT.Expect; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb deleted file mode 100644 index e2adc8c488d..00000000000 --- a/gcc/ada/g-socthi-vms.adb +++ /dev/null @@ -1,501 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2014, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the version for OpenVMS - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin is - - type VMS_Msghdr is new Msghdr; - pragma Pack (VMS_Msghdr); - -- On VMS 8.x (unlike other platforms), struct msghdr is packed, so a - -- specific derived type is required. This structure was not packed on - -- VMS 7.3. - - function Is_VMS_V7 return Integer; - pragma Import (C, Is_VMS_V7, "__gnat_is_vms_v7"); - -- Helper (defined in init.c) that returns a non-zero value if the VMS - -- version is 7.x. - - VMS_V7 : constant Boolean := Is_VMS_V7 /= 0; - -- True if VMS version is 7.x. - - Non_Blocking_Sockets : aliased Fd_Set; - -- When this package is initialized with Process_Blocking_IO set to True, - -- sockets are set in non-blocking mode to avoid blocking the whole process - -- when a thread wants to perform a blocking IO operation. But the user can - -- also set a socket in non-blocking mode by purpose. In order to make a - -- difference between these two situations, we track the origin of - -- non-blocking mode in Non_Blocking_Sockets. Note that if S is in - -- Non_Blocking_Sockets, it has been set in non-blocking mode by the user. - - Quantum : constant Duration := 0.2; - -- When SOSC.Thread_Blocking_IO is False, we set sockets to non-blocking - -- mode and we spend a period of time Quantum between two attempts on a - -- blocking operation. - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Accept, "accept"); - - function Syscall_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (C, Syscall_Connect, "connect"); - - function Syscall_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recv, "recv"); - - function Syscall_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recvmsg, "recvmsg"); - - function Syscall_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Sendmsg, "sendmsg"); - - function Syscall_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - pragma Import (C, Syscall_Sendto, "sendto"); - - function Syscall_Socket - (Domain, Typ, Protocol : C.int) return C.int; - pragma Import (C, Syscall_Socket, "socket"); - - function Non_Blocking_Socket (S : C.int) return Boolean; - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); - - -------------- - -- C_Accept -- - -------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Discard : C.int; - pragma Warnings (Off, Discard); - - begin - loop - R := Syscall_Accept (S, Addr, Addrlen); - exit when SOSC.Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties of its server, especially - -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - end if; - - return R; - end C_Accept; - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Syscall_Connect (S, Name, Namelen); - - if SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EINPROGRESS - then - return Res; - end if; - - declare - WSet : aliased Fd_Set; - Now : aliased Timeval; - - begin - Reset_Socket_Set (WSet'Access); - loop - Insert_Socket_In_Set (WSet'Access, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set_Access, - WSet'Access, - No_Fd_Set_Access, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - return Res; - end if; - - delay Quantum; - end loop; - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure and then Errno = SOSC.EISCONN then - return Thin_Common.Success; - else - return Res; - end if; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return C_Ioctl (S, Req, Arg); - end Socket_Ioctl; - - ------------ - -- C_Recv -- - ------------ - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recv (S, Msg, Len, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recv; - - ---------------- - -- C_Recvfrom -- - ---------------- - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - Msg_Addr : System.Address; - - GNAT_Msg : Msghdr; - for GNAT_Msg'Address use Msg; - pragma Import (Ada, GNAT_Msg); - - VMS_Msg : aliased VMS_Msghdr; - - begin - if VMS_V7 then - Msg_Addr := Msg; - else - VMS_Msg := VMS_Msghdr (GNAT_Msg); - Msg_Addr := VMS_Msg'Address; - end if; - - loop - Res := Syscall_Recvmsg (S, Msg_Addr, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not VMS_V7 then - GNAT_Msg := Msghdr (VMS_Msg); - end if; - - return System.CRTL.ssize_t (Res); - end C_Recvmsg; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - Msg_Addr : System.Address; - - GNAT_Msg : Msghdr; - for GNAT_Msg'Address use Msg; - pragma Import (Ada, GNAT_Msg); - - VMS_Msg : aliased VMS_Msghdr; - - begin - if VMS_V7 then - Msg_Addr := Msg; - else - VMS_Msg := VMS_Msghdr (GNAT_Msg); - Msg_Addr := VMS_Msg'Address; - end if; - - loop - Res := Syscall_Sendmsg (S, Msg_Addr, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not VMS_V7 then - GNAT_Msg := Msghdr (VMS_Msg); - end if; - - return System.CRTL.ssize_t (Res); - end C_Sendmsg; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Sendto; - - -------------- - -- C_Socket -- - -------------- - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Discard : C.int; - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- Do not use Socket_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - Set_Non_Blocking_Socket (R, False); - end if; - - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is separate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Reset_Socket_Set (Non_Blocking_Sockets'Access); - end Initialize; - - ------------------------- - -- Non_Blocking_Socket -- - ------------------------- - - function Non_Blocking_Socket (S : C.int) return Boolean is - R : Boolean; - begin - Task_Lock.Lock; - R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------------------- - -- Set_Non_Blocking_Socket -- - ----------------------------- - - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is - begin - Task_Lock.Lock; - - if V then - Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is separate; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads deleted file mode 100644 index 25c58705703..00000000000 --- a/gcc/ada/g-socthi-vms.ads +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2013, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the Alpha/VMS version - -with Interfaces.C; - -with GNAT.OS_Lib; -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - -- ??? more comments needed ??? - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; - -- Returns last socket error number - - procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno; - -- Set last socket error number - - function Socket_Error_Message (Errno : Integer) return String; - -- Returns the error message string for the error number Errno. If Errno is - -- not known, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Close - (Fd : C.int) return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : C.int) return C.int; - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - - function C_System - (Command : System.Address) return C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - ------------------------------------------- - -- Nonreentrant network databases access -- - ------------------------------------------- - - function Nonreentrant_Gethostbyname - (Name : C.char_array) return Hostent_Access; - - function Nonreentrant_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int) return Hostent_Access; - - function Nonreentrant_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access; - - function Nonreentrant_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access; - - procedure Initialize; - procedure Finalize; - -private - - pragma Import (C, C_Bind, "DECC$BIND"); - pragma Import (C, C_Close, "DECC$CLOSE"); - pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); - pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); - pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); - pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); - pragma Import (C, C_Listen, "DECC$LISTEN"); - pragma Import (C, C_Select, "DECC$SELECT"); - pragma Import (C, C_Setsockopt, "DECC$SETSOCKOPT"); - pragma Import (C, C_Shutdown, "DECC$SHUTDOWN"); - pragma Import (C, C_System, "DECC$SYSTEM"); - - pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); - pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR"); - pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME"); - pragma Import (C, Nonreentrant_Getservbyport, "DECC$GETSERVBYPORT"); - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/i-cstrea-vms.adb b/gcc/ada/i-cstrea-vms.adb deleted file mode 100644 index 85e6f56b31a..00000000000 --- a/gcc/ada/i-cstrea-vms.adb +++ /dev/null @@ -1,253 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version - -with Ada.Unchecked_Conversion; -package body Interfaces.C_Streams is - - use type System.CRTL.size_t; - - -- As the functions fread, fwrite and setvbuf are too big to be inlined, - -- they are just wrappers to the following implementation functions. - - function fread_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function fread_impl - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function fwrite_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function setvbuf_impl - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int; - - ------------ - -- fread -- - ------------ - - function fread_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - Get_Count : size_t := 0; - - type Buffer_Type is array (size_t range 1 .. count, - size_t range 1 .. size) of Character; - type Buffer_Access is access Buffer_Type; - function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); - - BA : constant Buffer_Access := To_BA (buffer); - Ch : int; - - begin - -- This Fread goes with the Fwrite below. The C library fread sometimes - -- can't read fputc generated files. - - for C in 1 .. count loop - for S in 1 .. size loop - Ch := fgetc (stream); - - if Ch = EOF then - return Get_Count; - end if; - - BA.all (C, S) := Character'Val (Ch); - end loop; - - Get_Count := Get_Count + 1; - end loop; - - return Get_Count; - end fread_impl; - - function fread_impl - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - Get_Count : size_t := 0; - - type Buffer_Type is array (size_t range 1 .. count, - size_t range 1 .. size) of Character; - type Buffer_Access is access Buffer_Type; - function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); - - BA : constant Buffer_Access := To_BA (buffer); - Ch : int; - - begin - -- This Fread goes with the Fwrite below. The C library fread sometimes - -- can't read fputc generated files. - - for C in 1 + index .. count + index loop - for S in 1 .. size loop - Ch := fgetc (stream); - - if Ch = EOF then - return Get_Count; - end if; - - BA.all (C, S) := Character'Val (Ch); - end loop; - - Get_Count := Get_Count + 1; - end loop; - - return Get_Count; - end fread_impl; - - function fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return fread_impl (buffer, size, count, stream); - end fread; - - function fread - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return fread_impl (buffer, index, size, count, stream); - end fread; - - ------------ - -- fwrite -- - ------------ - - function fwrite_impl - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - Put_Count : size_t := 0; - - type Buffer_Type is array (size_t range 1 .. count, - size_t range 1 .. size) of Character; - type Buffer_Access is access Buffer_Type; - function To_BA is new Ada.Unchecked_Conversion (voids, Buffer_Access); - - BA : constant Buffer_Access := To_BA (buffer); - - begin - -- Fwrite on VMS has the undesirable effect of always generating at - -- least one record of output per call, regardless of buffering. To - -- get around this, we do multiple fputc calls instead. - - for C in 1 .. count loop - for S in 1 .. size loop - if fputc (Character'Pos (BA.all (C, S)), stream) = EOF then - return Put_Count; - end if; - end loop; - - Put_Count := Put_Count + 1; - end loop; - - return Put_Count; - end fwrite_impl; - - function fwrite - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return fwrite_impl (buffer, size, count, stream); - end fwrite; - - ------------- - -- setvbuf -- - ------------- - - function setvbuf_impl - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int - is - use type System.Address; - - begin - -- In order for the above fwrite hack to work, we must always buffer - -- stdout and stderr. Is_regular_file on VMS cannot detect when - -- these are redirected to a file, so checking for that condition - -- doesn't help. - - if mode = IONBF - and then (stream = stdout or else stream = stderr) - then - return System.CRTL.setvbuf - (stream, buffer, IOLBF, System.CRTL.size_t (size)); - else - return System.CRTL.setvbuf - (stream, buffer, mode, System.CRTL.size_t (size)); - end if; - end setvbuf_impl; - - function setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int - is - begin - return setvbuf_impl (stream, buffer, mode, size); - end setvbuf; - -end Interfaces.C_Streams; diff --git a/gcc/ada/mlib-tgt-specific-vms-alpha.adb b/gcc/ada/mlib-tgt-specific-vms-alpha.adb deleted file mode 100644 index 082cbbebcd4..00000000000 --- a/gcc/ada/mlib-tgt-specific-vms-alpha.adb +++ /dev/null @@ -1,509 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . S P E C I F I C -- --- (Alpha VMS Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha VMS version of the body - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -with MLib.Fil; -with MLib.Utl; - -with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common; - -with Opt; use Opt; -with Output; use Output; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System; use System; -with System.Case_Util; use System.Case_Util; -with System.CRTL; use System.CRTL; - -package body MLib.Tgt.Specific is - - -- Non default subprogram. See comment in mlib-tgt.ads - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - -- Local variables - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Libgcc_Switch : constant Argument_List := - (1 => Shared_Libgcc'Access); - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. For other libraries, always - -- return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is - -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy - -- is Autonomous, fails gnatmake if Lib_Version is not the image of a - -- positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 2) = "b__" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Path then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - - begin - if Lib_Version = "" - or else Symbol_Data.Symbol_Policy /= Autonomous - then - return ""; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """ - & Lib_Version - & """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - --------------------- - -- Local Variables -- - --------------------- - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- If option file name does not ends with ".opt", append "/OPTIONS" - -- to its specification for the VMS linker. - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - For_Linker_Opt := - new String'("--for-linker=" & Opt_File_Name & "/OPTIONS"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name & " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "__init.asm"; - Macro_File : File_Descriptor; - Init_Proc : constant String := Init_Proc_Name (Lib_Filename); - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - - mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - - begin - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - use ASCII; - - -- Output a dummy transfer address for debugging - -- followed by the LIB$INITIALIZE section. - - Lines : constant String := - HT & ".text" & LF & - HT & ".align 4" & LF & - HT & ".globl __main" & LF & - HT & ".ent __main" & LF & - "__main..en:" & LF & - HT & ".base $27" & LF & - HT & ".frame $29,0,$26,8" & LF & - HT & "ret $31,($26),1" & LF & - HT & ".link" & LF & - "__main:" & LF & - HT & ".pdesc __main..en,null" & LF & - HT & ".end __main" & LF & LF & - HT & ".section LIB$INITIALIZE,GBL,NOWRT" & LF & - HT & ".long " & Init_Proc & LF; - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, Lines (Lines'First)'Address, - Lines'Length); - OK := Len = Lines'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := popen (command (command'First)'Address, - mode (mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "__init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Path then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - - when Restricted => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-R"); - - when Direct => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-D"); - - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """ - & Lib_Filename - & """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Shared_Libgcc_Switch & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "__init.obj"; - Disregard : Boolean; - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - --- Package initialization - -begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; -end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-specific-vms-ia64.adb b/gcc/ada/mlib-tgt-specific-vms-ia64.adb deleted file mode 100644 index c2958586097..00000000000 --- a/gcc/ada/mlib-tgt-specific-vms-ia64.adb +++ /dev/null @@ -1,513 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . S P E C I F I C -- --- (Integrity VMS Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Integrity VMS version of the body - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -with MLib.Fil; -with MLib.Utl; - -with MLib.Tgt.VMS_Common; use MLib.Tgt.VMS_Common; - -with Opt; use Opt; -with Output; use Output; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; - -with System; use System; -with System.Case_Util; use System.Case_Util; -with System.CRTL; use System.CRTL; - -package body MLib.Tgt.Specific is - - -- Non default subprogram, see comment in mlib-tgt.ads - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False); - - -- Local variables - - Empty_Argument_List : aliased Argument_List := (1 .. 0 => null); - Additional_Objects : Argument_List_Access := Empty_Argument_List'Access; - -- Used to add the generated auto-init object files for auto-initializing - -- stand-alone libraries. - - Macro_Name : constant String := "mcr gnu:[bin]gcc -c -x assembler"; - -- The name of the command to invoke the macro-assembler - - VMS_Options : Argument_List := (1 .. 1 => null); - - Gnatsym_Name : constant String := "gnatsym"; - - Gnatsym_Path : String_Access; - - Arguments : Argument_List_Access := null; - Last_Argument : Natural := 0; - - Success : Boolean := False; - - Shared_Libgcc : aliased String := "-shared-libgcc"; - - Shared_Libgcc_Switch : constant Argument_List := - (1 => Shared_Libgcc'Access); - - --------------------------- - -- Build_Dynamic_Library -- - --------------------------- - - procedure Build_Dynamic_Library - (Ofiles : Argument_List; - Options : Argument_List; - Interfaces : Argument_List; - Lib_Filename : String; - Lib_Dir : String; - Symbol_Data : Symbol_Record; - Driver_Name : Name_Id := No_Name; - Lib_Version : String := ""; - Auto_Init : Boolean := False) - is - - Lib_File : constant String := - Lib_Dir & Directory_Separator & "lib" & - Fil.Ext_To (Lib_Filename, DLL_Ext); - - Opts : Argument_List := Options; - Last_Opt : Natural := Opts'Last; - Opts2 : Argument_List (Options'Range); - Last_Opt2 : Natural := Opts2'First - 1; - - Inter : constant Argument_List := Interfaces; - - function Is_Interface (Obj_File : String) return Boolean; - -- For a Stand-Alone Library, returns True if Obj_File is the object - -- file name of an interface of the SAL. For other libraries, always - -- return True. - - function Option_File_Name return String; - -- Returns Symbol_File, if not empty. Otherwise, returns "symvec.opt" - - function Version_String return String; - -- Returns Lib_Version if not empty and if Symbol_Data.Symbol_Policy is - -- not Autonomous, otherwise returns "". When Symbol_Data.Symbol_Policy - -- is Autonomous, fails gnatmake if Lib_Version is not the image of a - -- positive number. - - ------------------ - -- Is_Interface -- - ------------------ - - function Is_Interface (Obj_File : String) return Boolean is - ALI : constant String := - Fil.Ext_To - (Filename => To_Lower (Base_Name (Obj_File)), - New_Ext => "ali"); - - begin - if Inter'Length = 0 then - return True; - - elsif ALI'Length > 2 and then - ALI (ALI'First .. ALI'First + 2) = "b__" - then - return True; - - else - for J in Inter'Range loop - if Inter (J).all = ALI then - return True; - end if; - end loop; - - return False; - end if; - end Is_Interface; - - ---------------------- - -- Option_File_Name -- - ---------------------- - - function Option_File_Name return String is - begin - if Symbol_Data.Symbol_File = No_Path then - return "symvec.opt"; - else - Get_Name_String (Symbol_Data.Symbol_File); - To_Lower (Name_Buffer (1 .. Name_Len)); - return Name_Buffer (1 .. Name_Len); - end if; - end Option_File_Name; - - -------------------- - -- Version_String -- - -------------------- - - function Version_String return String is - Version : Integer := 0; - begin - if Lib_Version = "" - or else Symbol_Data.Symbol_Policy /= Autonomous - then - return ""; - - else - begin - Version := Integer'Value (Lib_Version); - - if Version <= 0 then - raise Constraint_Error; - end if; - - return Lib_Version; - - exception - when Constraint_Error => - Fail ("illegal version """ - & Lib_Version - & """ (on VMS version must be a positive number)"); - return ""; - end; - end if; - end Version_String; - - --------------------- - -- Local Variables -- - --------------------- - - Opt_File_Name : constant String := Option_File_Name; - Version : constant String := Version_String; - For_Linker_Opt : String_Access; - - -- Start of processing for Build_Dynamic_Library - - begin - -- Option file must end with ".opt" - - if Opt_File_Name'Length > 4 - and then - Opt_File_Name (Opt_File_Name'Last - 3 .. Opt_File_Name'Last) = ".opt" - then - For_Linker_Opt := new String'("--for-linker=" & Opt_File_Name); - else - Fail ("Options File """ & Opt_File_Name & """ must end with .opt"); - end if; - - VMS_Options (VMS_Options'First) := For_Linker_Opt; - - for J in Inter'Range loop - To_Lower (Inter (J).all); - end loop; - - -- "gnatsym" is necessary for building the option file - - if Gnatsym_Path = null then - Gnatsym_Path := Locate_Exec_On_Path (Gnatsym_Name); - - if Gnatsym_Path = null then - Fail (Gnatsym_Name & " not found in path"); - end if; - end if; - - -- For auto-initialization of a stand-alone library, we create - -- a macro-assembly file and we invoke the macro-assembler. - - if Auto_Init then - declare - Macro_File_Name : constant String := Lib_Filename & "__init.asm"; - Macro_File : File_Descriptor; - Init_Proc : constant String := Init_Proc_Name (Lib_Filename); - Popen_Result : System.Address; - Pclose_Result : Integer; - Len : Natural; - OK : Boolean := True; - - command : constant String := - Macro_Name & " " & Macro_File_Name & ASCII.NUL; - -- The command to invoke the assembler on the generated auto-init - -- assembly file. - -- Why odd lower case name ??? - - mode : constant String := "r" & ASCII.NUL; - -- The mode for the invocation of Popen - -- Why odd lower case name ??? - - begin - if Verbose_Mode then - Write_Str ("Creating auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - -- Create and write the auto-init assembly file - - declare - use ASCII; - - -- Output a dummy transfer address for debugging - -- followed by the LIB$INITIALIZE section. - - Lines : constant String := - HT & ".pred.safe_across_calls p1-p5,p16-p63" & LF & - HT & ".text" & LF & - HT & ".align 16" & LF & - HT & ".global __main#" & LF & - HT & ".proc __main#" & LF & - "__main:" & LF & - HT & ".prologue" & LF & - HT & ".body" & LF & - HT & ".mib" & LF & - HT & "nop 0" & LF & - HT & "nop 0" & LF & - HT & "br.ret.sptk.many b0" & LF & - HT & ".endp __main#" & LF & LF & - HT & ".type " & Init_Proc & "#, @function" & LF & - HT & ".global " & Init_Proc & "#" & LF & - HT & ".global LIB$INITIALIZE#" & LF & - HT & ".section LIB$INITIALIZE#,""a"",@progbits" & LF & - HT & "data4 @fptr(" & Init_Proc & "#)" & LF; - - begin - Macro_File := Create_File (Macro_File_Name, Text); - OK := Macro_File /= Invalid_FD; - - if OK then - Len := Write - (Macro_File, Lines (Lines'First)'Address, - Lines'Length); - OK := Len = Lines'Length; - end if; - - if OK then - Close (Macro_File, OK); - end if; - - if not OK then - Fail ("creation of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - end; - - -- Invoke the macro-assembler - - if Verbose_Mode then - Write_Str ("Assembling auto-init assembly file """); - Write_Str (Macro_File_Name); - Write_Line (""""); - end if; - - Popen_Result := popen (command (command'First)'Address, - mode (mode'First)'Address); - - if Popen_Result = Null_Address then - Fail ("assembly of auto-init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Wait for the end of execution of the macro-assembler - - Pclose_Result := pclose (Popen_Result); - - if Pclose_Result < 0 then - Fail ("assembly of auto init assembly file """ - & Macro_File_Name - & """ failed"); - end if; - - -- Add the generated object file to the list of objects to be - -- included in the library. - - Additional_Objects := - new Argument_List' - (1 => new String'(Lib_Filename & "__init.obj")); - end; - end if; - - -- Allocate the argument list and put the symbol file name, the - -- reference (if any) and the policy (if not autonomous). - - Arguments := new Argument_List (1 .. Ofiles'Length + 8); - - Last_Argument := 0; - - -- Verbosity - - if Verbose_Mode then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-v"); - end if; - - -- Version number (major ID) - - if Lib_Version /= "" then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-V"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Version); - end if; - - -- Symbol file - - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-s"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Opt_File_Name); - - -- Reference Symbol File - - if Symbol_Data.Reference /= No_Path then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-r"); - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := - new String'(Get_Name_String (Symbol_Data.Reference)); - end if; - - -- Policy - - case Symbol_Data.Symbol_Policy is - when Autonomous => - null; - - when Compliant => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-c"); - - when Controlled => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-C"); - - when Restricted => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-R"); - - when Direct => - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'("-D"); - end case; - - -- Add each relevant object file - - for Index in Ofiles'Range loop - if Is_Interface (Ofiles (Index).all) then - Last_Argument := Last_Argument + 1; - Arguments (Last_Argument) := new String'(Ofiles (Index).all); - end if; - end loop; - - -- Spawn gnatsym - - Spawn (Program_Name => Gnatsym_Path.all, - Args => Arguments (1 .. Last_Argument), - Success => Success); - - if not Success then - Fail ("unable to create symbol file for library """ - & Lib_Filename - & """"); - end if; - - Free (Arguments); - - -- Move all the -l switches from Opts to Opts2 - - declare - Index : Natural := Opts'First; - Opt : String_Access; - - begin - while Index <= Last_Opt loop - Opt := Opts (Index); - - if Opt'Length > 2 and then - Opt (Opt'First .. Opt'First + 1) = "-l" - then - if Index < Last_Opt then - Opts (Index .. Last_Opt - 1) := - Opts (Index + 1 .. Last_Opt); - end if; - - Last_Opt := Last_Opt - 1; - - Last_Opt2 := Last_Opt2 + 1; - Opts2 (Last_Opt2) := Opt; - - else - Index := Index + 1; - end if; - end loop; - end; - - -- Invoke gcc to build the library - - Utl.Gcc - (Output_File => Lib_File, - Objects => Ofiles & Additional_Objects.all, - Options => VMS_Options, - Options_2 => Shared_Libgcc_Switch & - Opts (Opts'First .. Last_Opt) & - Opts2 (Opts2'First .. Last_Opt2), - Driver_Name => Driver_Name); - - -- The auto-init object file need to be deleted, so that it will not - -- be included in the library as a regular object file, otherwise - -- it will be included twice when the library will be built next - -- time, which may lead to errors. - - if Auto_Init then - declare - Auto_Init_Object_File_Name : constant String := - Lib_Filename & "__init.obj"; - - Disregard : Boolean; - pragma Warnings (Off, Disregard); - - begin - if Verbose_Mode then - Write_Str ("deleting auto-init object file """); - Write_Str (Auto_Init_Object_File_Name); - Write_Line (""""); - end if; - - Delete_File (Auto_Init_Object_File_Name, Success => Disregard); - end; - end if; - end Build_Dynamic_Library; - --- Package initialization - -begin - Build_Dynamic_Library_Ptr := Build_Dynamic_Library'Access; -end MLib.Tgt.Specific; diff --git a/gcc/ada/mlib-tgt-vms_common.adb b/gcc/ada/mlib-tgt-vms_common.adb deleted file mode 100644 index 53db3a887d4..00000000000 --- a/gcc/ada/mlib-tgt-vms_common.adb +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . V M S _ C O M M O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2011, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the part of MLib.Tgt.Specific common to both VMS versions - -with System.Case_Util; use System.Case_Util; - -package body MLib.Tgt.VMS_Common is - - -- Non default subprograms. See comments in mlib-tgt.ads - - function Archive_Ext return String; - - function Default_Symbol_File_Name return String; - - function DLL_Ext return String; - - function Is_Object_Ext (Ext : String) return Boolean; - - function Is_Archive_Ext (Ext : String) return Boolean; - - function Libgnat return String; - - function Object_Ext return String; - - function Library_Major_Minor_Id_Supported return Boolean; - - function PIC_Option return String; - - ----------------- - -- Archive_Ext -- - ----------------- - - function Archive_Ext return String is - begin - return "olb"; - end Archive_Ext; - - ------------------------------ - -- Default_Symbol_File_Name -- - ------------------------------ - - function Default_Symbol_File_Name return String is - begin - return "symvec.opt"; - end Default_Symbol_File_Name; - - ------------- - -- DLL_Ext -- - ------------- - - function DLL_Ext return String is - begin - return "exe"; - end DLL_Ext; - - -------------------- - -- Init_Proc_Name -- - -------------------- - - function Init_Proc_Name (Library_Name : String) return String is - Result : String := Library_Name & "INIT"; - begin - To_Upper (Result); - - if Result = "ADAINIT" then - return "ADA_INIT"; - - else - return Result; - end if; - end Init_Proc_Name; - - ------------------- - -- Is_Object_Ext -- - ------------------- - - function Is_Object_Ext (Ext : String) return Boolean is - begin - return Ext = ".obj"; - end Is_Object_Ext; - - -------------------- - -- Is_Archive_Ext -- - -------------------- - - function Is_Archive_Ext (Ext : String) return Boolean is - begin - return Ext = ".olb" or else Ext = ".exe"; - end Is_Archive_Ext; - - ------------- - -- Libgnat -- - ------------- - - function Libgnat return String is - Libgnat_A : constant String := "libgnat.a"; - Libgnat_Olb : constant String := "libgnat.olb"; - - begin - Name_Len := Libgnat_A'Length; - Name_Buffer (1 .. Name_Len) := Libgnat_A; - - if Osint.Find_File (Name_Enter, Osint.Library) /= No_File then - return Libgnat_A; - else - return Libgnat_Olb; - end if; - end Libgnat; - - -------------------------------------- - -- Library_Major_Minor_Id_Supported -- - -------------------------------------- - - function Library_Major_Minor_Id_Supported return Boolean is - begin - return False; - end Library_Major_Minor_Id_Supported; - - ---------------- - -- Object_Ext -- - ---------------- - - function Object_Ext return String is - begin - return "obj"; - end Object_Ext; - - ---------------- - -- PIC_Option -- - ---------------- - - function PIC_Option return String is - begin - return ""; - end PIC_Option; - --- Package initialization - -begin - Archive_Ext_Ptr := Archive_Ext'Access; - Default_Symbol_File_Name_Ptr := Default_Symbol_File_Name'Access; - DLL_Ext_Ptr := DLL_Ext'Access; - Is_Object_Ext_Ptr := Is_Object_Ext'Access; - Is_Archive_Ext_Ptr := Is_Archive_Ext'Access; - Libgnat_Ptr := Libgnat'Access; - Object_Ext_Ptr := Object_Ext'Access; - PIC_Option_Ptr := PIC_Option'Access; - Library_Major_Minor_Id_Supported_Ptr := - Library_Major_Minor_Id_Supported'Access; - -end MLib.Tgt.VMS_Common; diff --git a/gcc/ada/mlib-tgt-vms_common.ads b/gcc/ada/mlib-tgt-vms_common.ads deleted file mode 100644 index 7a4fbb88278..00000000000 --- a/gcc/ada/mlib-tgt-vms_common.ads +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M L I B . T G T . V M S _ C O M M O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2011, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the part of MLib.Tgt.Specific common to both VMS versions - -package MLib.Tgt.VMS_Common is - pragma Elaborate_Body; - - function Init_Proc_Name (Library_Name : String) return String; - -- Returns, in upper case, Library_Name & "INIT", except when Library_Name - -- is "ada" (case insensitive), returns "ADA_INIT". - -end MLib.Tgt.VMS_Common; diff --git a/gcc/ada/namet.h b/gcc/ada/namet.h index 0bc841ac85d..1ca589ba50c 100644 --- a/gcc/ada/namet.h +++ b/gcc/ada/namet.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * Copyright (C) 1992-2012, Free Software Foundation, Inc. * + * Copyright (C) 1992-2014, Free Software Foundation, Inc. * * * * GNAT 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- * @@ -109,9 +109,6 @@ extern char *Spec_Context_List, *Body_Context_List; #define Body_Filename exp_dbug__body_filename extern char *Spec_Filename, *Body_Filename; -#define Is_Non_Ada_Error exp_ch11__is_non_ada_error -extern Boolean Is_Non_Ada_Error (Entity_Id); - /* Here are some functions in sinput.adb we call from trans.c. */ typedef Nat Source_File_Index; diff --git a/gcc/ada/s-asthan-vms-alpha.adb b/gcc/ada/s-asthan-vms-alpha.adb deleted file mode 100644 index 1f09a71be1f..00000000000 --- a/gcc/ada/s-asthan-vms-alpha.adb +++ /dev/null @@ -1,603 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS/Alpha version - -with System; use System; - -with System.IO; - -with System.Machine_Code; -with System.Parameters; -with System.Storage_Elements; - -with System.Tasking; -with System.Tasking.Rendezvous; -with System.Tasking.Initialization; -with System.Tasking.Utilities; - -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - -with Ada.Finalization; -with Ada.Task_Attributes; - -with Ada.Exceptions; use Ada.Exceptions; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body System.AST_Handling is - - package ATID renames Ada.Task_Identification; - - package SP renames System.Parameters; - package ST renames System.Tasking; - package STR renames System.Tasking.Rendezvous; - package STI renames System.Tasking.Initialization; - package STU renames System.Tasking.Utilities; - - package SSE renames System.Storage_Elements; - package STPO renames System.Task_Primitives.Operations; - package STPOD renames System.Task_Primitives.Operations.DEC; - - AST_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion - -- from all other AST tasks. It is only used by Lock_AST and - -- Unlock_AST. - - procedure Lock_AST (Self_ID : ST.Task_Id); - -- Locks out other AST tasks. Preceding a section of code by Lock_AST and - -- following it by Unlock_AST creates a critical region. - - procedure Unlock_AST (Self_ID : ST.Task_Id); - -- Releases lock previously set by call to Lock_AST. - -- All nested locks must be released before other tasks competing for the - -- tasking lock are released. - - -------------- - -- Lock_AST -- - -------------- - - procedure Lock_AST (Self_ID : ST.Task_Id) is - begin - STI.Defer_Abort_Nestable (Self_ID); - STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); - end Lock_AST; - - ---------------- - -- Unlock_AST -- - ---------------- - - procedure Unlock_AST (Self_ID : ST.Task_Id) is - begin - STPO.Unlock (AST_Lock'Access, Global_Lock => True); - STI.Undefer_Abort_Nestable (Self_ID); - end Unlock_AST; - - --------------------------------- - -- AST_Handler Data Structures -- - --------------------------------- - - -- As noted in the private part of the spec of System.Aux_DEC, the - -- AST_Handler type is simply a pointer to a procedure that takes - -- a single 64bit parameter. The following is a local copy - -- of that definition. - - -- We need our own copy because we need to get our hands on this - -- and we cannot see the private part of System.Aux_DEC. We don't - -- want to be a child of Aux_Dec because of complications resulting - -- from the use of pragma Extend_System. We will use unchecked - -- conversions between the two versions of the declarations. - - type AST_Handler is access procedure (Param : Long_Integer); - - -- However, this declaration is somewhat misleading, since the values - -- referenced by AST_Handler values (all produced in this package by - -- calls to Create_AST_Handler) are highly stylized. - - -- The first point is that in VMS/Alpha, procedure pointers do not in - -- fact point to code, but rather to a 48-byte procedure descriptor. - -- So a value of type AST_Handler is in fact a pointer to one of these - -- 48-byte descriptors. - - type Descriptor_Type is new SSE.Storage_Array (1 .. 48); - for Descriptor_Type'Alignment use Standard'Maximum_Alignment; - - type Descriptor_Ref is access all Descriptor_Type; - - -- Normally, there is only one such descriptor for a given procedure, but - -- it works fine to make a copy of the single allocated descriptor, and - -- use the copy itself, and we take advantage of this in the design here. - -- The idea is that AST_Handler values will all point to a record with the - -- following structure: - - -- Note: When we say it works fine, there is one delicate point, which - -- is that the code for the AST procedure itself requires the original - -- descriptor address. We handle this by saving the original descriptor - -- address in this structure and restoring in Process_AST. - - type AST_Handler_Data is record - Descriptor : Descriptor_Type; - Original_Descriptor_Ref : Descriptor_Ref; - Taskid : ATID.Task_Id; - Entryno : Natural; - end record; - - type AST_Handler_Data_Ref is access all AST_Handler_Data; - - function To_AST_Handler is new Ada.Unchecked_Conversion - (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); - - -- Each time Create_AST_Handler is called, a new value of this record - -- type is created, containing a copy of the procedure descriptor for - -- the routine used to handle all AST's (Process_AST), and the Task_Id - -- and entry number parameters identifying the task entry involved. - - -- The AST_Handler value returned is a pointer to this record. Since - -- the record starts with the procedure descriptor, it can be used - -- by the system in the normal way to call the procedure. But now - -- when the procedure gets control, it can determine the address of - -- the procedure descriptor used to call it (since the ABI specifies - -- that this is left sitting in register r27 on entry), and then use - -- that address to retrieve the Task_Id and entry number so that it - -- knows on which entry to queue the AST request. - - -- The next issue is where are these records placed. Since we intend - -- to pass pointers to these records to asynchronous system service - -- routines, they have to be on the heap, which means we have to worry - -- about when to allocate them and deallocate them. - - -- We solve this problem by introducing a task attribute that points to - -- a vector, indexed by the entry number, of AST_Handler_Data records - -- for a given task. The pointer itself is a controlled object allowing - -- us to write a finalization routine that frees the referenced vector. - - -- An entry in this vector is either initialized (Entryno non-zero) and - -- can be used for any subsequent reference to the same entry, or it is - -- unused, marked by the Entryno value being zero. - - type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; - type AST_Handler_Vector_Ref is access all AST_Handler_Vector; - - type AST_Vector_Ptr is new Ada.Finalization.Controlled with record - Vector : AST_Handler_Vector_Ref; - end record; - - procedure Finalize (Obj : in out AST_Vector_Ptr); - -- Override Finalize so that the AST Vector gets freed. - - procedure Finalize (Obj : in out AST_Vector_Ptr) is - procedure Free is new - Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); - begin - if Obj.Vector /= null then - Free (Obj.Vector); - end if; - end Finalize; - - AST_Vector_Init : AST_Vector_Ptr; - -- Initial value, treated as constant, Vector will be null - - package AST_Attribute is new Ada.Task_Attributes - (Attribute => AST_Vector_Ptr, - Initial_Value => AST_Vector_Init); - - use AST_Attribute; - - ----------------------- - -- AST Service Queue -- - ----------------------- - - -- The following global data structures are used to queue pending - -- AST requests. When an AST is signalled, the AST service routine - -- Process_AST is called, and it makes an entry in this structure. - - type AST_Instance is record - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : Long_Integer; - end record; - -- The Taskid and Entryno indicate the entry on which this AST is to - -- be queued, and Param is the parameter provided from the AST itself. - - AST_Service_Queue_Size : constant := 256; - AST_Service_Queue_Limit : constant := 250; - type AST_Service_Queue_Index is mod AST_Service_Queue_Size; - -- Index used to refer to entries in the circular buffer which holds - -- active AST_Instance values. The upper bound reflects the maximum - -- number of AST instances that can be stored in the buffer. Since - -- these entries are immediately serviced by the high priority server - -- task that does the actual entry queuing, it is very unusual to have - -- any significant number of entries simultaneously queued. - - AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; - pragma Volatile_Components (AST_Service_Queue); - -- The circular buffer used to store active AST requests - - AST_Service_Queue_Put : AST_Service_Queue_Index := 0; - AST_Service_Queue_Get : AST_Service_Queue_Index := 0; - pragma Atomic (AST_Service_Queue_Put); - pragma Atomic (AST_Service_Queue_Get); - -- These two variables point to the next slots in the AST_Service_Queue - -- to be used for putting a new entry in and taking an entry out. This - -- is a circular buffer, so these pointers wrap around. If the two values - -- are equal the buffer is currently empty. The pointers are atomic to - -- ensure proper synchronization between the single producer (namely the - -- Process_AST procedure), and the single consumer (the AST_Service_Task). - - -------------------------------- - -- AST Server Task Structures -- - -------------------------------- - - -- The basic approach is that when an AST comes in, a call is made to - -- the Process_AST procedure. It queues the request in the service queue - -- and then wakes up an AST server task to perform the actual call to the - -- required entry. We use this intermediate server task, since the AST - -- procedure itself cannot wait to return, and we need some caller for - -- the rendezvous so that we can use the normal rendezvous mechanism. - - -- It would work to have only one AST server task, but then we would lose - -- all overlap in AST processing, and furthermore, we could get priority - -- inversion effects resulting in starvation of AST requests. - - -- We therefore maintain a small pool of AST server tasks. We adjust - -- the size of the pool dynamically to reflect traffic, so that we have - -- a sufficient number of server tasks to avoid starvation. - - Max_AST_Servers : constant Natural := 16; - -- Maximum number of AST server tasks that can be allocated - - Num_AST_Servers : Natural := 0; - -- Number of AST server tasks currently active - - Num_Waiting_AST_Servers : Natural := 0; - -- This is the number of AST server tasks that are either waiting for - -- work, or just about to go to sleep and wait for work. - - Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); - -- An array of flags showing which AST server tasks are currently waiting - - AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; - -- Task Id's of allocated AST server tasks - - task type AST_Server_Task (Num : Natural) is - pragma Priority (Priority'Last); - end AST_Server_Task; - -- Declaration for AST server task. This task has no entries, it is - -- controlled by sleep and wakeup calls at the task primitives level. - - type AST_Server_Task_Ptr is access all AST_Server_Task; - -- Type used to allocate server tasks - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate_New_AST_Server; - -- Allocate an additional AST server task - - procedure Process_AST (Param : Long_Integer); - -- This is the central routine for processing all AST's, it is referenced - -- as the code address of all created AST_Handler values. See detailed - -- description in body to understand how it works to have a single such - -- procedure for all AST's even though it does not get any indication of - -- the entry involved passed as an explicit parameter. The single explicit - -- parameter Param is the parameter passed by the system with the AST. - - ----------------------------- - -- Allocate_New_AST_Server -- - ----------------------------- - - procedure Allocate_New_AST_Server is - Dummy : AST_Server_Task_Ptr; - - begin - if Num_AST_Servers = Max_AST_Servers then - return; - - else - -- Note: it is safe to increment Num_AST_Servers immediately, since - -- no one will try to activate this task until it indicates that it - -- is sleeping by setting its entry in Is_Waiting to True. - - Num_AST_Servers := Num_AST_Servers + 1; - Dummy := new AST_Server_Task (Num_AST_Servers); - end if; - end Allocate_New_AST_Server; - - --------------------- - -- AST_Server_Task -- - --------------------- - - task body AST_Server_Task is - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : aliased Long_Integer; - Self_Id : constant ST.Task_Id := ST.Self; - - pragma Volatile (Param); - - -- By making this task independent of master, when the environment - -- task is finalizing, the AST_Server_Task will be notified that it - -- should terminate. - - Ignore : constant Boolean := STU.Make_Independent; - pragma Unreferenced (Ignore); - - begin - -- Record our task Id for access by Process_AST - - AST_Task_Ids (Num) := Self_Id; - - -- Note: this entire task operates with the main task lock set, except - -- when it is sleeping waiting for work, or busy doing a rendezvous - -- with an AST server. This lock protects the data structures that - -- are shared by multiple instances of the server task. - - Lock_AST (Self_Id); - - -- This is the main infinite loop of the task. We go to sleep and - -- wait to be woken up by Process_AST when there is some work to do. - - loop - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; - - Unlock_AST (Self_Id); - - STI.Defer_Abort (Self_Id); - - if SP.Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - Is_Waiting (Num) := True; - - Self_Id.Common.State := ST.AST_Server_Sleep; - STPO.Sleep (Self_Id, ST.AST_Server_Sleep); - Self_Id.Common.State := ST.Runnable; - - STPO.Unlock (Self_Id); - - if SP.Single_Lock then - STPO.Unlock_RTS; - end if; - - -- If the process is finalizing, Undefer_Abort will simply end - -- this task. - - STI.Undefer_Abort (Self_Id); - - -- We are awake, there is something to do - - Lock_AST (Self_Id); - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; - - -- Loop here to service outstanding requests. We are always - -- locked on entry to this loop. - - while AST_Service_Queue_Get /= AST_Service_Queue_Put loop - Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; - Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; - Param := AST_Service_Queue (AST_Service_Queue_Get).Param; - - AST_Service_Queue_Get := AST_Service_Queue_Get + 1; - - -- This is a manual expansion of the normal call simple code - - declare - type AA is access all Long_Integer; - P : AA := Param'Unrestricted_Access; - - function To_ST_Task_Id is new Ada.Unchecked_Conversion - (ATID.Task_Id, ST.Task_Id); - - begin - Unlock_AST (Self_Id); - STR.Call_Simple - (Acceptor => To_ST_Task_Id (Taskid), - E => ST.Task_Entry_Index (Entryno), - Uninterpreted_Data => P'Address); - - exception - when E : others => - System.IO.Put_Line ("%Debugging event"); - System.IO.Put_Line (Exception_Name (E) & - " raised when trying to deliver an AST."); - - if Exception_Message (E)'Length /= 0 then - System.IO.Put_Line (Exception_Message (E)); - end if; - - System.IO.Put_Line ("Task type is " & "Receiver_Type"); - System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); - end; - - Lock_AST (Self_Id); - end loop; - end loop; - end AST_Server_Task; - - ------------------------ - -- Create_AST_Handler -- - ------------------------ - - function Create_AST_Handler - (Taskid : ATID.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler - is - Attr_Ref : Attribute_Handle; - - Process_AST_Ptr : constant AST_Handler := Process_AST'Access; - -- Reference to standard procedure descriptor for Process_AST - - pragma Warnings (Off, "*alignment*"); - -- Suppress harmless warnings about alignment. - -- Should explain why this warning is harmless ??? - - function To_Descriptor_Ref is new Ada.Unchecked_Conversion - (AST_Handler, Descriptor_Ref); - - Original_Descriptor_Ref : constant Descriptor_Ref := - To_Descriptor_Ref (Process_AST_Ptr); - - pragma Warnings (On, "*alignment*"); - - begin - if ATID.Is_Terminated (Taskid) then - raise Program_Error; - end if; - - Attr_Ref := Reference (Taskid); - - -- Allocate another server if supply is getting low - - if Num_Waiting_AST_Servers < 2 then - Allocate_New_AST_Server; - end if; - - -- No point in creating more if we have zillions waiting to - -- be serviced. - - while AST_Service_Queue_Put - AST_Service_Queue_Get - > AST_Service_Queue_Limit - loop - delay 0.01; - end loop; - - -- If no AST vector allocated, or the one we have is too short, then - -- allocate one of right size and initialize all entries except the - -- one we will use to unused. Note that the assignment automatically - -- frees the old allocated table if there is one. - - if Attr_Ref.Vector = null - or else Attr_Ref.Vector'Length < Entryno - then - Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); - - for E in 1 .. Entryno loop - Attr_Ref.Vector (E).Descriptor := - Original_Descriptor_Ref.all; - Attr_Ref.Vector (E).Original_Descriptor_Ref := - Original_Descriptor_Ref; - Attr_Ref.Vector (E).Taskid := Taskid; - Attr_Ref.Vector (E).Entryno := E; - end loop; - end if; - - return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); - end Create_AST_Handler; - - ---------------------------- - -- Expand_AST_Packet_Pool -- - ---------------------------- - - procedure Expand_AST_Packet_Pool - (Requested_Packets : Natural; - Actual_Number : out Natural; - Total_Number : out Natural) - is - pragma Unreferenced (Requested_Packets); - begin - -- The AST implementation of GNAT does not permit dynamic expansion - -- of the pool, so we simply add no entries and return the total. If - -- it is necessary to expand the allocation, then this package body - -- must be recompiled with a larger value for AST_Service_Queue_Size. - - Actual_Number := 0; - Total_Number := AST_Service_Queue_Size; - end Expand_AST_Packet_Pool; - - ----------------- - -- Process_AST -- - ----------------- - - procedure Process_AST (Param : Long_Integer) is - - Handler_Data_Ptr : AST_Handler_Data_Ref; - -- This variable is set to the address of the descriptor through - -- which Process_AST is called. Since the descriptor is part of - -- an AST_Handler value, this is also the address of this value, - -- from which we can obtain the task and entry number information. - - function To_Address is new Ada.Unchecked_Conversion - (ST.Task_Id, System.Task_Primitives.Task_Address); - - begin - System.Machine_Code.Asm - (Template => "addq $27,0,%0", - Outputs => AST_Handler_Data_Ref'Asm_Output ("=r", Handler_Data_Ptr), - Volatile => True); - - System.Machine_Code.Asm - (Template => "ldq $27,%0", - Inputs => Descriptor_Ref'Asm_Input - ("m", Handler_Data_Ptr.Original_Descriptor_Ref), - Volatile => True); - - AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' - (Taskid => Handler_Data_Ptr.Taskid, - Entryno => Handler_Data_Ptr.Entryno, - Param => Param); - - -- OpenVMS Programming Concepts manual, chapter 8.2.3: - -- "Implicit synchronization can be achieved for data that is shared - -- for write by using only AST routines to write the data, since only - -- one AST can be running at any one time." - - -- This subprogram runs at AST level so is guaranteed to be - -- called sequentially at a given access level. - - AST_Service_Queue_Put := AST_Service_Queue_Put + 1; - - -- Need to wake up processing task. If there is no waiting server - -- then we have temporarily run out, but things should still be - -- OK, since one of the active ones will eventually pick up the - -- service request queued in the AST_Service_Queue. - - for J in 1 .. Num_AST_Servers loop - if Is_Waiting (J) then - Is_Waiting (J) := False; - - -- Sleeps are handled by ASTs on VMS, so don't call Wakeup - - STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); - exit; - end if; - end loop; - end Process_AST; - -begin - STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); -end System.AST_Handling; diff --git a/gcc/ada/s-asthan-vms-ia64.adb b/gcc/ada/s-asthan-vms-ia64.adb deleted file mode 100644 index 0fd29b125e9..00000000000 --- a/gcc/ada/s-asthan-vms-ia64.adb +++ /dev/null @@ -1,608 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S T _ H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS/IA64 version - -with System; use System; - -with System.IO; - -with System.Machine_Code; -with System.Parameters; - -with System.Tasking; -with System.Tasking.Rendezvous; -with System.Tasking.Initialization; -with System.Tasking.Utilities; - -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - -with Ada.Finalization; -with Ada.Task_Attributes; - -with Ada.Exceptions; use Ada.Exceptions; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body System.AST_Handling is - - package ATID renames Ada.Task_Identification; - - package SP renames System.Parameters; - package ST renames System.Tasking; - package STR renames System.Tasking.Rendezvous; - package STI renames System.Tasking.Initialization; - package STU renames System.Tasking.Utilities; - - package STPO renames System.Task_Primitives.Operations; - package STPOD renames System.Task_Primitives.Operations.DEC; - - AST_Lock : aliased System.Task_Primitives.RTS_Lock; - -- This is a global lock; it is used to execute in mutual exclusion - -- from all other AST tasks. It is only used by Lock_AST and - -- Unlock_AST. - - procedure Lock_AST (Self_ID : ST.Task_Id); - -- Locks out other AST tasks. Preceding a section of code by Lock_AST and - -- following it by Unlock_AST creates a critical region. - - procedure Unlock_AST (Self_ID : ST.Task_Id); - -- Releases lock previously set by call to Lock_AST. - -- All nested locks must be released before other tasks competing for the - -- tasking lock are released. - - -------------- - -- Lock_AST -- - -------------- - - procedure Lock_AST (Self_ID : ST.Task_Id) is - begin - STI.Defer_Abort_Nestable (Self_ID); - STPO.Write_Lock (AST_Lock'Access, Global_Lock => True); - end Lock_AST; - - ---------------- - -- Unlock_AST -- - ---------------- - - procedure Unlock_AST (Self_ID : ST.Task_Id) is - begin - STPO.Unlock (AST_Lock'Access, Global_Lock => True); - STI.Undefer_Abort_Nestable (Self_ID); - end Unlock_AST; - - --------------------------------- - -- AST_Handler Data Structures -- - --------------------------------- - - -- As noted in the private part of the spec of System.Aux_DEC, the - -- AST_Handler type is simply a pointer to a procedure that takes - -- a single 64bit parameter. The following is a local copy - -- of that definition. - - -- We need our own copy because we need to get our hands on this - -- and we cannot see the private part of System.Aux_DEC. We don't - -- want to be a child of Aux_Dec because of complications resulting - -- from the use of pragma Extend_System. We will use unchecked - -- conversions between the two versions of the declarations. - - type AST_Handler is access procedure (Param : Long_Integer); - - -- However, this declaration is somewhat misleading, since the values - -- referenced by AST_Handler values (all produced in this package by - -- calls to Create_AST_Handler) are highly stylized. - - -- The first point is that in VMS/I64, procedure pointers do not in - -- fact point to code, but rather to a procedure descriptor. - -- So a value of type AST_Handler is in fact a pointer to one of - -- descriptors. - - type Descriptor_Type is - record - Entry_Point : System.Address; - GP_Value : System.Address; - end record; - for Descriptor_Type'Alignment use Standard'Maximum_Alignment; - -- pragma Warnings (Off, Descriptor_Type); - -- Suppress harmless warnings about alignment. - -- Should explain why this warning is harmless ??? - - type Descriptor_Ref is access all Descriptor_Type; - - -- Normally, there is only one such descriptor for a given procedure, but - -- it works fine to make a copy of the single allocated descriptor, and - -- use the copy itself, and we take advantage of this in the design here. - -- The idea is that AST_Handler values will all point to a record with the - -- following structure: - - -- Note: When we say it works fine, there is one delicate point, which - -- is that the code for the AST procedure itself requires the original - -- descriptor address. We handle this by saving the orignal descriptor - -- address in this structure and restoring in Process_AST. - - type AST_Handler_Data is record - Descriptor : Descriptor_Type; - Original_Descriptor_Ref : Descriptor_Ref; - Taskid : ATID.Task_Id; - Entryno : Natural; - end record; - - type AST_Handler_Data_Ref is access all AST_Handler_Data; - - function To_AST_Handler is new Ada.Unchecked_Conversion - (AST_Handler_Data_Ref, System.Aux_DEC.AST_Handler); - - -- Each time Create_AST_Handler is called, a new value of this record - -- type is created, containing a copy of the procedure descriptor for - -- the routine used to handle all AST's (Process_AST), and the Task_Id - -- and entry number parameters identifying the task entry involved. - - -- The AST_Handler value returned is a pointer to this record. Since - -- the record starts with the procedure descriptor, it can be used - -- by the system in the normal way to call the procedure. But now - -- when the procedure gets control, it can determine the address of - -- the procedure descriptor used to call it (since the ABI specifies - -- that this is left sitting in register r27 on entry), and then use - -- that address to retrieve the Task_Id and entry number so that it - -- knows on which entry to queue the AST request. - - -- The next issue is where are these records placed. Since we intend - -- to pass pointers to these records to asynchronous system service - -- routines, they have to be on the heap, which means we have to worry - -- about when to allocate them and deallocate them. - - -- We solve this problem by introducing a task attribute that points to - -- a vector, indexed by the entry number, of AST_Handler_Data records - -- for a given task. The pointer itself is a controlled object allowing - -- us to write a finalization routine that frees the referenced vector. - - -- An entry in this vector is either initialized (Entryno non-zero) and - -- can be used for any subsequent reference to the same entry, or it is - -- unused, marked by the Entryno value being zero. - - type AST_Handler_Vector is array (Natural range <>) of AST_Handler_Data; - type AST_Handler_Vector_Ref is access all AST_Handler_Vector; - - type AST_Vector_Ptr is new Ada.Finalization.Controlled with record - Vector : AST_Handler_Vector_Ref; - end record; - - procedure Finalize (Obj : in out AST_Vector_Ptr); - -- Override Finalize so that the AST Vector gets freed. - - procedure Finalize (Obj : in out AST_Vector_Ptr) is - procedure Free is new - Ada.Unchecked_Deallocation (AST_Handler_Vector, AST_Handler_Vector_Ref); - begin - if Obj.Vector /= null then - Free (Obj.Vector); - end if; - end Finalize; - - AST_Vector_Init : AST_Vector_Ptr; - -- Initial value, treated as constant, Vector will be null - - package AST_Attribute is new Ada.Task_Attributes - (Attribute => AST_Vector_Ptr, - Initial_Value => AST_Vector_Init); - - use AST_Attribute; - - ----------------------- - -- AST Service Queue -- - ----------------------- - - -- The following global data structures are used to queue pending - -- AST requests. When an AST is signalled, the AST service routine - -- Process_AST is called, and it makes an entry in this structure. - - type AST_Instance is record - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : Long_Integer; - end record; - -- The Taskid and Entryno indicate the entry on which this AST is to - -- be queued, and Param is the parameter provided from the AST itself. - - AST_Service_Queue_Size : constant := 256; - AST_Service_Queue_Limit : constant := 250; - type AST_Service_Queue_Index is mod AST_Service_Queue_Size; - -- Index used to refer to entries in the circular buffer which holds - -- active AST_Instance values. The upper bound reflects the maximum - -- number of AST instances that can be stored in the buffer. Since - -- these entries are immediately serviced by the high priority server - -- task that does the actual entry queuing, it is very unusual to have - -- any significant number of entries simulaneously queued. - - AST_Service_Queue : array (AST_Service_Queue_Index) of AST_Instance; - pragma Volatile_Components (AST_Service_Queue); - -- The circular buffer used to store active AST requests - - AST_Service_Queue_Put : AST_Service_Queue_Index := 0; - AST_Service_Queue_Get : AST_Service_Queue_Index := 0; - pragma Atomic (AST_Service_Queue_Put); - pragma Atomic (AST_Service_Queue_Get); - -- These two variables point to the next slots in the AST_Service_Queue - -- to be used for putting a new entry in and taking an entry out. This - -- is a circular buffer, so these pointers wrap around. If the two values - -- are equal the buffer is currently empty. The pointers are atomic to - -- ensure proper synchronization between the single producer (namely the - -- Process_AST procedure), and the single consumer (the AST_Service_Task). - - -------------------------------- - -- AST Server Task Structures -- - -------------------------------- - - -- The basic approach is that when an AST comes in, a call is made to - -- the Process_AST procedure. It queues the request in the service queue - -- and then wakes up an AST server task to perform the actual call to the - -- required entry. We use this intermediate server task, since the AST - -- procedure itself cannot wait to return, and we need some caller for - -- the rendezvous so that we can use the normal rendezvous mechanism. - - -- It would work to have only one AST server task, but then we would lose - -- all overlap in AST processing, and furthermore, we could get priority - -- inversion effects resulting in starvation of AST requests. - - -- We therefore maintain a small pool of AST server tasks. We adjust - -- the size of the pool dynamically to reflect traffic, so that we have - -- a sufficient number of server tasks to avoid starvation. - - Max_AST_Servers : constant Natural := 16; - -- Maximum number of AST server tasks that can be allocated - - Num_AST_Servers : Natural := 0; - -- Number of AST server tasks currently active - - Num_Waiting_AST_Servers : Natural := 0; - -- This is the number of AST server tasks that are either waiting for - -- work, or just about to go to sleep and wait for work. - - Is_Waiting : array (1 .. Max_AST_Servers) of Boolean := (others => False); - -- An array of flags showing which AST server tasks are currently waiting - - AST_Task_Ids : array (1 .. Max_AST_Servers) of ST.Task_Id; - -- Task Id's of allocated AST server tasks - - task type AST_Server_Task (Num : Natural) is - pragma Priority (Priority'Last); - end AST_Server_Task; - -- Declaration for AST server task. This task has no entries, it is - -- controlled by sleep and wakeup calls at the task primitives level. - - type AST_Server_Task_Ptr is access all AST_Server_Task; - -- Type used to allocate server tasks - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate_New_AST_Server; - -- Allocate an additional AST server task - - procedure Process_AST (Param : Long_Integer); - -- This is the central routine for processing all AST's, it is referenced - -- as the code address of all created AST_Handler values. See detailed - -- description in body to understand how it works to have a single such - -- procedure for all AST's even though it does not get any indication of - -- the entry involved passed as an explicit parameter. The single explicit - -- parameter Param is the parameter passed by the system with the AST. - - ----------------------------- - -- Allocate_New_AST_Server -- - ----------------------------- - - procedure Allocate_New_AST_Server is - Dummy : AST_Server_Task_Ptr; - - begin - if Num_AST_Servers = Max_AST_Servers then - return; - - else - -- Note: it is safe to increment Num_AST_Servers immediately, since - -- no one will try to activate this task until it indicates that it - -- is sleeping by setting its entry in Is_Waiting to True. - - Num_AST_Servers := Num_AST_Servers + 1; - Dummy := new AST_Server_Task (Num_AST_Servers); - end if; - end Allocate_New_AST_Server; - - --------------------- - -- AST_Server_Task -- - --------------------- - - task body AST_Server_Task is - Taskid : ATID.Task_Id; - Entryno : Natural; - Param : aliased Long_Integer; - Self_Id : constant ST.Task_Id := ST.Self; - - pragma Volatile (Param); - - -- By making this task independent of master, when the environment - -- task is finalizing, the AST_Server_Task will be notified that it - -- should terminate. - - Ignore : constant Boolean := STU.Make_Independent; - pragma Unreferenced (Ignore); - - begin - -- Record our task Id for access by Process_AST - - AST_Task_Ids (Num) := Self_Id; - - -- Note: this entire task operates with the main task lock set, except - -- when it is sleeping waiting for work, or busy doing a rendezvous - -- with an AST server. This lock protects the data structures that - -- are shared by multiple instances of the server task. - - Lock_AST (Self_Id); - - -- This is the main infinite loop of the task. We go to sleep and - -- wait to be woken up by Process_AST when there is some work to do. - - loop - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers + 1; - - Unlock_AST (Self_Id); - - STI.Defer_Abort (Self_Id); - - if SP.Single_Lock then - STPO.Lock_RTS; - end if; - - STPO.Write_Lock (Self_Id); - - Is_Waiting (Num) := True; - - Self_Id.Common.State := ST.AST_Server_Sleep; - STPO.Sleep (Self_Id, ST.AST_Server_Sleep); - Self_Id.Common.State := ST.Runnable; - - STPO.Unlock (Self_Id); - - if SP.Single_Lock then - STPO.Unlock_RTS; - end if; - - -- If the process is finalizing, Undefer_Abort will simply end - -- this task. - - STI.Undefer_Abort (Self_Id); - - -- We are awake, there is something to do - - Lock_AST (Self_Id); - Num_Waiting_AST_Servers := Num_Waiting_AST_Servers - 1; - - -- Loop here to service outstanding requests. We are always - -- locked on entry to this loop. - - while AST_Service_Queue_Get /= AST_Service_Queue_Put loop - Taskid := AST_Service_Queue (AST_Service_Queue_Get).Taskid; - Entryno := AST_Service_Queue (AST_Service_Queue_Get).Entryno; - Param := AST_Service_Queue (AST_Service_Queue_Get).Param; - - AST_Service_Queue_Get := AST_Service_Queue_Get + 1; - - -- This is a manual expansion of the normal call simple code - - declare - type AA is access all Long_Integer; - P : AA := Param'Unrestricted_Access; - - function To_ST_Task_Id is new Ada.Unchecked_Conversion - (ATID.Task_Id, ST.Task_Id); - - begin - Unlock_AST (Self_Id); - STR.Call_Simple - (Acceptor => To_ST_Task_Id (Taskid), - E => ST.Task_Entry_Index (Entryno), - Uninterpreted_Data => P'Address); - - exception - when E : others => - System.IO.Put_Line ("%Debugging event"); - System.IO.Put_Line (Exception_Name (E) & - " raised when trying to deliver an AST."); - - if Exception_Message (E)'Length /= 0 then - System.IO.Put_Line (Exception_Message (E)); - end if; - - System.IO.Put_Line ("Task type is " & "Receiver_Type"); - System.IO.Put_Line ("Task id is " & ATID.Image (Taskid)); - end; - - Lock_AST (Self_Id); - end loop; - end loop; - end AST_Server_Task; - - ------------------------ - -- Create_AST_Handler -- - ------------------------ - - function Create_AST_Handler - (Taskid : ATID.Task_Id; - Entryno : Natural) return System.Aux_DEC.AST_Handler - is - Attr_Ref : Attribute_Handle; - - Process_AST_Ptr : constant AST_Handler := Process_AST'Access; - -- Reference to standard procedure descriptor for Process_AST - - function To_Descriptor_Ref is new Ada.Unchecked_Conversion - (AST_Handler, Descriptor_Ref); - - Original_Descriptor_Ref : constant Descriptor_Ref := - To_Descriptor_Ref (Process_AST_Ptr); - - begin - if ATID.Is_Terminated (Taskid) then - raise Program_Error; - end if; - - Attr_Ref := Reference (Taskid); - - -- Allocate another server if supply is getting low - - if Num_Waiting_AST_Servers < 2 then - Allocate_New_AST_Server; - end if; - - -- No point in creating more if we have zillions waiting to - -- be serviced. - - while AST_Service_Queue_Put - AST_Service_Queue_Get - > AST_Service_Queue_Limit - loop - delay 0.01; - end loop; - - -- If no AST vector allocated, or the one we have is too short, then - -- allocate one of right size and initialize all entries except the - -- one we will use to unused. Note that the assignment automatically - -- frees the old allocated table if there is one. - - if Attr_Ref.Vector = null - or else Attr_Ref.Vector'Length < Entryno - then - Attr_Ref.Vector := new AST_Handler_Vector (1 .. Entryno); - - for E in 1 .. Entryno loop - Attr_Ref.Vector (E).Descriptor.Entry_Point := - Original_Descriptor_Ref.Entry_Point; - Attr_Ref.Vector (E).Descriptor.GP_Value := - Attr_Ref.Vector (E)'Address; - Attr_Ref.Vector (E).Original_Descriptor_Ref := - Original_Descriptor_Ref; - Attr_Ref.Vector (E).Taskid := Taskid; - Attr_Ref.Vector (E).Entryno := E; - end loop; - end if; - - return To_AST_Handler (Attr_Ref.Vector (Entryno)'Unrestricted_Access); - end Create_AST_Handler; - - ---------------------------- - -- Expand_AST_Packet_Pool -- - ---------------------------- - - procedure Expand_AST_Packet_Pool - (Requested_Packets : Natural; - Actual_Number : out Natural; - Total_Number : out Natural) - is - pragma Unreferenced (Requested_Packets); - begin - -- The AST implementation of GNAT does not permit dynamic expansion - -- of the pool, so we simply add no entries and return the total. If - -- it is necessary to expand the allocation, then this package body - -- must be recompiled with a larger value for AST_Service_Queue_Size. - - Actual_Number := 0; - Total_Number := AST_Service_Queue_Size; - end Expand_AST_Packet_Pool; - - ----------------- - -- Process_AST -- - ----------------- - - procedure Process_AST (Param : Long_Integer) is - - Handler_Data_Ptr : AST_Handler_Data_Ref; - -- This variable is set to the address of the descriptor through - -- which Process_AST is called. Since the descriptor is part of - -- an AST_Handler value, this is also the address of this value, - -- from which we can obtain the task and entry number information. - - function To_Address is new Ada.Unchecked_Conversion - (ST.Task_Id, System.Task_Primitives.Task_Address); - - begin - -- Move the contrived GP into place so Taskid and Entryno - -- become available, then restore the true GP. - - System.Machine_Code.Asm - (Template => "mov %0 = r1", - Outputs => AST_Handler_Data_Ref'Asm_Output - ("=r", Handler_Data_Ptr), - Volatile => True); - - System.Machine_Code.Asm - (Template => "ld8 r1 = %0;;", - Inputs => System.Address'Asm_Input - ("m", Handler_Data_Ptr.Original_Descriptor_Ref.GP_Value), - Volatile => True); - - AST_Service_Queue (AST_Service_Queue_Put) := AST_Instance' - (Taskid => Handler_Data_Ptr.Taskid, - Entryno => Handler_Data_Ptr.Entryno, - Param => Param); - - -- OpenVMS Programming Concepts manual, chapter 8.2.3: - -- "Implicit synchronization can be achieved for data that is shared - -- for write by using only AST routines to write the data, since only - -- one AST can be running at any one time." - - -- This subprogram runs at AST level so is guaranteed to be - -- called sequentially at a given access level. - - AST_Service_Queue_Put := AST_Service_Queue_Put + 1; - - -- Need to wake up processing task. If there is no waiting server - -- then we have temporarily run out, but things should still be - -- OK, since one of the active ones will eventually pick up the - -- service request queued in the AST_Service_Queue. - - for J in 1 .. Num_AST_Servers loop - if Is_Waiting (J) then - Is_Waiting (J) := False; - - -- Sleeps are handled by ASTs on VMS, so don't call Wakeup - - STPOD.Interrupt_AST_Handler (To_Address (AST_Task_Ids (J))); - exit; - end if; - end loop; - end Process_AST; - -begin - STPO.Initialize_Lock (AST_Lock'Access, STPO.Global_Task_Level); -end System.AST_Handling; diff --git a/gcc/ada/s-auxdec-vms-alpha.adb b/gcc/ada/s-auxdec-vms-alpha.adb deleted file mode 100644 index 4116e32b355..00000000000 --- a/gcc/ada/s-auxdec-vms-alpha.adb +++ /dev/null @@ -1,809 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version. - -pragma Style_Checks (All_Checks); --- Turn off alpha ordering check on subprograms, this unit is laid --- out to correspond to the declarations in the DEC 83 System unit. - -with System.Machine_Code; use System.Machine_Code; -package body System.Aux_DEC is - - ------------------------ - -- Fetch_From_Address -- - ------------------------ - - function Fetch_From_Address (A : Address) return Target is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - return Ptr.all; - end Fetch_From_Address; - - ----------------------- - -- Assign_To_Address -- - ----------------------- - - procedure Assign_To_Address (A : Address; T : Target) is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - Ptr.all := T; - end Assign_To_Address; - - ----------------------- - -- Clear_Interlocked -- - ----------------------- - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - use ASCII; - Clr_Bit : Boolean := Bit; - Old_Bit : Boolean; - - begin - -- All these ASM sequences should be commented. I suggest defining - -- a constant called E which is LF & HT and then you have more space - -- for line by line comments ??? - - System.Machine_Code.Asm - ( - "lda $16, %2" & LF & HT & - "mb" & LF & HT & - "sll $16, 3, $17 " & LF & HT & - "bis $31, 1, $1" & LF & HT & - "and $17, 63, $18" & LF & HT & - "bic $17, 63, $17" & LF & HT & - "sra $17, 3, $17" & LF & HT & - "bis $31, 1, %1" & LF & HT & - "sll %1, $18, $18" & LF & HT & - "1:" & LF & HT & - "ldq_l $1, 0($17)" & LF & HT & - "and $1, $18, %1" & LF & HT & - "bic $1, $18, $1" & LF & HT & - "stq_c $1, 0($17)" & LF & HT & - "cmpeq %1, 0, %1" & LF & HT & - "beq $1, 1b" & LF & HT & - "mb" & LF & HT & - "xor %1, 1, %1" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), - Boolean'Asm_Output ("=r", Old_Bit)), - Inputs => Boolean'Asm_Input ("m", Clr_Bit), - Clobber => "$1, $16, $17, $18", - Volatile => True); - - Bit := Clr_Bit; - Old_Value := Old_Bit; - end Clear_Interlocked; - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - use ASCII; - Clr_Bit : Boolean := Bit; - Succ, Old_Bit : Boolean; - - begin - System.Machine_Code.Asm - ( - "lda $16, %3" & LF & HT & - "mb" & LF & HT & - "sll $16, 3, $18 " & LF & HT & - "bis $31, 1, %1" & LF & HT & - "and $18, 63, $19" & LF & HT & - "bic $18, 63, $18" & LF & HT & - "sra $18, 3, $18" & LF & HT & - "bis $31, %4, $17" & LF & HT & - "sll %1, $19, $19" & LF & HT & - "1:" & LF & HT & - "ldq_l %2, 0($18)" & LF & HT & - "and %2, $19, %1" & LF & HT & - "bic %2, $19, %2" & LF & HT & - "stq_c %2, 0($18)" & LF & HT & - "beq %2, 2f" & LF & HT & - "cmpeq %1, 0, %1" & LF & HT & - "br 3f" & LF & HT & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "3:" & LF & HT & - "mb" & LF & HT & - "xor %1, 1, %1" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Clr_Bit), - Boolean'Asm_Output ("=r", Old_Bit), - Boolean'Asm_Output ("=r", Succ)), - Inputs => (Boolean'Asm_Input ("m", Clr_Bit), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$16, $17, $18, $19", - Volatile => True); - - Bit := Clr_Bit; - Old_Value := Old_Bit; - Success_Flag := Succ; - end Clear_Interlocked; - - --------------------- - -- Set_Interlocked -- - --------------------- - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - use ASCII; - Set_Bit : Boolean := Bit; - Old_Bit : Boolean; - - begin - -- Don't we need comments on these long asm sequences??? - - System.Machine_Code.Asm - ( - "lda $16, %2" & LF & HT & - "sll $16, 3, $17 " & LF & HT & - "bis $31, 1, $1" & LF & HT & - "and $17, 63, $18" & LF & HT & - "mb" & LF & HT & - "bic $17, 63, $17" & LF & HT & - "sra $17, 3, $17" & LF & HT & - "bis $31, 1, %1" & LF & HT & - "sll %1, $18, $18" & LF & HT & - "1:" & LF & HT & - "ldq_l $1, 0($17)" & LF & HT & - "and $1, $18, %1" & LF & HT & - "bis $1, $18, $1" & LF & HT & - "stq_c $1, 0($17)" & LF & HT & - "cmovne %1, 1, %1" & LF & HT & - "beq $1, 1b" & LF & HT & - "mb" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Set_Bit), - Boolean'Asm_Output ("=r", Old_Bit)), - Inputs => Boolean'Asm_Input ("m", Set_Bit), - Clobber => "$1, $16, $17, $18", - Volatile => True); - - Bit := Set_Bit; - Old_Value := Old_Bit; - end Set_Interlocked; - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - use ASCII; - Set_Bit : Boolean := Bit; - Succ, Old_Bit : Boolean; - - begin - System.Machine_Code.Asm - ( - "lda $16, %3" & LF & HT & -- Address of Bit - "mb" & LF & HT & - "sll $16, 3, $18 " & LF & HT & -- Byte address to bit address - "bis $31, 1, %1" & LF & HT & -- Set temp to 1 for the sll - "and $18, 63, $19" & LF & HT & -- Quadword bit offset - "bic $18, 63, $18" & LF & HT & -- Quadword bit address - "sra $18, 3, $18" & LF & HT & -- Quadword address - "bis $31, %4, $17" & LF & HT & -- Retry_Count -> $17 - "sll %1, $19, $19" & LF & -- $19 = 1 << bit_offset - "1:" & LF & HT & - "ldq_l %2, 0($18)" & LF & HT & -- Load & lock - "and %2, $19, %1" & LF & HT & -- Previous value -> %1 - "bis %2, $19, %2" & LF & HT & -- Set Bit - "stq_c %2, 0($18)" & LF & HT & -- Store conditional - "beq %2, 2f" & LF & HT & -- Goto 2: if failed - "cmovne %1, 1, %1" & LF & HT & -- Set Old_Bit - "br 3f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & -- Retry_Count - 1 - "bgt $17, 1b" & LF & -- Retry ? - "3:" & LF & HT & - "mb" & LF & HT & - "trapb", - Outputs => (Boolean'Asm_Output ("=m", Set_Bit), - Boolean'Asm_Output ("=r", Old_Bit), - Boolean'Asm_Output ("=r", Succ)), - Inputs => (Boolean'Asm_Input ("m", Set_Bit), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$16, $17, $18, $19", - Volatile => True); - - Bit := Set_Bit; - Old_Value := Old_Bit; - Success_Flag := Succ; - end Set_Interlocked; - - --------------------- - -- Add_Interlocked -- - --------------------- - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer) - is - use ASCII; - Overflowed : Boolean := False; - - begin - System.Machine_Code.Asm - ( - "lda $18, %0" & LF & HT & - "bic $18, 6, $21" & LF & HT & - "mb" & LF & HT & - "1:" & LF & HT & - "ldq_l $0, 0($21)" & LF & HT & - "extwl $0, $18, $19" & LF & HT & - "mskwl $0, $18, $0" & LF & HT & - "addq $19, %3, $20" & LF & HT & - "inswl $20, $18, $17" & LF & HT & - "xor $19, %3, $19" & LF & HT & - "bis $17, $0, $0" & LF & HT & - "stq_c $0, 0($21)" & LF & HT & - "beq $0, 1b" & LF & HT & - "srl $20, 16, $0" & LF & HT & - "mb" & LF & HT & - "srl $20, 12, $21" & LF & HT & - "zapnot $20, 3, $20" & LF & HT & - "and $0, 1, $0" & LF & HT & - "and $21, 8, $21" & LF & HT & - "bis $21, $0, $0" & LF & HT & - "cmpeq $20, 0, $21" & LF & HT & - "xor $20, 2, $20" & LF & HT & - "sll $21, 2, $21" & LF & HT & - "bis $21, $0, $0" & LF & HT & - "bic $20, $19, $21" & LF & HT & - "srl $21, 14, $21" & LF & HT & - "and $21, 2, $21" & LF & HT & - "bis $21, $0, $0" & LF & HT & - "and $0, 2, %2" & LF & HT & - "bne %2, 2f" & LF & HT & - "and $0, 4, %1" & LF & HT & - "cmpeq %1, 0, %1" & LF & HT & - "and $0, 8, $0" & LF & HT & - "lda $16, -1" & LF & HT & - "cmovne $0, $16, %1" & LF & HT & - "2:", - Outputs => (Aligned_Word'Asm_Output ("=m", Augend), - Integer'Asm_Output ("=r", Sign), - Boolean'Asm_Output ("=r", Overflowed)), - Inputs => (Short_Integer'Asm_Input ("r", Addend), - Aligned_Word'Asm_Input ("m", Augend)), - Clobber => "$0, $1, $16, $17, $18, $19, $20, $21", - Volatile => True); - - if Overflowed then - raise Constraint_Error; - end if; - end Add_Interlocked; - - ---------------- - -- Add_Atomic -- - ---------------- - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "addl $1, %2, $0" & LF & HT & - "stl_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", Amount)), - Clobber => "$0, $1", - Volatile => True); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "addl $1, %4, $0" & LF & HT & - "stl_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stl $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Integer'Asm_Output ("=m", To), - Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", Amount), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "addq $1, %2, $0" & LF & HT & - "stq_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", Amount)), - Clobber => "$0, $1", - Volatile => True); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "addq $1, %4, $0" & LF & HT & - "stq_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stq $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), - Long_Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", Amount), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Add_Atomic; - - ---------------- - -- And_Atomic -- - ---------------- - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "and $1, %2, $0" & LF & HT & - "stl_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "and $1, %4, $0" & LF & HT & - "stl_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stl $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Integer'Asm_Output ("=m", To), - Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "and $1, %2, $0" & LF & HT & - "stq_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "and $1, %4, $0" & LF & HT & - "stq_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stq $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), - Long_Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end And_Atomic; - - --------------- - -- Or_Atomic -- - --------------- - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "bis $1, %2, $0" & LF & HT & - "stl_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldl_l $1, %0" & LF & HT & - "bis $1, %4, $0" & LF & HT & - "stl_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stl $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Integer'Asm_Output ("=m", To), - Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Integer'Asm_Input ("m", To), - Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "bis $1, %2, $0" & LF & HT & - "stq_c $0, %1" & LF & HT & - "beq $0, 1b" & LF & HT & - "mb", - Outputs => Aligned_Long_Integer'Asm_Output ("=m", To), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From)), - Clobber => "$0, $1", - Volatile => True); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "mb" & LF & HT & - "bis $31, %5, $17" & LF & - "1:" & LF & HT & - "ldq_l $1, %0" & LF & HT & - "bis $1, %4, $0" & LF & HT & - "stq_c $0, %3" & LF & HT & - "beq $0, 2f" & LF & - "3:" & LF & HT & - "mb" & LF & HT & - "stq $0, %2" & LF & HT & - "stq $1, %1" & LF & HT & - "br 4f" & LF & - "2:" & LF & HT & - "subq $17, 1, $17" & LF & HT & - "bgt $17, 1b" & LF & HT & - "br 3b" & LF & - "4:", - Outputs => (Aligned_Long_Integer'Asm_Output ("=m", To), - Long_Integer'Asm_Output ("=m", Old_Value), - Boolean'Asm_Output ("=m", Success_Flag)), - Inputs => (Aligned_Long_Integer'Asm_Input ("m", To), - Long_Integer'Asm_Input ("rJ", From), - Natural'Asm_Input ("rJ", Retry_Count)), - Clobber => "$0, $1, $17", - Volatile => True); - end Or_Atomic; - - ------------ - -- Insqhi -- - ------------ - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %1, $17" & LF & HT & - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x87" & LF & HT & - "mb", - Outputs => Insq_Status'Asm_Output ("=v", Status), - Inputs => (Address'Asm_Input ("rJ", Item), - Address'Asm_Input ("rJ", Header)), - Clobber => "$16, $17", - Volatile => True); - end Insqhi; - - ------------ - -- Remqhi -- - ------------ - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x93" & LF & HT & - "mb" & LF & HT & - "bis $31, $1, %1", - Outputs => (Remq_Status'Asm_Output ("=v", Status), - Address'Asm_Output ("=r", Item)), - Inputs => Address'Asm_Input ("rJ", Header), - Clobber => "$1, $16", - Volatile => True); - end Remqhi; - - ------------ - -- Insqti -- - ------------ - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %1, $17" & LF & HT & - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x88" & LF & HT & - "mb", - Outputs => Insq_Status'Asm_Output ("=v", Status), - Inputs => (Address'Asm_Input ("rJ", Item), - Address'Asm_Input ("rJ", Header)), - Clobber => "$16, $17", - Volatile => True); - end Insqti; - - ------------ - -- Remqti -- - ------------ - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - use ASCII; - - begin - System.Machine_Code.Asm - ( - "bis $31, %2, $16" & LF & HT & - "mb" & LF & HT & - "call_pal 0x94" & LF & HT & - "mb" & LF & HT & - "bis $31, $1, %1", - Outputs => (Remq_Status'Asm_Output ("=v", Status), - Address'Asm_Output ("=r", Item)), - Inputs => Address'Asm_Input ("rJ", Header), - Clobber => "$1, $16", - Volatile => True); - end Remqti; - -end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-vms-ia64.adb b/gcc/ada/s-auxdec-vms-ia64.adb deleted file mode 100644 index b8ca67e85b2..00000000000 --- a/gcc/ada/s-auxdec-vms-ia64.adb +++ /dev/null @@ -1,576 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Itanium/VMS version. - --- The Add,Clear_Interlocked subprograms are dubiously implmented due to --- the lack of a single bit sync_lock_test_and_set builtin. - --- The "Retry" parameter is ignored due to the lack of retry builtins making --- the subprograms identical to the non-retry versions. - -pragma Style_Checks (All_Checks); --- Turn off alpha ordering check on subprograms, this unit is laid --- out to correspond to the declarations in the DEC 83 System unit. - -with Interfaces; -package body System.Aux_DEC is - - use type Interfaces.Unsigned_8; - - ------------------------ - -- Fetch_From_Address -- - ------------------------ - - function Fetch_From_Address (A : Address) return Target is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - return Ptr.all; - end Fetch_From_Address; - - ----------------------- - -- Assign_To_Address -- - ----------------------- - - procedure Assign_To_Address (A : Address; T : Target) is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - Ptr.all := T; - end Assign_To_Address; - - ----------------------- - -- Clear_Interlocked -- - ----------------------- - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - Clr_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - - begin - Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0); - Bit := Clr_Bit; - Old_Value := Old_Uns /= 0; - end Clear_Interlocked; - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - Clr_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - - begin - Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0); - Bit := Clr_Bit; - Old_Value := Old_Uns /= 0; - Success_Flag := True; - end Clear_Interlocked; - - --------------------- - -- Set_Interlocked -- - --------------------- - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - Set_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - - begin - Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1); - Bit := Set_Bit; - Old_Value := Old_Uns /= 0; - end Set_Interlocked; - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - Set_Bit : Boolean := Bit; - Old_Uns : Interfaces.Unsigned_8; - - function Sync_Lock_Test_And_Set - (Ptr : Address; - Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8; - pragma Import (Intrinsic, Sync_Lock_Test_And_Set, - "__sync_lock_test_and_set_1"); - begin - Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1); - Bit := Set_Bit; - Old_Value := Old_Uns /= 0; - Success_Flag := True; - end Set_Interlocked; - - --------------------- - -- Add_Interlocked -- - --------------------- - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer) - is - Overflowed : Boolean := False; - Former : Aligned_Word; - - function Sync_Fetch_And_Add - (Ptr : Address; - Value : Short_Integer) return Short_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2"); - - begin - Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend); - - if Augend.Value < 0 then - Sign := -1; - elsif Augend.Value > 0 then - Sign := 1; - else - Sign := 0; - end if; - - if Former.Value > 0 and then Augend.Value <= 0 then - Overflowed := True; - end if; - - if Overflowed then - raise Constraint_Error; - end if; - end Add_Interlocked; - - ---------------- - -- Add_Atomic -- - ---------------- - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer) - is - procedure Sync_Add_And_Fetch - (Ptr : Address; - Value : Integer); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - begin - Sync_Add_And_Fetch (To.Value'Address, Amount); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Add - (Ptr : Address; - Value : Integer) return Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4"); - - begin - Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount); - Success_Flag := True; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer) - is - procedure Sync_Add_And_Fetch - (Ptr : Address; - Value : Long_Integer); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8"); - begin - Sync_Add_And_Fetch (To.Value'Address, Amount); - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Add - (Ptr : Address; - Value : Long_Integer) return Long_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8"); - -- Why do we keep importing this over and over again??? - - begin - Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount); - Success_Flag := True; - end Add_Atomic; - - ---------------- - -- And_Atomic -- - ---------------- - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - procedure Sync_And_And_Fetch - (Ptr : Address; - Value : Integer); - pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4"); - begin - Sync_And_And_Fetch (To.Value'Address, From); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_And - (Ptr : Address; - Value : Integer) return Integer; - pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4"); - - begin - Old_Value := Sync_Fetch_And_And (To.Value'Address, From); - Success_Flag := True; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - procedure Sync_And_And_Fetch - (Ptr : Address; - Value : Long_Integer); - pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8"); - begin - Sync_And_And_Fetch (To.Value'Address, From); - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_And - (Ptr : Address; - Value : Long_Integer) return Long_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8"); - - begin - Old_Value := Sync_Fetch_And_And (To.Value'Address, From); - Success_Flag := True; - end And_Atomic; - - --------------- - -- Or_Atomic -- - --------------- - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - procedure Sync_Or_And_Fetch - (Ptr : Address; - Value : Integer); - pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4"); - - begin - Sync_Or_And_Fetch (To.Value'Address, From); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Or - (Ptr : Address; - Value : Integer) return Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4"); - - begin - Old_Value := Sync_Fetch_And_Or (To.Value'Address, From); - Success_Flag := True; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - procedure Sync_Or_And_Fetch - (Ptr : Address; - Value : Long_Integer); - pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8"); - begin - Sync_Or_And_Fetch (To.Value'Address, From); - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Unreferenced (Retry_Count); - - function Sync_Fetch_And_Or - (Ptr : Address; - Value : Long_Integer) return Long_Integer; - pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8"); - - begin - Old_Value := Sync_Fetch_And_Or (To.Value'Address, From); - Success_Flag := True; - end Or_Atomic; - - ------------ - -- Insqhi -- - ------------ - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status) is - - procedure SYS_PAL_INSQHIL - (STATUS : out Integer; Header : Address; ITEM : Address); - pragma Import (External, SYS_PAL_INSQHIL); - pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL", - (Integer, Address, Address), - (Value, Value, Value)); - - Istat : Integer; - - begin - SYS_PAL_INSQHIL (Istat, Header, Item); - - if Istat = 0 then - Status := OK_Not_First; - elsif Istat = 1 then - Status := OK_First; - - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - end Insqhi; - - ------------ - -- Remqhi -- - ------------ - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - -- The removed item is returned in the second function return register, - -- R9 on IVMS. The VMS ABI calls for "small" records to be returned in - -- these registers, so inventing this odd looking record type makes that - -- all work. - - type Remq is record - Status : Long_Integer; - Item : Address; - end record; - - procedure SYS_PAL_REMQHIL - (Remret : out Remq; Header : Address); - pragma Import (External, SYS_PAL_REMQHIL); - pragma Import_Valued_Procedure - (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL", - (Remq, Address), - (Value, Value)); - - -- Following variables need documentation??? - - Rstat : Long_Integer; - Remret : Remq; - - begin - SYS_PAL_REMQHIL (Remret, Header); - - Rstat := Remret.Status; - Item := Remret.Item; - - if Rstat = 0 then - Status := Fail_Was_Empty; - - elsif Rstat = 1 then - Status := OK_Not_Empty; - - elsif Rstat = 2 then - Status := OK_Empty; - - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - - end Remqhi; - - ------------ - -- Insqti -- - ------------ - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status) is - - procedure SYS_PAL_INSQTIL - (STATUS : out Integer; Header : Address; ITEM : Address); - pragma Import (External, SYS_PAL_INSQTIL); - pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL", - (Integer, Address, Address), - (Value, Value, Value)); - - Istat : Integer; - - begin - SYS_PAL_INSQTIL (Istat, Header, Item); - - if Istat = 0 then - Status := OK_Not_First; - - elsif Istat = 1 then - Status := OK_First; - - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - end Insqti; - - ------------ - -- Remqti -- - ------------ - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - -- The removed item is returned in the second function return register, - -- R9 on IVMS. The VMS ABI calls for "small" records to be returned in - -- these registers, so inventing (where is rest of this comment???) - - type Remq is record - Status : Long_Integer; - Item : Address; - end record; - - procedure SYS_PAL_REMQTIL - (Remret : out Remq; Header : Address); - pragma Import (External, SYS_PAL_REMQTIL); - pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL", - (Remq, Address), - (Value, Value)); - - Rstat : Long_Integer; - Remret : Remq; - - begin - SYS_PAL_REMQTIL (Remret, Header); - - Rstat := Remret.Status; - Item := Remret.Item; - - -- Wouldn't case be nicer here, and in previous similar cases ??? - - if Rstat = 0 then - Status := Fail_Was_Empty; - - elsif Rstat = 1 then - Status := OK_Not_Empty; - - elsif Rstat = 2 then - Status := OK_Empty; - else - -- This status is never returned on IVMS - - Status := Fail_No_Lock; - end if; - end Remqti; - -end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec-vms_64.ads b/gcc/ada/s-auxdec-vms_64.ads deleted file mode 100644 index 1bac3fbac95..00000000000 --- a/gcc/ada/s-auxdec-vms_64.ads +++ /dev/null @@ -1,693 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains definitions that are designed to be compatible --- with the extra definitions in package System for DEC Ada implementations. - --- These definitions can be used directly by withing this package, or merged --- with System using pragma Extend_System (Aux_DEC) - --- This is the VMS 64 bit version - -with Ada.Unchecked_Conversion; - -package System.Aux_DEC is - pragma Preelaborate; - - type Short_Integer_Address is - range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; - -- Integer literals cannot appear naked in an address context, as a - -- result the bounds of Short_Address cannot be given simply as 2^32 etc. - - subtype Short_Address is Address - range Address (Short_Integer_Address'First) .. - Address (Short_Integer_Address'Last); - for Short_Address'Object_Size use 32; - -- This subtype allows addresses to be converted from 64 bits to 32 bits - -- with an appropriate range check. Note that since this is a subtype of - -- type System.Address, the same limitations apply to this subtype. Namely - -- there are no visible arithmetic operations, and integer literals are - -- not available. - - Short_Memory_Size : constant := 2 ** 32; - -- Defined for convenience of porting - - type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; - for Integer_8'Size use 8; - - type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1; - for Integer_16'Size use 16; - - type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; - for Integer_32'Size use 32; - - type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1; - for Integer_64'Size use 64; - - type Integer_8_Array is array (Integer range <>) of Integer_8; - type Integer_16_Array is array (Integer range <>) of Integer_16; - type Integer_32_Array is array (Integer range <>) of Integer_32; - type Integer_64_Array is array (Integer range <>) of Integer_64; - -- These array types are not in all versions of DEC System, and in fact it - -- is not quite clear why they are in some and not others, but since they - -- definitely appear in some versions, we include them unconditionally. - - type Largest_Integer is range Min_Int .. Max_Int; - - type AST_Handler is private; - - No_AST_Handler : constant AST_Handler; - - type Type_Class is - (Type_Class_Enumeration, - Type_Class_Integer, - Type_Class_Fixed_Point, - Type_Class_Floating_Point, - Type_Class_Array, - Type_Class_Record, - Type_Class_Access, - Type_Class_Task, -- also in Ada 95 protected - Type_Class_Address); - - function "not" (Left : Largest_Integer) return Largest_Integer; - function "and" (Left, Right : Largest_Integer) return Largest_Integer; - function "or" (Left, Right : Largest_Integer) return Largest_Integer; - function "xor" (Left, Right : Largest_Integer) return Largest_Integer; - - Address_Zero : constant Address; - No_Addr : constant Address; - Address_Size : constant := Standard'Address_Size; - Short_Address_Size : constant := 32; - - function "+" (Left : Address; Right : Integer) return Address; - function "+" (Left : Integer; Right : Address) return Address; - function "-" (Left : Address; Right : Address) return Integer; - function "-" (Left : Address; Right : Integer) return Address; - - pragma Import (Intrinsic, "+"); - pragma Import (Intrinsic, "-"); - - generic - type Target is private; - function Fetch_From_Address (A : Address) return Target; - - generic - type Target is private; - procedure Assign_To_Address (A : Address; T : Target); - - -- Floating point type declarations for VAX floating point data types - - pragma Warnings (Off); - -- ??? needs comment - - type F_Float is digits 6; - pragma Float_Representation (VAX_Float, F_Float); - - type D_Float is digits 9; - pragma Float_Representation (Vax_Float, D_Float); - - type G_Float is digits 15; - pragma Float_Representation (Vax_Float, G_Float); - - -- Floating point type declarations for IEEE floating point data types - - type IEEE_Single_Float is digits 6; - pragma Float_Representation (IEEE_Float, IEEE_Single_Float); - - type IEEE_Double_Float is digits 15; - pragma Float_Representation (IEEE_Float, IEEE_Double_Float); - - pragma Warnings (On); - - Non_Ada_Error : exception; - - -- Hardware-oriented types and functions - - type Bit_Array is array (Integer range <>) of Boolean; - pragma Pack (Bit_Array); - - subtype Bit_Array_8 is Bit_Array (0 .. 7); - subtype Bit_Array_16 is Bit_Array (0 .. 15); - subtype Bit_Array_32 is Bit_Array (0 .. 31); - subtype Bit_Array_64 is Bit_Array (0 .. 63); - - type Unsigned_Byte is range 0 .. 255; - for Unsigned_Byte'Size use 8; - - function "not" (Left : Unsigned_Byte) return Unsigned_Byte; - function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - - function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte; - function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8; - - type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte; - - type Unsigned_Word is range 0 .. 65535; - for Unsigned_Word'Size use 16; - - function "not" (Left : Unsigned_Word) return Unsigned_Word; - function "and" (Left, Right : Unsigned_Word) return Unsigned_Word; - function "or" (Left, Right : Unsigned_Word) return Unsigned_Word; - function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word; - - function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word; - function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16; - - type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word; - - type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647; - for Unsigned_Longword'Size use 32; - - function "not" (Left : Unsigned_Longword) return Unsigned_Longword; - function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - - function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword; - function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32; - - type Unsigned_Longword_Array is - array (Integer range <>) of Unsigned_Longword; - - type Unsigned_32 is range 0 .. 4_294_967_295; - for Unsigned_32'Size use 32; - - function "not" (Left : Unsigned_32) return Unsigned_32; - function "and" (Left, Right : Unsigned_32) return Unsigned_32; - function "or" (Left, Right : Unsigned_32) return Unsigned_32; - function "xor" (Left, Right : Unsigned_32) return Unsigned_32; - - function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32; - function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32; - - type Unsigned_Quadword is record - L0 : Unsigned_Longword; - L1 : Unsigned_Longword; - end record; - - for Unsigned_Quadword'Size use 64; - for Unsigned_Quadword'Alignment use - Integer'Min (8, Standard'Maximum_Alignment); - - function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword; - function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - - function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword; - function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64; - - type Unsigned_Quadword_Array is - array (Integer range <>) of Unsigned_Quadword; - - function To_Address (X : Integer) return Short_Address; - pragma Pure_Function (To_Address); - - function To_Address_Long (X : Unsigned_Longword) return Short_Address; - pragma Pure_Function (To_Address_Long); - - function To_Integer (X : Short_Address) return Integer; - - function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword; - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; - - -- Conventional names for static subtypes of type UNSIGNED_LONGWORD - - subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1; - subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1; - subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1; - subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1; - subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1; - subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1; - subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1; - subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1; - subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1; - subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1; - subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1; - subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1; - subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1; - subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1; - subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1; - subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1; - subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1; - subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1; - subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1; - subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1; - subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1; - subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1; - subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1; - subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1; - subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1; - subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1; - subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1; - subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1; - subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1; - subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1; - subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1; - - -- Function for obtaining global symbol values - - function Import_Value (Symbol : String) return Unsigned_Longword; - function Import_Address (Symbol : String) return Address; - function Import_Largest_Value (Symbol : String) return Largest_Integer; - - pragma Import (Intrinsic, Import_Value); - pragma Import (Intrinsic, Import_Address); - pragma Import (Intrinsic, Import_Largest_Value); - - -- For the following declarations, note that the declaration without a - -- Retry_Count parameter means to retry infinitely. A value of zero for - -- the Retry_Count parameter means do not retry. - - -- Interlocked-instruction procedures - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean); - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean); - - type Aligned_Word is record - Value : Short_Integer; - end record; - - for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment); - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean); - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean); - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer); - - type Aligned_Integer is record - Value : Integer; - end record; - - for Aligned_Integer'Alignment use - Integer'Min (4, Standard'Maximum_Alignment); - - type Aligned_Long_Integer is record - Value : Long_Integer; - end record; - - for Aligned_Long_Integer'Alignment use - Integer'Min (8, Standard'Maximum_Alignment); - - -- For the following declarations, note that the declaration without a - -- Retry_Count parameter mean to retry infinitely. A value of zero for - -- the Retry_Count means do not retry. - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer); - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer); - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer); - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer); - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer); - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First); - - for Insq_Status use - (Fail_No_Lock => -1, - OK_Not_First => 0, - OK_First => +1); - - type Remq_Status is ( - Fail_No_Lock, - Fail_Was_Empty, - OK_Not_Empty, - OK_Empty); - - for Remq_Status use - (Fail_No_Lock => -1, - Fail_Was_Empty => 0, - OK_Not_Empty => +1, - OK_Empty => +2); - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status); - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status); - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status); - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status); - -private - - Address_Zero : constant Address := Null_Address; - No_Addr : constant Address := Null_Address; - - -- An AST_Handler value is from a typing point of view simply a pointer - -- to a procedure taking a single 64 bit parameter. However, this - -- is a bit misleading, because the data that this pointer references is - -- highly stylized. See body of System.AST_Handling for full details. - - type AST_Handler is access procedure (Param : Long_Integer); - No_AST_Handler : constant AST_Handler := null; - - -- Other operators have incorrect profiles. It would be nice to make - -- them intrinsic, since the backend can handle them, but the front - -- end is not prepared to deal with them, so at least inline them. - - pragma Import (Intrinsic, "not"); - pragma Import (Intrinsic, "and"); - pragma Import (Intrinsic, "or"); - pragma Import (Intrinsic, "xor"); - - -- Other inlined subprograms - - pragma Inline_Always (Fetch_From_Address); - pragma Inline_Always (Assign_To_Address); - - -- Synchronization related subprograms. Mechanism is explicitly set - -- so that the critical parameters are passed by reference. - -- Without this, the parameters are passed by copy, creating load/store - -- race conditions. We also inline them, since this seems more in the - -- spirit of the original (hardware intrinsic) routines. - - pragma Export_Procedure - (Clear_Interlocked, - External => "system__aux_dec__clear_interlocked__1", - Parameter_Types => (Boolean, Boolean), - Mechanism => (Reference, Reference)); - pragma Export_Procedure - (Clear_Interlocked, - External => "system__aux_dec__clear_interlocked__2", - Parameter_Types => (Boolean, Boolean, Natural, Boolean), - Mechanism => (Reference, Reference, Value, Reference)); - pragma Inline_Always (Clear_Interlocked); - - pragma Export_Procedure - (Set_Interlocked, - External => "system__aux_dec__set_interlocked__1", - Parameter_Types => (Boolean, Boolean), - Mechanism => (Reference, Reference)); - pragma Export_Procedure - (Set_Interlocked, - External => "system__aux_dec__set_interlocked__2", - Parameter_Types => (Boolean, Boolean, Natural, Boolean), - Mechanism => (Reference, Reference, Value, Reference)); - pragma Inline_Always (Set_Interlocked); - - pragma Export_Procedure - (Add_Interlocked, - External => "system__aux_dec__add_interlocked__1", - Mechanism => (Value, Reference, Reference)); - pragma Inline_Always (Add_Interlocked); - - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (Add_Atomic); - - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (And_Atomic); - - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (Or_Atomic); - - -- Inline the VAX Queue Functions - - pragma Inline_Always (Insqhi); - pragma Inline_Always (Remqhi); - pragma Inline_Always (Insqti); - pragma Inline_Always (Remqti); - - -- Provide proper unchecked conversion definitions for transfer - -- functions. Note that we need this level of indirection because - -- the formal parameter name is X and not Source (and this is indeed - -- detectable by a program) - - function To_Unsigned_Byte_A is new - Ada.Unchecked_Conversion (Bit_Array_8, Unsigned_Byte); - - function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte - renames To_Unsigned_Byte_A; - - function To_Bit_Array_8_A is new - Ada.Unchecked_Conversion (Unsigned_Byte, Bit_Array_8); - - function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8 - renames To_Bit_Array_8_A; - - function To_Unsigned_Word_A is new - Ada.Unchecked_Conversion (Bit_Array_16, Unsigned_Word); - - function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word - renames To_Unsigned_Word_A; - - function To_Bit_Array_16_A is new - Ada.Unchecked_Conversion (Unsigned_Word, Bit_Array_16); - - function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16 - renames To_Bit_Array_16_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_Longword); - - function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - function To_Bit_Array_32_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Bit_Array_32); - - function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32 - renames To_Bit_Array_32_A; - - function To_Unsigned_32_A is new - Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_32); - - function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32 - renames To_Unsigned_32_A; - - function To_Bit_Array_32_A is new - Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_32); - - function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32 - renames To_Bit_Array_32_A; - - function To_Unsigned_Quadword_A is new - Ada.Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword); - - function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword - renames To_Unsigned_Quadword_A; - - function To_Bit_Array_64_A is new - Ada.Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64); - - function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64 - renames To_Bit_Array_64_A; - - pragma Warnings (Off); - -- Turn warnings off. This is needed for systems with 64-bit integers, - -- where some of these operations are of dubious meaning, but we do not - -- want warnings when we compile on such systems. - - function To_Address_A is new - Ada.Unchecked_Conversion (Integer, Short_Address); - pragma Pure_Function (To_Address_A); - - function To_Address (X : Integer) return Short_Address - renames To_Address_A; - pragma Pure_Function (To_Address); - - function To_Address_Long_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Short_Address); - pragma Pure_Function (To_Address_Long_A); - - function To_Address_Long (X : Unsigned_Longword) return Short_Address - renames To_Address_Long_A; - pragma Pure_Function (To_Address_Long); - - function To_Integer_A is new - Ada.Unchecked_Conversion (Short_Address, Integer); - - function To_Integer (X : Short_Address) return Integer - renames To_Integer_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); - - function To_Unsigned_Longword (X : Short_Address) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (AST_Handler, Unsigned_Longword); - - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - pragma Warnings (On); - -end System.Aux_DEC; diff --git a/gcc/ada/s-inmaop-vms.adb b/gcc/ada/s-inmaop-vms.adb deleted file mode 100644 index b99b155f38c..00000000000 --- a/gcc/ada/s-inmaop-vms.adb +++ /dev/null @@ -1,303 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.INTERRUPT_MANAGEMENT.OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - -with System.OS_Interface; -with System.Aux_DEC; -with System.Parameters; -with System.Tasking; -with System.Tasking.Initialization; -with System.Task_Primitives; -with System.Task_Primitives.Operations; -with System.Task_Primitives.Operations.DEC; - -with Ada.Unchecked_Conversion; - -package body System.Interrupt_Management.Operations is - - use System.OS_Interface; - use System.Parameters; - use System.Tasking; - use type unsigned_short; - - function To_Address is - new Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - package POP renames System.Task_Primitives.Operations; - - ---------------------------- - -- Thread_Block_Interrupt -- - ---------------------------- - - procedure Thread_Block_Interrupt (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Thread_Block_Interrupt; - - ------------------------------ - -- Thread_Unblock_Interrupt -- - ------------------------------ - - procedure Thread_Unblock_Interrupt (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Thread_Unblock_Interrupt; - - ------------------------ - -- Set_Interrupt_Mask -- - ------------------------ - - procedure Set_Interrupt_Mask (Mask : access Interrupt_Mask) is - pragma Warnings (Off, Mask); - begin - null; - end Set_Interrupt_Mask; - - procedure Set_Interrupt_Mask - (Mask : access Interrupt_Mask; - OMask : access Interrupt_Mask) - is - pragma Warnings (Off, Mask); - pragma Warnings (Off, OMask); - begin - null; - end Set_Interrupt_Mask; - - ------------------------ - -- Get_Interrupt_Mask -- - ------------------------ - - procedure Get_Interrupt_Mask (Mask : access Interrupt_Mask) is - pragma Warnings (Off, Mask); - begin - null; - end Get_Interrupt_Mask; - - -------------------- - -- Interrupt_Wait -- - -------------------- - - function To_unsigned_long is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, unsigned_long); - - function Interrupt_Wait (Mask : access Interrupt_Mask) - return Interrupt_ID - is - Self_ID : constant Task_Id := Self; - Iosb : IO_Status_Block_Type := (0, 0, 0); - Status : Cond_Value_Type; - - begin - - -- A QIO read is registered. The system call returns immediately - -- after scheduling an AST to be fired when the operation - -- completes. - - Sys_QIO - (Status => Status, - Chan => Rcv_Interrupt_Chan, - Func => IO_READVBLK, - Iosb => Iosb, - Astadr => - POP.DEC.Interrupt_AST_Handler'Access, - Astprm => To_Address (Self_ID), - P1 => To_unsigned_long (Interrupt_Mailbox'Address), - P2 => Interrupt_ID'Size / 8); - - pragma Assert ((Status and 1) = 1); - - loop - - -- Wait to be woken up. Could be that the AST has fired, - -- in which case the Iosb.Status variable will be non-zero, - -- or maybe the wait is being aborted. - - POP.Sleep - (Self_ID, - System.Tasking.Interrupt_Server_Blocked_On_Event_Flag); - - if Iosb.Status /= 0 then - if (Iosb.Status and 1) = 1 - and then Mask (Signal (Interrupt_Mailbox)) - then - return Interrupt_Mailbox; - else - return 0; - end if; - else - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - System.Tasking.Initialization.Defer_Abort (Self_ID); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - end if; - end loop; - end Interrupt_Wait; - - ---------------------------- - -- Install_Default_Action -- - ---------------------------- - - procedure Install_Default_Action (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Install_Default_Action; - - --------------------------- - -- Install_Ignore_Action -- - --------------------------- - - procedure Install_Ignore_Action (Interrupt : Interrupt_ID) is - pragma Warnings (Off, Interrupt); - begin - null; - end Install_Ignore_Action; - - ------------------------- - -- Fill_Interrupt_Mask -- - ------------------------- - - procedure Fill_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - Mask.all := (others => True); - end Fill_Interrupt_Mask; - - -------------------------- - -- Empty_Interrupt_Mask -- - -------------------------- - - procedure Empty_Interrupt_Mask (Mask : access Interrupt_Mask) is - begin - Mask.all := (others => False); - end Empty_Interrupt_Mask; - - --------------------------- - -- Add_To_Interrupt_Mask -- - --------------------------- - - procedure Add_To_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - Mask (Signal (Interrupt)) := True; - end Add_To_Interrupt_Mask; - - -------------------------------- - -- Delete_From_Interrupt_Mask -- - -------------------------------- - - procedure Delete_From_Interrupt_Mask - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) - is - begin - Mask (Signal (Interrupt)) := False; - end Delete_From_Interrupt_Mask; - - --------------- - -- Is_Member -- - --------------- - - function Is_Member - (Mask : access Interrupt_Mask; - Interrupt : Interrupt_ID) return Boolean - is - begin - return Mask (Signal (Interrupt)); - end Is_Member; - - ------------------------- - -- Copy_Interrupt_Mask -- - ------------------------- - - procedure Copy_Interrupt_Mask - (X : out Interrupt_Mask; - Y : Interrupt_Mask) - is - begin - X := Y; - end Copy_Interrupt_Mask; - - ---------------------------- - -- Interrupt_Self_Process -- - ---------------------------- - - procedure Interrupt_Self_Process (Interrupt : Interrupt_ID) is - Status : Cond_Value_Type; - begin - Sys_QIO - (Status => Status, - Chan => Snd_Interrupt_Chan, - Func => IO_WRITEVBLK, - P1 => To_unsigned_long (Interrupt'Address), - P2 => Interrupt_ID'Size / 8); - - -- The following could use a comment ??? - - pragma Assert ((Status and 1) = 1); - end Interrupt_Self_Process; - - -------------------------- - -- Setup_Interrupt_Mask -- - -------------------------- - - procedure Setup_Interrupt_Mask is - begin - null; - end Setup_Interrupt_Mask; - -begin - Interrupt_Management.Initialize; - Environment_Mask := (others => False); - All_Tasks_Mask := (others => True); - - for J in Interrupt_ID loop - if Keep_Unmasked (J) then - Environment_Mask (Signal (J)) := True; - All_Tasks_Mask (Signal (J)) := False; - end if; - end loop; -end System.Interrupt_Management.Operations; diff --git a/gcc/ada/s-interr-vms.adb b/gcc/ada/s-interr-vms.adb deleted file mode 100644 index 1fc141f62e6..00000000000 --- a/gcc/ada/s-interr-vms.adb +++ /dev/null @@ -1,1128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is an OpenVMS/Alpha version of this package - --- Invariants: - --- Once we associate a Server_Task with an interrupt, the task never --- goes away, and we never remove the association. - --- There is no more than one interrupt per Server_Task and no more than --- one Server_Task per interrupt. - --- Within this package, the lock L is used to protect the various status --- tables. If there is a Server_Task associated with an interrupt, we use --- the per-task lock of the Server_Task instead so that we protect the --- status between Interrupt_Manager and Server_Task. Protection among --- service requests are done using User Request to Interrupt_Manager --- rendezvous. - -with Ada.Task_Identification; -with Ada.Unchecked_Conversion; - -with System.Task_Primitives; -with System.Interrupt_Management; - -with System.Interrupt_Management.Operations; -pragma Elaborate_All (System.Interrupt_Management.Operations); - -with System.Task_Primitives.Operations; -with System.Task_Primitives.Interrupt_Operations; -with System.Storage_Elements; -with System.Tasking.Utilities; - -with System.Tasking.Rendezvous; -pragma Elaborate_All (System.Tasking.Rendezvous); - -with System.Tasking.Initialization; -with System.Parameters; - -package body System.Interrupts is - - use Tasking; - use System.Parameters; - - package POP renames System.Task_Primitives.Operations; - package PIO renames System.Task_Primitives.Interrupt_Operations; - package IMNG renames System.Interrupt_Management; - package IMOP renames System.Interrupt_Management.Operations; - - function To_System is new Ada.Unchecked_Conversion - (Ada.Task_Identification.Task_Id, Task_Id); - - ----------------- - -- Local Tasks -- - ----------------- - - -- WARNING: System.Tasking.Stages performs calls to this task with - -- low-level constructs. Do not change this spec without synchronizing it. - - task Interrupt_Manager is - entry Detach_Interrupt_Entries (T : Task_Id); - - entry Initialize (Mask : IMNG.Interrupt_Mask); - - entry Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - entry Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean); - - entry Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - entry Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Interrupt : Interrupt_ID); - - entry Block_Interrupt (Interrupt : Interrupt_ID); - - entry Unblock_Interrupt (Interrupt : Interrupt_ID); - - entry Ignore_Interrupt (Interrupt : Interrupt_ID); - - entry Unignore_Interrupt (Interrupt : Interrupt_ID); - - pragma Interrupt_Priority (System.Interrupt_Priority'Last); - end Interrupt_Manager; - - task type Server_Task (Interrupt : Interrupt_ID) is - pragma Priority (System.Interrupt_Priority'Last); - -- Note: the above pragma Priority is strictly speaking improper since - -- it is outside the range of allowed priorities, but the compiler - -- treats system units specially and does not apply this range checking - -- rule to system units. - - end Server_Task; - - type Server_Task_Access is access Server_Task; - - ------------------------------- - -- Local Types and Variables -- - ------------------------------- - - type Entry_Assoc is record - T : Task_Id; - E : Task_Entry_Index; - end record; - - type Handler_Assoc is record - H : Parameterless_Handler; - Static : Boolean; -- Indicates static binding; - end record; - - User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := - (others => (null, Static => False)); - pragma Volatile_Components (User_Handler); - -- Holds the protected procedure handler (if any) and its Static - -- information for each interrupt. A handler is a Static one if it is - -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, - -- not static) - - User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := - (others => (T => Null_Task, E => Null_Task_Entry)); - pragma Volatile_Components (User_Entry); - -- Holds the task and entry index (if any) for each interrupt - - Blocked : constant array (Interrupt_ID'Range) of Boolean := - (others => False); - -- ??? pragma Volatile_Components (Blocked); - -- True iff the corresponding interrupt is blocked in the process level - - Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); - pragma Volatile_Components (Ignored); - -- True iff the corresponding interrupt is blocked in the process level - - Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id := - (others => Null_Task); - -- ??? pragma Volatile_Components (Last_Unblocker); - -- Holds the ID of the last Task which Unblocked this Interrupt. It - -- contains Null_Task if no tasks have ever requested the Unblocking - -- operation or the Interrupt is currently Blocked. - - Server_ID : array (Interrupt_ID'Range) of Task_Id := - (others => Null_Task); - pragma Atomic_Components (Server_ID); - -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is - -- needed to accomplish locking per Interrupt base. Also is needed to - -- decide whether to create a new Server_Task. - - -- Type and Head, Tail of the list containing Registered Interrupt - -- Handlers. These definitions are used to register the handlers - -- specified by the pragma Interrupt_Handler. - - type Registered_Handler; - type R_Link is access all Registered_Handler; - - type Registered_Handler is record - H : System.Address := System.Null_Address; - Next : R_Link := null; - end record; - - Registered_Handler_Head : R_Link := null; - Registered_Handler_Tail : R_Link := null; - - Access_Hold : Server_Task_Access; - -- variable used to allocate Server_Task using "new" - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean; - -- See if the Handler has been "pragma"ed using Interrupt_Handler. - -- Always consider a null handler as registered. - - -------------------------------- - -- Register_Interrupt_Handler -- - -------------------------------- - - procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is - New_Node_Ptr : R_Link; - - begin - -- This routine registers the Handler as usable for Dynamic Interrupt - -- Handler. Routines attaching and detaching Handler dynamically should - -- first consult if the Handler is registered. A Program Error should be - -- raised if it is not registered. - - -- The pragma Interrupt_Handler can only appear in the library level PO - -- definition and instantiation. Therefore, we do not need to implement - -- Unregistering operation. Neither we need to protect the queue - -- structure using a Lock. - - pragma Assert (Handler_Addr /= System.Null_Address); - - New_Node_Ptr := new Registered_Handler; - New_Node_Ptr.H := Handler_Addr; - - if Registered_Handler_Head = null then - Registered_Handler_Head := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - - else - Registered_Handler_Tail.Next := New_Node_Ptr; - Registered_Handler_Tail := New_Node_Ptr; - end if; - end Register_Interrupt_Handler; - - ------------------- - -- Is_Registered -- - ------------------- - - function Is_Registered (Handler : Parameterless_Handler) return Boolean is - type Fat_Ptr is record - Object_Addr : System.Address; - Handler_Addr : System.Address; - end record; - - function To_Fat_Ptr is new Ada.Unchecked_Conversion - (Parameterless_Handler, Fat_Ptr); - - Ptr : R_Link; - Fat : Fat_Ptr; - - begin - if Handler = null then - return True; - end if; - - Fat := To_Fat_Ptr (Handler); - - Ptr := Registered_Handler_Head; - while Ptr /= null loop - if Ptr.H = Fat.Handler_Addr then - return True; - end if; - - Ptr := Ptr.Next; - end loop; - - return False; - end Is_Registered; - - ----------------- - -- Is_Reserved -- - ----------------- - - function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is - begin - return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); - end Is_Reserved; - - ----------------------- - -- Is_Entry_Attached -- - ----------------------- - - function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return User_Entry (Interrupt).T /= Null_Task; - end Is_Entry_Attached; - - ------------------------- - -- Is_Handler_Attached -- - ------------------------- - - function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return User_Handler (Interrupt).H /= null; - end Is_Handler_Attached; - - ---------------- - -- Is_Blocked -- - ---------------- - - function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Blocked (Interrupt); - end Is_Blocked; - - ---------------- - -- Is_Ignored -- - ---------------- - - function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Ignored (Interrupt); - end Is_Ignored; - - --------------------- - -- Current_Handler -- - --------------------- - - function Current_Handler - (Interrupt : Interrupt_ID) return Parameterless_Handler - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - -- ??? Since Parameterless_Handler is not Atomic, the current - -- implementation is wrong. We need a new service in Interrupt_Manager - -- to ensure atomicity. - - return User_Handler (Interrupt).H; - end Current_Handler; - - -------------------- - -- Attach_Handler -- - -------------------- - - -- Calling this procedure with New_Handler = null and Static = True - -- means we want to detach the current handler regardless of the previous - -- handler's binding status (i.e. we do not care if it is a dynamic or - -- static handler). - - -- This option is needed so that during the finalization of a PO, we - -- can detach handlers attached through pragma Attach_Handler. - - procedure Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); - end Attach_Handler; - - ---------------------- - -- Exchange_Handler -- - ---------------------- - - -- Calling this procedure with New_Handler = null and Static = True means - -- we want to detach the current handler regardless of the previous - -- handler's binding status (i.e. do not care if it is dynamic or static - -- handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - -------------------- - -- Detach_Handler -- - -------------------- - - -- Calling this procedure with Static = True means we want to Detach the - -- current handler regardless of the previous handler's binding status - -- (i.e. do not care if it is a dynamic or static handler). - - -- This option is needed so that during the finalization of a PO, we can - -- detach handlers attached through pragma Attach_Handler. - - procedure Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean := False) - is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Detach_Handler (Interrupt, Static); - end Detach_Handler; - - --------------- - -- Reference -- - --------------- - - function Reference (Interrupt : Interrupt_ID) return System.Address is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Storage_Elements.To_Address - (Storage_Elements.Integer_Address (Interrupt)); - end Reference; - - ----------------------------- - -- Bind_Interrupt_To_Entry -- - ----------------------------- - - -- This procedure raises a Program_Error if it tries to - -- bind an interrupt to which an Entry or a Procedure is - -- already bound. - - procedure Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Int_Ref : System.Address) - is - Interrupt : constant Interrupt_ID := - Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); - - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); - end Bind_Interrupt_To_Entry; - - ------------------------------ - -- Detach_Interrupt_Entries -- - ------------------------------ - - procedure Detach_Interrupt_Entries (T : Task_Id) is - begin - Interrupt_Manager.Detach_Interrupt_Entries (T); - end Detach_Interrupt_Entries; - - --------------------- - -- Block_Interrupt -- - --------------------- - - procedure Block_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Block_Interrupt (Interrupt); - end Block_Interrupt; - - ----------------------- - -- Unblock_Interrupt -- - ----------------------- - - procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Unblock_Interrupt (Interrupt); - end Unblock_Interrupt; - - ------------------ - -- Unblocked_By -- - ------------------ - - function Unblocked_By - (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - return Last_Unblocker (Interrupt); - end Unblocked_By; - - ---------------------- - -- Ignore_Interrupt -- - ---------------------- - - procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Ignore_Interrupt (Interrupt); - end Ignore_Interrupt; - - ------------------------ - -- Unignore_Interrupt -- - ------------------------ - - procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is - begin - if Is_Reserved (Interrupt) then - raise Program_Error with - "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; - end if; - - Interrupt_Manager.Unignore_Interrupt (Interrupt); - end Unignore_Interrupt; - - ----------------------- - -- Interrupt_Manager -- - ----------------------- - - task body Interrupt_Manager is - -- By making this task independent of master, when the process goes - -- away, the Interrupt_Manager will terminate gracefully. - - Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; - - -------------------- - -- Local Routines -- - -------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False); - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean); - - ---------------------------------- - -- Unprotected_Exchange_Handler -- - ---------------------------------- - - procedure Unprotected_Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - - -- In case we have an Interrupt Entry already installed. - -- raise a program error. (propagate it to the caller). - - raise Program_Error with "an interrupt is already installed"; - end if; - - -- Note: A null handler with Static=True will pass the following - -- check. That is the case when we want to Detach a handler - -- regardless of the Static status of the current_Handler. We don't - -- check anything if Restoration is True, since we may be detaching - -- a static handler to restore a dynamic one. - - if not Restoration and then not Static - - -- Tries to overwrite a static Interrupt Handler with a - -- dynamic Handler - - and then (User_Handler (Interrupt).Static - - -- The new handler is not specified as an - -- Interrupt Handler by a pragma. - - or else not Is_Registered (New_Handler)) - then - raise Program_Error with - "trying to overwrite a static interrupt handler with a " & - "dynamic handler"; - end if; - - -- The interrupt should no longer be ignored if it was ever ignored - - Ignored (Interrupt) := False; - - -- Save the old handler - - Old_Handler := User_Handler (Interrupt).H; - - -- The new handler - - User_Handler (Interrupt).H := New_Handler; - - if New_Handler = null then - - -- The null handler means we are detaching the handler - - User_Handler (Interrupt).Static := False; - - else - User_Handler (Interrupt).Static := Static; - end if; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_Id info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - Access_Hold := new Server_Task (Interrupt); - Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); - else - POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); - end if; - - end Unprotected_Exchange_Handler; - - -------------------------------- - -- Unprotected_Detach_Handler -- - -------------------------------- - - procedure Unprotected_Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - is - begin - if User_Entry (Interrupt).T /= Null_Task then - - -- In case we have an Interrupt Entry installed, raise a program - -- error, (propagate it to the caller). - - raise Program_Error with - "an interrupt entry is already installed"; - end if; - - -- Note : Static = True will pass the following check. That is the - -- case when we want to detach a handler regardless of the static - -- status of the current_Handler. - - if not Static and then User_Handler (Interrupt).Static then - - -- Tries to detach a static Interrupt Handler, raise program error - - raise Program_Error with - "trying to detach a static interrupt handler"; - end if; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - - -- The new handler - - User_Handler (Interrupt).H := null; - User_Handler (Interrupt).Static := False; - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); - - end Unprotected_Detach_Handler; - - -- Start of processing for Interrupt_Manager - - begin - -- Environment task gets its own interrupt mask, saves it, and then - -- masks all interrupts except the Keep_Unmasked set. - - -- During rendezvous, the Interrupt_Manager receives the old interrupt - -- mask of the environment task, and sets its own interrupt mask to that - -- value. - - -- The environment task will call the entry of Interrupt_Manager some - -- during elaboration of the body of this package. - - accept Initialize (Mask : IMNG.Interrupt_Mask) do - pragma Warnings (Off, Mask); - null; - end Initialize; - - -- Note: All tasks in RTS will have all the Reserve Interrupts being - -- masked (except the Interrupt_Manager) and Keep_Unmasked unmasked - -- when created. - - -- Abort_Task_Interrupt is one of the Interrupt unmasked in all tasks. - -- We mask the Interrupt in this particular task so that "sigwait" is - -- possible to catch an explicitly sent Abort_Task_Interrupt from the - -- Server_Tasks. - - -- This sigwaiting is needed so that we make sure a Server_Task is out - -- of its own sigwait state. This extra synchronization is necessary to - -- prevent following scenarios. - - -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the - -- Server_Task then changes its own interrupt mask (OS level). - -- If an interrupt (corresponding to the Server_Task) arrives - -- in the mean time we have the Interrupt_Manager unmasked and - -- the Server_Task waiting on sigwait. - - -- 2) For unbinding handler, we install a default action in the - -- Interrupt_Manager. POSIX.1c states that the result of using - -- "sigwait" and "sigaction" simultaneously on the same interrupt - -- is undefined. Therefore, we need to be informed from the - -- Server_Task of the fact that the Server_Task is out of its - -- sigwait stage. - - loop - -- A block is needed to absorb Program_Error exception - - declare - Old_Handler : Parameterless_Handler; - - begin - select - - accept Attach_Handler - (New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean; - Restoration : Boolean := False) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static, Restoration); - end Attach_Handler; - - or accept Exchange_Handler - (Old_Handler : out Parameterless_Handler; - New_Handler : Parameterless_Handler; - Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Exchange_Handler - (Old_Handler, New_Handler, Interrupt, Static); - end Exchange_Handler; - - or accept Detach_Handler - (Interrupt : Interrupt_ID; - Static : Boolean) - do - Unprotected_Detach_Handler (Interrupt, Static); - end Detach_Handler; - - or accept Bind_Interrupt_To_Entry - (T : Task_Id; - E : Task_Entry_Index; - Interrupt : Interrupt_ID) - do - -- if there is a binding already (either a procedure or an - -- entry), raise Program_Error (propagate it to the caller). - - if User_Handler (Interrupt).H /= null - or else User_Entry (Interrupt).T /= Null_Task - then - raise Program_Error with - "a binding for this interrupt is already present"; - end if; - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (Interrupt) := False; - User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); - - -- Indicate the attachment of Interrupt Entry in ATCB. - -- This is need so that when an Interrupt Entry task - -- terminates the binding can be cleaned. - -- The call to unbinding must be - -- make by the task before it terminates. - - T.Interrupt_Entry := True; - - -- Invoke a corresponding Server_Task if not yet created. - -- Place Task_Id info in Server_ID array. - - if Server_ID (Interrupt) = Null_Task then - - Access_Hold := new Server_Task (Interrupt); - Server_ID (Interrupt) := - To_System (Access_Hold.all'Identity); - else - POP.Wakeup (Server_ID (Interrupt), - Interrupt_Server_Idle_Sleep); - end if; - end Bind_Interrupt_To_Entry; - - or accept Detach_Interrupt_Entries (T : Task_Id) - do - for J in Interrupt_ID'Range loop - if not Is_Reserved (J) then - if User_Entry (J).T = T then - - -- The interrupt should no longer be ignored if - -- it was ever ignored. - - Ignored (J) := False; - User_Entry (J) := - Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); - IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); - end if; - end if; - end loop; - - -- Indicate in ATCB that no Interrupt Entries are attached - - T.Interrupt_Entry := False; - end Detach_Interrupt_Entries; - - or accept Block_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Block_Interrupt; - - or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Unblock_Interrupt; - - or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Ignore_Interrupt; - - or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do - pragma Warnings (Off, Interrupt); - raise Program_Error; - end Unignore_Interrupt; - - end select; - - exception - -- If there is a program error we just want to propagate it to the - -- caller and do not want to stop this task. - - when Program_Error => - null; - - when others => - pragma Assert (False); - null; - end; - end loop; - end Interrupt_Manager; - - ----------------- - -- Server_Task -- - ----------------- - - task body Server_Task is - -- By making this task independent of master, when the process - -- goes away, the Server_Task will terminate gracefully. - - Ignore : constant Boolean := System.Tasking.Utilities.Make_Independent; - - Self_ID : constant Task_Id := Self; - Tmp_Handler : Parameterless_Handler; - Tmp_ID : Task_Id; - Tmp_Entry_Index : Task_Entry_Index; - Intwait_Mask : aliased IMNG.Interrupt_Mask; - - begin - -- Install default action in system level - - IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); - - -- Set up the mask (also clears the event flag) - - IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); - IMOP.Add_To_Interrupt_Mask - (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); - - -- Remember the Interrupt_ID for Abort_Task - - PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); - - -- Note: All tasks in RTS will have all the Reserve Interrupts - -- being masked (except the Interrupt_Manager) and Keep_Unmasked - -- unmasked when created. - - loop - System.Tasking.Initialization.Defer_Abort (Self_ID); - - -- A Handler or an Entry is installed. At this point all tasks - -- mask for the Interrupt is masked. Catch the Interrupt using - -- sigwait. - - -- This task may wake up from sigwait by receiving an interrupt - -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding - -- a Procedure Handler or an Entry. Or it could be a wake up - -- from status change (Unblocked -> Blocked). If that is not - -- the case, we should execute the attached Procedure or Entry. - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - if User_Handler (Interrupt).H = null - and then User_Entry (Interrupt).T = Null_Task - then - -- No Interrupt binding. If there is an interrupt, - -- Interrupt_Manager will take default action. - - Self_ID.Common.State := Interrupt_Server_Idle_Sleep; - POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); - Self_ID.Common.State := Runnable; - - else - Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; - Self_ID.Common.State := Runnable; - - if not (Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level - < Self_ID.ATC_Nesting_Level) - then - if User_Handler (Interrupt).H /= null then - Tmp_Handler := User_Handler (Interrupt).H; - - -- RTS calls should not be made with self being locked - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - Tmp_Handler.all; - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - - elsif User_Entry (Interrupt).T /= Null_Task then - Tmp_ID := User_Entry (Interrupt).T; - Tmp_Entry_Index := User_Entry (Interrupt).E; - - -- RTS calls should not be made with self being locked - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - System.Tasking.Rendezvous.Call_Simple - (Tmp_ID, Tmp_Entry_Index, System.Null_Address); - - if Single_Lock then - POP.Lock_RTS; - end if; - - POP.Write_Lock (Self_ID); - end if; - end if; - end if; - - POP.Unlock (Self_ID); - - if Single_Lock then - POP.Unlock_RTS; - end if; - - -- Undefer abort here to allow a window for this task to be aborted - -- at the time of system shutdown. - - System.Tasking.Initialization.Undefer_Abort (Self_ID); - end loop; - end Server_Task; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Dynamic_Interrupt_Protection) return Boolean - is - pragma Warnings (Off, Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Static_Interrupt_Protection) is - begin - -- ??? loop to be executed only when we're not doing library level - -- finalization, since in this case all interrupt tasks are gone. - - if not Interrupt_Manager'Terminated then - for N in reverse Object.Previous_Handlers'Range loop - Interrupt_Manager.Attach_Handler - (New_Handler => Object.Previous_Handlers (N).Handler, - Interrupt => Object.Previous_Handlers (N).Interrupt, - Static => Object.Previous_Handlers (N).Static, - Restoration => True); - end loop; - end if; - - Tasking.Protected_Objects.Entries.Finalize - (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); - end Finalize; - - ------------------------------------- - -- Has_Interrupt_Or_Attach_Handler -- - ------------------------------------- - - function Has_Interrupt_Or_Attach_Handler - (Object : access Static_Interrupt_Protection) return Boolean - is - pragma Warnings (Off, Object); - begin - return True; - end Has_Interrupt_Or_Attach_Handler; - - ---------------------- - -- Install_Handlers -- - ---------------------- - - procedure Install_Handlers - (Object : access Static_Interrupt_Protection; - New_Handlers : New_Handler_Array) - is - begin - for N in New_Handlers'Range loop - - -- We need a lock around this ??? - - Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; - Object.Previous_Handlers (N).Static := User_Handler - (New_Handlers (N).Interrupt).Static; - - -- We call Exchange_Handler and not directly Interrupt_Manager. - -- Exchange_Handler so we get the Is_Reserved check. - - Exchange_Handler - (Old_Handler => Object.Previous_Handlers (N).Handler, - New_Handler => New_Handlers (N).Handler, - Interrupt => New_Handlers (N).Interrupt, - Static => True); - end loop; - end Install_Handlers; - - --------------------------------- - -- Install_Restricted_Handlers -- - --------------------------------- - - procedure Install_Restricted_Handlers - (Prio : Any_Priority; - Handlers : New_Handler_Array) - is - pragma Unreferenced (Prio); - begin - for N in Handlers'Range loop - Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); - end loop; - end Install_Restricted_Handlers; - --- Elaboration code for package System.Interrupts - -begin - -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent - - Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); - - -- During the elaboration of this package body we want RTS to inherit the - -- interrupt mask from the Environment Task. - - -- The Environment Task should have gotten its mask from the enclosing - -- process during the RTS start up. (See in s-inmaop.adb). Pass the - -- Interrupt_Mask of the Environment task to the Interrupt_Manager. - - -- Note : At this point we know that all tasks (including RTS internal - -- servers) are masked for non-reserved signals (see s-taprop.adb). Only - -- the Interrupt_Manager will have masks set up differently inheriting the - -- original Environment Task's mask. - - Interrupt_Manager.Initialize (IMOP.Environment_Mask); -end System.Interrupts; diff --git a/gcc/ada/s-intman-vms.adb b/gcc/ada/s-intman-vms.adb deleted file mode 100644 index 0f198f15226..00000000000 --- a/gcc/ada/s-intman-vms.adb +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - -package body System.Interrupt_Management is - - ---------------- - -- Initialize -- - ---------------- - - Initialized : Boolean := False; - - procedure Initialize is - use System.OS_Interface; - Status : Cond_Value_Type; - - begin - if Initialized then - return; - end if; - - Initialized := True; - Abort_Task_Interrupt := Interrupt_ID_0; - -- Unused - - Reserve := Reserve or Keep_Unmasked or Keep_Masked; - Reserve (Interrupt_ID_0) := True; - - Sys_Crembx - (Status => Status, - Prmflg => 0, - Chan => Rcv_Interrupt_Chan, - Maxmsg => Interrupt_ID'Size, - Bufquo => Interrupt_Bufquo, - Lognam => "GNAT_Interrupt_Mailbox", - Flags => CMB_M_READONLY); - pragma Assert ((Status and 1) = 1); - - Sys_Assign - (Status => Status, - Devnam => "GNAT_Interrupt_Mailbox", - Chan => Snd_Interrupt_Chan, - Flags => AGN_M_WRITEONLY); - pragma Assert ((Status and 1) = 1); - end Initialize; - -end System.Interrupt_Management; diff --git a/gcc/ada/s-intman-vms.ads b/gcc/ada/s-intman-vms.ads deleted file mode 100644 index cc5124217ca..00000000000 --- a/gcc/ada/s-intman-vms.ads +++ /dev/null @@ -1,119 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . I N T E R R U P T _ M A N A G E M E N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2009, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/VMS version of this package - --- This package encapsulates and centralizes information about all uses of --- interrupts (or signals), including the target-dependent mapping of --- interrupts (or signals) to exceptions. - --- PLEASE DO NOT add any with-clauses to this package - --- PLEASE DO NOT put any subprogram declarations with arguments of type --- Interrupt_ID into the visible part of this package. - --- The type Interrupt_ID is used to derive the type in Ada.Interrupts, and --- adding more operations to that type would be illegal according to the Ada --- Reference Manual. (This is the reason why the signals sets below are --- implemented as visible arrays rather than functions.) - -with System.OS_Interface; - -package System.Interrupt_Management is - pragma Preelaborate; - - type Interrupt_Mask is limited private; - - type Interrupt_ID is new System.OS_Interface.Signal; - - type Interrupt_Set is array (Interrupt_ID) of Boolean; - - -- The following objects serve as constants, but are initialized in the - -- body to aid portability. This permits us to use more portable names for - -- interrupts, where distinct names may map to the same interrupt ID - -- value. For example, suppose SIGRARE is a signal that is not defined on - -- all systems, but is always reserved when it is defined. If we have the - -- convention that ID zero is not used for any "real" signals, and SIGRARE - -- = 0 when SIGRARE is not one of the locally supported signals, we can - -- write: - -- Reserved (SIGRARE) := true; - -- Then the initialization code will be portable. - - Abort_Task_Interrupt : Interrupt_ID; - -- The interrupt that is used to implement task abort, if an interrupt is - -- used for that purpose. This is one of the reserved interrupts. - - Keep_Unmasked : Interrupt_Set := (others => False); - -- Keep_Unmasked (I) is true iff the interrupt I is one that must be kept - -- unmasked at all times, except (perhaps) for short critical sections. - -- This includes interrupts that are mapped to exceptions (see - -- System.Interrupt_Exceptions.Is_Exception), but may also include - -- interrupts (e.g. timer) that need to be kept unmasked for other - -- reasons. Where interrupts are implemented as OS signals, and signal - -- masking is per-task, the interrupt should be unmasked in ALL TASKS. - - Reserve : Interrupt_Set := (others => False); - -- Reserve (I) is true iff the interrupt I is one that cannot be permitted - -- to be attached to a user handler. The possible reasons are many. For - -- example it may be mapped to an exception used to implement task abort. - - Keep_Masked : Interrupt_Set := (others => False); - -- Keep_Masked (I) is true iff the interrupt I must always be masked. - -- Where interrupts are implemented as OS signals, and signal masking is - -- per-task, the interrupt should be masked in ALL TASKS. There might not - -- be any interrupts in this class, depending on the environment. For - -- example, if interrupts are OS signals and signal masking is per-task, - -- use of the sigwait operation requires the signal be masked in all tasks. - - procedure Initialize; - -- Initialize the various variables defined in this package. - -- This procedure must be called before accessing any object from this - -- package and can be called multiple times. - -private - use type System.OS_Interface.unsigned_long; - - type Interrupt_Mask is new System.OS_Interface.sigset_t; - - -- Interrupts on VMS are implemented with a mailbox. A QIO read is - -- registered on the Rcv channel and the interrupt occurs by registering - -- a QIO write on the Snd channel. The maximum number of pending - -- interrupts is arbitrarily set at 1000. One nice feature of using - -- a mailbox is that it is trivially extendable to cross process - -- interrupts. - - Rcv_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; - Snd_Interrupt_Chan : System.OS_Interface.unsigned_short := 0; - Interrupt_Mailbox : Interrupt_ID := 0; - Interrupt_Bufquo : System.OS_Interface.unsigned_long := - 1000 * (Interrupt_ID'Size / 8); - -end System.Interrupt_Management; diff --git a/gcc/ada/s-mastop-vms.adb b/gcc/ada/s-mastop-vms.adb deleted file mode 100644 index 7426f50a5ec..00000000000 --- a/gcc/ada/s-mastop-vms.adb +++ /dev/null @@ -1,274 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Version for Alpha/VMS) -- --- -- --- Copyright (C) 2001-2012, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of System.Machine_State_Operations is for use on --- Alpha systems running VMS. - -with System.Memory; -with System.Aux_DEC; use System.Aux_DEC; -with Ada.Unchecked_Conversion; - -package body System.Machine_State_Operations is - - subtype Cond_Value_Type is Unsigned_Longword; - - -- Record layouts copied from Starlet - - type ICB_Fflags_Bits_Type is record - Exception_Frame : Boolean; - Ast_Frame : Boolean; - Bottom_Of_Stack : Boolean; - Base_Frame : Boolean; - Filler_1 : Unsigned_20; - end record; - - for ICB_Fflags_Bits_Type use record - Exception_Frame at 0 range 0 .. 0; - Ast_Frame at 0 range 1 .. 1; - Bottom_Of_Stack at 0 range 2 .. 2; - Base_Frame at 0 range 3 .. 3; - Filler_1 at 0 range 4 .. 23; - end record; - for ICB_Fflags_Bits_Type'Size use 24; - - type ICB_Hdr_Quad_Type is record - Context_Length : Unsigned_Longword; - Fflags_Bits : ICB_Fflags_Bits_Type; - Block_Version : Unsigned_Byte; - end record; - - for ICB_Hdr_Quad_Type use record - Context_Length at 0 range 0 .. 31; - Fflags_Bits at 4 range 0 .. 23; - Block_Version at 7 range 0 .. 7; - end record; - for ICB_Hdr_Quad_Type'Size use 64; - - type Invo_Context_Blk_Type is record - - Hdr_Quad : ICB_Hdr_Quad_Type; - -- The first quadword contains: - -- o The length of the structure in bytes (a longword field) - -- o The frame flags (a 3 byte field of bits) - -- o The version number (a 1 byte field) - - Procedure_Descriptor : Unsigned_Quadword; - -- The address of the procedure descriptor for the procedure - - Program_Counter : Integer_64; - -- The current PC of a given procedure invocation - - Processor_Status : Integer_64; - -- The current PS of a given procedure invocation - - Ireg : Unsigned_Quadword_Array (0 .. 30); - Freg : Unsigned_Quadword_Array (0 .. 30); - -- The register contents areas. 31 for scalars, 31 for float - - System_Defined : Unsigned_Quadword_Array (0 .. 1); - -- The following is an "internal" area that's reserved for use by - -- the operating system. It's size may vary over time. - - -- Chfctx_Addr : Unsigned_Quadword; - -- Defined as a comment since it overlaps other fields - - Filler_1 : String (1 .. 0); - -- Align to octaword - end record; - - for Invo_Context_Blk_Type use record - Hdr_Quad at 0 range 0 .. 63; - Procedure_Descriptor at 8 range 0 .. 63; - Program_Counter at 16 range 0 .. 63; - Processor_Status at 24 range 0 .. 63; - Ireg at 32 range 0 .. 1983; - Freg at 280 range 0 .. 1983; - System_Defined at 528 range 0 .. 127; - - -- Component representation spec(s) below are defined as - -- comments since they overlap other fields - - -- Chfctx_Addr at 528 range 0 .. 63; - - Filler_1 at 544 range 0 .. -1; - end record; - for Invo_Context_Blk_Type'Size use 4352; - - subtype Invo_Handle_Type is Unsigned_Longword; - - type Invo_Handle_Access_Type is access all Invo_Handle_Type; - - function Fetch is new Fetch_From_Address (Code_Loc); - - function To_Invo_Handle_Access is new Ada.Unchecked_Conversion - (Machine_State, Invo_Handle_Access_Type); - - function To_Machine_State is new Ada.Unchecked_Conversion - (System.Address, Machine_State); - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - begin - return To_Machine_State - (Memory.Alloc (Invo_Handle_Type'Max_Size_In_Storage_Elements)); - end Allocate_Machine_State; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - -- The starting address is in the second longword pointed to by Loc - - return Fetch (System.Aux_DEC."+" (Loc, 8)); - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - Memory.Free (Address (M)); - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - procedure Get_Invo_Context ( - Result : out Unsigned_Longword; -- return value - Invo_Handle : Invo_Handle_Type; - Invo_Context : out Invo_Context_Blk_Type); - - pragma Import (External, Get_Invo_Context); - - pragma Import_Valued_Procedure (Get_Invo_Context, "LIB$GET_INVO_CONTEXT", - (Unsigned_Longword, Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Value, Reference)); - - Asm_Call_Size : constant := 4; - -- Under VMS a call - -- asm instruction takes 4 bytes. So we must remove this amount. - - ICB : Invo_Context_Blk_Type; - Status : Cond_Value_Type; - - begin - Get_Invo_Context (Status, To_Invo_Handle_Access (M).all, ICB); - - if (Status and 1) /= 1 then - return Code_Loc (System.Null_Address); - end if; - - return Code_Loc (ICB.Program_Counter - Asm_Call_Size); - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset - is - use System.Storage_Elements; - - begin - return Invo_Handle_Type'Size / 8; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame (M : Machine_State) is - procedure Get_Prev_Invo_Handle ( - Result : out Invo_Handle_Type; -- return value - ICB : Invo_Handle_Type); - - pragma Import (External, Get_Prev_Invo_Handle); - - pragma Import_Valued_Procedure - (Get_Prev_Invo_Handle, "LIB$GET_PREV_INVO_HANDLE", - (Invo_Handle_Type, Invo_Handle_Type), - (Value, Value)); - - Prev_Handle : aliased Invo_Handle_Type; - - begin - Get_Prev_Invo_Handle (Prev_Handle, To_Invo_Handle_Access (M).all); - To_Invo_Handle_Access (M).all := Prev_Handle; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - - procedure Get_Curr_Invo_Context - (Invo_Context : out Invo_Context_Blk_Type); - - pragma Import (External, Get_Curr_Invo_Context); - - pragma Import_Valued_Procedure - (Get_Curr_Invo_Context, "LIB$GET_CURR_INVO_CONTEXT", - (Invo_Context_Blk_Type), - (Reference)); - - procedure Get_Invo_Handle ( - Result : out Invo_Handle_Type; -- return value - Invo_Context : Invo_Context_Blk_Type); - - pragma Import (External, Get_Invo_Handle); - - pragma Import_Valued_Procedure (Get_Invo_Handle, "LIB$GET_INVO_HANDLE", - (Invo_Handle_Type, Invo_Context_Blk_Type), - (Value, Reference)); - - ICB : Invo_Context_Blk_Type; - Invo_Handle : aliased Invo_Handle_Type; - - begin - Get_Curr_Invo_Context (ICB); - Get_Invo_Handle (Invo_Handle, ICB); - To_Invo_Handle_Access (M).all := Invo_Handle; - Pop_Frame (M, System.Null_Address); - end Set_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/s-memory-vms_64.adb b/gcc/ada/s-memory-vms_64.adb deleted file mode 100644 index 7a08f7d0799..00000000000 --- a/gcc/ada/s-memory-vms_64.adb +++ /dev/null @@ -1,230 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS 64 bit implementation of this package - --- This implementation assumes that the underlying malloc/free/realloc --- implementation is thread safe, and thus, no additional lock is required. --- Note that we still need to defer abort because on most systems, an --- asynchronous signal (as used for implementing asynchronous abort of --- task) cannot safely be handled while malloc is executing. - --- If you are not using Ada constructs containing the "abort" keyword, then --- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from --- this unit. - -pragma Compiler_Unit_Warning; - -with Ada.Exceptions; -with System.Soft_Links; -with System.Parameters; -with System.CRTL; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : System.CRTL.size_t) return System.Address - renames System.CRTL.malloc; - - procedure c_free (Ptr : System.Address) - renames System.CRTL.free; - - function c_realloc - (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address - renames System.CRTL.realloc; - - Gnat_Heap_Size : Integer; - pragma Import (C, Gnat_Heap_Size, "__gl_heap_size"); - -- Set by Feature logical GNAT$NO_MALLOC_64 and/or Binder switch -Hnn - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Gnat_Heap_Size = 32 then - return Alloc32 (Size); - end if; - - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - if Parameters.No_Abort then - Result := c_malloc (System.CRTL.size_t (Actual_Size)); - else - Abort_Defer.all; - Result := c_malloc (System.CRTL.size_t (Actual_Size)); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - ------------- - -- Alloc32 -- - ------------- - - function Alloc32 (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - if Parameters.No_Abort then - Result := C_malloc32 (Actual_Size); - else - Abort_Defer.all; - Result := C_malloc32 (Actual_Size); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc32; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - if Parameters.No_Abort then - c_free (Ptr); - else - Abort_Defer.all; - c_free (Ptr); - Abort_Undefer.all; - end if; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - - begin - if Gnat_Heap_Size = 32 then - return Realloc32 (Ptr, Size); - end if; - - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - if Parameters.No_Abort then - Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size)); - else - Abort_Defer.all; - Result := c_realloc (Ptr, System.CRTL.size_t (Actual_Size)); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - - --------------- - -- Realloc32 -- - --------------- - - function Realloc32 - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - if Parameters.No_Abort then - Result := C_realloc32 (Ptr, Actual_Size); - else - Abort_Defer.all; - Result := C_realloc32 (Ptr, Actual_Size); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc32; -end System.Memory; diff --git a/gcc/ada/s-memory-vms_64.ads b/gcc/ada/s-memory-vms_64.ads deleted file mode 100644 index 464446a8b2e..00000000000 --- a/gcc/ada/s-memory-vms_64.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the low level memory allocation/deallocation --- mechanisms used by GNAT for VMS 64 bit. - --- To provide an alternate implementation, simply recompile the modified --- body of this package with gnatmake -u -a -g s-memory.adb and make sure --- that the ali and object files for this unit are found in the object --- search path. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -pragma Compiler_Unit_Warning; - -package System.Memory is - pragma Elaborate_Body; - - type size_t is mod 2 ** Standard'Address_Size; - -- Note: the reason we redefine this here instead of using the - -- definition in Interfaces.C is that we do not want to drag in - -- all of Interfaces.C just because System.Memory is used. - - function Alloc (Size : size_t) return System.Address; - -- This is the low level allocation routine. Given a size in storage - -- units, it returns the address of a maximally aligned block of - -- memory. The implementation of this routine is guaranteed to be - -- task safe, and also aborts are deferred if necessary. - -- - -- If size_t is set to size_t'Last on entry, then a Storage_Error - -- exception is raised with a message "object too large". - -- - -- If size_t is set to zero on entry, then a minimal (but non-zero) - -- size block is allocated. - -- - -- Note: this is roughly equivalent to the standard C malloc call - -- with the additional semantics as described above. - - function Alloc32 (Size : size_t) return System.Address; - -- Equivalent to Alloc except on VMS 64 bit where it invokes - -- 32 bit malloc. - - procedure Free (Ptr : System.Address); - -- This is the low level free routine. It frees a block previously - -- allocated with a call to Alloc. As in the case of Alloc, this - -- call is guaranteed task safe, and aborts are deferred. - -- - -- Note: this is roughly equivalent to the standard C free call - -- with the additional semantics as described above. - - function Realloc - (Ptr : System.Address; - Size : size_t) return System.Address; - -- This is the low level reallocation routine. It takes an existing - -- block address returned by a previous call to Alloc or Realloc, - -- and reallocates the block. The size can either be increased or - -- decreased. If possible the reallocation is done in place, so that - -- the returned result is the same as the value of Ptr on entry. - -- However, it may be necessary to relocate the block to another - -- address, in which case the information is copied to the new - -- block, and the old block is freed. The implementation of this - -- routine is guaranteed to be task safe, and also aborts are - -- deferred as necessary. - -- - -- If size_t is set to size_t'Last on entry, then a Storage_Error - -- exception is raised with a message "object too large". - -- - -- If size_t is set to zero on entry, then a minimal (but non-zero) - -- size block is allocated. - -- - -- Note: this is roughly equivalent to the standard C realloc call - -- with the additional semantics as described above. - - function Realloc32 - (Ptr : System.Address; - Size : size_t) return System.Address; - -- Equivalent to Realloc except on VMS 64 bit where it invokes - -- 32 bit realloc. - -private - - -- The following names are used from the generated compiler code - - pragma Export (C, Alloc, "__gnat_malloc"); - pragma Export (C, Alloc32, "__gnat_malloc32"); - pragma Export (C, Free, "__gnat_free"); - pragma Export (C, Realloc, "__gnat_realloc"); - pragma Export (C, Realloc32, "__gnat_realloc32"); - - function C_malloc32 (Size : size_t) return System.Address; - pragma Import (C, C_malloc32, "_malloc32"); - -- An alias for malloc for allocating 32bit memory on 64bit VMS - - function C_realloc32 - (Ptr : System.Address; - Size : size_t) return System.Address; - pragma Import (C, C_realloc32, "_realloc32"); - -- An alias for realloc for allocating 32bit memory on 64bit VMS - -end System.Memory; diff --git a/gcc/ada/s-osinte-vms.adb b/gcc/ada/s-osinte-vms.adb deleted file mode 100644 index ae8fc38c984..00000000000 --- a/gcc/ada/s-osinte-vms.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2012, AdaCore -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by children of System. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during --- tasking operations. It causes infinite loops and other problems. - -with Interfaces.C; use Interfaces.C; - -package body System.OS_Interface is - - ----------------- - -- sched_yield -- - ----------------- - - function sched_yield return int is - procedure sched_yield_base; - pragma Import (C, sched_yield_base, "PTHREAD_YIELD_NP"); - - begin - sched_yield_base; - return 0; - end sched_yield; - -end System.OS_Interface; diff --git a/gcc/ada/s-osinte-vms.ads b/gcc/ada/s-osinte-vms.ads deleted file mode 100644 index 2b2b135d0e9..00000000000 --- a/gcc/ada/s-osinte-vms.ads +++ /dev/null @@ -1,660 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS version of this package - --- This package encapsulates all direct interfaces to OS services --- that are needed by the tasking run-time (libgnarl). - --- PLEASE DO NOT add any with-clauses to this package or remove the pragma --- Preelaborate. This package is designed to be a bottom-level (leaf) package. - -with Interfaces.C; - -with Ada.Unchecked_Conversion; - -with System.Aux_DEC; - -package System.OS_Interface is - pragma Preelaborate; - - -- pragma Linker_Options ("--for-linker=/threads_enable"); - -- Enable upcalls and multiple kernel threads. - - subtype int is Interfaces.C.int; - subtype short is Interfaces.C.short; - subtype long is Interfaces.C.long; - subtype unsigned is Interfaces.C.unsigned; - subtype unsigned_short is Interfaces.C.unsigned_short; - subtype unsigned_long is Interfaces.C.unsigned_long; - subtype unsigned_char is Interfaces.C.unsigned_char; - subtype plain_char is Interfaces.C.plain_char; - subtype size_t is Interfaces.C.size_t; - - ----------------------------- - -- Signals (Interrupt IDs) -- - ----------------------------- - - -- Type signal has an arbitrary limit of 31 - - Max_Interrupt : constant := 31; - type Signal is new unsigned range 0 .. Max_Interrupt; - for Signal'Size use unsigned'Size; - - type sigset_t is array (Signal) of Boolean; - pragma Pack (sigset_t); - - -- Interrupt_Number_Type - -- Unsigned long integer denoting the number of an interrupt - - subtype Interrupt_Number_Type is unsigned_long; - - -- OpenVMS system services return values of type Cond_Value_Type - - subtype Cond_Value_Type is unsigned_long; - subtype Short_Cond_Value_Type is unsigned_short; - - type IO_Status_Block_Type is record - Status : Short_Cond_Value_Type; - Count : unsigned_short; - Dev_Info : unsigned_long; - end record; - - type AST_Handler is access procedure (Param : Address); - pragma Convention (C, AST_Handler); - No_AST_Handler : constant AST_Handler := null; - - CMB_M_READONLY : constant := 16#00000001#; - CMB_M_WRITEONLY : constant := 16#00000002#; - AGN_M_READONLY : constant := 16#00000001#; - AGN_M_WRITEONLY : constant := 16#00000002#; - - IO_WRITEVBLK : constant := 48; -- WRITE VIRTUAL BLOCK - IO_READVBLK : constant := 49; -- READ VIRTUAL BLOCK - - ---------------- - -- Sys_Assign -- - ---------------- - -- - -- Assign I/O Channel - -- - -- Status = returned status - -- Devnam = address of device name or logical name string - -- descriptor - -- Chan = address of word to receive channel number assigned - -- Acmode = access mode associated with channel - -- Mbxnam = address of mailbox logical name string descriptor, if - -- mailbox associated with device - -- Flags = optional channel flags longword for specifying options - -- for the $ASSIGN operation - -- - - procedure Sys_Assign - (Status : out Cond_Value_Type; - Devnam : String; - Chan : out unsigned_short; - Acmode : unsigned_short := 0; - Mbxnam : String := String'Null_Parameter; - Flags : unsigned_long := 0); - pragma Import (External, Sys_Assign); - pragma Import_Valued_Procedure - (Sys_Assign, "SYS$ASSIGN", - (Cond_Value_Type, String, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Descriptor (s), Reference, - Value, Descriptor (s), Value), - Flags); - - ---------------- - -- Sys_Cantim -- - ---------------- - -- - -- Cancel Timer - -- - -- Status = returned status - -- Reqidt = ID of timer to be cancelled - -- Acmode = Access mode - -- - procedure Sys_Cantim - (Status : out Cond_Value_Type; - Reqidt : Address; - Acmode : unsigned); - pragma Import (External, Sys_Cantim); - pragma Import_Valued_Procedure - (Sys_Cantim, "SYS$CANTIM", - (Cond_Value_Type, Address, unsigned), - (Value, Value, Value)); - - ---------------- - -- Sys_Crembx -- - ---------------- - -- - -- Create mailbox - -- - -- Status = returned status - -- Prmflg = permanent flag - -- Chan = channel - -- Maxmsg = maximum message - -- Bufquo = buufer quote - -- Promsk = protection mast - -- Acmode = access mode - -- Lognam = logical name - -- Flags = flags - -- - procedure Sys_Crembx - (Status : out Cond_Value_Type; - Prmflg : unsigned_char; - Chan : out unsigned_short; - Maxmsg : unsigned_long := 0; - Bufquo : unsigned_long := 0; - Promsk : unsigned_short := 0; - Acmode : unsigned_short := 0; - Lognam : String; - Flags : unsigned_long := 0); - pragma Import (External, Sys_Crembx); - pragma Import_Valued_Procedure - (Sys_Crembx, "SYS$CREMBX", - (Cond_Value_Type, unsigned_char, unsigned_short, - unsigned_long, unsigned_long, unsigned_short, - unsigned_short, String, unsigned_long), - (Value, Value, Reference, - Value, Value, Value, - Value, Descriptor (s), Value)); - - ------------- - -- Sys_QIO -- - ------------- - -- - -- Queue I/O - -- - -- Status = Returned status of call - -- EFN = event flag to be set when I/O completes - -- Chan = channel - -- Func = function - -- Iosb = I/O status block - -- Astadr = system trap to be generated when I/O completes - -- Astprm = AST parameter - -- P1-6 = optional parameters - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : unsigned_long := 0; - Chan : unsigned_short; - Func : unsigned_long := 0; - Iosb : out IO_Status_Block_Type; - Astadr : AST_Handler := No_AST_Handler; - Astprm : Address := Null_Address; - P1 : unsigned_long := 0; - P2 : unsigned_long := 0; - P3 : unsigned_long := 0; - P4 : unsigned_long := 0; - P5 : unsigned_long := 0; - P6 : unsigned_long := 0); - - procedure Sys_QIO - (Status : out Cond_Value_Type; - EFN : unsigned_long := 0; - Chan : unsigned_short; - Func : unsigned_long := 0; - Iosb : Address := Null_Address; - Astadr : AST_Handler := No_AST_Handler; - Astprm : Address := Null_Address; - P1 : unsigned_long := 0; - P2 : unsigned_long := 0; - P3 : unsigned_long := 0; - P4 : unsigned_long := 0; - P5 : unsigned_long := 0; - P6 : unsigned_long := 0); - - pragma Import (External, Sys_QIO); - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - IO_Status_Block_Type, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Reference, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - pragma Import_Valued_Procedure - (Sys_QIO, "SYS$QIO", - (Cond_Value_Type, unsigned_long, unsigned_short, unsigned_long, - Address, AST_Handler, Address, - unsigned_long, unsigned_long, unsigned_long, - unsigned_long, unsigned_long, unsigned_long), - (Value, Value, Value, Value, - Value, Value, Value, - Value, Value, Value, - Value, Value, Value)); - - ---------------- - -- Sys_Setimr -- - ---------------- - -- - -- Set Timer - -- - -- Status = Returned status of call - -- EFN = event flag to be set when timer expires - -- Tim = expiration time - -- AST = system trap to be generated when timer expires - -- Redidt = returned ID of timer (e.g. to cancel timer) - -- Flags = flags - -- - procedure Sys_Setimr - (Status : out Cond_Value_Type; - EFN : unsigned_long; - Tim : Long_Integer; - AST : AST_Handler; - Reqidt : Address; - Flags : unsigned_long); - pragma Import (External, Sys_Setimr); - pragma Import_Valued_Procedure - (Sys_Setimr, "SYS$SETIMR", - (Cond_Value_Type, unsigned_long, Long_Integer, - AST_Handler, Address, unsigned_long), - (Value, Value, Reference, - Value, Value, Value)); - - Interrupt_ID_0 : constant := 0; - Interrupt_ID_1 : constant := 1; - Interrupt_ID_2 : constant := 2; - Interrupt_ID_3 : constant := 3; - Interrupt_ID_4 : constant := 4; - Interrupt_ID_5 : constant := 5; - Interrupt_ID_6 : constant := 6; - Interrupt_ID_7 : constant := 7; - Interrupt_ID_8 : constant := 8; - Interrupt_ID_9 : constant := 9; - Interrupt_ID_10 : constant := 10; - Interrupt_ID_11 : constant := 11; - Interrupt_ID_12 : constant := 12; - Interrupt_ID_13 : constant := 13; - Interrupt_ID_14 : constant := 14; - Interrupt_ID_15 : constant := 15; - Interrupt_ID_16 : constant := 16; - Interrupt_ID_17 : constant := 17; - Interrupt_ID_18 : constant := 18; - Interrupt_ID_19 : constant := 19; - Interrupt_ID_20 : constant := 20; - Interrupt_ID_21 : constant := 21; - Interrupt_ID_22 : constant := 22; - Interrupt_ID_23 : constant := 23; - Interrupt_ID_24 : constant := 24; - Interrupt_ID_25 : constant := 25; - Interrupt_ID_26 : constant := 26; - Interrupt_ID_27 : constant := 27; - Interrupt_ID_28 : constant := 28; - Interrupt_ID_29 : constant := 29; - Interrupt_ID_30 : constant := 30; - Interrupt_ID_31 : constant := 31; - - ----------- - -- Errno -- - ----------- - - function errno return int; - pragma Import (C, errno, "__get_errno"); - - EINTR : constant := 4; -- Interrupted system call - EAGAIN : constant := 11; -- No more processes - ENOMEM : constant := 12; -- Not enough core - - ------------------------- - -- Priority Scheduling -- - ------------------------- - - SCHED_FIFO : constant := 1; - SCHED_RR : constant := 2; - SCHED_OTHER : constant := 3; - SCHED_BG : constant := 4; - SCHED_LFI : constant := 5; - SCHED_LRR : constant := 6; - - ------------- - -- Process -- - ------------- - - type pid_t is private; - - function kill (pid : pid_t; sig : Signal) return int; - pragma Import (C, kill); - - function getpid return pid_t; - pragma Import (C, getpid); - - ------------- - -- Threads -- - ------------- - - type Thread_Body is access - function (arg : System.Address) return System.Address; - pragma Convention (C, Thread_Body); - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); - - type pthread_t is private; - subtype Thread_Id is pthread_t; - - type pthread_mutex_t is limited private; - type pthread_cond_t is limited private; - type pthread_attr_t is limited private; - type pthread_mutexattr_t is limited private; - type pthread_condattr_t is limited private; - type pthread_key_t is private; - - PTHREAD_CREATE_JOINABLE : constant := 0; - PTHREAD_CREATE_DETACHED : constant := 1; - - PTHREAD_CANCEL_DISABLE : constant := 0; - PTHREAD_CANCEL_ENABLE : constant := 1; - - PTHREAD_CANCEL_DEFERRED : constant := 0; - PTHREAD_CANCEL_ASYNCHRONOUS : constant := 1; - - -- Don't use ERRORCHECK mutexes, they don't work when a thread is not - -- the owner. AST's, at least, unlock others threads mutexes. Even - -- if the error is ignored, they don't work. - PTHREAD_MUTEX_NORMAL_NP : constant := 0; - PTHREAD_MUTEX_RECURSIVE_NP : constant := 1; - PTHREAD_MUTEX_ERRORCHECK_NP : constant := 2; - - PTHREAD_INHERIT_SCHED : constant := 0; - PTHREAD_EXPLICIT_SCHED : constant := 1; - - function pthread_cancel (thread : pthread_t) return int; - pragma Import (C, pthread_cancel, "PTHREAD_CANCEL"); - - procedure pthread_testcancel; - pragma Import (C, pthread_testcancel, "PTHREAD_TESTCANCEL"); - - function pthread_setcancelstate - (newstate : int; oldstate : access int) return int; - pragma Import (C, pthread_setcancelstate, "PTHREAD_SETCANCELSTATE"); - - function pthread_setcanceltype - (newtype : int; oldtype : access int) return int; - pragma Import (C, pthread_setcanceltype, "PTHREAD_SETCANCELTYPE"); - - ------------------------- - -- POSIX.1c Section 3 -- - ------------------------- - - function pthread_lock_global_np return int; - pragma Import (C, pthread_lock_global_np, "PTHREAD_LOCK_GLOBAL_NP"); - - function pthread_unlock_global_np return int; - pragma Import (C, pthread_unlock_global_np, "PTHREAD_UNLOCK_GLOBAL_NP"); - - -------------------------- - -- POSIX.1c Section 11 -- - -------------------------- - - function pthread_mutexattr_init - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_init, "PTHREAD_MUTEXATTR_INIT"); - - function pthread_mutexattr_destroy - (attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutexattr_destroy, "PTHREAD_MUTEXATTR_DESTROY"); - - function pthread_mutexattr_settype_np - (attr : access pthread_mutexattr_t; - mutextype : int) return int; - pragma Import (C, pthread_mutexattr_settype_np, - "PTHREAD_MUTEXATTR_SETTYPE_NP"); - - function pthread_mutex_init - (mutex : access pthread_mutex_t; - attr : access pthread_mutexattr_t) return int; - pragma Import (C, pthread_mutex_init, "PTHREAD_MUTEX_INIT"); - - function pthread_mutex_destroy (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_destroy, "PTHREAD_MUTEX_DESTROY"); - - function pthread_mutex_lock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_lock, "PTHREAD_MUTEX_LOCK"); - - function pthread_mutex_unlock (mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_mutex_unlock, "PTHREAD_MUTEX_UNLOCK"); - - function pthread_mutex_setname_np - (attr : access pthread_mutex_t; - name : System.Address; - mbz : System.Address) return int; - pragma Import (C, pthread_mutex_setname_np, "PTHREAD_MUTEX_SETNAME_NP"); - - function pthread_condattr_init - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_init, "PTHREAD_CONDATTR_INIT"); - - function pthread_condattr_destroy - (attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_condattr_destroy, "PTHREAD_CONDATTR_DESTROY"); - - function pthread_cond_init - (cond : access pthread_cond_t; - attr : access pthread_condattr_t) return int; - pragma Import (C, pthread_cond_init, "PTHREAD_COND_INIT"); - - function pthread_cond_destroy (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_destroy, "PTHREAD_COND_DESTROY"); - - function pthread_cond_signal (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal, "PTHREAD_COND_SIGNAL"); - - function pthread_cond_signal_int_np - (cond : access pthread_cond_t) return int; - pragma Import (C, pthread_cond_signal_int_np, - "PTHREAD_COND_SIGNAL_INT_NP"); - - function pthread_cond_wait - (cond : access pthread_cond_t; - mutex : access pthread_mutex_t) return int; - pragma Import (C, pthread_cond_wait, "PTHREAD_COND_WAIT"); - - -------------------------- - -- POSIX.1c Section 13 -- - -------------------------- - - function pthread_mutexattr_setprotocol - (attr : access pthread_mutexattr_t; protocol : int) return int; - pragma Import (C, pthread_mutexattr_setprotocol, - "PTHREAD_MUTEXATTR_SETPROTOCOL"); - - type struct_sched_param is record - sched_priority : int; -- scheduling priority - end record; - for struct_sched_param'Size use 8 * 4; - pragma Convention (C, struct_sched_param); - - function pthread_setschedparam - (thread : pthread_t; - policy : int; - param : access struct_sched_param) return int; - pragma Import (C, pthread_setschedparam, "PTHREAD_SETSCHEDPARAM"); - - function pthread_attr_setscope - (attr : access pthread_attr_t; - contentionscope : int) return int; - pragma Import (C, pthread_attr_setscope, "PTHREAD_ATTR_SETSCOPE"); - - function pthread_attr_setinheritsched - (attr : access pthread_attr_t; - inheritsched : int) return int; - pragma Import (C, pthread_attr_setinheritsched, - "PTHREAD_ATTR_SETINHERITSCHED"); - - function pthread_attr_setschedpolicy - (attr : access pthread_attr_t; policy : int) return int; - pragma Import (C, pthread_attr_setschedpolicy, - "PTHREAD_ATTR_SETSCHEDPOLICY"); - - function pthread_attr_setschedparam - (attr : access pthread_attr_t; - sched_param : int) return int; - pragma Import (C, pthread_attr_setschedparam, "PTHREAD_ATTR_SETSCHEDPARAM"); - - function pthread_attr_setname_np - (attr : access pthread_attr_t; - name : System.Address; - mbz : System.Address) return int; - pragma Import (C, pthread_attr_setname_np, "PTHREAD_ATTR_SETNAME_NP"); - - function sched_yield return int; - - -------------------------- - -- P1003.1c Section 16 -- - -------------------------- - - function pthread_attr_init (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_init, "PTHREAD_ATTR_INIT"); - - function pthread_attr_destroy - (attributes : access pthread_attr_t) return int; - pragma Import (C, pthread_attr_destroy, "PTHREAD_ATTR_DESTROY"); - - function pthread_attr_setdetachstate - (attr : access pthread_attr_t; - detachstate : int) return int; - pragma Import (C, pthread_attr_setdetachstate, - "PTHREAD_ATTR_SETDETACHSTATE"); - - function pthread_attr_setstacksize - (attr : access pthread_attr_t; - stacksize : size_t) return int; - pragma Import (C, pthread_attr_setstacksize, "PTHREAD_ATTR_SETSTACKSIZE"); - - function pthread_create - (thread : access pthread_t; - attributes : access pthread_attr_t; - start_routine : Thread_Body; - arg : System.Address) return int; - pragma Import (C, pthread_create, "PTHREAD_CREATE"); - - procedure pthread_exit (status : System.Address); - pragma Import (C, pthread_exit, "PTHREAD_EXIT"); - - function pthread_self return pthread_t; - pragma Import (C, pthread_self, "PTHREAD_SELF"); - - -------------------------- - -- POSIX.1c Section 17 -- - -------------------------- - - function pthread_setspecific - (key : pthread_key_t; - value : System.Address) return int; - pragma Import (C, pthread_setspecific, "PTHREAD_SETSPECIFIC"); - - function pthread_getspecific (key : pthread_key_t) return System.Address; - pragma Import (C, pthread_getspecific, "PTHREAD_GETSPECIFIC"); - - type destructor_pointer is access procedure (arg : System.Address); - pragma Convention (C, destructor_pointer); - - function pthread_key_create - (key : access pthread_key_t; - destructor : destructor_pointer) return int; - pragma Import (C, pthread_key_create, "PTHREAD_KEY_CREATE"); - -private - - type pid_t is new int; - - type pthreadLongAddr_p is mod 2 ** Long_Integer'Size; - - type pthreadLongAddr_t is mod 2 ** Long_Integer'Size; - type pthreadLongAddr_t_ptr is mod 2 ** Long_Integer'Size; - - type pthreadLongString_t is mod 2 ** Long_Integer'Size; - - type pthreadLongUint_t is mod 2 ** Long_Integer'Size; - type pthreadLongUint_array is array (Natural range <>) - of pthreadLongUint_t; - - type pthread_t is mod 2 ** Long_Integer'Size; - - type pthread_cond_t is record - state : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_t_ptr; - end record; - for pthread_cond_t'Size use 8 * 32; - pragma Convention (C, pthread_cond_t); - - type pthread_attr_t is record - valid : long; - name : pthreadLongString_t; - arg : pthreadLongUint_t; - reserved : pthreadLongUint_array (0 .. 18); - end record; - for pthread_attr_t'Size use 8 * 176; - pragma Convention (C, pthread_attr_t); - - type pthread_mutex_t is record - lock : unsigned; - valid : unsigned; - name : pthreadLongString_t; - arg : unsigned; - sequence : unsigned; - block : pthreadLongAddr_p; - owner : unsigned; - depth : unsigned; - end record; - for pthread_mutex_t'Size use 8 * 40; - pragma Convention (C, pthread_mutex_t); - - type pthread_mutexattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 14); - end record; - for pthread_mutexattr_t'Size use 8 * 128; - pragma Convention (C, pthread_mutexattr_t); - - type pthread_condattr_t is record - valid : long; - reserved : pthreadLongUint_array (0 .. 12); - end record; - for pthread_condattr_t'Size use 8 * 112; - pragma Convention (C, pthread_condattr_t); - - type pthread_key_t is new unsigned; - - pragma Inline (pthread_self); - -end System.OS_Interface; diff --git a/gcc/ada/s-osprim-vms.adb b/gcc/ada/s-osprim-vms.adb deleted file mode 100644 index 5fa499bd13f..00000000000 --- a/gcc/ada/s-osprim-vms.adb +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2012, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS/Alpha version of this file - -with System.Aux_DEC; - -package body System.OS_Primitives is - - -------------------------------------- - -- Local functions and declarations -- - -------------------------------------- - - function Get_GMToff return Integer; - pragma Import (C, Get_GMToff, "get_gmtoff"); - -- Get the offset from GMT for this timezone - - function VMS_Epoch_Offset return Long_Integer; - pragma Inline (VMS_Epoch_Offset); - -- The offset between the Unix Epoch and the VMS Epoch - - subtype Cond_Value_Type is System.Aux_DEC.Unsigned_Longword; - -- Condition Value return type - - ---------------------- - -- VMS_Epoch_Offset -- - ---------------------- - - function VMS_Epoch_Offset return Long_Integer is - begin - return 10_000_000 * (3_506_716_800 + Long_Integer (Get_GMToff)); - end VMS_Epoch_Offset; - - ---------------- - -- Sys_Schdwk -- - ---------------- - -- - -- Schedule Wakeup - -- - -- status = returned status - -- pidadr = address of process id to be woken up - -- prcnam = name of process to be woken up - -- daytim = time to wake up - -- reptim = repetition interval of wakeup calls - -- - - procedure Sys_Schdwk - ( - Status : out Cond_Value_Type; - Pidadr : Address := Null_Address; - Prcnam : String := String'Null_Parameter; - Daytim : Long_Integer; - Reptim : Long_Integer := Long_Integer'Null_Parameter - ); - - pragma Import (External, Sys_Schdwk); - -- VMS system call to schedule a wakeup event - pragma Import_Valued_Procedure - (Sys_Schdwk, "SYS$SCHDWK", - (Cond_Value_Type, Address, String, Long_Integer, Long_Integer), - (Value, Value, Descriptor (S), Reference, Reference) - ); - - ---------------- - -- Sys_Gettim -- - ---------------- - -- - -- Get System Time - -- - -- status = returned status - -- tim = current system time - -- - - procedure Sys_Gettim - ( - Status : out Cond_Value_Type; - Tim : out OS_Time - ); - -- VMS system call to get the current system time - pragma Import (External, Sys_Gettim); - pragma Import_Valued_Procedure - (Sys_Gettim, "SYS$GETTIM", - (Cond_Value_Type, OS_Time), - (Value, Reference) - ); - - --------------- - -- Sys_Hiber -- - --------------- - - -- Hibernate (until woken up) - - -- status = returned status - - procedure Sys_Hiber (Status : out Cond_Value_Type); - -- VMS system call to hibernate the current process - pragma Import (External, Sys_Hiber); - pragma Import_Valued_Procedure - (Sys_Hiber, "SYS$HIBER", - (Cond_Value_Type), - (Value) - ); - - ----------- - -- Clock -- - ----------- - - function OS_Clock return OS_Time is - Status : Cond_Value_Type; - T : OS_Time; - begin - Sys_Gettim (Status, T); - return (T); - end OS_Clock; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - begin - return To_Duration (OS_Clock, Absolute_Calendar); - end Clock; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration renames Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Sleep_Time : OS_Time; - Status : Cond_Value_Type; - pragma Unreferenced (Status); - - begin - Sleep_Time := To_OS_Time (Time, Mode); - Sys_Schdwk (Status => Status, Daytim => Sleep_Time); - Sys_Hiber (Status); - end Timed_Delay; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : OS_Time; Mode : Integer) return Duration is - pragma Warnings (Off, Mode); - begin - return Duration'Fixed_Value (T - VMS_Epoch_Offset) * 100; - end To_Duration; - - ---------------- - -- To_OS_Time -- - ---------------- - - function To_OS_Time (D : Duration; Mode : Integer) return OS_Time is - begin - if Mode = Relative then - return -(Long_Integer'Integer_Value (D) / 100); - else - return Long_Integer'Integer_Value (D) / 100 + VMS_Epoch_Offset; - end if; - end To_OS_Time; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-vms.ads b/gcc/ada/s-osprim-vms.ads deleted file mode 100644 index 3b4ed328c8e..00000000000 --- a/gcc/ada/s-osprim-vms.ads +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides low level primitives used to implement clock and --- delays in non tasking applications on Alpha/VMS. - --- The choice of the real clock/delay implementation (depending on whether --- tasking is involved or not) is done via soft links (see s-soflin.ads) - --- NEVER add any dependency to tasking packages here - -package System.OS_Primitives is - pragma Preelaborate; - - subtype OS_Time is Long_Integer; - -- System time on VMS is used for performance reasons. - -- Note that OS_Time is *not* the same as Ada.Calendar.Time, the - -- difference being that relative OS_Time is negative, but relative - -- Calendar.Time is positive. - -- See Ada.Calendar.Delays for more information on VMS Time. - - Max_Sensible_Delay : constant Duration := - Duration'Min (183 * 24 * 60 * 60.0, - Duration'Last); - -- Max of half a year delay, needed to prevent exceptions for large delay - -- values. It seems unlikely that any test will notice this restriction, - -- except in the case of applications setting the clock at run time (see - -- s-tastim.adb). Also note that a larger value might cause problems (e.g - -- overflow, or more likely OS limitation in the primitives used). In the - -- case where half a year is too long (which occurs in high integrity mode - -- with 32-bit words, and possibly on some specific ports of GNAT), - -- Duration'Last is used instead. - - procedure Initialize; - -- Initialize global settings related to this package. This procedure - -- should be called before any other subprograms in this package. Note - -- that this procedure can be called several times. - - function OS_Clock return OS_Time; - -- Returns "absolute" time, represented as an offset - -- relative to "the Epoch", which is Nov 17, 1858 on VMS. - - function Clock return Duration; - pragma Inline (Clock); - -- Returns "absolute" time, represented as an offset relative to "the - -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This - -- implementation is affected by system's clock changes. - - function Monotonic_Clock return Duration; - pragma Inline (Monotonic_Clock); - -- Returns "absolute" time, represented as an offset relative to "the Unix - -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is - -- immune to the system's clock changes. - - Relative : constant := 0; - Absolute_Calendar : constant := 1; - Absolute_RT : constant := 2; - -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies - -- on these values. So any change here must be reflected in corresponding - -- changes in the compiler. - - procedure Timed_Delay (Time : Duration; Mode : Integer); - -- Implements the semantics of the delay statement when no tasking is used - -- in the application. - -- - -- Mode is one of the three values above - -- - -- Time is a relative or absolute duration value, depending on Mode. - -- - -- Note that currently Ada.Real_Time always uses the tasking run time, - -- so this procedure should never be called with Mode set to Absolute_RT. - -- This may change in future or bare board implementations. - - function To_Duration (T : OS_Time; Mode : Integer) return Duration; - -- Convert VMS system time to Duration - -- Mode is one of the three values above - - function To_OS_Time (D : Duration; Mode : Integer) return OS_Time; - -- Convert Duration to VMS system time - -- Mode is one of the three values above - -end System.OS_Primitives; diff --git a/gcc/ada/s-parame-vms-alpha.ads b/gcc/ada/s-parame-vms-alpha.ads deleted file mode 100644 index 1e7161fbe16..00000000000 --- a/gcc/ada/s-parame-vms-alpha.ads +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the OpenVMS Alpha version - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ptr_bits : constant := 32; - subtype C_Address is System.Address - range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1; - for C_Address'Object_Size use ptr_bits; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. System.Aux_DEC.Short_Address can't be used because of - -- elaboration circularity. - - C_Malloc_Linkname : constant String := "__gnat_malloc32"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := True; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Max_Attribute_Count : constant := 32; - -- Number of task attributes stored in the task control block - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 512; - -- This constant specifies the maximum number of characters to allow in an - -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the - -- default minimum of 200 to allow for the length of chained VMS condition - -- handling messages. - -end System.Parameters; diff --git a/gcc/ada/s-parame-vms-ia64.ads b/gcc/ada/s-parame-vms-ia64.ads deleted file mode 100644 index 0f18f3dcf28..00000000000 --- a/gcc/ada/s-parame-vms-ia64.ads +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Integrity OpenVMS version - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := 32; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this is not true - -- of all targets. For example, in OpenVMS long /= Long_Integer. - - ptr_bits : constant := 32; - subtype C_Address is System.Address - range -2 ** (ptr_bits - 1) .. 2 ** (ptr_bits - 1) - 1; - for C_Address'Object_Size use ptr_bits; - -- Number of bits in Interfaces.C pointers, normally a standard address, - -- except on 64-bit VMS where they are 32-bit addresses, for compatibility - -- with legacy code. System.Aux_DEC.Short_Address can't be used because of - -- elaboration circularity. - - C_Malloc_Linkname : constant String := "__gnat_malloc32"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Max_Attribute_Count : constant := 32; - -- Number of task attributes stored in the task control block - - -------------------- - -- Runtime Traces -- - -------------------- - - Runtime_Traces : constant Boolean := False; - -- This constant indicates whether the runtime outputs traces to a - -- predefined output or not (True means that traces are output). - -- See System.Traces for more details. - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 512; - -- This constant specifies the maximum number of characters to allow in an - -- exception message (see RM 11.4.1(18)). The value for VMS exceeds the - -- default minimum of 200 to allow for the length of chained VMS condition - -- handling messages. - -end System.Parameters; diff --git a/gcc/ada/s-ransee-vms.adb b/gcc/ada/s-ransee-vms.adb deleted file mode 100644 index 713edaef79f..00000000000 --- a/gcc/ada/s-ransee-vms.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R A N D O M _ S E E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version used on OpenVMS systems, where Clock accuracy is too low for --- RM A.5.2(45). - -with Interfaces; use Interfaces; - -package body System.Random_Seed is - - function Sys_Rpcc_64 return Unsigned_64; - pragma Import (C, Sys_Rpcc_64, "SYS$RPCC_64"); - - -------------- - -- Get_Seed -- - -------------- - - function Get_Seed return Interfaces.Unsigned_64 is - begin - return Sys_Rpcc_64; - end Get_Seed; - -end System.Random_Seed; diff --git a/gcc/ada/s-taasde.adb b/gcc/ada/s-taasde.adb index 37b94305de6..b111f31a7a0 100644 --- a/gcc/ada/s-taasde.adb +++ b/gcc/ada/s-taasde.adb @@ -153,9 +153,9 @@ package body System.Tasking.Async_Delays is STI.Undefer_Abort_Nestable (D.Self_Id); end Cancel_Async_Delay; - --------------------------- - -- Enqueue_Time_Duration -- - --------------------------- + ---------------------- + -- Enqueue_Duration -- + ---------------------- function Enqueue_Duration (T : Duration; diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb deleted file mode 100644 index 53034cad012..00000000000 --- a/gcc/ada/s-taprop-vms.adb +++ /dev/null @@ -1,1278 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - --- This package contains all the GNULL primitives that interface directly with --- the underlying OS. - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.Tasking.Debug; -with System.OS_Primitives; -with System.Soft_Links; -with System.Aux_DEC; - -package body System.Task_Primitives.Operations is - - use System.Tasking.Debug; - use System.Tasking; - use Interfaces.C; - use System.OS_Interface; - use System.Parameters; - use System.OS_Primitives; - use type System.OS_Primitives.OS_Time; - - package SSL renames System.Soft_Links; - - ---------------- - -- Local Data -- - ---------------- - - -- The followings are logically constants, but need to be initialized - -- at run time. - - Single_RTS_Lock : aliased RTS_Lock; - -- This is a lock to allow only one thread of control in the RTS at - -- a time; it is used to execute in mutual exclusion from all other tasks. - -- Used mainly in Single_Lock mode, but also to protect All_Tasks_List - - ATCB_Key : aliased pthread_key_t; - -- Key used to find the Ada Task_Id associated with a thread - - Environment_Task_Id : Task_Id; - -- A variable to hold Task_Id for the environment task - - Time_Slice_Val : Integer; - pragma Import (C, Time_Slice_Val, "__gl_time_slice_val"); - - Dispatching_Policy : Character; - pragma Import (C, Dispatching_Policy, "__gl_task_dispatching_policy"); - - Foreign_Task_Elaborated : aliased Boolean := True; - -- Used to identified fake tasks (i.e., non-Ada Threads) - - -------------------- - -- Local Packages -- - -------------------- - - package Specific is - - procedure Initialize (Environment_Task : Task_Id); - pragma Inline (Initialize); - -- Initialize various data needed by this package - - function Is_Valid_Task return Boolean; - pragma Inline (Is_Valid_Task); - -- Does executing thread have a TCB? - - procedure Set (Self_Id : Task_Id); - pragma Inline (Set); - -- Set the self id for the current task - - function Self return Task_Id; - pragma Inline (Self); - -- Return a pointer to the Ada Task Control Block of the calling task - - end Specific; - - package body Specific is separate; - -- The body of this package is target specific - - ---------------------------------- - -- ATCB allocation/deallocation -- - ---------------------------------- - - package body ATCB_Allocation is separate; - -- The body of this package is shared across several targets - - --------------------------------- - -- Support for foreign threads -- - --------------------------------- - - function Register_Foreign_Thread (Thread : Thread_Id) return Task_Id; - -- Allocate and Initialize a new ATCB for the current Thread - - function Register_Foreign_Thread - (Thread : Thread_Id) return Task_Id is separate; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Task_Id is - new Ada.Unchecked_Conversion - (System.Task_Primitives.Task_Address, Task_Id); - - function To_Address is - new Ada.Unchecked_Conversion - (Task_Id, System.Task_Primitives.Task_Address); - - procedure Timer_Sleep_AST (ID : Address); - pragma Convention (C, Timer_Sleep_AST); - -- Signal the condition variable when AST fires - - procedure Timer_Sleep_AST (ID : Address) is - Result : Interfaces.C.int; - pragma Warnings (Off, Result); - Self_ID : constant Task_Id := To_Task_Id (ID); - begin - Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Timer_Sleep_AST; - - ----------------- - -- Stack_Guard -- - ----------------- - - -- The underlying thread system sets a guard page at the bottom of a thread - -- stack, so nothing is needed. - -- ??? Check the comment above - - procedure Stack_Guard (T : ST.Task_Id; On : Boolean) is - pragma Unreferenced (T); - pragma Unreferenced (On); - begin - null; - end Stack_Guard; - - -------------------- - -- Get_Thread_Id -- - -------------------- - - function Get_Thread_Id (T : ST.Task_Id) return OSI.Thread_Id is - begin - return T.Common.LL.Thread; - end Get_Thread_Id; - - ---------- - -- Self -- - ---------- - - function Self return Task_Id renames Specific.Self; - - --------------------- - -- Initialize_Lock -- - --------------------- - - -- Note: mutexes and cond_variables needed per-task basis are initialized - -- in Initialize_TCB and the Storage_Error is handled. Other mutexes (such - -- as RTS_Lock, Memory_Lock...) used in RTS is initialized before any - -- status change of RTS. Therefore raising Storage_Error in the following - -- routines should be able to be handled safely. - - procedure Initialize_Lock - (Prio : System.Any_Priority; - L : not null access Lock) - is - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - L.Prio_Save := 0; - L.Prio := Interfaces.C.int (Prio); - - Result := pthread_mutex_init (L.L'Access, Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - procedure Initialize_Lock - (L : not null access RTS_Lock; - Level : Lock_Level) - is - pragma Unreferenced (Level); - - Attributes : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - - begin - Result := pthread_mutexattr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - --- Don't use, see comment in s-osinte.ads about ERRORCHECK mutexes??? --- Result := pthread_mutexattr_settype_np --- (Attributes'Access, PTHREAD_MUTEX_ERRORCHECK_NP); --- pragma Assert (Result = 0); - --- Result := pthread_mutexattr_setprotocol --- (Attributes'Access, PTHREAD_PRIO_PROTECT); --- pragma Assert (Result = 0); - --- Result := pthread_mutexattr_setprioceiling --- (Attributes'Access, Interfaces.C.int (System.Any_Priority'Last)); --- pragma Assert (Result = 0); - - Result := pthread_mutex_init (L, Attributes'Access); - - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Attributes'Access); - pragma Assert (Result = 0); - end Initialize_Lock; - - ------------------- - -- Finalize_Lock -- - ------------------- - - procedure Finalize_Lock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L.L'Access); - pragma Assert (Result = 0); - end Finalize_Lock; - - procedure Finalize_Lock (L : not null access RTS_Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_destroy (L); - pragma Assert (Result = 0); - end Finalize_Lock; - - ---------------- - -- Write_Lock -- - ---------------- - - procedure Write_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - Self_ID : constant Task_Id := Self; - All_Tasks_Link : constant Task_Id := Self.Common.All_Tasks_Link; - Current_Prio : System.Any_Priority; - Result : Interfaces.C.int; - - begin - Current_Prio := Get_Priority (Self_ID); - - -- If there is no other tasks, no need to check priorities - - if All_Tasks_Link /= Null_Task - and then L.Prio < Interfaces.C.int (Current_Prio) - then - Ceiling_Violation := True; - return; - end if; - - Result := pthread_mutex_lock (L.L'Access); - pragma Assert (Result = 0); - - Ceiling_Violation := False; --- Why is this commented out ??? --- L.Prio_Save := Interfaces.C.int (Current_Prio); --- Set_Priority (Self_ID, System.Any_Priority (L.Prio)); - end Write_Lock; - - procedure Write_Lock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_lock (L); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - procedure Write_Lock (T : Task_Id) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_lock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Write_Lock; - - --------------- - -- Read_Lock -- - --------------- - - procedure Read_Lock - (L : not null access Lock; - Ceiling_Violation : out Boolean) - is - begin - Write_Lock (L, Ceiling_Violation); - end Read_Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (L : not null access Lock) is - Result : Interfaces.C.int; - begin - Result := pthread_mutex_unlock (L.L'Access); - pragma Assert (Result = 0); - end Unlock; - - procedure Unlock - (L : not null access RTS_Lock; - Global_Lock : Boolean := False) - is - Result : Interfaces.C.int; - begin - if not Single_Lock or else Global_Lock then - Result := pthread_mutex_unlock (L); - pragma Assert (Result = 0); - end if; - end Unlock; - - procedure Unlock (T : Task_Id) is - Result : Interfaces.C.int; - begin - if not Single_Lock then - Result := pthread_mutex_unlock (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - end Unlock; - - ----------------- - -- Set_Ceiling -- - ----------------- - - -- Dynamic priority ceilings are not supported by the underlying system - - procedure Set_Ceiling - (L : not null access Lock; - Prio : System.Any_Priority) - is - pragma Unreferenced (L, Prio); - begin - null; - end Set_Ceiling; - - ----------- - -- Sleep -- - ----------- - - procedure Sleep - (Self_ID : Task_Id; - Reason : System.Tasking.Task_States) - is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - - begin - Result := - pthread_cond_wait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access)); - - -- EINTR is not considered a failure - - pragma Assert (Result = 0 or else Result = EINTR); - - if Self_ID.Deferral_Level = 0 - and then Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level - then - Unlock (Self_ID); - raise Standard'Abort_Signal; - end if; - end Sleep; - - ----------------- - -- Timed_Sleep -- - ----------------- - - procedure Timed_Sleep - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes; - Reason : System.Tasking.Task_States; - Timedout : out Boolean; - Yielded : out Boolean) - is - pragma Unreferenced (Reason); - - Sleep_Time : OS_Time; - Result : Interfaces.C.int; - Status : Cond_Value_Type; - - -- The body below requires more comments ??? - - begin - Timedout := False; - Yielded := False; - - Sleep_Time := To_OS_Time (Time, Mode); - - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then - return; - end if; - - Self_ID.Common.LL.AST_Pending := True; - - Sys_Setimr - (Status, 0, Sleep_Time, - Timer_Sleep_AST'Access, To_Address (Self_ID), 0); - - if (Status and 1) /= 1 then - raise Storage_Error; - end if; - - if Single_Lock then - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Single_RTS_Lock'Access); - pragma Assert (Result = 0); - - else - Result := - pthread_cond_wait - (Self_ID.Common.LL.CV'Access, Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Yielded := True; - - if not Self_ID.Common.LL.AST_Pending then - Timedout := True; - else - Sys_Cantim (Status, To_Address (Self_ID), 0); - pragma Assert ((Status and 1) = 1); - end if; - end Timed_Sleep; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Self_ID : Task_Id; - Time : Duration; - Mode : ST.Delay_Modes) - is - Sleep_Time : OS_Time; - Result : Interfaces.C.int; - Status : Cond_Value_Type; - Yielded : Boolean := False; - - begin - if Single_Lock then - Lock_RTS; - end if; - - -- More comments required in body below ??? - - Write_Lock (Self_ID); - - if Time /= 0.0 or else Mode /= Relative then - Sleep_Time := To_OS_Time (Time, Mode); - - if Mode = Relative or else OS_Clock <= Sleep_Time then - Self_ID.Common.State := Delay_Sleep; - Self_ID.Common.LL.AST_Pending := True; - - Sys_Setimr - (Status, 0, Sleep_Time, - Timer_Sleep_AST'Access, To_Address (Self_ID), 0); - - -- Comment following test - - if (Status and 1) /= 1 then - raise Storage_Error; - end if; - - loop - if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level then - Sys_Cantim (Status, To_Address (Self_ID), 0); - pragma Assert ((Status and 1) = 1); - exit; - end if; - - Result := - pthread_cond_wait - (cond => Self_ID.Common.LL.CV'Access, - mutex => (if Single_Lock - then Single_RTS_Lock'Access - else Self_ID.Common.LL.L'Access)); - pragma Assert (Result = 0); - - Yielded := True; - - exit when not Self_ID.Common.LL.AST_Pending; - end loop; - - Self_ID.Common.State := Runnable; - end if; - end if; - - Unlock (Self_ID); - - if Single_Lock then - Unlock_RTS; - end if; - - if not Yielded then - Result := sched_yield; - pragma Assert (Result = 0); - end if; - end Timed_Delay; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration - renames System.OS_Primitives.Monotonic_Clock; - - ------------------- - -- RT_Resolution -- - ------------------- - - function RT_Resolution return Duration is - begin - -- Document origin of this magic constant ??? - return 10#1.0#E-3; - end RT_Resolution; - - ------------ - -- Wakeup -- - ------------ - - procedure Wakeup (T : Task_Id; Reason : System.Tasking.Task_States) is - pragma Unreferenced (Reason); - Result : Interfaces.C.int; - begin - Result := pthread_cond_signal (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Wakeup; - - ----------- - -- Yield -- - ----------- - - procedure Yield (Do_Yield : Boolean := True) is - Result : Interfaces.C.int; - pragma Unreferenced (Result); - begin - if Do_Yield then - Result := sched_yield; - end if; - end Yield; - - ------------------ - -- Set_Priority -- - ------------------ - - procedure Set_Priority - (T : Task_Id; - Prio : System.Any_Priority; - Loss_Of_Inheritance : Boolean := False) - is - pragma Unreferenced (Loss_Of_Inheritance); - - Result : Interfaces.C.int; - Param : aliased struct_sched_param; - - function Get_Policy (Prio : System.Any_Priority) return Character; - pragma Import (C, Get_Policy, "__gnat_get_specific_dispatching"); - -- Get priority specific dispatching policy - - Priority_Specific_Policy : constant Character := Get_Policy (Prio); - -- Upper case first character of the policy name corresponding to the - -- task as set by a Priority_Specific_Dispatching pragma. - - begin - T.Common.Current_Priority := Prio; - Param.sched_priority := Interfaces.C.int (Underlying_Priorities (Prio)); - - if Dispatching_Policy = 'R' - or else Priority_Specific_Policy = 'R' - or else Time_Slice_Val > 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_RR, Param'Access); - - elsif Dispatching_Policy = 'F' - or else Priority_Specific_Policy = 'F' - or else Time_Slice_Val = 0 - then - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_FIFO, Param'Access); - - else - -- SCHED_OTHER priorities are restricted to the range 8 - 15. - -- Since the translation from Underlying priorities results - -- in a range of 16 - 31, dividing by 2 gives the correct result. - - Param.sched_priority := Param.sched_priority / 2; - Result := - pthread_setschedparam - (T.Common.LL.Thread, SCHED_OTHER, Param'Access); - end if; - - pragma Assert (Result = 0); - end Set_Priority; - - ------------------ - -- Get_Priority -- - ------------------ - - function Get_Priority (T : Task_Id) return System.Any_Priority is - begin - return T.Common.Current_Priority; - end Get_Priority; - - ---------------- - -- Enter_Task -- - ---------------- - - procedure Enter_Task (Self_ID : Task_Id) is - begin - Self_ID.Common.LL.Thread := pthread_self; - Specific.Set (Self_ID); - end Enter_Task; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean renames Specific.Is_Valid_Task; - - ----------------------------- - -- Register_Foreign_Thread -- - ----------------------------- - - function Register_Foreign_Thread return Task_Id is - begin - if Is_Valid_Task then - return Self; - else - return Register_Foreign_Thread (pthread_self); - end if; - end Register_Foreign_Thread; - - -------------------- - -- Initialize_TCB -- - -------------------- - - procedure Initialize_TCB (Self_ID : Task_Id; Succeeded : out Boolean) is - Mutex_Attr : aliased pthread_mutexattr_t; - Result : Interfaces.C.int; - Cond_Attr : aliased pthread_condattr_t; - - begin - -- More comments required in body below ??? - - if not Single_Lock then - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_mutex_init - (Self_ID.Common.LL.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = 0 then - Result := - pthread_cond_init - (Self_ID.Common.LL.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - end if; - - if Result = 0 then - Succeeded := True; - - else - if not Single_Lock then - Result := pthread_mutex_destroy (Self_ID.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Succeeded := False; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize_TCB; - - ----------------- - -- Create_Task -- - ----------------- - - procedure Create_Task - (T : Task_Id; - Wrapper : System.Address; - Stack_Size : System.Parameters.Size_Type; - Priority : System.Any_Priority; - Succeeded : out Boolean) - is - Attributes : aliased pthread_attr_t; - Result : Interfaces.C.int; - - function Thread_Body_Access is new - Ada.Unchecked_Conversion (System.Aux_DEC.Short_Address, Thread_Body); - - Task_Name : String (1 .. System.Parameters.Max_Task_Image_Length + 1); - - begin - -- Since the initial signal mask of a thread is inherited from the - -- creator, we need to set our local signal mask to mask all signals - -- during the creation operation, to make sure the new thread is - -- not disturbed by signals before it has set its own Task_Id. - - Result := pthread_attr_init (Attributes'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Succeeded := False; - return; - end if; - - Result := pthread_attr_setdetachstate - (Attributes'Access, PTHREAD_CREATE_DETACHED); - pragma Assert (Result = 0); - - Result := pthread_attr_setstacksize - (Attributes'Access, Interfaces.C.size_t (Stack_Size)); - pragma Assert (Result = 0); - - -- This call may be unnecessary, not sure. ??? - - Result := - pthread_attr_setinheritsched - (Attributes'Access, PTHREAD_EXPLICIT_SCHED); - pragma Assert (Result = 0); - - if T.Common.Task_Image_Len > 0 then - - -- Set thread name to ease debugging - - Task_Name (1 .. T.Common.Task_Image_Len) := - T.Common.Task_Image (1 .. T.Common.Task_Image_Len); - Task_Name (T.Common.Task_Image_Len + 1) := ASCII.NUL; - - Result := pthread_attr_setname_np - (Attributes'Access, Task_Name'Address, Null_Address); - pragma Assert (Result = 0); - end if; - - -- Note: the use of Unrestricted_Access in the following call is needed - -- because otherwise we have an error of getting a access-to-volatile - -- value which points to a non-volatile object. But in this case it is - -- safe to do this, since we know we have no problems with aliasing and - -- Unrestricted_Access bypasses this check. - - Result := - pthread_create - (T.Common.LL.Thread'Unrestricted_Access, - Attributes'Access, - Thread_Body_Access (Wrapper), - To_Address (T)); - - -- ENOMEM is a valid run-time error -- do not shut down - - pragma Assert (Result = 0 - or else Result = EAGAIN or else Result = ENOMEM); - - Succeeded := Result = 0; - - Result := pthread_attr_destroy (Attributes'Access); - pragma Assert (Result = 0); - - if Succeeded then - Set_Priority (T, Priority); - end if; - end Create_Task; - - ------------------ - -- Finalize_TCB -- - ------------------ - - procedure Finalize_TCB (T : Task_Id) is - Result : Interfaces.C.int; - - begin - if not Single_Lock then - Result := pthread_mutex_destroy (T.Common.LL.L'Access); - pragma Assert (Result = 0); - end if; - - Result := pthread_cond_destroy (T.Common.LL.CV'Access); - pragma Assert (Result = 0); - - if T.Known_Tasks_Index /= -1 then - Known_Tasks (T.Known_Tasks_Index) := null; - end if; - - ATCB_Allocation.Free_ATCB (T); - end Finalize_TCB; - - --------------- - -- Exit_Task -- - --------------- - - procedure Exit_Task is - begin - null; - end Exit_Task; - - ---------------- - -- Abort_Task -- - ---------------- - - procedure Abort_Task (T : Task_Id) is - begin - -- Interrupt Server_Tasks may be waiting on an event flag - - if T.Common.State = Interrupt_Server_Blocked_On_Event_Flag then - Wakeup (T, Interrupt_Server_Blocked_On_Event_Flag); - end if; - end Abort_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Suspension_Object) is - Mutex_Attr : aliased pthread_mutexattr_t; - Cond_Attr : aliased pthread_condattr_t; - Result : Interfaces.C.int; - begin - -- Initialize internal state (always to False (D.10 (6))) - - S.State := False; - S.Waiting := False; - - -- Initialize internal mutex - - Result := pthread_mutexattr_init (Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - raise Storage_Error; - end if; - - Result := pthread_mutex_init (S.L'Access, Mutex_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result = ENOMEM then - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - - Result := pthread_mutexattr_destroy (Mutex_Attr'Access); - pragma Assert (Result = 0); - - -- Initialize internal condition variable - - Result := pthread_condattr_init (Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - raise Storage_Error; - end if; - end if; - - Result := pthread_cond_init (S.CV'Access, Cond_Attr'Access); - pragma Assert (Result = 0 or else Result = ENOMEM); - - if Result /= 0 then - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - if Result = ENOMEM then - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - - raise Storage_Error; - end if; - end if; - - Result := pthread_condattr_destroy (Cond_Attr'Access); - pragma Assert (Result = 0); - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - -- Destroy internal mutex - - Result := pthread_mutex_destroy (S.L'Access); - pragma Assert (Result = 0); - - -- Destroy internal condition variable - - Result := pthread_cond_destroy (S.CV'Access); - pragma Assert (Result = 0); - end Finalize; - - ------------------- - -- Current_State -- - ------------------- - - function Current_State (S : Suspension_Object) return Boolean is - begin - -- We do not want to use lock on this read operation. State is marked - -- as Atomic so that we ensure that the value retrieved is correct. - - return S.State; - end Current_State; - - --------------- - -- Set_False -- - --------------- - - procedure Set_False (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - S.State := False; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_False; - - -------------- - -- Set_True -- - -------------- - - procedure Set_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - -- If there is already a task waiting on this suspension object then - -- we resume it, leaving the state of the suspension object to False, - -- as specified in (RM D.10(9)), otherwise leave state set to True. - - if S.Waiting then - S.Waiting := False; - S.State := False; - - Result := pthread_cond_signal (S.CV'Access); - pragma Assert (Result = 0); - - else - S.State := True; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end Set_True; - - ------------------------ - -- Suspend_Until_True -- - ------------------------ - - procedure Suspend_Until_True (S : in out Suspension_Object) is - Result : Interfaces.C.int; - - begin - SSL.Abort_Defer.all; - - Result := pthread_mutex_lock (S.L'Access); - pragma Assert (Result = 0); - - if S.Waiting then - - -- Program_Error must be raised upon calling Suspend_Until_True - -- if another task is already waiting on that suspension object - -- (RM D.10(10)). - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - - raise Program_Error; - - else - -- Suspend the task if the state is False. Otherwise, the task - -- continues its execution, and the state of the suspension object - -- is set to False (ARM D.10 par. 9). - - if S.State then - S.State := False; - else - S.Waiting := True; - - loop - -- Loop in case pthread_cond_wait returns earlier than expected - -- (e.g. in case of EINTR caused by a signal). - - Result := pthread_cond_wait (S.CV'Access, S.L'Access); - pragma Assert (Result = 0 or else Result = EINTR); - - exit when not S.Waiting; - end loop; - end if; - - Result := pthread_mutex_unlock (S.L'Access); - pragma Assert (Result = 0); - - SSL.Abort_Undefer.all; - end if; - end Suspend_Until_True; - - ---------------- - -- Check_Exit -- - ---------------- - - -- Dummy version - - function Check_Exit (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_Exit; - - -------------------- - -- Check_No_Locks -- - -------------------- - - function Check_No_Locks (Self_ID : ST.Task_Id) return Boolean is - pragma Unreferenced (Self_ID); - begin - return True; - end Check_No_Locks; - - ---------------------- - -- Environment_Task -- - ---------------------- - - function Environment_Task return Task_Id is - begin - return Environment_Task_Id; - end Environment_Task; - - -------------- - -- Lock_RTS -- - -------------- - - procedure Lock_RTS is - begin - Write_Lock (Single_RTS_Lock'Access, Global_Lock => True); - end Lock_RTS; - - ---------------- - -- Unlock_RTS -- - ---------------- - - procedure Unlock_RTS is - begin - Unlock (Single_RTS_Lock'Access, Global_Lock => True); - end Unlock_RTS; - - ------------------ - -- Suspend_Task -- - ------------------ - - function Suspend_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Suspend_Task; - - ----------------- - -- Resume_Task -- - ----------------- - - function Resume_Task - (T : ST.Task_Id; - Thread_Self : Thread_Id) return Boolean - is - pragma Unreferenced (T); - pragma Unreferenced (Thread_Self); - begin - return False; - end Resume_Task; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - begin - null; - end Stop_All_Tasks; - - --------------- - -- Stop_Task -- - --------------- - - function Stop_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Stop_Task; - - ------------------- - -- Continue_Task -- - ------------------- - - function Continue_Task (T : ST.Task_Id) return Boolean is - pragma Unreferenced (T); - begin - return False; - end Continue_Task; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_Id) is - - -- The DEC Ada facility code defined in Starlet - Ada_Facility : constant := 49; - - function DBGEXT (Control_Block : System.Address) - return System.Aux_DEC.Unsigned_Word; - -- DBGEXT is imported from s-tasdeb.adb and its parameter re-typed - -- as Address to avoid having a VMS specific s-tasdeb.ads. - pragma Import (C, DBGEXT); - pragma Import_Function (DBGEXT, "GNAT$DBGEXT"); - - type Facility_Type is range 0 .. 65535; - - procedure Debug_Register - (ADBGEXT : System.Address; - ATCB_Key : pthread_key_t; - Facility : Facility_Type; - Std_Prolog : Integer); - pragma Import (C, Debug_Register, "CMA$DEBUG_REGISTER"); - begin - Environment_Task_Id := Environment_Task; - - -- Initialize the lock used to synchronize chain of all ATCBs - - Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); - - Specific.Initialize (Environment_Task); - - -- Pass the context key on to CMA along with the other parameters - Debug_Register - ( - DBGEXT'Address, -- Our DEBUG handling entry point - ATCB_Key, -- CMA context key for our Ada TCB's - Ada_Facility, -- Out facility code - 0 -- False, we don't have the std TCB prolog - ); - - -- Make environment task known here because it doesn't go through - -- Activate_Tasks, which does it for all other tasks. - - Known_Tasks (Known_Tasks'First) := Environment_Task; - Environment_Task.Known_Tasks_Index := Known_Tasks'First; - - Enter_Task (Environment_Task); - end Initialize; - - ----------------------- - -- Set_Task_Affinity -- - ----------------------- - - procedure Set_Task_Affinity (T : ST.Task_Id) is - pragma Unreferenced (T); - - begin - -- Setting task affinity is not supported by the underlying system - - null; - end Set_Task_Affinity; -end System.Task_Primitives.Operations; diff --git a/gcc/ada/s-tasdeb-vms.adb b/gcc/ada/s-tasdeb-vms.adb deleted file mode 100644 index 0ef6322f517..00000000000 --- a/gcc/ada/s-tasdeb-vms.adb +++ /dev/null @@ -1,2159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K I N G . D E B U G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- OpenVMS Version - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with System.Aux_DEC; -with System.CRTL; -with System.Task_Primitives.Operations; -package body System.Tasking.Debug is - - package OSI renames System.OS_Interface; - package STPO renames System.Task_Primitives.Operations; - - use System.Aux_DEC; - - -- Condition value type - - subtype Cond_Value_Type is Unsigned_Longword; - - type Trace_Flag_Set is array (Character) of Boolean; - - Trace_On : Trace_Flag_Set := ('A' .. 'Z' => False, others => True); - - -- Print_Routine fuction codes - - type Print_Functions is - (No_Print, Print_Newline, Print_Control, - Print_String, Print_Symbol, Print_FAO); - for Print_Functions use - (No_Print => 0, Print_Newline => 1, Print_Control => 2, - Print_String => 3, Print_Symbol => 4, Print_FAO => 5); - - -- Counted ascii type declarations - - subtype Count_Type is Natural range 0 .. 255; - for Count_Type'Object_Size use 8; - - type ASCIC (Count : Count_Type) is record - Text : String (1 .. Count); - end record; - - for ASCIC use record - Count at 0 range 0 .. 7; - end record; - pragma Pack (ASCIC); - - type AASCIC is access ASCIC; - for AASCIC'Size use 32; - - type AASCIC_Array is array (Positive range <>) of AASCIC; - - type ASCIC127 is record - Count : Count_Type; - Text : String (1 .. 127); - end record; - - for ASCIC127 use record - Count at 0 range 0 .. 7; - Text at 1 range 0 .. 127 * 8 - 1; - end record; - - -- DEBUG Event record types used to signal DEBUG about Ada events - - type Debug_Event_Record is record - Code : Unsigned_Word; -- Event code that uniquely identifies event - Flags : Bit_Array_8; -- Flag bits - -- Bit 0: This event allows a parameter list - -- Bit 1: Parameters are address expressions - Sentinal : Unsigned_Byte; -- Sentinal valuye: Always K_EVENT_SENT - TS_Kind : Unsigned_Byte; -- DST type specification: Always K_TS_TASK - DType : Unsigned_Byte; -- DTYPE of parameter if of atomic data type - -- Always K_DTYPE_TASK - MBZ : Unsigned_Byte; -- Unused (must be zero) - Minchr : Count_Type; -- Minimum chars needed to identify event - Name : ASCIC (31); -- Event name uppercase only - Help : AASCIC; -- Event description - end record; - - for Debug_Event_Record use record - Code at 0 range 0 .. 15; - Flags at 2 range 0 .. 7; - Sentinal at 3 range 0 .. 7; - TS_Kind at 4 range 0 .. 7; - Dtype at 5 range 0 .. 7; - MBZ at 6 range 0 .. 7; - Minchr at 7 range 0 .. 7; - Name at 8 range 0 .. 32 * 8 - 1; - Help at 40 range 0 .. 31; - end record; - - type Ada_Event_Control_Block_Type is record - Code : Unsigned_Word; -- Reserved and defined by DEBUG - Unused1 : Unsigned_Byte; -- Reserved and defined by DEBUG - Sentinal : Unsigned_Byte; -- Reserved and defined by DEBUG - Facility : Unsigned_Word; -- Reserved and defined by DEBUG - Flags : Unsigned_Word; -- Reserved and defined by DEBUG - Value : Unsigned_Longword; -- Reserved and defined by DEBUG - Unused2 : Unsigned_Longword; -- Reserved and defined by DEBUG - Sigargs : Unsigned_Longword; - P1 : Unsigned_Longword; - Sub_Event : Unsigned_Longword; - end record; - - for Ada_Event_Control_Block_Type use record - Code at 0 range 0 .. 15; - Unused1 at 2 range 0 .. 7; - Sentinal at 3 range 0 .. 7; - Facility at 4 range 0 .. 15; - Flags at 6 range 0 .. 15; - Value at 8 range 0 .. 31; - Unused2 at 12 range 0 .. 31; - Sigargs at 16 range 0 .. 31; - P1 at 20 range 0 .. 31; - Sub_Event at 24 range 0 .. 31; - end record; - - type Ada_Event_Control_Block_Access is access Ada_Event_Control_Block_Type; - for Ada_Event_Control_Block_Access'Size use 32; - - -- Print_Routine_Type with max optional parameters - - type Print_Routine_Type is access procedure - (Print_Function : Print_Functions; - Print_Subfunction : Print_Functions; - P1 : Unsigned_Longword := 0; - P2 : Unsigned_Longword := 0; - P3 : Unsigned_Longword := 0; - P4 : Unsigned_Longword := 0; - P5 : Unsigned_Longword := 0; - P6 : Unsigned_Longword := 0); - for Print_Routine_Type'Size use 32; - - --------------- - -- Constants -- - --------------- - - -- These are used to obtain and convert task values - K_CVT_VALUE_NUM : constant := 1; - K_CVT_NUM_VALUE : constant := 2; - K_NEXT_TASK : constant := 3; - - -- These are used to ask ADA to display task information - K_SHOW_TASK : constant := 4; - K_SHOW_STAT : constant := 5; - K_SHOW_DEADLOCK : constant := 6; - - -- These are used to get and set various attributes of one or more tasks - -- Task state - -- K_GET_STATE : constant := 7; - -- K_GET_ACTIVE : constant := 8; - -- K_SET_ACTIVE : constant := 9; - K_SET_ABORT : constant := 10; - -- K_SET_HOLD : constant := 11; - - -- Task priority - K_GET_PRIORITY : constant := 12; - K_SET_PRIORITY : constant := 13; - K_RESTORE_PRIORITY : constant := 14; - - -- Task registers - -- K_GET_REGISTERS : constant := 15; - -- K_SET_REGISTERS : constant := 16; - - -- These are used to control definable events - K_ENABLE_EVENT : constant := 17; - K_DISABLE_EVENT : constant := 18; - K_ANNOUNCE_EVENT : constant := 19; - - -- These are used to control time-slicing. - -- K_SHOW_TIME_SLICE : constant := 20; - -- K_SET_TIME_SLICE : constant := 21; - - -- This is used to symbolize task stack addresses. - -- K_SYMBOLIZE_ADDRESS : constant := 22; - - K_GET_CALLER : constant := 23; - -- This is used to obtain the task value of the caller task - - -- Miscellaneous functions - see below for details - - K_CLEANUP_EVENT : constant := 24; - K_SHOW_EVENT_DEF : constant := 25; - -- K_CHECK_TASK_STACK : constant := 26; -- why commented out ??? - - -- This is used to obtain the DBGEXT-interface revision level - -- K_GET_DBGEXT_REV : constant := 27; -- why commented out ??? - - K_GET_STATE_1 : constant := 28; - -- This is used to obtain additional state info, primarily for PCA - - K_FIND_EVENT_BY_CODE : constant := 29; - K_FIND_EVENT_BY_NAME : constant := 30; - -- These are used to search for user-defined event entries - - -- This is used to stop task schedulding. Why commented out ??? - -- K_STOP_ALL_OTHER_TASKS : constant := 31; - - -- Debug event constants - - K_TASK_NOT_EXIST : constant := 3; - K_SUCCESS : constant := 1; - K_EVENT_SENT : constant := 16#9A#; - K_TS_TASK : constant := 18; - K_DTYPE_TASK : constant := 44; - - -- Status signal constants - - SS_BADPARAM : constant := 20; - SS_NORMAL : constant := 1; - - -- Miscellaneous mask constants - - V_EVNT_ALL : constant := 0; - V_Full_Display : constant := 11; - V_Suppress_Header : constant := 13; - - -- CMA constants (why are some commented out???) - - CMA_C_DEBGET_GUARDSIZE : constant := 1; - CMA_C_DEBGET_IS_HELD : constant := 2; --- CMA_C_DEBGET_IS_INITIAL : constant := 3; --- CMA_C_DEBGET_NUMBER : constant := 4; - CMA_C_DEBGET_STACKPTR : constant := 5; - CMA_C_DEBGET_STACK_BASE : constant := 6; - CMA_C_DEBGET_STACK_TOP : constant := 7; - CMA_C_DEBGET_SCHED_STATE : constant := 8; - CMA_C_DEBGET_YELLOWSIZE : constant := 9; --- CMA_C_DEBGET_BASE_PRIO : constant := 10; --- CMA_C_DEBGET_REGS : constant := 11; --- CMA_C_DEBGET_ALT_PENDING : constant := 12; --- CMA_C_DEBGET_ALT_A_ENABLE : constant := 13; --- CMA_C_DEBGET_ALT_G_ENABLE : constant := 14; --- CMA_C_DEBGET_SUBSTATE : constant := 15; --- CMA_C_DEBGET_OBJECT_ADDR : constant := 16; --- CMA_C_DEBGET_THKIND : constant := 17; --- CMA_C_DEBGET_DETACHED : constant := 18; - CMA_C_DEBGET_TCB_SIZE : constant := 19; --- CMA_C_DEBGET_START_PC : constant := 20; --- CMA_C_DEBGET_NEXT_PC : constant := 22; --- CMA_C_DEBGET_POLICY : constant := 23; --- CMA_C_DEBGET_STACK_YELLOW : constant := 24; --- CMA_C_DEBGET_STACK_DEFAULT : constant := 25; - - -- Miscellaneous counted ascii constants - - Star : constant AASCIC := new ASCIC'(2, ("* ")); - NoStar : constant AASCIC := new ASCIC'(2, (" ")); - Hold : constant AASCIC := new ASCIC'(4, ("HOLD")); - NoHold : constant AASCIC := new ASCIC'(4, (" ")); - Header : constant AASCIC := new ASCIC ' - (60, (" task id pri hold state substate task object")); - Empty_Text : constant AASCIC := new ASCIC (0); - - -- DEBUG Ada tasking states equated to their GNAT tasking equivalents - - Ada_State_Invalid_State : constant AASCIC := - new ASCIC'(17, "Invalid state "); --- Ada_State_Abnormal : constant AASCIC := --- new ASCIC'(17, "Abnormal "); - Ada_State_Aborting : constant AASCIC := - new ASCIC'(17, "Aborting "); -- Aborting (new) --- Ada_State_Completed_Abn : constant AASCIC := --- new ASCIC'(17, "Completed [abn] "); --- Ada_State_Completed_Exc : constant AASCIC := --- new ASCIC'(17, "Completed [exc] "); - Ada_State_Completed : constant AASCIC := - new ASCIC'(17, "Completed "); -- Master_Completion_Sleep - Ada_State_Runnable : constant AASCIC := - new ASCIC'(17, "Runnable "); -- Runnable - Ada_State_Activating : constant AASCIC := - new ASCIC'(17, "Activating "); - Ada_State_Accept : constant AASCIC := - new ASCIC'(17, "Accept "); -- Acceptor_Sleep - Ada_State_Select_or_Delay : constant AASCIC := - new ASCIC'(17, "Select or delay "); -- Acceptor_Delay_Sleep - Ada_State_Select_or_Term : constant AASCIC := - new ASCIC'(17, "Select or term. "); -- Terminate_Alternative - Ada_State_Select_or_Abort : constant AASCIC := - new ASCIC'(17, "Select or abort "); -- Async_Select_Sleep (new) --- Ada_State_Select : constant AASCIC := --- new ASCIC'(17, "Select "); - Ada_State_Activating_Tasks : constant AASCIC := - new ASCIC'(17, "Activating tasks "); -- Activator_Sleep - Ada_State_Delay : constant AASCIC := - new ASCIC'(17, "Delay "); -- AST_Pending --- Ada_State_Dependents : constant AASCIC := --- new ASCIC'(17, "Dependents "); - Ada_State_Entry_Call : constant AASCIC := - new ASCIC'(17, "Entry call "); -- Entry_Caller_Sleep - Ada_State_Cond_Entry_Call : constant AASCIC := - new ASCIC'(17, "Cond. entry call "); -- Call.Mode.Conditional_Call - Ada_State_Timed_Entry_Call : constant AASCIC := - new ASCIC'(17, "Timed entry call "); -- Call.Mode.Timed_Call - Ada_State_Async_Entry_Call : constant AASCIC := - new ASCIC'(17, "Async entry call "); -- Call.Mode.Asynchronous_Call (new) --- Ada_State_Dependents_Exc : constant AASCIC := --- new ASCIC'(17, "Dependents [exc] "); - Ada_State_IO_or_AST : constant AASCIC := - new ASCIC'(17, "I/O or AST "); -- AST_Server_Sleep --- Ada_State_Shared_Resource : constant AASCIC := --- new ASCIC'(17, "Shared resource "); - Ada_State_Not_Yet_Activated : constant AASCIC := - new ASCIC'(17, "Not yet activated"); -- Unactivated --- Ada_State_Terminated_Abn : constant AASCIC := --- new ASCIC'(17, "Terminated [abn] "); --- Ada_State_Terminated_Exc : constant AASCIC := --- new ASCIC'(17, "Terminated [exc] "); - Ada_State_Terminated : constant AASCIC := - new ASCIC'(17, "Terminated "); -- Terminated - Ada_State_Server : constant AASCIC := - new ASCIC'(17, "Server "); -- Servers - Ada_State_Async_Hold : constant AASCIC := - new ASCIC'(17, "Async_Hold "); -- Async_Hold - - -- Task state counted ascii constants - - Debug_State_Emp : constant AASCIC := new ASCIC'(5, " "); - Debug_State_Run : constant AASCIC := new ASCIC'(5, "RUN "); - Debug_State_Rea : constant AASCIC := new ASCIC'(5, "READY"); - Debug_State_Sus : constant AASCIC := new ASCIC'(5, "SUSP "); - Debug_State_Ter : constant AASCIC := new ASCIC'(5, "TERM "); - - -- Priority order of event display - - Global_Event_Display_Order : constant array (Event_Kind_Type) - of Event_Kind_Type := ( - Debug_Event_Abort_Terminated, - Debug_Event_Activating, - Debug_Event_Dependents_Exception, - Debug_Event_Exception_Terminated, - Debug_Event_Handled, - Debug_Event_Handled_Others, - Debug_Event_Preempted, - Debug_Event_Rendezvous_Exception, - Debug_Event_Run, - Debug_Event_Suspended, - Debug_Event_Terminated); - - -- Constant array defining all debug events - - Event_Directory : constant array (Event_Kind_Type) - of Debug_Event_Record := ( - (Debug_Event_Activating, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 2, - (31, "ACTIVATING "), - new ASCIC'(41, "!_a task is about to begin its activation")), - - (Debug_Event_Run, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 2, - (31, "RUN "), - new ASCIC'(24, "!_a task is about to run")), - - (Debug_Event_Suspended, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "SUSPENDED "), - new ASCIC'(33, "!_a task is about to be suspended")), - - (Debug_Event_Preempted, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "PREEMPTED "), - new ASCIC'(33, "!_a task is about to be preempted")), - - (Debug_Event_Terminated, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "TERMINATED "), - new ASCIC'(57, - "!_a task is terminating (including by abort or exception)")), - - (Debug_Event_Abort_Terminated, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 2, - (31, "ABORT_TERMINATED "), - new ASCIC'(40, "!_a task is terminating because of abort")), - - (Debug_Event_Exception_Terminated, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "EXCEPTION_TERMINATED "), - new ASCIC'(47, "!_a task is terminating because of an exception")), - - (Debug_Event_Rendezvous_Exception, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 3, - (31, "RENDEZVOUS_EXCEPTION "), - new ASCIC'(49, "!_an exception is propagating out of a rendezvous")), - - (Debug_Event_Handled, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "HANDLED "), - new ASCIC'(37, "!_an exception is about to be handled")), - - (Debug_Event_Dependents_Exception, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "DEPENDENTS_EXCEPTION "), - new ASCIC'(64, - "!_an exception is about to cause a task to await dependent tasks")), - - (Debug_Event_Handled_Others, - (False, False, False, False, False, False, False, True), - K_EVENT_SENT, - K_TS_TASK, - K_DTYPE_TASK, - 0, - 1, - (31, "HANDLED_OTHERS "), - new ASCIC'(58, - "!_an exception is about to be handled in an OTHERS handler"))); - - -- Help on events displayed in DEBUG - - Event_Def_Help : constant AASCIC_Array := ( - new ASCIC'(0, ""), - new ASCIC'(65, - " The general forms of commands to set a breakpoint or tracepoint"), - new ASCIC'(22, " on an Ada event are:"), - new ASCIC'(73, " SET BREAK/EVENT=event [task[, ... ]] " & - "[WHEN(expr)] [DO(comnd[; ... ])]"), - new ASCIC'(73, " SET TRACE/EVENT=event [task[, ... ]] " & - "[WHEN(expr)] [DO(comnd[; ... ])]"), - new ASCIC'(0, ""), - new ASCIC'(65, - " If tasks are specified, the breakpoint will trigger only if the"), - new ASCIC'(40, " event occurs for those specific tasks."), - new ASCIC'(0, ""), - new ASCIC'(39, " Ada event names and their definitions"), - new ASCIC'(0, "")); - - ----------------------- - -- Package Variables -- - ----------------------- - - AC_Buffer : ASCIC127; - - Events_Enabled_Count : Integer := 0; - - Print_Routine_Bufsiz : constant := 132; - Print_Routine_Bufcnt : Integer := 0; - Print_Routine_Linbuf : String (1 .. Print_Routine_Bufsiz); - - Global_Task_Debug_Events : Debug_Event_Array := - (False, False, False, False, False, False, False, False, - False, False, False, False, False, False, False, False); - -- Global table of task debug events set by the debugger - - -------------------------- - -- Exported Subprograms -- - -------------------------- - - procedure Default_Print_Routine - (Print_Function : Print_Functions; - Print_Subfunction : Print_Functions; - P1 : Unsigned_Longword := 0; - P2 : Unsigned_Longword := 0; - P3 : Unsigned_Longword := 0; - P4 : Unsigned_Longword := 0; - P5 : Unsigned_Longword := 0; - P6 : Unsigned_Longword := 0); - -- The default print routine if not overridden. - -- Print_Function determines option argument formatting. - -- Print_Subfunction buffers output if No_Print, calls Put_Output if - -- Print_Newline - - pragma Export_Procedure - (Default_Print_Routine, - Mechanism => (Value, Value, Reference, Reference, Reference)); - - -------------------------- - -- Imported Subprograms -- - -------------------------- - - procedure Debug_Get - (Thread_Id : OSI.Thread_Id; - Item_Req : Unsigned_Word; - Out_Buff : System.Address; - Buff_Siz : Unsigned_Word); - - procedure Debug_Get - (Thread_Id : OSI.Thread_Id; - Item_Req : Unsigned_Word; - Out_Buff : Unsigned_Longword; - Buff_Siz : Unsigned_Word); - pragma Import (External, Debug_Get); - - pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET", - (OSI.Thread_Id, Unsigned_Word, System.Address, Unsigned_Word), - (Reference, Value, Reference, Value)); - - pragma Import_Procedure (Debug_Get, "CMA$DEBUG_GET", - (OSI.Thread_Id, Unsigned_Word, Unsigned_Longword, Unsigned_Word), - (Reference, Value, Reference, Value)); - - procedure FAOL - (Status : out Cond_Value_Type; - Ctrstr : String; - Outlen : out Unsigned_Word; - Outbuf : out String; - Prmlst : Unsigned_Longword_Array); - pragma Import (External, FAOL); - - pragma Import_Valued_Procedure (FAOL, "SYS$FAOL", - (Cond_Value_Type, String, Unsigned_Word, String, Unsigned_Longword_Array), - (Value, Descriptor (S), Reference, Descriptor (S), Reference)); - - procedure Put_Output ( - Status : out Cond_Value_Type; - Message_String : String); - - procedure Put_Output (Message_String : String); - pragma Import (External, Put_Output); - - pragma Import_Valued_Procedure (Put_Output, "LIB$PUT_OUTPUT", - (Cond_Value_Type, String), - (Value, Short_Descriptor (S))); - - pragma Import_Procedure (Put_Output, "LIB$PUT_OUTPUT", - (String), - (Short_Descriptor (S))); - - procedure Signal - (Condition_Value : Cond_Value_Type; - Number_Of_Arguments : Integer := Integer'Null_Parameter; - FAO_Argument_1 : Unsigned_Longword := - Unsigned_Longword'Null_Parameter); - pragma Import (External, Signal); - - pragma Import_Procedure (Signal, "LIB$SIGNAL", - (Cond_Value_Type, Integer, Unsigned_Longword), - (Value, Value, Value), - Number_Of_Arguments); - - ---------------------------- - -- Generic Instantiations -- - ---------------------------- - - function Fetch is new Fetch_From_Address (Unsigned_Longword); - pragma Unreferenced (Fetch); - - procedure Free is new Ada.Unchecked_Deallocation - (Object => Ada_Event_Control_Block_Type, - Name => Ada_Event_Control_Block_Access); - - function To_AASCIC is new - Ada.Unchecked_Conversion (Unsigned_Longword, AASCIC); - - function To_Addr is new - Ada.Unchecked_Conversion (Task_Procedure_Access, Address); - pragma Unreferenced (To_Addr); - - function To_EVCB is new - Ada.Unchecked_Conversion - (Unsigned_Longword, Ada_Event_Control_Block_Access); - - function To_Integer is new - Ada.Unchecked_Conversion (Task_Id, System.Task_Primitives.Task_Address); - - function To_Print_Routine_Type is new - Ada.Unchecked_Conversion (Short_Address, Print_Routine_Type); - - -- Optional argumements passed to Print_Routine have to be - -- Unsigned_Longwords so define the required Unchecked_Conversions - - function To_UL is new - Ada.Unchecked_Conversion (AASCIC, Unsigned_Longword); - - function To_UL is new - Ada.Unchecked_Conversion (Integer, Unsigned_Longword); - - function To_UL is new - Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); - - pragma Warnings (Off); -- Different sizes - function To_UL is new - Ada.Unchecked_Conversion (Task_Entry_Index, Unsigned_Longword); - pragma Warnings (On); - - function To_UL is new - Ada.Unchecked_Conversion (Short_Address, Unsigned_Longword); - - function To_UL is new - Ada.Unchecked_Conversion - (Ada_Event_Control_Block_Access, Unsigned_Longword); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - subtype Function_Codes is System.Aux_DEC.Unsigned_Word range 1 .. 31; - -- The 31 function codes sent by the debugger needed to implement - -- tasking support, enumerated below. - - type Register_Array is array (Natural range 0 .. 16) of - System.Aux_DEC.Unsigned_Longword; - -- The register array is a holdover from VAX and not used - -- on Alpha or I64 but is kept as a filler below. - - type DBGEXT_Control_Block (Function_Code : Function_Codes) is record - Facility_ID : System.Aux_DEC.Unsigned_Word; - -- For GNAT use the "Ada" facility ID - Status : System.Aux_DEC.Unsigned_Longword; - -- Successful or otherwise returned status - Flags : System.Aux_DEC.Bit_Array_32; - -- Used to flag event as global - Print_Routine : System.Aux_DEC.Short_Address; - -- The print subprogram the caller wants to use for output - Event_Code_or_EVCB : System.Aux_DEC.Unsigned_Longword; - -- Dual use Event Code or EVent Control Block - Event_Value_or_Name : System.Aux_DEC.Unsigned_Longword; - -- Dual use Event Value or Event Name string pointer - Event_Entry : System.Aux_DEC.Unsigned_Longword; - Task_Value : Task_Id; - Task_Number : Integer; - Ada_Flags : System.Aux_DEC.Bit_Array_32; - Priority : System.Aux_DEC.Bit_Array_32; - Active_Registers : System.Aux_DEC.Short_Address; - - case Function_Code is - when K_GET_STATE_1 => - Base_Priority : System.Aux_DEC.Bit_Array_32; - Task_Type_Name : System.Aux_DEC.Short_Address; - Creation_PC : System.Aux_DEC.Short_Address; - Parent_Task_ID : Task_Id; - - when others => - Ignored_Unused : Register_Array; - - end case; - end record; - - for DBGEXT_Control_Block use record - Function_Code at 0 range 0 .. 15; - Facility_ID at 2 range 0 .. 15; - Status at 4 range 0 .. 31; - Flags at 8 range 0 .. 31; - Print_Routine at 12 range 0 .. 31; - Event_Code_or_EVCB at 16 range 0 .. 31; - Event_Value_or_Name at 20 range 0 .. 31; - Event_Entry at 24 range 0 .. 31; - Task_Value at 28 range 0 .. 31; - Task_Number at 32 range 0 .. 31; - Ada_Flags at 36 range 0 .. 31; - Priority at 40 range 0 .. 31; - Active_Registers at 44 range 0 .. 31; - Ignored_Unused at 48 range 0 .. 17 * 32 - 1; - Base_Priority at 48 range 0 .. 31; - Task_Type_Name at 52 range 0 .. 31; - Creation_PC at 56 range 0 .. 31; - Parent_Task_ID at 60 range 0 .. 31; - end record; - - type DBGEXT_Control_Block_Access is access all DBGEXT_Control_Block; - - function DBGEXT (Control_Block : DBGEXT_Control_Block_Access) - return System.Aux_DEC.Unsigned_Word; - -- Exported to s-taprop.adb to avoid having a VMS specific s-tasdeb.ads - pragma Convention (C, DBGEXT); - pragma Export_Function (DBGEXT, "GNAT$DBGEXT"); - -- This routine is called by CMA when VMS DEBUG wants the Gnat RTL - -- to give it some assistance (primarily when tasks are debugged). - -- - -- The single parameter is an "external control block". On input to - -- the Gnat RTL this control block determines the debugging function - -- to be performed, and supplies parameters. This routine cases on - -- the function code, and calls the appropriate Gnat RTL routine, - -- which returns values by modifying the external control block. - - procedure Announce_Event - (Event_EVCB : Unsigned_Longword; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Announce the occurence of a DEBUG tasking event - - procedure Cleanup_Event (Event_EVCB : Unsigned_Longword); - -- After DEBUG has processed an event that has signalled, the signaller - -- must cleanup. Cleanup consists of freeing the event control block. - - procedure Disable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type); - -- Disable a DEBUG tasking event - - function DoAC (S : String) return Address; - -- Convert a string to the address of an internal buffer containing - -- the counted ASCII. - - procedure Enable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type); - -- Enable a requested DEBUG tasking event - - procedure Find_Event_By_Code - (Event_Code : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type); - -- Convert an event code to the address of the event entry - - procedure Find_Event_By_Name - (Event_Name : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type); - -- Find an event entry given the event name - - procedure List_Entry_Waiters - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- List information about tasks waiting on an entry - - procedure Put (S : String); - -- Display S on standard output - - procedure Put_Line (S : String := ""); - -- Display S on standard output with an additional line terminator - - procedure Show_Event - (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Show what events are available - - procedure Show_One_Task - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Display information about one task - - procedure Show_Rendezvous - (Task_Value : Task_Id; - Ada_State : AASCIC := Empty_Text; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access); - -- Display information about a task rendezvous - - procedure Trace_Output (Message_String : String); - -- Call Put_Output if Trace_on ("VMS") - - procedure Write (Fd : Integer; S : String; Count : Integer); - - -------------------- - -- Announce_Event -- - -------------------- - - procedure Announce_Event - (Event_EVCB : Unsigned_Longword; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - EVCB : constant Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB); - - Event_Kind : constant Event_Kind_Type := - (if EVCB.Sub_Event /= 0 - then Event_Kind_Type (EVCB.Sub_Event) - else Event_Kind_Type (EVCB.Code)); - - TI : constant String := " Task %TASK !UI is "; - -- Announce prefix - - begin - Trace_Output ("Announce called"); - - case Event_Kind is - when Debug_Event_Activating => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "about to begin its activation")), - EVCB.Value); - when Debug_Event_Exception_Terminated => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "terminating because of an exception")), - EVCB.Value); - when Debug_Event_Run => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "about to run")), - EVCB.Value); - when Debug_Event_Abort_Terminated => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "terminating because of abort")), - EVCB.Value); - when Debug_Event_Terminated => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (TI & "terminating normally")), - EVCB.Value); - when others => null; - end case; - end Announce_Event; - - ------------------- - -- Cleanup_Event -- - ------------------- - - procedure Cleanup_Event (Event_EVCB : Unsigned_Longword) is - EVCB : Ada_Event_Control_Block_Access := To_EVCB (Event_EVCB); - begin - Free (EVCB); - end Cleanup_Event; - - ------------------------ - -- Continue_All_Tasks -- - ------------------------ - - procedure Continue_All_Tasks is - begin - null; -- VxWorks - end Continue_All_Tasks; - - ------------ - -- DBGEXT -- - ------------ - - function DBGEXT - (Control_Block : DBGEXT_Control_Block_Access) - return System.Aux_DEC.Unsigned_Word - is - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access; - begin - Trace_Output ("DBGEXT called"); - - if Control_Block.Print_Routine /= Address_Zero then - Print_Routine := To_Print_Routine_Type (Control_Block.Print_Routine); - end if; - - case Control_Block.Function_Code is - - -- Convert a task value to a task number. - -- The output results are stored in the CONTROL_BLOCK. - - when K_CVT_VALUE_NUM => - Trace_Output ("DBGEXT param 1 - CVT Value to NUM"); - Control_Block.Task_Number := - Control_Block.Task_Value.Known_Tasks_Index + 1; - Control_Block.Status := K_SUCCESS; - Trace_Output ("Task Number: "); - Trace_Output (Integer'Image (Control_Block.Task_Number)); - return SS_NORMAL; - - -- Convert a task number to a task value. - -- The output results are stored in the CONTROL_BLOCK. - - when K_CVT_NUM_VALUE => - Trace_Output ("DBGEXT param 2 - CVT NUM to Value"); - Trace_Output ("Task Number: "); - Trace_Output (Integer'Image (Control_Block.Task_Number)); - Control_Block.Task_Value := - Known_Tasks (Control_Block.Task_Number - 1); - Control_Block.Status := K_SUCCESS; - Trace_Output ("Task Value: "); - Trace_Output (Unsigned_Longword'Image - (To_UL (Control_Block.Task_Value))); - return SS_NORMAL; - - -- Obtain the "next" task after a specified task. - -- ??? To do: If specified check the PRIORITY, STATE, and HOLD - -- fields to restrict the selection of the next task. - -- The output results are stored in the CONTROL_BLOCK. - - when K_NEXT_TASK => - Trace_Output ("DBGEXT param 3 - Next Task"); - Trace_Output ("Task Value: "); - Trace_Output (Unsigned_Longword'Image - (To_UL (Control_Block.Task_Value))); - - if Control_Block.Task_Value = null then - Control_Block.Task_Value := Known_Tasks (Known_Tasks'First); - else - Control_Block.Task_Value := - Known_Tasks (Control_Block.Task_Value.Known_Tasks_Index + 1); - end if; - - if Control_Block.Task_Value = null then - Control_Block.Task_Value := Known_Tasks (Known_Tasks'First); - end if; - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- Display the state of a task. The FULL bit is checked to decide if - -- a full or brief task display is desired. The output results are - -- stored in the CONTROL_BLOCK. - - when K_SHOW_TASK => - Trace_Output ("DBGEXT param 4 - Show Task"); - - if Control_Block.Task_Value = null then - Control_Block.Status := K_TASK_NOT_EXIST; - else - Show_One_Task - (Control_Block.Task_Value, - Control_Block.Ada_Flags (V_Full_Display), - Control_Block.Ada_Flags (V_Suppress_Header), - Print_Routine); - - Control_Block.Status := K_SUCCESS; - end if; - - return SS_NORMAL; - - -- Enable a requested DEBUG tasking event - - when K_ENABLE_EVENT => - Trace_Output ("DBGEXT param 17 - Enable Event"); - Enable_Event - (Control_Block.Flags, - Control_Block.Event_Value_or_Name, - Control_Block.Event_Code_or_EVCB, - Control_Block.Status); - - return SS_NORMAL; - - -- Disable a DEBUG tasking event - - when K_DISABLE_EVENT => - Trace_Output ("DBGEXT param 18 - Disable Event"); - Disable_Event - (Control_Block.Flags, - Control_Block.Event_Value_or_Name, - Control_Block.Event_Code_or_EVCB, - Control_Block.Status); - - return SS_NORMAL; - - -- Announce the occurence of a DEBUG tasking event - - when K_ANNOUNCE_EVENT => - Trace_Output ("DBGEXT param 19 - Announce Event"); - Announce_Event - (Control_Block.Event_Code_or_EVCB, - Print_Routine); - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- After DEBUG has processed an event that has signalled, - -- the signaller must cleanup. - -- Cleanup consists of freeing the event control block. - - when K_CLEANUP_EVENT => - Trace_Output ("DBGEXT param 24 - Cleanup Event"); - Cleanup_Event (Control_Block.Event_Code_or_EVCB); - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- Show what events are available - - when K_SHOW_EVENT_DEF => - Trace_Output ("DBGEXT param 25 - Show Event Def"); - Show_Event (Print_Routine); - - Control_Block.Status := K_SUCCESS; - return SS_NORMAL; - - -- Convert an event code to the address of the event entry - - when K_FIND_EVENT_BY_CODE => - Trace_Output ("DBGEXT param 29 - Find Event by Code"); - Find_Event_By_Code - (Control_Block.Event_Code_or_EVCB, - Control_Block.Event_Entry, - Control_Block.Status); - - return SS_NORMAL; - - -- Find an event entry given the event name - - when K_FIND_EVENT_BY_NAME => - Trace_Output ("DBGEXT param 30 - Find Event by Name"); - Find_Event_By_Name - (Control_Block.Event_Value_or_Name, - Control_Block.Event_Entry, - Control_Block.Status); - return SS_NORMAL; - - -- ??? To do: Implement priority events - -- Get, set or restore a task's priority - - when K_GET_PRIORITY or K_SET_PRIORITY or K_RESTORE_PRIORITY => - Trace_Output ("DBGEXT priority param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement show statistics event - -- Display task statistics - - when K_SHOW_STAT => - Trace_Output ("DBGEXT show stat param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement get caller event - -- Obtain the caller of a task in a rendezvous. If no rendezvous, - -- null is returned - - when K_GET_CALLER => - Trace_Output ("DBGEXT get caller param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement set terminate event - -- Terminate a task - - when K_SET_ABORT => - Trace_Output ("DBGEXT set terminate param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - -- ??? To do: Implement show deadlock event - -- Detect a deadlock - - when K_SHOW_DEADLOCK => - Trace_Output ("DBGEXT show deadlock param - Not yet implemented"); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - when others => - Trace_Output ("DBGEXT bad param: "); - Trace_Output (Function_Codes'Image - (Control_Block.Function_Code)); - return SS_BADPARAM; - - end case; - end DBGEXT; - - --------------------------- - -- Default_Print_Routine -- - --------------------------- - - procedure Default_Print_Routine - (Print_Function : Print_Functions; - Print_Subfunction : Print_Functions; - P1 : Unsigned_Longword := 0; - P2 : Unsigned_Longword := 0; - P3 : Unsigned_Longword := 0; - P4 : Unsigned_Longword := 0; - P5 : Unsigned_Longword := 0; - P6 : Unsigned_Longword := 0) - is - Status : Cond_Value_Type; - Linlen : Unsigned_Word; - Item_List : Unsigned_Longword_Array (1 .. 17) := - (1 .. 17 => 0); - begin - - case Print_Function is - when Print_Control | Print_String => - null; - - -- Formatted Ascii Output - - when Print_FAO => - Item_List (1) := P2; - Item_List (2) := P3; - Item_List (3) := P4; - Item_List (4) := P5; - Item_List (5) := P6; - FAOL - (Status, - To_AASCIC (P1).Text, - Linlen, - Print_Routine_Linbuf - (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz), - Item_List); - - Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen); - - -- Symbolic output - - when Print_Symbol => - Item_List (1) := P1; - FAOL - (Status, - "!XI", - Linlen, - Print_Routine_Linbuf - (1 + Print_Routine_Bufcnt .. Print_Routine_Bufsiz), - Item_List); - - Print_Routine_Bufcnt := Print_Routine_Bufcnt + Integer (Linlen); - - when others => - null; - end case; - - case Print_Subfunction is - - -- Output buffer with a terminating newline - - when Print_Newline => - Put_Output (Status, - Print_Routine_Linbuf (1 .. Print_Routine_Bufcnt)); - Print_Routine_Bufcnt := 0; - - -- Buffer the output - - when No_Print => - null; - - when others => - null; - end case; - - end Default_Print_Routine; - - ------------------- - -- Disable_Event -- - ------------------- - - procedure Disable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type) - is - Task_Value : Task_Id; - Task_Index : constant Integer := Integer (Event_Value) - 1; - begin - - Events_Enabled_Count := Events_Enabled_Count - 1; - - if Flags (V_EVNT_ALL) then - Global_Task_Debug_Events (Integer (Event_Code)) := False; - Status := K_SUCCESS; - else - if Task_Index in Known_Tasks'Range then - Task_Value := Known_Tasks (Task_Index); - if Task_Value /= null then - Task_Value.Common.Debug_Events (Integer (Event_Code)) := False; - Status := K_SUCCESS; - else - Status := K_TASK_NOT_EXIST; - end if; - else - Status := K_TASK_NOT_EXIST; - end if; - end if; - - -- Keep count of events for efficiency - - if Events_Enabled_Count <= 0 then - Events_Enabled_Count := 0; - Global_Task_Debug_Event_Set := False; - end if; - - end Disable_Event; - - ---------- - -- DoAC -- - ---------- - - function DoAC (S : String) return Address is - begin - AC_Buffer.Count := S'Length; - AC_Buffer.Text (1 .. AC_Buffer.Count) := S; - return AC_Buffer'Address; - end DoAC; - - ------------------ - -- Enable_Event -- - ------------------ - - procedure Enable_Event - (Flags : Bit_Array_32; - Event_Value : Unsigned_Longword; - Event_Code : Unsigned_Longword; - Status : out Cond_Value_Type) - is - Task_Value : Task_Id; - Task_Index : constant Integer := Integer (Event_Value) - 1; - - begin - -- At least one event enabled, any and all events will cause a - -- condition to be raised and checked. Major tasking slowdown. - - Global_Task_Debug_Event_Set := True; - Events_Enabled_Count := Events_Enabled_Count + 1; - - if Flags (V_EVNT_ALL) then - Global_Task_Debug_Events (Integer (Event_Code)) := True; - Status := K_SUCCESS; - else - if Task_Index in Known_Tasks'Range then - Task_Value := Known_Tasks (Task_Index); - if Task_Value /= null then - Task_Value.Common.Debug_Events (Integer (Event_Code)) := True; - Status := K_SUCCESS; - else - Status := K_TASK_NOT_EXIST; - end if; - else - Status := K_TASK_NOT_EXIST; - end if; - end if; - - end Enable_Event; - - ------------------------ - -- Find_Event_By_Code -- - ------------------------ - - procedure Find_Event_By_Code - (Event_Code : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type) - is - K_SUCCESS : constant := 1; - K_NO_SUCH_EVENT : constant := 9; - - begin - Trace_Output ("Looking for Event: "); - Trace_Output (Unsigned_Longword'Image (Event_Code)); - - for I in Event_Kind_Type'Range loop - if Event_Code = Unsigned_Longword (Event_Directory (I).Code) then - Event_Entry := To_UL (Event_Directory (I)'Address); - Trace_Output ("Found Event # "); - Trace_Output (Integer'Image (I)); - Status := K_SUCCESS; - return; - end if; - end loop; - - Status := K_NO_SUCH_EVENT; - end Find_Event_By_Code; - - ------------------------ - -- Find_Event_By_Name -- - ------------------------ - - procedure Find_Event_By_Name - (Event_Name : Unsigned_Longword; - Event_Entry : out Unsigned_Longword; - Status : out Cond_Value_Type) - is - K_SUCCESS : constant := 1; - K_NO_SUCH_EVENT : constant := 9; - - Event_Name_Cstr : constant ASCIC := To_AASCIC (Event_Name).all; - begin - Trace_Output ("Looking for Event: "); - Trace_Output (Event_Name_Cstr.Text); - - for I in Event_Kind_Type'Range loop - if Event_Name_Cstr.Count >= Event_Directory (I).Minchr - and then Event_Name_Cstr.Count <= Event_Directory (I).Name.Count - and then Event_Name_Cstr.Text (1 .. Event_Directory (I).Minchr) = - Event_Directory (I).Name.Text (1 .. Event_Directory (I).Minchr) - then - Event_Entry := To_UL (Event_Directory (I)'Address); - Trace_Output ("Found Event # "); - Trace_Output (Integer'Image (I)); - Status := K_SUCCESS; - return; - end if; - end loop; - - Status := K_NO_SUCH_EVENT; - end Find_Event_By_Name; - - -------------------- - -- Get_User_State -- - -------------------- - - function Get_User_State return Long_Integer is - begin - return STPO.Self.User_State; - end Get_User_State; - - ------------------------ - -- List_Entry_Waiters -- - ------------------------ - - procedure List_Entry_Waiters - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - pragma Unreferenced (Suppress_Header); - - Entry_Call : Entry_Call_Link; - Have_Some : Boolean := False; - begin - if not Full_Display then - return; - end if; - - if Task_Value.Entry_Queues'Length > 0 then - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Waiting entry callers:"))); - end if; - for I in Task_Value.Entry_Queues'Range loop - Entry_Call := Task_Value.Entry_Queues (I).Head; - if Entry_Call /= null then - Have_Some := True; - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Waiters for entry !UI:")), - To_UL (I)); - - loop - declare - Task_Image : ASCIC := - (Entry_Call.Self.Common.Task_Image_Len, - Entry_Call.Self.Common.Task_Image - (1 .. Entry_Call.Self.Common.Task_Image_Len)); - begin - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" %TASK !UI, type: !AC")), - To_UL (Entry_Call.Self.Known_Tasks_Index + 1), - To_UL (Task_Image'Address)); - if Entry_Call = Task_Value.Entry_Queues (I).Tail then - exit; - end if; - Entry_Call := Entry_Call.Next; - end; - end loop; - end if; - end loop; - if not Have_Some then - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" none."))); - end if; - end List_Entry_Waiters; - - ---------------- - -- List_Tasks -- - ---------------- - - procedure List_Tasks is - C : Task_Id; - begin - C := All_Tasks_List; - - while C /= null loop - Print_Task_Info (C); - C := C.Common.All_Tasks_Link; - end loop; - end List_Tasks; - - ------------------------ - -- Print_Current_Task -- - ------------------------ - - procedure Print_Current_Task is - begin - Print_Task_Info (STPO.Self); - end Print_Current_Task; - - --------------------- - -- Print_Task_Info -- - --------------------- - - procedure Print_Task_Info (T : Task_Id) is - Entry_Call : Entry_Call_Link; - Parent : Task_Id; - - begin - if T = null then - Put_Line ("null task"); - return; - end if; - - Put (T.Common.Task_Image (1 .. T.Common.Task_Image_Len) & ": " & - Task_States'Image (T.Common.State)); - - Parent := T.Common.Parent; - - if Parent = null then - Put (", parent: <none>"); - else - Put (", parent: " & - Parent.Common.Task_Image (1 .. Parent.Common.Task_Image_Len)); - end if; - - Put (", prio:" & T.Common.Current_Priority'Img); - - if not T.Callable then - Put (", not callable"); - end if; - - if T.Aborting then - Put (", aborting"); - end if; - - if T.Deferral_Level /= 0 then - Put (", abort deferred"); - end if; - - if T.Common.Call /= null then - Entry_Call := T.Common.Call; - Put (", serving:"); - - while Entry_Call /= null loop - Put (To_Integer (Entry_Call.Self)'Img); - Entry_Call := Entry_Call.Acceptor_Prev_Call; - end loop; - end if; - - if T.Open_Accepts /= null then - Put (", accepting:"); - - for J in T.Open_Accepts'Range loop - Put (T.Open_Accepts (J).S'Img); - end loop; - - if T.Terminate_Alternative then - Put (" or terminate"); - end if; - end if; - - if T.User_State /= 0 then - Put (", state:" & T.User_State'Img); - end if; - - Put_Line; - end Print_Task_Info; - - --------- - -- Put -- - --------- - - procedure Put (S : String) is - begin - Write (2, S, S'Length); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (S : String := "") is - begin - Write (2, S & ASCII.LF, S'Length + 1); - end Put_Line; - - ---------------------- - -- Resume_All_Tasks -- - ---------------------- - - procedure Resume_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is - pragma Unreferenced (Thread_Self); - begin - null; -- VxWorks - end Resume_All_Tasks; - - --------------- - -- Set_Trace -- - --------------- - - procedure Set_Trace (Flag : Character; Value : Boolean := True) is - begin - Trace_On (Flag) := Value; - end Set_Trace; - - -------------------- - -- Set_User_State -- - -------------------- - - procedure Set_User_State (Value : Long_Integer) is - begin - STPO.Self.User_State := Value; - end Set_User_State; - - ---------------- - -- Show_Event -- - ---------------- - - procedure Show_Event - (Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - begin - for I in Event_Def_Help'Range loop - Print_Routine (Print_FAO, Print_Newline, To_UL (Event_Def_Help (I))); - end loop; - - for I in Event_Kind_Type'Range loop - Print_Routine (Print_FAO, Print_Newline, - To_UL (Event_Directory - (Global_Event_Display_Order (I)).Name'Address)); - Print_Routine (Print_FAO, Print_Newline, - To_UL (Event_Directory (Global_Event_Display_Order (I)).Help)); - end loop; - end Show_Event; - - -------------------- - -- Show_One_Task -- - -------------------- - - procedure Show_One_Task - (Task_Value : Task_Id; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - Task_SP : System.Address := Address_Zero; - Stack_Base : System.Address := Address_Zero; - Stack_Top : System.Address := Address_Zero; - TCB_Size : Unsigned_Longword := 0; - CMA_TCB_Size : Unsigned_Longword := 0; - Stack_Guard_Size : Unsigned_Longword := 0; - Total_Task_Storage : Unsigned_Longword := 0; - Stack_In_Use : Unsigned_Longword := 0; - Reserved_Size : Unsigned_Longword := 0; - Hold_Flag : Unsigned_Longword := 0; - Sched_State : Unsigned_Longword := 0; - User_Prio : Unsigned_Longword := 0; - Stack_Size : Unsigned_Longword := 0; - Run_State : Boolean := False; - Rea_State : Boolean := False; - Sus_State : Boolean := False; - Ter_State : Boolean := False; - - Current_Flag : AASCIC := NoStar; - Hold_String : AASCIC := NoHold; - Ada_State : AASCIC := Ada_State_Invalid_State; - Debug_State : AASCIC := Debug_State_Emp; - - Ada_State_Len : constant Unsigned_Longword := 17; - Debug_State_Len : constant Unsigned_Longword := 5; - - Entry_Call : Entry_Call_Record; - - begin - - -- Initialize local task info variables - - Task_SP := Address_Zero; - Stack_Base := Address_Zero; - Stack_Top := Address_Zero; - CMA_TCB_Size := 0; - Stack_Guard_Size := 0; - Reserved_Size := 0; - Hold_Flag := 0; - Sched_State := 0; - TCB_Size := Unsigned_Longword (Task_Id'Size); - - if not Suppress_Header or else Full_Display then - Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); - Print_Routine (Print_FAO, Print_Newline, To_UL (Header)); - end if; - - Trace_Output ("Show_One_Task Task Value: "); - Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value))); - - -- Callback to DEBUG to get some task info - - if Task_Value.Common.State /= Terminated then - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_STACKPTR, - Task_SP, - 8); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_TCB_SIZE, - CMA_TCB_Size, - 4); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_GUARDSIZE, - Stack_Guard_Size, - 4); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_YELLOWSIZE, - Reserved_Size, - 4); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_STACK_BASE, - Stack_Base, - 8); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_STACK_TOP, - Stack_Top, - 8); - - Stack_Size := Unsigned_Longword (Stack_Base - Stack_Top) - - Reserved_Size - Stack_Guard_Size; - Stack_In_Use := Unsigned_Longword (Stack_Base - Task_SP) + 4; - Total_Task_Storage := TCB_Size + Stack_Size + Stack_Guard_Size - + Reserved_Size + CMA_TCB_Size; - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_IS_HELD, - Hold_Flag, - 4); - - Hold_String := (if Hold_Flag /= 0 then Hold else NoHold); - - Debug_Get - (STPO.Get_Thread_Id (Task_Value), - CMA_C_DEBGET_SCHED_STATE, - Sched_State, - 4); - end if; - - Run_State := False; - Rea_State := False; - Sus_State := Task_Value.Common.State = Unactivated; - Ter_State := Task_Value.Common.State = Terminated; - - if not Ter_State then - Run_State := Sched_State = 0; - Rea_State := Sched_State = 1; - Sus_State := Sched_State /= 0 and Sched_State /= 1; - end if; - - -- Set the debug state - - if Run_State then - Debug_State := Debug_State_Run; - elsif Rea_State then - Debug_State := Debug_State_Rea; - elsif Sus_State then - Debug_State := Debug_State_Sus; - elsif Ter_State then - Debug_State := Debug_State_Ter; - end if; - - Trace_Output ("Before case State: "); - Trace_Output (Task_States'Image (Task_Value.Common.State)); - - -- Set the Ada state - - case Task_Value.Common.State is - when Unactivated => - Ada_State := Ada_State_Not_Yet_Activated; - - when Activating => - Ada_State := Ada_State_Activating; - - when Runnable => - Ada_State := Ada_State_Runnable; - - when Terminated => - Ada_State := Ada_State_Terminated; - - when Activator_Sleep => - Ada_State := Ada_State_Activating_Tasks; - - when Acceptor_Sleep => - Ada_State := Ada_State_Accept; - - when Acceptor_Delay_Sleep => - Ada_State := Ada_State_Select_or_Delay; - - when Entry_Caller_Sleep => - Entry_Call := - Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level); - - case Entry_Call.Mode is - when Simple_Call => - Ada_State := Ada_State_Entry_Call; - when Conditional_Call => - Ada_State := Ada_State_Cond_Entry_Call; - when Timed_Call => - Ada_State := Ada_State_Timed_Entry_Call; - when Asynchronous_Call => - Ada_State := Ada_State_Async_Entry_Call; - end case; - - when Async_Select_Sleep => - Ada_State := Ada_State_Select_or_Abort; - - when Delay_Sleep => - Ada_State := Ada_State_Delay; - - when Master_Completion_Sleep => - Ada_State := Ada_State_Completed; - - when Master_Phase_2_Sleep => - Ada_State := Ada_State_Completed; - - when Interrupt_Server_Idle_Sleep | - Interrupt_Server_Blocked_Interrupt_Sleep | - Timer_Server_Sleep | - Interrupt_Server_Blocked_On_Event_Flag => - Ada_State := Ada_State_Server; - - when AST_Server_Sleep => - Ada_State := Ada_State_IO_or_AST; - - when Asynchronous_Hold => - Ada_State := Ada_State_Async_Hold; - - end case; - - if Task_Value.Terminate_Alternative then - Ada_State := Ada_State_Select_or_Term; - end if; - - if Task_Value.Aborting then - Ada_State := Ada_State_Aborting; - end if; - - User_Prio := To_UL (Task_Value.Common.Current_Priority); - Trace_Output ("After user_prio"); - - -- Flag the current task - - Current_Flag := (if Task_Value = Self then Star else NoStar); - - -- Show task info - - Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!AC%TASK !5<!UI!>")), - To_UL (Current_Flag), To_UL (Task_Value.Known_Tasks_Index + 1)); - - Print_Routine (Print_FAO, No_Print, To_UL (DoAC ("!2UB")), User_Prio); - - Print_Routine (Print_FAO, No_Print, To_UL (DoAC (" !AC !5AD !17AD ")), - To_UL (Hold_String), Debug_State_Len, To_UL (Debug_State), - Ada_State_Len, To_UL (Ada_State)); - --- Print_Routine (Print_Symbol, Print_Newline, --- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point))); - - Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); - - -- If /full qualfier passed, show detailed info - - if Full_Display then - Show_Rendezvous (Task_Value, Ada_State, Full_Display, - Suppress_Header, Print_Routine); - - List_Entry_Waiters (Task_Value, Full_Display, - Suppress_Header, Print_Routine); - - Print_Routine (Print_FAO, Print_Newline, To_UL (Empty_Text)); - - declare - Task_Image : ASCIC := (Task_Value.Common.Task_Image_Len, - Task_Value.Common.Task_Image - (1 .. Task_Value.Common.Task_Image_Len)); - begin - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Task type: !AC")), - To_UL (Task_Image'Address)); - end; - - -- How to find Creation_PC ??? --- Print_Routine (Print_FAO, No_Print, --- To_UL (DoAC (" Created at PC: ")), --- Print_Routine (Print_FAO, Print_Newline, Creation_PC); - - if Task_Value.Common.Parent /= null then - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Parent task: %TASK !UI")), - To_UL (Task_Value.Common.Parent.Known_Tasks_Index + 1)); - else - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Parent task: none"))); - end if; - --- Print_Routine (Print_FAO, No_Print, --- To_UL (DoAC (" Start PC: "))); --- Print_Routine (Print_Symbol, Print_Newline, --- Fetch (To_Addr (Task_Value.Common.Task_Entry_Point))); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Task control block: Stack storage (bytes):"))); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Task value: !10<!UI!> RESERVED_BYTES: !10UI")), - To_UL (Task_Value), Reserved_Size); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Entries: !10<!UI!> TOP_GUARD_SIZE: !10UI")), - To_UL (Task_Value.Entry_Num), Stack_Guard_Size); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Size: !10<!UI!> STORAGE_SIZE: !10UI")), - TCB_Size + CMA_TCB_Size, Stack_Size); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Stack addresses: Bytes in use: !10UI")), - Stack_In_Use); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" Top address: !10<!XI!>")), - To_UL (Stack_Top)); - - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC ( - " Base address: !10<!XI!> Total storage: !10UI")), - To_UL (Stack_Base), Total_Task_Storage); - end if; - - end Show_One_Task; - - --------------------- - -- Show_Rendezvous -- - --------------------- - - procedure Show_Rendezvous - (Task_Value : Task_Id; - Ada_State : AASCIC := Empty_Text; - Full_Display : Boolean := False; - Suppress_Header : Boolean := False; - Print_Routine : Print_Routine_Type := Default_Print_Routine'Access) - is - pragma Unreferenced (Ada_State); - pragma Unreferenced (Suppress_Header); - - Temp_Entry : Entry_Index; - Entry_Call : Entry_Call_Record; - Called_Task : Task_Id; - AWR : constant String := " Awaiting rendezvous at: "; - -- Common prefix - - procedure Print_Accepts; - -- Display information about task rendezvous accepts - - procedure Print_Accepts is - begin - if Task_Value.Open_Accepts /= null then - for I in Task_Value.Open_Accepts'Range loop - Temp_Entry := Entry_Index (Task_Value.Open_Accepts (I).S); - declare - Entry_Name_Image : ASCIC := - (Task_Value.Entry_Names (Temp_Entry).all'Length, - Task_Value.Entry_Names (Temp_Entry).all); - begin - Trace_Output ("Accept at: " & Entry_Name_Image.Text); - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" accept at: !AC")), - To_UL (Entry_Name_Image'Address)); - end; - end loop; - end if; - end Print_Accepts; - begin - if not Full_Display then - return; - end if; - - Trace_Output ("Show_Rendezvous Task Value: "); - Trace_Output (Unsigned_Longword'Image (To_UL (Task_Value))); - - if Task_Value.Common.State = Acceptor_Sleep and then - not Task_Value.Terminate_Alternative - then - if Task_Value.Open_Accepts /= null then - Temp_Entry := Entry_Index (Task_Value.Open_Accepts - (Task_Value.Open_Accepts'First).S); - declare - Entry_Name_Image : ASCIC := - (Task_Value.Entry_Names (Temp_Entry).all'Length, - Task_Value.Entry_Names (Temp_Entry).all); - begin - Trace_Output (AWR & "accept " & Entry_Name_Image.Text); - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "accept !AC")), - To_UL (Entry_Name_Image'Address)); - end; - - else - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (" entry name unavailable"))); - end if; - else - case Task_Value.Common.State is - when Acceptor_Sleep => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "select with terminate."))); - Print_Accepts; - - when Async_Select_Sleep => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "select."))); - Print_Accepts; - - when Acceptor_Delay_Sleep => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "select with delay."))); - Print_Accepts; - - when Entry_Caller_Sleep => - Entry_Call := - Task_Value.Entry_Calls (Task_Value.ATC_Nesting_Level); - - case Entry_Call.Mode is - when Simple_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call"))); - when Conditional_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call with else"))); - when Timed_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call with delay"))); - when Asynchronous_Call => - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC (AWR & "entry call with abort"))); - end case; - Called_Task := Entry_Call.Called_Task; - declare - Task_Image : ASCIC := (Called_Task.Common.Task_Image_Len, - Called_Task.Common.Task_Image - (1 .. Called_Task.Common.Task_Image_Len)); - Entry_Name_Image : ASCIC := - (Called_Task.Entry_Names (Entry_Call.E).all'Length, - Called_Task.Entry_Names (Entry_Call.E).all); - begin - Print_Routine (Print_FAO, Print_Newline, - To_UL (DoAC - (" for entry !AC in %TASK !UI type !AC")), - To_UL (Entry_Name_Image'Address), - To_UL (Called_Task.Known_Tasks_Index), - To_UL (Task_Image'Address)); - end; - - when others => - return; - end case; - end if; - - end Show_Rendezvous; - - ------------------------ - -- Signal_Debug_Event -- - ------------------------ - - procedure Signal_Debug_Event - (Event_Kind : Event_Kind_Type; Task_Value : Task_Id) - is - Do_Signal : Boolean; - EVCB : Ada_Event_Control_Block_Access; - - EVCB_Sent : constant := 16#9B#; - Ada_Facility : constant := 49; - SS_DBGEVENT : constant := 1729; - begin - Do_Signal := Global_Task_Debug_Events (Event_Kind); - - if not Do_Signal then - if Task_Value /= null then - Do_Signal := Do_Signal - or else Task_Value.Common.Debug_Events (Event_Kind); - end if; - end if; - - if Do_Signal then - -- Build an a tasking event control block and signal DEBUG - - EVCB := new Ada_Event_Control_Block_Type; - EVCB.Code := Unsigned_Word (Event_Kind); - EVCB.Sentinal := EVCB_Sent; - EVCB.Facility := Ada_Facility; - - if Task_Value /= null then - EVCB.Value := Unsigned_Longword (Task_Value.Known_Tasks_Index + 1); - else - EVCB.Value := 0; - end if; - - EVCB.Sub_Event := 0; - EVCB.P1 := 0; - EVCB.Sigargs := 0; - EVCB.Flags := 0; - EVCB.Unused1 := 0; - EVCB.Unused2 := 0; - - Signal (SS_DBGEVENT, 1, To_UL (EVCB)); - end if; - end Signal_Debug_Event; - - -------------------- - -- Stop_All_Tasks -- - -------------------- - - procedure Stop_All_Tasks is - begin - null; -- VxWorks - end Stop_All_Tasks; - - ---------------------------- - -- Stop_All_Tasks_Handler -- - ---------------------------- - - procedure Stop_All_Tasks_Handler is - begin - null; -- VxWorks - end Stop_All_Tasks_Handler; - - ----------------------- - -- Suspend_All_Tasks -- - ----------------------- - - procedure Suspend_All_Tasks (Thread_Self : OS_Interface.Thread_Id) is - pragma Unreferenced (Thread_Self); - begin - null; -- VxWorks - end Suspend_All_Tasks; - - ------------------------ - -- Task_Creation_Hook -- - ------------------------ - - procedure Task_Creation_Hook (Thread : OS_Interface.Thread_Id) is - pragma Unreferenced (Thread); - begin - null; -- VxWorks - end Task_Creation_Hook; - - --------------------------- - -- Task_Termination_Hook -- - --------------------------- - - procedure Task_Termination_Hook is - begin - null; -- VxWorks - end Task_Termination_Hook; - - ----------- - -- Trace -- - ----------- - - procedure Trace - (Self_Id : Task_Id; - Msg : String; - Flag : Character; - Other_Id : Task_Id := null) - is - begin - if Trace_On (Flag) then - Put (To_Integer (Self_Id)'Img & - ':' & Flag & ':' & - Self_Id.Common.Task_Image (1 .. Self_Id.Common.Task_Image_Len) & - ':'); - - if Other_Id /= null then - Put (To_Integer (Other_Id)'Img & ':'); - end if; - - Put_Line (Msg); - end if; - end Trace; - - ------------------ - -- Trace_Output -- - ------------------ - - procedure Trace_Output (Message_String : String) is - begin - if Trace_On ('V') and Trace_On ('M') and Trace_On ('S') then - Put_Output (Message_String); - end if; - end Trace_Output; - - ----------- - -- Write -- - ----------- - - procedure Write (Fd : Integer; S : String; Count : Integer) is - Discard : System.CRTL.ssize_t; - -- Ignore write errors here; this is just debugging output, and there's - -- nothing to be done about errors anyway. - begin - Discard := - System.CRTL.write - (Fd, S (S'First)'Address, System.CRTL.size_t (Count)); - end Write; - -end System.Tasking.Debug; diff --git a/gcc/ada/s-taspri-vms.ads b/gcc/ada/s-taspri-vms.ads deleted file mode 100644 index 891dee28c9d..00000000000 --- a/gcc/ada/s-taspri-vms.ads +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . T A S K _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1991-2011, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a OpenVMS/Alpha version of this package - --- This package provides low-level support for most tasking features - -pragma Polling (Off); --- Turn off polling, we do not want ATC polling to take place during tasking --- operations. It causes infinite loops and other problems. - -with Interfaces.C; - -with System.OS_Interface; -with System.Aux_DEC; - -package System.Task_Primitives is - pragma Preelaborate; - - type Lock is limited private; - -- Should be used for implementation of protected objects - - type RTS_Lock is limited private; - -- Should be used inside the runtime system. The difference between Lock - -- and the RTS_Lock is that the later one serves only as a semaphore so - -- that do not check for ceiling violations. - - type Suspension_Object is limited private; - -- Should be used for the implementation of Ada.Synchronous_Task_Control - - type Task_Body_Access is access procedure; - -- Pointer to the task body's entry point (or possibly a wrapper - -- declared local to the GNARL). - - type Private_Data is limited private; - -- Any information that the GNULLI needs maintained on a per-task basis. - -- A component of this type is guaranteed to be included in the - -- Ada_Task_Control_Block. - - subtype Task_Address is System.Aux_DEC.Short_Address; - -- Task_Address is the short version of address defined in System.Aux_DEC. - -- To avoid dragging Aux_DEC into tasking packages a tasking specific - -- subtype is defined here. - - Task_Address_Size : constant := System.Aux_DEC.Short_Address_Size; - -- The size of Task_Address - - Alternate_Stack_Size : constant := 0; - -- No alternate signal stack is used on this platform - -private - - type Lock is record - L : aliased System.OS_Interface.pthread_mutex_t; - Prio : Interfaces.C.int; - Prio_Save : Interfaces.C.int; - end record; - - type RTS_Lock is new System.OS_Interface.pthread_mutex_t; - - type Suspension_Object is record - State : Boolean; - pragma Atomic (State); - -- Boolean that indicates whether the object is open. This field is - -- marked Atomic to ensure that we can read its value without locking - -- the access to the Suspension_Object. - - Waiting : Boolean; - -- Flag showing if there is a task already suspended on this object - - L : aliased System.OS_Interface.pthread_mutex_t; - -- Protection for ensuring mutual exclusion on the Suspension_Object - - CV : aliased System.OS_Interface.pthread_cond_t; - -- Condition variable used to queue threads until ondition is signaled - end record; - - type Private_Data is record - Thread : aliased System.OS_Interface.pthread_t; - pragma Atomic (Thread); - -- Thread field may be updated by two different threads of control. - -- (See, Enter_Task and Create_Task in s-taprop.adb). They put the - -- same value (thr_self value). We do not want to use lock on those - -- operations and the only thing we have to make sure is that they - -- are updated in atomic fashion. - - CV : aliased System.OS_Interface.pthread_cond_t; - - L : aliased RTS_Lock; - -- Protection for all components is lock L - - AST_Pending : Boolean; - -- Used to detect delay and sleep timeouts - - end record; - -end System.Task_Primitives; diff --git a/gcc/ada/s-tpopde-vms.adb b/gcc/ada/s-tpopde-vms.adb deleted file mode 100644 index 4f7cdad6123..00000000000 --- a/gcc/ada/s-tpopde-vms.adb +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is for OpenVMS/Alpha - -with System.OS_Interface; -with System.Parameters; -with System.Tasking; -with Ada.Unchecked_Conversion; -with System.Soft_Links; - -package body System.Task_Primitives.Operations.DEC is - - use System.OS_Interface; - use System.Parameters; - use System.Tasking; - use System.Aux_DEC; - use type Interfaces.C.int; - - package SSL renames System.Soft_Links; - - -- The FAB_RAB_Type specifies where the context field (the calling - -- task) is stored. Other fields defined for FAB_RAB arent' need and - -- so are ignored. - - type FAB_RAB_Type is record - CTX : Unsigned_Longword; - end record; - - for FAB_RAB_Type use record - CTX at 24 range 0 .. 31; - end record; - - for FAB_RAB_Type'Size use 224; - - type FAB_RAB_Access_Type is access all FAB_RAB_Type; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Unsigned_Longword is new - Ada.Unchecked_Conversion (Task_Id, Unsigned_Longword); - - function To_Task_Id is new - Ada.Unchecked_Conversion (Unsigned_Longword, Task_Id); - - function To_FAB_RAB is new - Ada.Unchecked_Conversion (Address, FAB_RAB_Access_Type); - - --------------------------- - -- Interrupt_AST_Handler -- - --------------------------- - - procedure Interrupt_AST_Handler (ID : Address) is - Result : Interfaces.C.int; - AST_Self_ID : constant Task_Id := To_Task_Id (ID); - begin - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Interrupt_AST_Handler; - - --------------------- - -- RMS_AST_Handler -- - --------------------- - - procedure RMS_AST_Handler (ID : Address) is - AST_Self_ID : constant Task_Id := To_Task_Id (To_FAB_RAB (ID).CTX); - Result : Interfaces.C.int; - - begin - AST_Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end RMS_AST_Handler; - - ---------- - -- Self -- - ---------- - - function Self return Unsigned_Longword is - Self_ID : constant Task_Id := Self; - begin - Self_ID.Common.LL.AST_Pending := True; - return To_Unsigned_Longword (Self); - end Self; - - ------------------------- - -- Starlet_AST_Handler -- - ------------------------- - - procedure Starlet_AST_Handler (ID : Address) is - Result : Interfaces.C.int; - AST_Self_ID : constant Task_Id := To_Task_Id (ID); - begin - AST_Self_ID.Common.LL.AST_Pending := False; - Result := pthread_cond_signal_int_np (AST_Self_ID.Common.LL.CV'Access); - pragma Assert (Result = 0); - end Starlet_AST_Handler; - - ---------------- - -- Task_Synch -- - ---------------- - - procedure Task_Synch is - Synch_Self_ID : constant Task_Id := Self; - - begin - if Single_Lock then - Lock_RTS; - else - Write_Lock (Synch_Self_ID); - end if; - - SSL.Abort_Defer.all; - Synch_Self_ID.Common.State := AST_Server_Sleep; - - while Synch_Self_ID.Common.LL.AST_Pending loop - Sleep (Synch_Self_ID, AST_Server_Sleep); - end loop; - - Synch_Self_ID.Common.State := Runnable; - - if Single_Lock then - Unlock_RTS; - else - Unlock (Synch_Self_ID); - end if; - - SSL.Abort_Undefer.all; - end Task_Synch; - -end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/s-tpopde-vms.ads b/gcc/ada/s-tpopde-vms.ads deleted file mode 100644 index e690f306e7a..00000000000 --- a/gcc/ada/s-tpopde-vms.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.DEC -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2011, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is for OpenVMS/Alpha. --- -with System.Aux_DEC; -package System.Task_Primitives.Operations.DEC is - - procedure Interrupt_AST_Handler (ID : Address); - pragma Convention (C, Interrupt_AST_Handler); - -- Handles the AST for Ada 95 Interrupts - - procedure RMS_AST_Handler (ID : Address); - -- Handles the AST for RMS_Asynch_Operations - - function Self return System.Aux_DEC.Unsigned_Longword; - -- Returns the task identification for the AST - - procedure Starlet_AST_Handler (ID : Address); - -- Handles the AST for Starlet Tasking_Services - - procedure Task_Synch; - -- Synchronizes the task after the system service completes - -end System.Task_Primitives.Operations.DEC; diff --git a/gcc/ada/s-tpopsp-vms.adb b/gcc/ada/s-tpopsp-vms.adb deleted file mode 100644 index 42503f6cd99..00000000000 --- a/gcc/ada/s-tpopsp-vms.adb +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- SYSTEM.TASK_PRIMITIVES.OPERATIONS.SPECIFIC -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNARL 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a VMS version of this package where foreign threads are --- recognized. - -separate (System.Task_Primitives.Operations) -package body Specific is - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Environment_Task : Task_Id) is - pragma Warnings (Off, Environment_Task); - Result : Interfaces.C.int; - - begin - Result := pthread_key_create (ATCB_Key'Access, null); - pragma Assert (Result = 0); - end Initialize; - - ------------------- - -- Is_Valid_Task -- - ------------------- - - function Is_Valid_Task return Boolean is - begin - return pthread_getspecific (ATCB_Key) /= System.Null_Address; - end Is_Valid_Task; - - --------- - -- Set -- - --------- - - procedure Set (Self_Id : Task_Id) is - Result : Interfaces.C.int; - begin - Result := pthread_setspecific (ATCB_Key, To_Address (Self_Id)); - pragma Assert (Result = 0); - end Set; - - ---------- - -- Self -- - ---------- - - -- To make Ada tasks and C threads interoperate better, we have added some - -- functionality to Self. Suppose a C main program (with threads) calls an - -- Ada procedure and the Ada procedure calls the tasking runtime system. - -- Eventually, a call will be made to self. Since the call is not coming - -- from an Ada task, there will be no corresponding ATCB. - - -- What we do in Self is to catch references that do not come from - -- recognized Ada tasks, and create an ATCB for the calling thread. - - -- The new ATCB will be "detached" from the normal Ada task master - -- hierarchy, much like the existing implicitly created signal-server - -- tasks. - - function Self return Task_Id is - Result : System.Address; - - begin - Result := pthread_getspecific (ATCB_Key); - - -- If the key value is Null then it is a non-Ada task - - if Result /= System.Null_Address then - return To_Task_Id (Result); - else - return Register_Foreign_Thread; - end if; - end Self; - -end Specific; diff --git a/gcc/ada/s-traent-vms.adb b/gcc/ada/s-traent-vms.adb deleted file mode 100644 index 51f0e682a78..00000000000 --- a/gcc/ada/s-traent-vms.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions. - -package body System.Traceback_Entries is - - ------------ - -- PC_For -- - ------------ - - function PC_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry.PC; - end PC_For; - - ------------ - -- PV_For -- - ------------ - - function PV_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry.PV; - end PV_For; - - ------------------ - -- TB_Entry_For -- - ------------------ - - function TB_Entry_For (PC : System.Address) return Traceback_Entry is - begin - return (PC => PC, PV => System.Null_Address); - end TB_Entry_For; - -end System.Traceback_Entries; diff --git a/gcc/ada/s-traent-vms.ads b/gcc/ada/s-traent-vms.ads deleted file mode 100644 index db327df4618..00000000000 --- a/gcc/ada/s-traent-vms.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Alpha/OpenVMS version of this package - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions. - -package System.Traceback_Entries is - pragma Preelaborate; - - -- Symbolization is performed by a VMS service which requires more - -- than an instruction pointer. - - type Traceback_Entry is record - PC : System.Address; -- Program Counter - PV : System.Address; -- Procedure Value - end record; - - pragma Suppress_Initialization (Traceback_Entry); - - Null_TB_Entry : constant Traceback_Entry := - (PC => System.Null_Address, - PV => System.Null_Address); - - type Tracebacks_Array is array (Positive range <>) of Traceback_Entry; - - function PC_For (TB_Entry : Traceback_Entry) return System.Address; - function PV_For (TB_Entry : Traceback_Entry) return System.Address; - - function TB_Entry_For (PC : System.Address) return Traceback_Entry; - -end System.Traceback_Entries; diff --git a/gcc/ada/s-vaflop-vms-alpha.adb b/gcc/ada/s-vaflop-vms-alpha.adb deleted file mode 100644 index 51571720b67..00000000000 --- a/gcc/ada/s-vaflop-vms-alpha.adb +++ /dev/null @@ -1,695 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A X _ F L O A T _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2012, Free Software Foundation, Inc. -- --- (Version for Alpha OpenVMS) -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.IO; -with System.Machine_Code; use System.Machine_Code; - -package body System.Vax_Float_Operations is - - -- Declare the functions that do the conversions between floating-point - -- formats. Call the operands IEEE float so they get passed in - -- FP registers. - - function Cvt_G_T (X : T) return T; - function Cvt_T_G (X : T) return T; - function Cvt_T_F (X : T) return S; - - pragma Import (C, Cvt_G_T, "OTS$CVT_FLOAT_G_T"); - pragma Import (C, Cvt_T_G, "OTS$CVT_FLOAT_T_G"); - pragma Import (C, Cvt_T_F, "OTS$CVT_FLOAT_T_F"); - - -- In each of the conversion routines that are done with OTS calls, - -- we define variables of the corresponding IEEE type so that they are - -- passed and kept in the proper register class. - - Debug_String_Buffer : String (1 .. 32); - -- Buffer used by all Debug_String_x routines for returning result - - ------------ - -- D_To_G -- - ------------ - - function D_To_G (X : D) return G is - A, B : T; - C : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), D'Asm_Input ("m", X)); - Asm ("cvtdg %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end D_To_G; - - ------------ - -- F_To_G -- - ------------ - - function F_To_G (X : F) return G is - A : T; - B : G; - begin - Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end F_To_G; - - ------------ - -- F_To_S -- - ------------ - - function F_To_S (X : F) return S is - A : T; - B : S; - - begin - -- Because converting to a wider FP format is a no-op, we say - -- A is 64-bit even though we are loading 32 bits into it. - - Asm ("ldf %0,%1", T'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - - B := S (Cvt_G_T (A)); - return B; - end F_To_S; - - ------------ - -- G_To_D -- - ------------ - - function G_To_D (X : G) return D is - A, B : T; - C : D; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgd %1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", D'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end G_To_D; - - ------------ - -- G_To_F -- - ------------ - - function G_To_F (X : G) return F is - A : T; - B : S; - C : F; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgf %1,%0", S'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end G_To_F; - - ------------ - -- G_To_Q -- - ------------ - - function G_To_Q (X : G) return Q is - A : T; - B : Q; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cvtgq %1,%0", Q'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - return B; - end G_To_Q; - - ------------ - -- G_To_T -- - ------------ - - function G_To_T (X : G) return T is - A, B : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - B := Cvt_G_T (A); - return B; - end G_To_T; - - ------------ - -- F_To_Q -- - ------------ - - function F_To_Q (X : F) return Q is - begin - return G_To_Q (F_To_G (X)); - end F_To_Q; - - ------------ - -- Q_To_F -- - ------------ - - function Q_To_F (X : Q) return F is - A : S; - B : F; - begin - Asm ("cvtqf %1,%0", S'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); - Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); - return B; - end Q_To_F; - - ------------ - -- Q_To_G -- - ------------ - - function Q_To_G (X : Q) return G is - A : T; - B : G; - begin - Asm ("cvtqg %1,%0", T'Asm_Output ("=f", A), Q'Asm_Input ("f", X)); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end Q_To_G; - - ------------ - -- S_To_F -- - ------------ - - function S_To_F (X : S) return F is - A : S; - B : F; - begin - A := Cvt_T_F (T (X)); - Asm ("stf %1,%0", F'Asm_Output ("=m", B), S'Asm_Input ("f", A)); - return B; - end S_To_F; - - ------------ - -- T_To_G -- - ------------ - - function T_To_G (X : T) return G is - A : T; - B : G; - begin - A := Cvt_T_G (X); - Asm ("stg %1,%0", G'Asm_Output ("=m", B), T'Asm_Input ("f", A)); - return B; - end T_To_G; - - ------------ - -- T_To_D -- - ------------ - - function T_To_D (X : T) return D is - begin - return G_To_D (T_To_G (X)); - end T_To_D; - - ----------- - -- Abs_F -- - ----------- - - function Abs_F (X : F) return F is - A, B : S; - C : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("cpys $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end Abs_F; - - ----------- - -- Abs_G -- - ----------- - - function Abs_G (X : G) return G is - A, B : T; - C : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("cpys $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end Abs_G; - - ----------- - -- Add_F -- - ----------- - - function Add_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("addf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Add_F; - - ----------- - -- Add_G -- - ----------- - - function Add_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("addg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Add_G; - - -------------------- - -- Debug_Output_D -- - -------------------- - - procedure Debug_Output_D (Arg : D) is - begin - System.IO.Put (D'Image (Arg)); - end Debug_Output_D; - - -------------------- - -- Debug_Output_F -- - -------------------- - - procedure Debug_Output_F (Arg : F) is - begin - System.IO.Put (F'Image (Arg)); - end Debug_Output_F; - - -------------------- - -- Debug_Output_G -- - -------------------- - - procedure Debug_Output_G (Arg : G) is - begin - System.IO.Put (G'Image (Arg)); - end Debug_Output_G; - - -------------------- - -- Debug_String_D -- - -------------------- - - function Debug_String_D (Arg : D) return System.Address is - Image_String : constant String := D'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_D; - - -------------------- - -- Debug_String_F -- - -------------------- - - function Debug_String_F (Arg : F) return System.Address is - Image_String : constant String := F'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_F; - - -------------------- - -- Debug_String_G -- - -------------------- - - function Debug_String_G (Arg : G) return System.Address is - Image_String : constant String := G'Image (Arg) & ASCII.NUL; - Image_Size : constant Integer := Image_String'Length; - begin - Debug_String_Buffer (1 .. Image_Size) := Image_String; - return Debug_String_Buffer (1)'Address; - end Debug_String_G; - - ----------- - -- Div_F -- - ----------- - - function Div_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("divf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Div_F; - - ----------- - -- Div_G -- - ----------- - - function Div_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("divg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Div_G; - - ---------- - -- Eq_F -- - ---------- - - function Eq_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Eq_F; - - ---------- - -- Eq_G -- - ---------- - - function Eq_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Eq_G; - - ---------- - -- Le_F -- - ---------- - - function Le_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgle %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Le_F; - - ---------- - -- Le_G -- - ---------- - - function Le_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgle %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Le_G; - - ---------- - -- Lt_F -- - ---------- - - function Lt_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpglt %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R /= 0.0; - end Lt_F; - - ---------- - -- Lt_G -- - ---------- - - function Lt_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpglt %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R /= 0.0; - end Lt_G; - - ----------- - -- Mul_F -- - ----------- - - function Mul_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("mulf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Mul_F; - - ----------- - -- Mul_G -- - ----------- - - function Mul_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("mulg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Mul_G; - - ---------- - -- Ne_F -- - ---------- - - function Ne_F (X, Y : F) return Boolean is - X1, Y1, R : S; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - return R = 0.0; - end Ne_F; - - ---------- - -- Ne_G -- - ---------- - - function Ne_G (X, Y : G) return Boolean is - X1, Y1, R : T; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("cmpgeq %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - return R = 0.0; - end Ne_G; - - ----------- - -- Neg_F -- - ----------- - - function Neg_F (X : F) return F is - A, B : S; - C : F; - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", A), F'Asm_Input ("m", X)); - Asm ("subf $f31,%1,%0", S'Asm_Output ("=f", B), S'Asm_Input ("f", A)); - Asm ("stf %1,%0", F'Asm_Output ("=m", C), S'Asm_Input ("f", B)); - return C; - end Neg_F; - - ----------- - -- Neg_G -- - ----------- - - function Neg_G (X : G) return G is - A, B : T; - C : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", A), G'Asm_Input ("m", X)); - Asm ("subg $f31,%1,%0", T'Asm_Output ("=f", B), T'Asm_Input ("f", A)); - Asm ("stg %1,%0", G'Asm_Output ("=m", C), T'Asm_Input ("f", B)); - return C; - end Neg_G; - - -------- - -- pd -- - -------- - - procedure pd (Arg : D) is - begin - System.IO.Put_Line (D'Image (Arg)); - end pd; - - -------- - -- pf -- - -------- - - procedure pf (Arg : F) is - begin - System.IO.Put_Line (F'Image (Arg)); - end pf; - - -------- - -- pg -- - -------- - - procedure pg (Arg : G) is - begin - System.IO.Put_Line (G'Image (Arg)); - end pg; - - -------------- - -- Return_D -- - -------------- - - function Return_D (X : D) return D is - R : D; - begin - -- The return value is already in $f0 so we need to trick the compiler - -- into thinking that we're moving X to $f0. - Asm ("cvtdg $f0,$f0", Inputs => D'Asm_Input ("g", X), Clobber => "$f0", - Volatile => True); - Asm ("stg $f0,%0", D'Asm_Output ("=m", R), Volatile => True); - return R; - end Return_D; - - -------------- - -- Return_F -- - -------------- - - function Return_F (X : F) return F is - R : F; - begin - -- The return value is already in $f0 so we need to trick the compiler - -- into thinking that we're moving X to $f0. - Asm ("stf $f0,%0", F'Asm_Output ("=m", R), F'Asm_Input ("g", X), - Clobber => "$f0", Volatile => True); - return R; - end Return_F; - - -------------- - -- Return_G -- - -------------- - - function Return_G (X : G) return G is - R : G; - begin - -- The return value is already in $f0 so we need to trick the compiler - -- into thinking that we're moving X to $f0. - Asm ("stg $f0,%0", G'Asm_Output ("=m", R), G'Asm_Input ("g", X), - Clobber => "$f0", Volatile => True); - return R; - end Return_G; - - ----------- - -- Sub_F -- - ----------- - - function Sub_F (X, Y : F) return F is - X1, Y1, R : S; - R1 : F; - - begin - Asm ("ldf %0,%1", S'Asm_Output ("=f", X1), F'Asm_Input ("m", X)); - Asm ("ldf %0,%1", S'Asm_Output ("=f", Y1), F'Asm_Input ("m", Y)); - Asm ("subf %1,%2,%0", S'Asm_Output ("=f", R), - (S'Asm_Input ("f", X1), S'Asm_Input ("f", Y1))); - Asm ("stf %1,%0", F'Asm_Output ("=m", R1), S'Asm_Input ("f", R)); - return R1; - end Sub_F; - - ----------- - -- Sub_G -- - ----------- - - function Sub_G (X, Y : G) return G is - X1, Y1, R : T; - R1 : G; - begin - Asm ("ldg %0,%1", T'Asm_Output ("=f", X1), G'Asm_Input ("m", X)); - Asm ("ldg %0,%1", T'Asm_Output ("=f", Y1), G'Asm_Input ("m", Y)); - Asm ("subg %1,%2,%0", T'Asm_Output ("=f", R), - (T'Asm_Input ("f", X1), T'Asm_Input ("f", Y1))); - Asm ("stg %1,%0", G'Asm_Output ("=m", R1), T'Asm_Input ("f", R)); - return R1; - end Sub_G; - - ------------- - -- Valid_D -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_D (Arg : D) return Boolean is - Val : constant T := G_To_T (D_To_G (Arg)); - begin - return Val'Valid; - end Valid_D; - - ------------- - -- Valid_F -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_F (Arg : F) return Boolean is - Val : constant S := F_To_S (Arg); - begin - return Val'Valid; - end Valid_F; - - ------------- - -- Valid_G -- - ------------- - - -- For now, convert to IEEE and do Valid test on result. This is not quite - -- accurate, but is good enough in practice. - - function Valid_G (Arg : G) return Boolean is - Val : constant T := G_To_T (Arg); - begin - return Val'Valid; - end Valid_G; - -end System.Vax_Float_Operations; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9685d7500f4..f95244560fa 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -10614,15 +10614,15 @@ package body Sem_Ch13 is Nam : Name_Id) return Boolean is function All_Static_Case_Alternatives (L : List_Id) return Boolean; - -- Given a list of case expression alternatives, returns True if - -- all the alternatives are static (have all static choices, and a - -- static expression). + -- Given a list of case expression alternatives, returns True if all + -- the alternatives are static (have all static choices, and a static + -- expression). function All_Static_Choices (L : List_Id) return Boolean; -- Returns true if all elements of the list are OK static choices -- as defined below for Is_Static_Choice. Used for case expression - -- alternatives and for the right operand of a membership test. - -- An others_choice is static if the corresponding expression is static. + -- alternatives and for the right operand of a membership test. An + -- others_choice is static if the corresponding expression is static. -- The staticness of the bounds is checked separately. function Is_Static_Choice (N : Node_Id) return Boolean; @@ -10636,10 +10636,10 @@ package body Sem_Ch13 is function Is_Type_Ref (N : Node_Id) return Boolean; pragma Inline (Is_Type_Ref); - -- Returns True if N is a reference to the type for the predicate in - -- the expression (i.e. if it is an identifier whose Chars field matches - -- the Nam given in the call). N must not be parenthesized, if the type - -- name appears in parens, this routine will return False. + -- Returns True if N is a reference to the type for the predicate in the + -- expression (i.e. if it is an identifier whose Chars field matches the + -- Nam given in the call). N must not be parenthesized, if the type name + -- appears in parens, this routine will return False. ---------------------------------- -- All_Static_Case_Alternatives -- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 19b32352314..6d93a294c75 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4514,8 +4514,8 @@ package body Sem_Ch3 is when Enumeration_Kind => Set_Ekind (Id, E_Enumeration_Subtype); - Set_Has_Dynamic_Predicate_Aspect (Id, - Has_Dynamic_Predicate_Aspect (T)); + Set_Has_Dynamic_Predicate_Aspect + (Id, Has_Dynamic_Predicate_Aspect (T)); Set_First_Literal (Id, First_Literal (Base_Type (T))); Set_Scalar_Range (Id, Scalar_Range (T)); Set_Is_Character_Type (Id, Is_Character_Type (T)); diff --git a/gcc/ada/symbols-processing-vms-alpha.adb b/gcc/ada/symbols-processing-vms-alpha.adb deleted file mode 100644 index c33739402c3..00000000000 --- a/gcc/ada/symbols-processing-vms-alpha.adb +++ /dev/null @@ -1,318 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S . P R O C E S S I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS Alpha version of this package - -separate (Symbols) -package body Processing is - - type Number is mod 2**16; - -- 16 bits unsigned number for number of characters - - EMH : constant Number := 8; - -- Code for the Module Header section - - GSD : constant Number := 10; - -- Code for the Global Symbol Definition section - - C_SYM : constant Number := 1; - -- Code for a Symbol subsection - - V_DEF_Mask : constant Number := 2 ** 1; - V_NORM_Mask : constant Number := 2 ** 6; - -- Comments ??? - - B : Byte; - - Number_Of_Characters : Natural := 0; - -- The number of characters of each section - - Native_Format : Boolean; - -- True if records are decoded by the system (like on VMS) - - Has_Pad : Boolean; - -- If true, a pad byte must be skipped before reading the next record - - -- The following variables are used by procedure Process when reading an - -- object file. - - Code : Number := 0; - Length : Natural := 0; - - Dummy : Number; - - Nchars : Natural := 0; - Flags : Number := 0; - - Symbol : String (1 .. 255); - LSymb : Natural; - - procedure Get (N : out Number); - -- Read two bytes from the object file LSB first as unsigned 16 bit number - - procedure Get (N : out Natural); - -- Read two bytes from the object file, LSByte first, as a Natural - - --------- - -- Get -- - --------- - - procedure Get (N : out Number) is - C : Byte; - LSByte : Number; - begin - Read (File, C); - LSByte := Byte'Pos (C); - Read (File, C); - N := LSByte + (256 * Byte'Pos (C)); - end Get; - - procedure Get (N : out Natural) is - Result : Number; - begin - Get (Result); - N := Natural (Result); - end Get; - - ------------- - -- Process -- - ------------- - - procedure Process - (Object_File : String; - Success : out Boolean) - is - OK : Boolean := True; - - begin - -- Open the object file with Byte_IO. Return with Success = False if - -- this fails. - - begin - Open (File, In_File, Object_File); - exception - when others => - Put_Line - ("*** Unable to open object file """ & Object_File & """"); - Success := False; - return; - end; - - -- Assume that the object file has a correct format - - Success := True; - - -- Check the file format in case of cross-tool - - Get (Code); - Get (Number_Of_Characters); - Get (Dummy); - - if Code = Dummy and then Number_Of_Characters = Natural (EMH) then - - -- Looks like a cross tool - - Native_Format := False; - Number_Of_Characters := Natural (Dummy) - 4; - Has_Pad := (Number_Of_Characters mod 2) = 1; - - elsif Code = EMH then - Native_Format := True; - Number_Of_Characters := Number_Of_Characters - 6; - Has_Pad := False; - - else - Put_Line ("file """ & Object_File & """ is not an object file"); - Close (File); - Success := False; - return; - end if; - - -- Skip the EMH section - - for J in 1 .. Number_Of_Characters loop - Read (File, B); - end loop; - - -- Get the different sections one by one from the object file - - while not End_Of_File (File) loop - - if not Native_Format then - - -- Skip pad byte if present - - if Has_Pad then - Get (B); - end if; - - -- Skip record length - - Get (Dummy); - end if; - - Get (Code); - Get (Number_Of_Characters); - - if not Native_Format then - if Natural (Dummy) /= Number_Of_Characters then - - -- Format error - - raise Constraint_Error; - end if; - - Has_Pad := (Number_Of_Characters mod 2) = 1; - end if; - - -- The header is 4 bytes length - - Number_Of_Characters := Number_Of_Characters - 4; - - -- If this is not a Global Symbol Definition section, skip to the - -- next section. - - if Code /= GSD then - for J in 1 .. Number_Of_Characters loop - Read (File, B); - end loop; - - else - -- Skip over the next 4 bytes - - Get (Dummy); - Get (Dummy); - Number_Of_Characters := Number_Of_Characters - 4; - - -- Get each subsection in turn - - loop - Get (Code); - Get (Nchars); - Get (Dummy); - Get (Flags); - Number_Of_Characters := Number_Of_Characters - 8; - Nchars := Nchars - 8; - - -- If this is a symbol and the V_DEF flag is set, get symbol - - if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then - - -- First, reach the symbol length - - for J in 1 .. 25 loop - Read (File, B); - Nchars := Nchars - 1; - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - - Length := Byte'Pos (B); - LSymb := 0; - - -- Get the symbol characters - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - - if Length > 0 then - LSymb := LSymb + 1; - Symbol (LSymb) := B; - Length := Length - 1; - end if; - end loop; - - -- Check if it is a symbol from a generic body - - OK := True; - - for J in 1 .. LSymb - 2 loop - if Symbol (J) = 'G' and then Symbol (J + 1) = 'P' - and then Symbol (J + 2) in '0' .. '9' - then - OK := False; - exit; - end if; - end loop; - - if OK then - - -- Create the new Symbol - - declare - S_Data : Symbol_Data; - - begin - S_Data.Name := new String'(Symbol (1 .. LSymb)); - - -- The symbol kind (Data or Procedure) depends on the - -- V_NORM flag. - - if (Flags and V_NORM_Mask) = 0 then - S_Data.Kind := Data; - else - S_Data.Kind := Proc; - end if; - - -- Put the new symbol in the table - - Symbol_Table.Append (Complete_Symbols, S_Data); - end; - end if; - - else - -- As it is not a symbol subsection, skip to the next - -- subsection. - - for J in 1 .. Nchars loop - Read (File, B); - Number_Of_Characters := Number_Of_Characters - 1; - end loop; - end if; - - -- Exit the GSD section when number of characters reaches zero - - exit when Number_Of_Characters = 0; - end loop; - end if; - end loop; - - -- The object file has been processed, close it - - Close (File); - - exception - -- For any exception, output an error message, close the object file - -- and return with Success = False. - - when X : others => - Put_Line ("unexpected exception raised while processing """ - & Object_File & """"); - Put_Line (Exception_Information (X)); - Close (File); - Success := False; - end Process; - -end Processing; diff --git a/gcc/ada/symbols-processing-vms-ia64.adb b/gcc/ada/symbols-processing-vms-ia64.adb deleted file mode 100644 index beb099e40b0..00000000000 --- a/gcc/ada/symbols-processing-vms-ia64.adb +++ /dev/null @@ -1,430 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S . P R O C E S S I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS/IA64 version of this package - -with Ada.IO_Exceptions; - -with Ada.Unchecked_Deallocation; - -separate (Symbols) -package body Processing is - - type String_Array is array (Positive range <>) of String_Access; - type Strings_Ptr is access String_Array; - - procedure Free is - new Ada.Unchecked_Deallocation (String_Array, Strings_Ptr); - - type Section_Header is record - Shname : Integer; - Shtype : Integer; - Shoffset : Integer; - Shsize : Integer; - Shlink : Integer; - end record; - - type Section_Header_Array is array (Natural range <>) of Section_Header; - type Section_Header_Ptr is access Section_Header_Array; - - procedure Free is - new Ada.Unchecked_Deallocation (Section_Header_Array, Section_Header_Ptr); - - ------------- - -- Process -- - ------------- - - procedure Process - (Object_File : String; - Success : out Boolean) - is - B : Byte; - W : Integer; - - Str : String (1 .. 1000) := (others => ' '); - Str_Last : Natural; - - Strings : Strings_Ptr; - - Shoff : Integer; - Shnum : Integer; - Shentsize : Integer; - - Shname : Integer; - Shtype : Integer; - Shoffset : Integer; - Shsize : Integer; - Shlink : Integer; - - Symtab_Index : Natural := 0; - String_Table_Index : Natural := 0; - - End_Symtab : Integer; - - Stname : Integer; - Stinfo : Character; - Stother : Character; - Sttype : Integer; - Stbind : Integer; - Stshndx : Integer; - Stvis : Integer; - - STV_Internal : constant := 1; - STV_Hidden : constant := 2; - - Section_Headers : Section_Header_Ptr; - - Offset : Natural := 0; - OK : Boolean := True; - - procedure Get_Byte (B : out Byte); - -- Read one byte from the object file - - procedure Get_Half (H : out Integer); - -- Read one half work from the object file - - procedure Get_Word (W : out Integer); - -- Read one full word from the object file - - procedure Reset; - -- Restart reading the object file - - procedure Skip_Half; - -- Read and disregard one half word from the object file - - -------------- - -- Get_Byte -- - -------------- - - procedure Get_Byte (B : out Byte) is - begin - Byte_IO.Read (File, B); - Offset := Offset + 1; - end Get_Byte; - - -------------- - -- Get_Half -- - -------------- - - procedure Get_Half (H : out Integer) is - C1, C2 : Character; - begin - Get_Byte (C1); Get_Byte (C2); - H := - Integer'(Character'Pos (C2)) * 256 + Integer'(Character'Pos (C1)); - end Get_Half; - - -------------- - -- Get_Word -- - -------------- - - procedure Get_Word (W : out Integer) is - H1, H2 : Integer; - begin - Get_Half (H1); Get_Half (H2); - W := H2 * 256 * 256 + H1; - end Get_Word; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - Offset := 0; - Byte_IO.Reset (File); - end Reset; - - --------------- - -- Skip_Half -- - --------------- - - procedure Skip_Half is - B : Byte; - pragma Unreferenced (B); - begin - Byte_IO.Read (File, B); - Byte_IO.Read (File, B); - Offset := Offset + 2; - end Skip_Half; - - -- Start of processing for Process - - begin - -- Open the object file with Byte_IO. Return with Success = False if - -- this fails. - - begin - Open (File, In_File, Object_File); - exception - when others => - Put_Line - ("*** Unable to open object file """ & Object_File & """"); - Success := False; - return; - end; - - -- Assume that the object file has a correct format - - Success := True; - - -- Skip ELF identification - - while Offset < 16 loop - Get_Byte (B); - end loop; - - -- Skip e_type - - Skip_Half; - - -- Skip e_machine - - Skip_Half; - - -- Skip e_version - - Get_Word (W); - - -- Skip e_entry - - for J in 1 .. 8 loop - Get_Byte (B); - end loop; - - -- Skip e_phoff - - for J in 1 .. 8 loop - Get_Byte (B); - end loop; - - Get_Word (Shoff); - - -- Skip upper half of Shoff - - for J in 1 .. 4 loop - Get_Byte (B); - end loop; - - -- Skip e_flags - - Get_Word (W); - - -- Skip e_ehsize - - Skip_Half; - - -- Skip e_phentsize - - Skip_Half; - - -- Skip e_phnum - - Skip_Half; - - Get_Half (Shentsize); - - Get_Half (Shnum); - - Section_Headers := new Section_Header_Array (0 .. Shnum - 1); - - -- Go to Section Headers - - while Offset < Shoff loop - Get_Byte (B); - end loop; - - -- Reset Symtab_Index - - Symtab_Index := 0; - - for J in Section_Headers'Range loop - - -- Get the data for each Section Header - - Get_Word (Shname); - Get_Word (Shtype); - - for K in 1 .. 16 loop - Get_Byte (B); - end loop; - - Get_Word (Shoffset); - Get_Word (W); - - Get_Word (Shsize); - Get_Word (W); - - Get_Word (Shlink); - - while (Offset - Shoff) mod Shentsize /= 0 loop - Get_Byte (B); - end loop; - - -- If this is the Symbol Table Section Header, record its index - - if Shtype = 2 then - Symtab_Index := J; - end if; - - Section_Headers (J) := (Shname, Shtype, Shoffset, Shsize, Shlink); - end loop; - - if Symtab_Index = 0 then - Success := False; - return; - end if; - - End_Symtab := - Section_Headers (Symtab_Index).Shoffset + - Section_Headers (Symtab_Index).Shsize; - - String_Table_Index := Section_Headers (Symtab_Index).Shlink; - Strings := - new String_Array (1 .. Section_Headers (String_Table_Index).Shsize); - - -- Go get the String Table section for the Symbol Table - - Reset; - - while Offset < Section_Headers (String_Table_Index).Shoffset loop - Get_Byte (B); - end loop; - - Offset := 0; - - Get_Byte (B); -- zero - - while Offset < Section_Headers (String_Table_Index).Shsize loop - Str_Last := 0; - - loop - Get_Byte (B); - if B /= ASCII.NUL then - Str_Last := Str_Last + 1; - Str (Str_Last) := B; - - else - Strings (Offset - Str_Last - 1) := - new String'(Str (1 .. Str_Last)); - exit; - end if; - end loop; - end loop; - - -- Go get the Symbol Table - - Reset; - - while Offset < Section_Headers (Symtab_Index).Shoffset loop - Get_Byte (B); - end loop; - - while Offset < End_Symtab loop - Get_Word (Stname); - Get_Byte (Stinfo); - Get_Byte (Stother); - Get_Half (Stshndx); - for J in 1 .. 4 loop - Get_Word (W); - end loop; - - Sttype := Integer'(Character'Pos (Stinfo)) mod 16; - Stbind := Integer'(Character'Pos (Stinfo)) / 16; - Stvis := Integer'(Character'Pos (Stother)) mod 4; - - if (Sttype = 1 or else Sttype = 2) - and then Stbind /= 0 - and then Stshndx /= 0 - and then Stvis /= STV_Internal - and then Stvis /= STV_Hidden - then - -- Check if this is a symbol from a generic body - - OK := True; - - for J in Strings (Stname)'First .. Strings (Stname)'Last - 2 loop - if Strings (Stname) (J) = 'G' - and then Strings (Stname) (J + 1) = 'P' - and then Strings (Stname) (J + 2) in '0' .. '9' - then - OK := False; - exit; - end if; - end loop; - - if OK then - declare - S_Data : Symbol_Data; - begin - S_Data.Name := new String'(Strings (Stname).all); - - if Sttype = 1 then - S_Data.Kind := Data; - - else - S_Data.Kind := Proc; - end if; - - -- Put the new symbol in the table - - Symbol_Table.Append (Complete_Symbols, S_Data); - end; - end if; - end if; - end loop; - - -- The object file has been processed, close it - - Close (File); - - -- Free the allocated memory - - Free (Section_Headers); - - for J in Strings'Range loop - if Strings (J) /= null then - Free (Strings (J)); - end if; - end loop; - - Free (Strings); - - exception - -- For any exception, output an error message, close the object file - -- and return with Success = False. - - when Ada.IO_Exceptions.End_Error => - Close (File); - - when X : others => - Put_Line ("unexpected exception raised while processing """ - & Object_File & """"); - Put_Line (Exception_Information (X)); - Close (File); - Success := False; - end Process; - -end Processing; diff --git a/gcc/ada/symbols-vms.adb b/gcc/ada/symbols-vms.adb deleted file mode 100644 index 39c9beb3202..00000000000 --- a/gcc/ada/symbols-vms.adb +++ /dev/null @@ -1,637 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y M B O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2007, Free Software Foundation, Inc. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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 GNAT; see file COPYING3. If not, go to -- --- http://www.gnu.org/licenses for a complete copy of the license. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the VMS version of this package - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Sequential_IO; -with Ada.Text_IO; use Ada.Text_IO; - -package body Symbols is - - Case_Sensitive : constant String := "case_sensitive="; - Symbol_Vector : constant String := "SYMBOL_VECTOR=("; - Equal_Data : constant String := "=DATA)"; - Equal_Procedure : constant String := "=PROCEDURE)"; - Gsmatch : constant String := "gsmatch="; - Gsmatch_Lequal : constant String := "gsmatch=lequal,"; - - Symbol_File_Name : String_Access := null; - -- Name of the symbol file - - Long_Symbol_Length : constant := 100; - -- Magic length of symbols, over which the lines are split - - Sym_Policy : Policy := Autonomous; - -- The symbol policy. Set by Initialize - - Major_ID : Integer := 1; - -- The Major ID. May be modified by Initialize if Library_Version is - -- specified or if it is read from the reference symbol file. - - Soft_Major_ID : Boolean := True; - -- False if library version is specified in procedure Initialize. - -- When True, Major_ID may be modified if found in the reference symbol - -- file. - - Minor_ID : Natural := 0; - -- The Minor ID. May be modified if read from the reference symbol file - - Soft_Minor_ID : Boolean := True; - -- False if symbol policy is Autonomous, if library version is specified - -- in procedure Initialize and is not the same as the major ID read from - -- the reference symbol file. When True, Minor_ID may be increased in - -- Compliant symbol policy. - - subtype Byte is Character; - -- Object files are stream of bytes, but some of these bytes, those for - -- the names of the symbols, are ASCII characters. - - package Byte_IO is new Ada.Sequential_IO (Byte); - use Byte_IO; - - File : Byte_IO.File_Type; - -- Each object file is read as a stream of bytes (characters) - - function Equal (Left, Right : Symbol_Data) return Boolean; - -- Test for equality of symbols - - function Image (N : Integer) return String; - -- Returns the image of N, without the initial space - - ----------- - -- Equal -- - ----------- - - function Equal (Left, Right : Symbol_Data) return Boolean is - begin - return Left.Name /= null and then - Right.Name /= null and then - Left.Name.all = Right.Name.all and then - Left.Kind = Right.Kind and then - Left.Present = Right.Present; - end Equal; - - ----------- - -- Image -- - ----------- - - function Image (N : Integer) return String is - Result : constant String := N'Img; - begin - if Result (Result'First) = ' ' then - return Result (Result'First + 1 .. Result'Last); - else - return Result; - end if; - end Image; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (Symbol_File : String; - Reference : String; - Symbol_Policy : Policy; - Quiet : Boolean; - Version : String; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - Line : String (1 .. 2_000); - Last : Natural; - - Offset : Natural; - - begin - -- Record the symbol file name - - Symbol_File_Name := new String'(Symbol_File); - - -- Record the policy - - Sym_Policy := Symbol_Policy; - - -- Record the version (Major ID) - - if Version = "" then - Major_ID := 1; - Soft_Major_ID := True; - - else - begin - Major_ID := Integer'Value (Version); - Soft_Major_ID := False; - - if Major_ID <= 0 then - raise Constraint_Error; - end if; - - exception - when Constraint_Error => - if not Quiet then - Put_Line ("Version """ & Version & """ is illegal."); - Put_Line ("On VMS, version must be a positive number"); - end if; - - Success := False; - return; - end; - end if; - - Minor_ID := 0; - Soft_Minor_ID := Sym_Policy /= Autonomous; - - -- Empty the symbol tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Assume that everything will be fine - - Success := True; - - -- If policy is Compliant or Controlled, attempt to read the reference - -- file. If policy is Restricted, attempt to read the symbol file. - - if Sym_Policy /= Autonomous then - case Sym_Policy is - when Autonomous | Direct => - null; - - when Compliant | Controlled => - begin - Open (File, In_File, Reference); - - exception - when Ada.Text_IO.Name_Error => - Success := False; - return; - - when X : others => - if not Quiet then - Put_Line ("could not open """ & Reference & """"); - Put_Line (Exception_Message (X)); - end if; - - Success := False; - return; - end; - - when Restricted => - begin - Open (File, In_File, Symbol_File); - - exception - when Ada.Text_IO.Name_Error => - Success := False; - return; - - when X : others => - if not Quiet then - Put_Line ("could not open """ & Symbol_File & """"); - Put_Line (Exception_Message (X)); - end if; - - Success := False; - return; - end; - end case; - - -- Read line by line - - while not End_Of_File (File) loop - Offset := 0; - loop - Get_Line (File, Line (Offset + 1 .. Line'Last), Last); - exit when Line (Last) /= '-'; - - if End_Of_File (File) then - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted:"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - - else - Offset := Last - 1; - end if; - end loop; - - -- Ignore empty lines - - if Last = 0 then - null; - - -- Ignore lines starting with "case_sensitive=" - - elsif Last > Case_Sensitive'Length - and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive - then - null; - - -- Line starting with "SYMBOL_VECTOR=(" - - elsif Last > Symbol_Vector'Length - and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector - then - - -- SYMBOL_VECTOR=(<symbol>=DATA) - - if Last > Symbol_Vector'Length + Equal_Data'Length and then - Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data - then - Symbol_Table.Append (Original_Symbols, - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Data'Length)), - Kind => Data, - Present => True)); - - -- SYMBOL_VECTOR=(<symbol>=PROCEDURE) - - elsif Last > Symbol_Vector'Length + Equal_Procedure'Length - and then - Line (Last - Equal_Procedure'Length + 1 .. Last) = - Equal_Procedure - then - Symbol_Table.Append (Original_Symbols, - (Name => - new String'(Line (Symbol_Vector'Length + 1 .. - Last - Equal_Procedure'Length)), - Kind => Proc, - Present => True)); - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted:"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - - -- Lines with "gsmatch=lequal," or "gsmatch=equal," - - elsif Last > Gsmatch'Length - and then Line (1 .. Gsmatch'Length) = Gsmatch - then - declare - Start : Positive := Gsmatch'Length + 1; - Finish : Positive := Start; - OK : Boolean := True; - ID : Integer; - - begin - -- First, look for the first coma - - loop - if Start >= Last - 1 then - OK := False; - exit; - - elsif Line (Start) = ',' then - Start := Start + 1; - exit; - - else - Start := Start + 1; - end if; - end loop; - - Finish := Start; - - -- If the comma is found, get the Major and the Minor IDs - - if OK then - loop - if Line (Finish) not in '0' .. '9' - or else Finish >= Last - 1 - then - OK := False; - exit; - end if; - - exit when Line (Finish + 1) = ','; - - Finish := Finish + 1; - end loop; - end if; - - if OK then - ID := Integer'Value (Line (Start .. Finish)); - OK := ID /= 0; - - -- If Soft_Major_ID is True, it means that - -- Library_Version was not specified. - - if Soft_Major_ID then - Major_ID := ID; - - -- If the Major ID in the reference file is different - -- from the Library_Version, then the Minor ID will be 0 - -- because there is no point in taking the Minor ID in - -- the reference file, or incrementing it. So, we set - -- Soft_Minor_ID to False, so that we don't modify - -- the Minor_ID later. - - elsif Major_ID /= ID then - Soft_Minor_ID := False; - end if; - - Start := Finish + 2; - Finish := Start; - - loop - if Line (Finish) not in '0' .. '9' then - OK := False; - exit; - end if; - - exit when Finish = Last; - - Finish := Finish + 1; - end loop; - - -- Only set Minor_ID if Soft_Minor_ID is True (see above) - - if OK and then Soft_Minor_ID then - Minor_ID := Integer'Value (Line (Start .. Finish)); - end if; - end if; - - -- If OK is not True, that means the line is not correctly - -- formatted. - - if not OK then - if not Quiet then - Put_Line ("symbol file """ & Reference & - """ is incorrectly formatted"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end; - - -- Anything else is incorrectly formatted - - else - if not Quiet then - Put_Line ("unexpected line in symbol file """ & - Reference & """"); - Put_Line ("""" & Line (1 .. Last) & """"); - end if; - - Close (File); - Success := False; - return; - end if; - end loop; - - Close (File); - end if; - end Initialize; - - ---------------- - -- Processing -- - ---------------- - - package body Processing is separate; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize - (Quiet : Boolean; - Success : out Boolean) - is - File : Ada.Text_IO.File_Type; - -- The symbol file - - S_Data : Symbol_Data; - -- A symbol - - Cur : Positive := 1; - -- Most probable index in the Complete_Symbols of the current symbol - -- in Original_Symbol. - - Found : Boolean; - - begin - -- Nothing to be done if Initialize has never been called - - if Symbol_File_Name = null then - Success := False; - - else - - -- First find if the symbols in the reference symbol file are also - -- in the object files. Note that this is not done if the policy is - -- Autonomous, because no reference symbol file has been read. - - -- Expect the first symbol in the symbol file to also be the first - -- in Complete_Symbols. - - Cur := 1; - - for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop - S_Data := Original_Symbols.Table (Index_1); - Found := False; - - First_Object_Loop : - for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit First_Object_Loop; - end if; - end loop First_Object_Loop; - - -- If the symbol could not be found between Cur and Last, try - -- before Cur. - - if not Found then - Second_Object_Loop : - for Index_2 in 1 .. Cur - 1 loop - if Equal (S_Data, Complete_Symbols.Table (Index_2)) then - Cur := Index_2 + 1; - Complete_Symbols.Table (Index_2).Present := False; - Found := True; - exit Second_Object_Loop; - end if; - end loop Second_Object_Loop; - end if; - - -- If the symbol is not found, mark it as such in the table - - if not Found then - if (not Quiet) or else Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is no longer present in the object files"); - end if; - - if Sym_Policy = Controlled or else Sym_Policy = Restricted then - Success := False; - return; - - -- Any symbol that is undefined in the reference symbol file - -- triggers an increase of the Major ID, because the new - -- version of the library is no longer compatible with - -- existing executables. - - elsif Soft_Major_ID then - Major_ID := Major_ID + 1; - Minor_ID := 0; - Soft_Major_ID := False; - Soft_Minor_ID := False; - end if; - - Original_Symbols.Table (Index_1).Present := False; - Free (Original_Symbols.Table (Index_1).Name); - - if Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - end if; - end loop; - - if Sym_Policy /= Restricted then - - -- Append additional symbols, if any, to the Original_Symbols - -- table. - - for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop - S_Data := Complete_Symbols.Table (Index); - - if S_Data.Present then - - if Sym_Policy = Controlled then - Put_Line ("symbol """ & S_Data.Name.all & - """ is not in the reference symbol file"); - Success := False; - return; - - elsif Soft_Minor_ID then - Minor_ID := Minor_ID + 1; - Soft_Minor_ID := False; - end if; - - Symbol_Table.Append (Original_Symbols, S_Data); - Complete_Symbols.Table (Index).Present := False; - end if; - end loop; - - -- Create the symbol file - - Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all); - - Put (File, Case_Sensitive); - Put_Line (File, "yes"); - - -- Put a line in the symbol file for each symbol in symbol table - - for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop - if Original_Symbols.Table (Index).Present then - Put (File, Symbol_Vector); - - -- Split the line if symbol name length is too large - - if Original_Symbols.Table (Index).Name'Length > - Long_Symbol_Length - then - Put_Line (File, "-"); - end if; - - Put (File, Original_Symbols.Table (Index).Name.all); - - if Original_Symbols.Table (Index).Name'Length > - Long_Symbol_Length - then - Put_Line (File, "-"); - end if; - - if Original_Symbols.Table (Index).Kind = Data then - Put_Line (File, Equal_Data); - - else - Put_Line (File, Equal_Procedure); - end if; - - Free (Original_Symbols.Table (Index).Name); - end if; - end loop; - - Put (File, Case_Sensitive); - Put_Line (File, "NO"); - - -- Put the version IDs - - Put (File, Gsmatch_Lequal); - Put (File, Image (Major_ID)); - Put (File, ','); - Put_Line (File, Image (Minor_ID)); - - -- And we are done - - Close (File); - - -- Reset both tables - - Symbol_Table.Set_Last (Original_Symbols, 0); - Symbol_Table.Set_Last (Complete_Symbols, 0); - - -- Clear the symbol file name - - Free (Symbol_File_Name); - end if; - - Success := True; - end if; - - exception - when X : others => - Put_Line ("unexpected exception raised while finalizing """ - & Symbol_File_Name.all & """"); - Put_Line (Exception_Information (X)); - Success := False; - end Finalize; - -end Symbols; diff --git a/gcc/ada/system-vms-ia64.ads b/gcc/ada/system-vms-ia64.ads deleted file mode 100644 index 0b7f9475150..00000000000 --- a/gcc/ada/system-vms-ia64.ads +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS 64bit Itanium GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is new Long_Integer; - Null_Address : constant Address; - -- Although this is declared as an integer type, no arithmetic operations - -- are available (see abstract declarations below), and furthermore there - -- is special processing in the compiler that prevents the use of integer - -- literals with this type (use To_Address to convert integer literals). - -- - -- Conversion to and from Short_Address is however freely permitted, and - -- is indeed the reason that Address is declared as an integer type. - - Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Abstract declarations for arithmetic operations on type address. - -- These declarations are needed when Address is non-private. They - -- avoid excessive visibility of arithmetic operations on address - -- which are typically available elsewhere (e.g. Storage_Elements) - -- and which would cause excessive ambiguities in application code. - - function "+" (Left, Right : Address) return Address is abstract; - function "-" (Left, Right : Address) return Address is abstract; - function "/" (Left, Right : Address) return Address is abstract; - function "*" (Left, Right : Address) return Address is abstract; - function "mod" (Left, Right : Address) return Address is abstract; - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := True; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - VAX_Float : constant Boolean := False; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 <your application> - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f <your options> <your application> - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (Cond_Value : Integer); - pragma Import (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove. - - pragma Ident ("GNAT"); -- Gnat_Static_Version_String - -- Default ident for all VMS images. - -end System; diff --git a/gcc/ada/system-vms_64.ads b/gcc/ada/system-vms_64.ads deleted file mode 100644 index cc03c165968..00000000000 --- a/gcc/ada/system-vms_64.ads +++ /dev/null @@ -1,257 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (OpenVMS 64bit GCC_ZCX DEC Threads Version) -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the contents of the part following the private keyword. -- --- -- --- GNAT 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 3, or (at your option) any later ver- -- --- sion. GNAT 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- <http://www.gnu.org/licenses/>. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - type Name is (SYSTEM_NAME_GNAT); - System_Name : constant Name := SYSTEM_NAME_GNAT; - - -- System-Dependent Named Numbers - - Min_Int : constant := Long_Long_Integer'First; - Max_Int : constant := Long_Long_Integer'Last; - - Max_Binary_Modulus : constant := 2 ** Long_Long_Integer'Size; - Max_Nonbinary_Modulus : constant := 2 ** Integer'Size - 1; - - Max_Base_Digits : constant := Long_Long_Float'Digits; - Max_Digits : constant := Long_Long_Float'Digits; - - Max_Mantissa : constant := 63; - Fine_Delta : constant := 2.0 ** (-Max_Mantissa); - - Tick : constant := 0.01; - - -- Storage-related Declarations - - type Address is new Long_Integer; - Null_Address : constant Address; - -- Although this is declared as an integer type, no arithmetic operations - -- are available (see abstract declarations below), and furthermore there - -- is special processing in the compiler that prevents the use of integer - -- literals with this type (use To_Address to convert integer literals). - -- - -- Conversion to and from Short_Address is however freely permitted, and - -- is indeed the reason that Address is declared as an integer type. - - Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Abstract declarations for arithmetic operations on type address. - -- These declarations are needed when Address is non-private. They - -- avoid excessive visibility of arithmetic operations on address - -- which are typically available elsewhere (e.g. Storage_Elements) - -- and which would cause excessive ambiguities in application code. - - function "+" (Left, Right : Address) return Address is abstract; - function "-" (Left, Right : Address) return Address is abstract; - function "/" (Left, Right : Address) return Address is abstract; - function "*" (Left, Right : Address) return Address is abstract; - function "mod" (Left, Right : Address) return Address is abstract; - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := Low_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - Max_Priority : constant Positive := 30; - Max_Interrupt_Priority : constant Positive := 31; - - subtype Any_Priority is Integer range 0 .. 31; - subtype Priority is Any_Priority range 0 .. 30; - subtype Interrupt_Priority is Any_Priority range 31 .. 31; - - Default_Priority : constant Priority := 15; - -private - - Null_Address : constant Address := 0; - - -------------------------------------- - -- System Implementation Parameters -- - -------------------------------------- - - -- These parameters provide information about the target that is used - -- by the compiler. They are in the private part of System, where they - -- can be accessed using the special circuitry in the Targparm unit - -- whose source should be consulted for more detailed descriptions - -- of the individual switch values. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := True; - Configurable_Run_Time : constant Boolean := False; - Denorm : constant Boolean := False; - Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := True; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - OpenVMS : constant Boolean := True; - VAX_Float : constant Boolean := False; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := True; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For DEC Threads OpenVMS, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in OpenVMS. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O3 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O3 <your application> - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f <your options> <your application> - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - - ---------------------------- - -- Special VMS Interfaces -- - ---------------------------- - - procedure Lib_Stop (Cond_Value : Integer); - pragma Import (C, Lib_Stop); - pragma Import_Procedure (Lib_Stop, "LIB$STOP", Mechanism => (Value)); - -- Interface to VMS condition handling. Used by RTSfind and pragma - -- {Import,Export}_Exception. Put here because this is the only - -- VMS specific package that doesn't drag in tasking. - - ADA_GNAT : constant Boolean := True; - pragma Export_Object (ADA_GNAT, "ADA$GNAT"); - -- Ubiquitous global symbol identifying a GNAT compiled image to VMS Debug. - -- Do not remove. - - pragma Ident ("GNAT"); -- Gnat_Static_Version_String - -- Default ident for all VMS images. - -end System; |