1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--                       S Y S T E M . A U X _ D E C                        --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--          Copyright (C) 1992-2012, 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-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
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 Itanium/VMS version.
33
34--  The Add,Clear_Interlocked subprograms are dubiously implmented due to
35--  the lack of a single bit sync_lock_test_and_set builtin.
36
37--  The "Retry" parameter is ignored due to the lack of retry builtins making
38--  the subprograms identical to the non-retry versions.
39
40pragma Style_Checks (All_Checks);
41--  Turn off alpha ordering check on subprograms, this unit is laid
42--  out to correspond to the declarations in the DEC 83 System unit.
43
44with Interfaces;
45package body System.Aux_DEC is
46
47   use type Interfaces.Unsigned_8;
48
49   ------------------------
50   -- Fetch_From_Address --
51   ------------------------
52
53   function Fetch_From_Address (A : Address) return Target is
54      type T_Ptr is access all Target;
55      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
56      Ptr : constant T_Ptr := To_T_Ptr (A);
57   begin
58      return Ptr.all;
59   end Fetch_From_Address;
60
61   -----------------------
62   -- Assign_To_Address --
63   -----------------------
64
65   procedure Assign_To_Address (A : Address; T : Target) is
66      type T_Ptr is access all Target;
67      function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr);
68      Ptr : constant T_Ptr := To_T_Ptr (A);
69   begin
70      Ptr.all := T;
71   end Assign_To_Address;
72
73   -----------------------
74   -- Clear_Interlocked --
75   -----------------------
76
77   procedure Clear_Interlocked
78     (Bit       : in out Boolean;
79      Old_Value : out Boolean)
80   is
81      Clr_Bit : Boolean := Bit;
82      Old_Uns : Interfaces.Unsigned_8;
83
84      function Sync_Lock_Test_And_Set
85        (Ptr   : Address;
86         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
87      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
88                     "__sync_lock_test_and_set_1");
89
90   begin
91      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
92      Bit := Clr_Bit;
93      Old_Value := Old_Uns /= 0;
94   end Clear_Interlocked;
95
96   procedure Clear_Interlocked
97     (Bit          : in out Boolean;
98      Old_Value    : out Boolean;
99      Retry_Count  : Natural;
100      Success_Flag : out Boolean)
101   is
102      pragma Unreferenced (Retry_Count);
103
104      Clr_Bit : Boolean := Bit;
105      Old_Uns : Interfaces.Unsigned_8;
106
107      function Sync_Lock_Test_And_Set
108        (Ptr   : Address;
109         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
110      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
111                     "__sync_lock_test_and_set_1");
112
113   begin
114      Old_Uns := Sync_Lock_Test_And_Set (Clr_Bit'Address, 0);
115      Bit := Clr_Bit;
116      Old_Value := Old_Uns /= 0;
117      Success_Flag := True;
118   end Clear_Interlocked;
119
120   ---------------------
121   -- Set_Interlocked --
122   ---------------------
123
124   procedure Set_Interlocked
125     (Bit       : in out Boolean;
126      Old_Value : out Boolean)
127   is
128      Set_Bit : Boolean := Bit;
129      Old_Uns : Interfaces.Unsigned_8;
130
131      function Sync_Lock_Test_And_Set
132        (Ptr   : Address;
133         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
134      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
135                     "__sync_lock_test_and_set_1");
136
137   begin
138      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
139      Bit := Set_Bit;
140      Old_Value := Old_Uns /= 0;
141   end Set_Interlocked;
142
143   procedure Set_Interlocked
144     (Bit          : in out Boolean;
145      Old_Value    : out Boolean;
146      Retry_Count  : Natural;
147      Success_Flag : out Boolean)
148   is
149      pragma Unreferenced (Retry_Count);
150
151      Set_Bit : Boolean := Bit;
152      Old_Uns : Interfaces.Unsigned_8;
153
154      function Sync_Lock_Test_And_Set
155        (Ptr   : Address;
156         Value : Interfaces.Unsigned_8) return Interfaces.Unsigned_8;
157      pragma Import (Intrinsic, Sync_Lock_Test_And_Set,
158                     "__sync_lock_test_and_set_1");
159   begin
160      Old_Uns := Sync_Lock_Test_And_Set (Set_Bit'Address, 1);
161      Bit := Set_Bit;
162      Old_Value := Old_Uns /= 0;
163      Success_Flag := True;
164   end Set_Interlocked;
165
166   ---------------------
167   -- Add_Interlocked --
168   ---------------------
169
170   procedure Add_Interlocked
171     (Addend : Short_Integer;
172      Augend : in out Aligned_Word;
173      Sign   : out Integer)
174   is
175      Overflowed : Boolean := False;
176      Former     : Aligned_Word;
177
178      function Sync_Fetch_And_Add
179        (Ptr   : Address;
180         Value : Short_Integer) return Short_Integer;
181      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_2");
182
183   begin
184      Former.Value := Sync_Fetch_And_Add (Augend.Value'Address, Addend);
185
186      if Augend.Value < 0 then
187         Sign := -1;
188      elsif Augend.Value > 0 then
189         Sign := 1;
190      else
191         Sign := 0;
192      end if;
193
194      if Former.Value > 0 and then Augend.Value <= 0 then
195         Overflowed := True;
196      end if;
197
198      if Overflowed then
199         raise Constraint_Error;
200      end if;
201   end Add_Interlocked;
202
203   ----------------
204   -- Add_Atomic --
205   ----------------
206
207   procedure Add_Atomic
208     (To     : in out Aligned_Integer;
209      Amount : Integer)
210   is
211      procedure Sync_Add_And_Fetch
212        (Ptr   : Address;
213         Value : Integer);
214      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4");
215   begin
216      Sync_Add_And_Fetch (To.Value'Address, Amount);
217   end Add_Atomic;
218
219   procedure Add_Atomic
220     (To           : in out Aligned_Integer;
221      Amount       : Integer;
222      Retry_Count  : Natural;
223      Old_Value    : out Integer;
224      Success_Flag : out Boolean)
225   is
226      pragma Unreferenced (Retry_Count);
227
228      function Sync_Fetch_And_Add
229        (Ptr   : Address;
230         Value : Integer) return Integer;
231      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_4");
232
233   begin
234      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
235      Success_Flag := True;
236   end Add_Atomic;
237
238   procedure Add_Atomic
239     (To     : in out Aligned_Long_Integer;
240      Amount : Long_Integer)
241   is
242      procedure Sync_Add_And_Fetch
243        (Ptr   : Address;
244         Value : Long_Integer);
245      pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_8");
246   begin
247      Sync_Add_And_Fetch (To.Value'Address, Amount);
248   end Add_Atomic;
249
250   procedure Add_Atomic
251     (To           : in out Aligned_Long_Integer;
252      Amount       : Long_Integer;
253      Retry_Count  : Natural;
254      Old_Value    : out Long_Integer;
255      Success_Flag : out Boolean)
256   is
257      pragma Unreferenced (Retry_Count);
258
259      function Sync_Fetch_And_Add
260        (Ptr   : Address;
261         Value : Long_Integer) return Long_Integer;
262      pragma Import (Intrinsic, Sync_Fetch_And_Add, "__sync_fetch_and_add_8");
263      --  Why do we keep importing this over and over again???
264
265   begin
266      Old_Value := Sync_Fetch_And_Add (To.Value'Address, Amount);
267      Success_Flag := True;
268   end Add_Atomic;
269
270   ----------------
271   -- And_Atomic --
272   ----------------
273
274   procedure And_Atomic
275     (To   : in out Aligned_Integer;
276      From : Integer)
277   is
278      procedure Sync_And_And_Fetch
279        (Ptr   : Address;
280         Value : Integer);
281      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_4");
282   begin
283      Sync_And_And_Fetch (To.Value'Address, From);
284   end And_Atomic;
285
286   procedure And_Atomic
287     (To           : in out Aligned_Integer;
288      From         : Integer;
289      Retry_Count  : Natural;
290      Old_Value    : out Integer;
291      Success_Flag : out Boolean)
292   is
293      pragma Unreferenced (Retry_Count);
294
295      function Sync_Fetch_And_And
296        (Ptr   : Address;
297         Value : Integer) return Integer;
298      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_4");
299
300   begin
301      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
302      Success_Flag := True;
303   end And_Atomic;
304
305   procedure And_Atomic
306     (To   : in out Aligned_Long_Integer;
307      From : Long_Integer)
308   is
309      procedure Sync_And_And_Fetch
310        (Ptr   : Address;
311         Value : Long_Integer);
312      pragma Import (Intrinsic, Sync_And_And_Fetch, "__sync_and_and_fetch_8");
313   begin
314      Sync_And_And_Fetch (To.Value'Address, From);
315   end And_Atomic;
316
317   procedure And_Atomic
318     (To           : in out Aligned_Long_Integer;
319      From         : Long_Integer;
320      Retry_Count  : Natural;
321      Old_Value    : out Long_Integer;
322      Success_Flag : out Boolean)
323   is
324      pragma Unreferenced (Retry_Count);
325
326      function Sync_Fetch_And_And
327        (Ptr   : Address;
328         Value : Long_Integer) return Long_Integer;
329      pragma Import (Intrinsic, Sync_Fetch_And_And, "__sync_fetch_and_and_8");
330
331   begin
332      Old_Value := Sync_Fetch_And_And (To.Value'Address, From);
333      Success_Flag := True;
334   end And_Atomic;
335
336   ---------------
337   -- Or_Atomic --
338   ---------------
339
340   procedure Or_Atomic
341     (To   : in out Aligned_Integer;
342      From : Integer)
343   is
344      procedure Sync_Or_And_Fetch
345        (Ptr   : Address;
346         Value : Integer);
347      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_4");
348
349   begin
350      Sync_Or_And_Fetch (To.Value'Address, From);
351   end Or_Atomic;
352
353   procedure Or_Atomic
354     (To           : in out Aligned_Integer;
355      From         : Integer;
356      Retry_Count  : Natural;
357      Old_Value    : out Integer;
358      Success_Flag : out Boolean)
359   is
360      pragma Unreferenced (Retry_Count);
361
362      function Sync_Fetch_And_Or
363        (Ptr   : Address;
364         Value : Integer) return Integer;
365      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_4");
366
367   begin
368      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
369      Success_Flag := True;
370   end Or_Atomic;
371
372   procedure Or_Atomic
373     (To   : in out Aligned_Long_Integer;
374      From : Long_Integer)
375   is
376      procedure Sync_Or_And_Fetch
377        (Ptr   : Address;
378         Value : Long_Integer);
379      pragma Import (Intrinsic, Sync_Or_And_Fetch, "__sync_or_and_fetch_8");
380   begin
381      Sync_Or_And_Fetch (To.Value'Address, From);
382   end Or_Atomic;
383
384   procedure Or_Atomic
385     (To           : in out Aligned_Long_Integer;
386      From         : Long_Integer;
387      Retry_Count  : Natural;
388      Old_Value    : out Long_Integer;
389      Success_Flag : out Boolean)
390   is
391      pragma Unreferenced (Retry_Count);
392
393      function Sync_Fetch_And_Or
394        (Ptr   : Address;
395         Value : Long_Integer) return Long_Integer;
396      pragma Import (Intrinsic, Sync_Fetch_And_Or, "__sync_fetch_and_or_8");
397
398   begin
399      Old_Value := Sync_Fetch_And_Or (To.Value'Address, From);
400      Success_Flag := True;
401   end Or_Atomic;
402
403   ------------
404   -- Insqhi --
405   ------------
406
407   procedure Insqhi
408     (Item   : Address;
409      Header : Address;
410      Status : out Insq_Status) is
411
412      procedure SYS_PAL_INSQHIL
413        (STATUS : out Integer; Header : Address; ITEM : Address);
414      pragma Import (External, SYS_PAL_INSQHIL);
415      pragma Import_Valued_Procedure (SYS_PAL_INSQHIL, "SYS$PAL_INSQHIL",
416         (Integer, Address, Address),
417         (Value, Value, Value));
418
419      Istat : Integer;
420
421   begin
422      SYS_PAL_INSQHIL (Istat, Header, Item);
423
424      if Istat = 0 then
425         Status := OK_Not_First;
426      elsif Istat = 1 then
427         Status := OK_First;
428
429      else
430         --  This status is never returned on IVMS
431
432         Status := Fail_No_Lock;
433      end if;
434   end Insqhi;
435
436   ------------
437   -- Remqhi --
438   ------------
439
440   procedure Remqhi
441     (Header : Address;
442      Item   : out Address;
443      Status : out Remq_Status)
444   is
445      --  The removed item is returned in the second function return register,
446      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
447      --  these registers, so inventing this odd looking record type makes that
448      --  all work.
449
450      type Remq is record
451         Status : Long_Integer;
452         Item   : Address;
453      end record;
454
455      procedure SYS_PAL_REMQHIL
456        (Remret : out Remq; Header : Address);
457      pragma Import (External, SYS_PAL_REMQHIL);
458      pragma Import_Valued_Procedure
459        (SYS_PAL_REMQHIL, "SYS$PAL_REMQHIL",
460         (Remq, Address),
461         (Value, Value));
462
463      --  Following variables need documentation???
464
465      Rstat  : Long_Integer;
466      Remret : Remq;
467
468   begin
469      SYS_PAL_REMQHIL (Remret, Header);
470
471      Rstat := Remret.Status;
472      Item := Remret.Item;
473
474      if Rstat = 0 then
475         Status := Fail_Was_Empty;
476
477      elsif Rstat = 1 then
478         Status := OK_Not_Empty;
479
480      elsif Rstat = 2 then
481         Status := OK_Empty;
482
483      else
484         --  This status is never returned on IVMS
485
486         Status := Fail_No_Lock;
487      end if;
488
489   end Remqhi;
490
491   ------------
492   -- Insqti --
493   ------------
494
495   procedure Insqti
496     (Item   : Address;
497      Header : Address;
498      Status : out Insq_Status) is
499
500      procedure SYS_PAL_INSQTIL
501        (STATUS : out Integer; Header : Address; ITEM : Address);
502      pragma Import (External, SYS_PAL_INSQTIL);
503      pragma Import_Valued_Procedure (SYS_PAL_INSQTIL, "SYS$PAL_INSQTIL",
504         (Integer, Address, Address),
505         (Value, Value, Value));
506
507      Istat : Integer;
508
509   begin
510      SYS_PAL_INSQTIL (Istat, Header, Item);
511
512      if Istat = 0 then
513         Status := OK_Not_First;
514
515      elsif Istat = 1 then
516         Status := OK_First;
517
518      else
519         --  This status is never returned on IVMS
520
521         Status := Fail_No_Lock;
522      end if;
523   end Insqti;
524
525   ------------
526   -- Remqti --
527   ------------
528
529   procedure Remqti
530     (Header : Address;
531      Item   : out Address;
532      Status : out Remq_Status)
533   is
534      --  The removed item is returned in the second function return register,
535      --  R9 on IVMS. The VMS ABI calls for "small" records to be returned in
536      --  these registers, so inventing (where is rest of this comment???)
537
538      type Remq is record
539         Status : Long_Integer;
540         Item   : Address;
541      end record;
542
543      procedure SYS_PAL_REMQTIL
544        (Remret : out Remq; Header : Address);
545      pragma Import (External, SYS_PAL_REMQTIL);
546      pragma Import_Valued_Procedure (SYS_PAL_REMQTIL, "SYS$PAL_REMQTIL",
547         (Remq, Address),
548         (Value, Value));
549
550      Rstat  : Long_Integer;
551      Remret : Remq;
552
553   begin
554      SYS_PAL_REMQTIL (Remret, Header);
555
556      Rstat := Remret.Status;
557      Item := Remret.Item;
558
559      --  Wouldn't case be nicer here, and in previous similar cases ???
560
561      if Rstat = 0 then
562         Status := Fail_Was_Empty;
563
564      elsif Rstat = 1 then
565         Status := OK_Not_Empty;
566
567      elsif Rstat = 2 then
568         Status := OK_Empty;
569      else
570         --  This status is never returned on IVMS
571
572         Status := Fail_No_Lock;
573      end if;
574   end Remqti;
575
576end System.Aux_DEC;
577