OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [s-gloloc.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT COMPILER COMPONENTS                         --
4
--                                                                          --
5
--                  S Y S T E M . G L O B A L _ L O C K S                   --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1999-2009, 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
with System.Soft_Links;
33
 
34
package body System.Global_Locks is
35
 
36
   type String_Access is access String;
37
 
38
   Dir_Separator : Character;
39
   pragma Import (C, Dir_Separator, "__gnat_dir_separator");
40
 
41
   type Lock_File_Entry is record
42
      Dir  : String_Access;
43
      File : String_Access;
44
   end record;
45
 
46
   Last_Lock  : Lock_Type := Null_Lock;
47
   Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry;
48
 
49
   procedure Lock_File
50
     (Dir     : String;
51
      File    : String;
52
      Wait    : Duration := 0.1;
53
      Retries : Natural  := Natural'Last);
54
   --  Create a lock file File in directory Dir. If the file  cannot be
55
   --  locked because someone already owns the lock, this procedure
56
   --  waits Wait seconds and retries at most Retries times. If the file
57
   --  still cannot be locked, Lock_Error is raised. The default is to try
58
   --  every second, almost forever (Natural'Last times).
59
 
60
   ------------------
61
   -- Acquire_Lock --
62
   ------------------
63
 
64
   procedure Acquire_Lock (Lock : in out Lock_Type) is
65
   begin
66
      Lock_File
67
        (Lock_Table (Lock).Dir.all,
68
         Lock_Table (Lock).File.all);
69
   end Acquire_Lock;
70
 
71
   -----------------
72
   -- Create_Lock --
73
   -----------------
74
 
75
   procedure Create_Lock (Lock : out Lock_Type; Name : String) is
76
      L : Lock_Type;
77
 
78
   begin
79
      System.Soft_Links.Lock_Task.all;
80
      Last_Lock := Last_Lock + 1;
81
      L := Last_Lock;
82
      System.Soft_Links.Unlock_Task.all;
83
 
84
      if L > Lock_Table'Last then
85
         raise Lock_Error;
86
      end if;
87
 
88
      for J in reverse Name'Range loop
89
         if Name (J) = Dir_Separator then
90
            Lock_Table (L).Dir := new String'(Name (Name'First .. J - 1));
91
            Lock_Table (L).File := new String'(Name (J + 1 .. Name'Last));
92
            exit;
93
         end if;
94
      end loop;
95
 
96
      if Lock_Table (L).Dir = null then
97
         Lock_Table (L).Dir  := new String'(".");
98
         Lock_Table (L).File := new String'(Name);
99
      end if;
100
 
101
      Lock := L;
102
   end Create_Lock;
103
 
104
   ---------------
105
   -- Lock_File --
106
   ---------------
107
 
108
   procedure Lock_File
109
     (Dir     : String;
110
      File    : String;
111
      Wait    : Duration := 0.1;
112
      Retries : Natural  := Natural'Last)
113
   is
114
      C_Dir  : aliased String := Dir & ASCII.NUL;
115
      C_File : aliased String := File & ASCII.NUL;
116
 
117
      function Try_Lock (Dir, File : System.Address) return Integer;
118
      pragma Import (C, Try_Lock, "__gnat_try_lock");
119
 
120
   begin
121
      for I in 0 .. Retries loop
122
         if Try_Lock (C_Dir'Address, C_File'Address) = 1 then
123
            return;
124
         end if;
125
 
126
         exit when I = Retries;
127
         delay Wait;
128
      end loop;
129
 
130
      raise Lock_Error;
131
   end Lock_File;
132
 
133
   ------------------
134
   -- Release_Lock --
135
   ------------------
136
 
137
   procedure Release_Lock (Lock : in out Lock_Type) is
138
      S : aliased String :=
139
            Lock_Table (Lock).Dir.all & Dir_Separator &
140
            Lock_Table (Lock).File.all & ASCII.NUL;
141
 
142
      procedure unlink (A : System.Address);
143
      pragma Import (C, unlink, "unlink");
144
 
145
   begin
146
      unlink (S'Address);
147
   end Release_Lock;
148
 
149
end System.Global_Locks;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.