File : s-init-lynxos178-cert.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- S Y S T E M . I N I T --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2013-2014, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- In particular, you can freely distribute your programs built with the --
23 -- GNAT Pro compiler, including any required library run-time units, using --
24 -- any licensing terms of your choosing. See the AdaCore Software License --
25 -- for full details. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- This is the Level A cert version for LynxOS 178
33
34 -- This file should be kept synchronized with init.c, s-osvers-*.ads, and
35 -- s-init-xi-sparc.adb. All these files implement the required functionality
36 -- for different targets.
37
38 with Interfaces.C;
39
40 package body System.Init is
41
42 use Interfaces.C;
43
44 Stack_Limit_Hook : System.Address;
45 pragma Export (C, Stack_Limit_Hook, "__gnat_set_stack_limit_hook");
46 -- Used when stack limit checking is the stack overflow checking method
47
48 -----------------------------
49 -- Binder Generated Values --
50 -----------------------------
51
52 Gl_Main_Priority : Integer := -1;
53 pragma Export (C, Gl_Main_Priority, "__gl_main_priority");
54
55 Gl_Main_CPU : Integer := -1;
56 pragma Export (C, Gl_Main_CPU, "__gl_main_cpu");
57
58 ------------------------
59 -- Signal Definitions --
60 ------------------------
61
62 NSIG : constant := 64;
63 -- Number of signals on the target OS
64
65 type Signal is new int range 0 .. Interfaces.C."-" (NSIG, 1);
66
67 SIGILL : constant := 4; -- illegal instruction (not reset)
68 SIGFPE : constant := 8; -- floating point exception
69 SIGBUS : constant := 10; -- bus error
70 SIGSEGV : constant := 11; -- segmentation violation
71
72 SIG_SETMASK : constant := 2;
73
74 type sigset_t is array (1 .. 2) of long;
75
76 type struct_sigaction is record
77 sa_handler : System.Address;
78 sa_mask : sigset_t;
79 sa_flags : int;
80 end record;
81 pragma Convention (C, struct_sigaction);
82 type struct_sigaction_ptr is access all struct_sigaction;
83
84 function sigaction
85 (sig : Signal;
86 act : struct_sigaction_ptr;
87 oact : struct_sigaction_ptr) return int;
88 pragma Import (C, sigaction, "sigaction");
89
90 function sigemptyset (set : access sigset_t) return int;
91 pragma Import (C, sigemptyset, "sigemptyset");
92
93 function sigdelset (set : access sigset_t; sig : Signal) return int;
94 pragma Import (C, sigdelset, "sigdelset");
95
96 type sigset_t_ptr is access all sigset_t;
97
98 function pthread_sigmask
99 (How : int;
100 Set : sigset_t_ptr;
101 Oset : sigset_t_ptr) return int;
102 pragma Import (C, pthread_sigmask, "pthread_sigmask");
103
104 ----------------------
105 -- Local Procedures --
106 ----------------------
107
108 procedure GNAT_Error_Handler (Sig : Signal);
109 pragma No_Return (GNAT_Error_Handler);
110 -- Common procedure that is executed when a SIGFPE, SIGILL, SIGSEGV, or
111 -- SIGBUS is captured.
112
113 ------------------------
114 -- GNAT_Error_Handler --
115 ------------------------
116
117 procedure GNAT_Error_Handler (Sig : Signal) is
118 Mask : aliased sigset_t;
119 Result : int;
120 pragma Unreferenced (Result);
121 begin
122 Result := pthread_sigmask (SIG_SETMASK, null, Mask'Unchecked_Access);
123 Result := sigdelset (Mask'Unchecked_Access, Sig);
124 Result := pthread_sigmask (SIG_SETMASK, Mask'Unchecked_Access, null);
125
126 case Sig is
127 when SIGFPE =>
128 raise Constraint_Error with "SIGFPE";
129
130 when SIGILL =>
131 raise Constraint_Error with "SIGILL";
132
133 when SIGSEGV =>
134 raise Storage_Error with "SIGSEGV";
135
136 when SIGBUS =>
137 raise Program_Error with "SIGBUS";
138
139 when others =>
140 raise Program_Error with "unexpected signal";
141 end case;
142 end GNAT_Error_Handler;
143
144 ---------------------
145 -- Install_Handler --
146 ---------------------
147
148 procedure Install_Handler is
149 Mask : aliased sigset_t;
150 Signal_Action : aliased struct_sigaction;
151
152 Result : Interfaces.C.int;
153 pragma Unreferenced (Result);
154
155 begin
156 -- Set up signal handler to map synchronous signals to appropriate
157 -- exceptions. Make sure that the handler isn't interrupted by another
158 -- signal that might cause a scheduling event.
159
160 Signal_Action.sa_handler := GNAT_Error_Handler'Address;
161 Signal_Action.sa_flags := 0;
162 Result := sigemptyset (Mask'Unchecked_Access);
163 Signal_Action.sa_mask := Mask;
164
165 Result :=
166 sigaction (Signal (SIGFPE), Signal_Action'Unchecked_Access, null);
167
168 Result :=
169 sigaction (Signal (SIGILL), Signal_Action'Unchecked_Access, null);
170
171 Result :=
172 sigaction (Signal (SIGSEGV), Signal_Action'Unchecked_Access, null);
173
174 Result :=
175 sigaction (Signal (SIGBUS), Signal_Action'Unchecked_Access, null);
176 end Install_Handler;
177
178 ------------------------
179 -- Runtime_Initialize --
180 ------------------------
181
182 procedure Runtime_Initialize is
183 begin
184 Install_Handler;
185 end Runtime_Initialize;
186
187 ----------------------
188 -- Runtime_Finalize --
189 ----------------------
190
191 procedure Runtime_Finalize is
192 begin
193 null;
194 end Runtime_Finalize;
195
196 end System.Init;