+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
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
-- --
-- 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- --
-- 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
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
* *
* 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- *
#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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
STI.Undefer_Abort_Nestable (D.Self_Id);
end Cancel_Async_Delay;
- ---------------------------
- -- Enqueue_Time_Duration --
- ---------------------------
+ ----------------------
+ -- Enqueue_Duration --
+ ----------------------
function Enqueue_Duration
(T : Duration;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
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;
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 --
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));
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
projects / thirdparty / gcc.git / commitdiff
