← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to rtl/linux/system.pp

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2005-05-30 11:59:10 UTC
  • mfrom: (1.2.2 upstream)
  • Revision ID: james.westby@ubuntu.com-20050530115910-x5pbzm4qqta4i94h
Tags: 2.0.0-2
http://bugs.debian.org/310907
debian/fp-compiler.postinst.in: forgot to reapply the patch that
correctly creates the slave link to pc(1).  (Closes: #310907)

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/linux/system.pp
1
1
{
2
 
    $Id: system.pp,v 1.14 2004/01/20 23:09:14 hajny Exp $
 
2
    $Id: system.pp,v 1.25 2005/04/24 21:19:22 peter Exp $
3
3
    This file is part of the Free Pascal run time librar~y.
4
4
    Copyright (c) 2000 by Marco van de Voort
5
5
    member of the Free Pascal development team.
25
25
Unit {$ifdef VER1_0}Syslinux{$else}System{$endif};
26
26
 
27
27
Interface
28
 
{$define oldreaddir}
29
 
{$define usedomain}
30
 
{$define posixworkaround}
 
28
 
31
29
{$define FPC_IS_SYSTEM}
32
 
{$ifdef FPC_USE_LIBC}
33
 
{$define usegetcwd}
34
 
{$endif}
 
30
 
 
31
{$i osdefs.inc}
35
32
 
36
33
{$I sysunixh.inc}
37
34
 
38
35
Implementation
39
36
 
40
37
 
41
 
{$ifdef FPC_USE_LIBC}
42
 
 
43
 
const clib = 'c';
44
 
 
45
 
type libcint=longint;
46
 
     plibcint=^libcint;
47
 
 
48
 
function geterrnolocation: Plibcint; cdecl;external clib name'__errno_location';
49
 
 
50
 
function geterrno:libcint; [public, alias: 'FPC_SYS_GETERRNO'];
51
 
 
52
 
begin
53
 
 geterrno:=geterrnolocation^;
54
 
end;
55
 
 
56
 
procedure seterrno(err:libcint); [public, alias: 'FPC_SYS_SETERRNO'];
57
 
begin
58
 
  geterrnolocation^:=err;
59
 
end;
60
 
 
61
 
{$else}
62
 
 
63
 
{$ifdef ver1_0}
64
 
Var
65
 
{$else}
66
 
ThreadVar
67
 
{$endif}
68
 
  Errno : longint;
69
 
 
70
 
function geterrno:longint; [public, alias: 'FPC_SYS_GETERRNO'];
71
 
 
72
 
begin
73
 
 GetErrno:=Errno;
74
 
end;
75
 
 
76
 
procedure seterrno(err:longint); [public, alias: 'FPC_SYS_SETERRNO'];
77
 
 
78
 
begin
79
 
 Errno:=err;
80
 
end;
81
 
{$endif}
82
 
 
83
38
{$I system.inc}
84
39
 
85
 
{ OS dependant parts  }
86
 
 
87
 
{$I errno.inc}                          // error numbers
88
 
{$I bunxtype.inc}                       // c-types, unix base types, unix
89
 
                                        //    base structures
90
 
 
91
 
{*****************************************************************************
92
 
                 Extra cdecl declarations for FPC_USE_LIBC for this os
93
 
*****************************************************************************}
94
 
 
95
 
{$ifdef FPC_USE_LIBC}
96
 
Function fpReadLink(name,linkname:pchar;maxlen:cint):cint;  cdecl; external name 'readlink';
97
 
function fpgetcwd(buf:pchar;_size:size_t):pchar; cdecl; external name 'getcwd';
98
 
{$endif}
99
 
 
100
 
 
101
 
{$I ossysc.inc}                         // base syscalls
102
 
{$I osmain.inc}                         // base wrappers *nix RTL (derivatives)
103
 
 
104
 
{ more OS independant parts}
105
 
 
106
 
{$I text.inc}
107
 
{$I heap.inc}
108
 
 
109
 
{*****************************************************************************
110
 
                 UnTyped File Handling
111
 
*****************************************************************************}
112
 
 
113
 
{$i file.inc}
114
 
 
115
 
{*****************************************************************************
116
 
                 Typed File Handling
117
 
*****************************************************************************}
118
 
 
119
 
{$i typefile.inc}
 
40
 
 
41
{*****************************************************************************
 
42
                       Misc. System Dependent Functions
 
43
*****************************************************************************}
 
44
 
 
45
procedure haltproc(e:longint);cdecl;external name '_haltproc';
 
46
 
 
47
procedure System_exit;
 
48
begin
 
49
  haltproc(ExitCode);
 
50
End;
 
51
 
 
52
 
 
53
Function ParamCount: Longint;
 
54
Begin
 
55
  Paramcount:=argc-1
 
56
End;
 
57
 
 
58
 
 
59
function BackPos(c:char; const s: shortstring): integer;
 
60
var
 
61
 i: integer;
 
62
Begin
 
63
  for i:=length(s) downto 0 do
 
64
    if s[i] = c then break;
 
65
  if i=0 then
 
66
    BackPos := 0
 
67
  else
 
68
    BackPos := i;
 
69
end;
 
70
 
 
71
 
 
72
 { variable where full path and filename and executable is stored }
 
73
 { is setup by the startup of the system unit.                    }
 
74
var
 
75
 execpathstr : shortstring;
 
76
 
 
77
function paramstr(l: longint) : string;
 
78
 begin
 
79
   { stricly conforming POSIX applications  }
 
80
   { have the executing filename as argv[0] }
 
81
   if l=0 then
 
82
     begin
 
83
       paramstr := execpathstr;
 
84
     end
 
85
   else
 
86
     paramstr:=strpas(argv[l]);
 
87
 end;
 
88
 
 
89
Procedure Randomize;
 
90
Begin
 
91
  randseed:=longint(Fptime(nil));
 
92
End;
 
93
 
 
94
 
 
95
{*****************************************************************************
 
96
                         SystemUnit Initialization
 
97
*****************************************************************************}
 
98
 
 
99
function  reenable_signal(sig : longint) : boolean;
 
100
var
 
101
  e : TSigSet;
 
102
  i,j : byte;
 
103
begin
 
104
  fillchar(e,sizeof(e),#0);
 
105
  { set is 1 based PM }
 
106
  dec(sig);
 
107
  i:=sig mod 32;
 
108
  j:=sig div 32;
 
109
  e[j]:=1 shl i;
 
110
  fpsigprocmask(SIG_UNBLOCK,@e,nil);
 
111
  reenable_signal:=geterrno=0;
 
112
end;
 
113
 
 
114
 
 
115
// signal handler is arch dependant due to processorexception to language
 
116
// exception translation
 
117
 
 
118
{$i sighnd.inc}
 
119
 
 
120
var
 
121
  act: SigActionRec;
 
122
 
 
123
Procedure InstallSignals;
 
124
begin
 
125
  { Initialize the sigaction structure }
 
126
  { all flags and information set to zero }
 
127
  FillChar(act, sizeof(SigActionRec),0);
 
128
  { initialize handler                    }
 
129
  act.sa_handler := SigActionHandler(@SignalToRunError);
 
130
  act.sa_flags:=SA_SIGINFO
 
131
{$ifdef cpux86_64}
 
132
    or $4000000
 
133
{$endif cpux86_64}
 
134
    ;
 
135
  FpSigAction(SIGFPE,@act,nil);
 
136
  FpSigAction(SIGSEGV,@act,nil);
 
137
  FpSigAction(SIGBUS,@act,nil);
 
138
  FpSigAction(SIGILL,@act,nil);
 
139
end;
 
140
 
 
141
procedure SetupCmdLine;
 
142
var
 
143
  bufsize,
 
144
  len,j,
 
145
  size,i : longint;
 
146
  found  : boolean;
 
147
  buf    : pchar;
 
148
 
 
149
  procedure AddBuf;
 
150
  begin
 
151
    reallocmem(cmdline,size+bufsize);
 
152
    move(buf^,cmdline[size],bufsize);
 
153
    inc(size,bufsize);
 
154
    bufsize:=0;
 
155
  end;
 
156
 
 
157
begin
 
158
  GetMem(buf,ARG_MAX);
 
159
  size:=0;
 
160
  bufsize:=0;
 
161
  i:=0;
 
162
  while (i<argc) do
 
163
   begin
 
164
     len:=strlen(argv[i]);
 
165
     if len>ARG_MAX-2 then
 
166
      len:=ARG_MAX-2;
 
167
     found:=false;
 
168
     for j:=1 to len do
 
169
      if argv[i][j]=' ' then
 
170
       begin
 
171
         found:=true;
 
172
         break;
 
173
       end;
 
174
     if bufsize+len>=ARG_MAX-2 then
 
175
      AddBuf;
 
176
     if found then
 
177
      begin
 
178
        buf[bufsize]:='"';
 
179
        inc(bufsize);
 
180
      end;
 
181
     move(argv[i]^,buf[bufsize],len);
 
182
     inc(bufsize,len);
 
183
     if found then
 
184
      begin
 
185
        buf[bufsize]:='"';
 
186
        inc(bufsize);
 
187
      end;
 
188
     if i<argc then
 
189
      buf[bufsize]:=' '
 
190
     else
 
191
      buf[bufsize]:=#0;
 
192
     inc(bufsize);
 
193
     inc(i);
 
194
   end;
 
195
  AddBuf;
 
196
  FreeMem(buf,ARG_MAX);
 
197
end;
120
198
 
121
199
 
122
200
procedure SysInitStdIO;
123
201
begin
124
202
  OpenStdIO(Input,fmInput,StdInputHandle);
125
203
  OpenStdIO(Output,fmOutput,StdOutputHandle);
 
204
  OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
126
205
  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
127
206
  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
128
207
end;
130
209
 
131
210
procedure SysInitExecPath;
132
211
var
133
 
  hs   : string[16];
134
 
  link : string;
135
212
  i    : longint;
136
213
begin
137
 
  str(Fpgetpid,hs);
138
 
  hs:='/proc/'+hs+'/exe'#0;
139
 
  i:=Fpreadlink(@hs[1],@link[1],high(link));
 
214
  execpathstr[0]:=#0;
 
215
  i:=Fpreadlink('/proc/self/exe',@execpathstr[1],high(execpathstr));
140
216
  { it must also be an absolute filename, linux 2.0 points to a memory
141
217
    location so this will skip that }
142
 
  if (i>0) and (link[1]='/') then
143
 
   begin
144
 
     link[0]:=chr(i);
145
 
     ExecPathStr:=link;
146
 
   end;
 
218
  if (i>0) and (execpathstr[1]='/') then
 
219
     execpathstr[0]:=char(i);
 
220
end;
 
221
 
 
222
function GetProcessID: SizeUInt;
 
223
begin
 
224
 GetProcessID := SizeUInt (fpGetPID);
147
225
end;
148
226
 
149
227
 
152
230
  IsLibrary := FALSE;
153
231
  StackLength := InitialStkLen;
154
232
  StackBottom := Sptr - StackLength;
155
 
{ Set up signals handlers }
 
233
  { Set up signals handlers }
156
234
  InstallSignals;
157
 
{ Setup heap }
 
235
  { Setup heap }
158
236
  InitHeap;
159
237
  SysInitExceptions;
160
 
{ Arguments }
 
238
  { Arguments }
161
239
  SetupCmdLine;
162
240
  SysInitExecPath;
163
 
{ Setup stdin, stdout and stderr }
 
241
  { Setup stdin, stdout and stderr }
164
242
  SysInitStdIO;
165
 
{ Reset IO Error }
 
243
  { Reset IO Error }
166
244
  InOutRes:=0;
167
 
(* This should be changed to a real value during *)
168
 
(* thread driver initialization if appropriate.  *)
169
 
  ThreadID := 1;
 
245
  { threading }
 
246
  InitSystemThreads;
170
247
{$ifdef HASVARIANT}
171
248
  initvariantmanager;
172
249
{$endif HASVARIANT}
 
250
{$ifdef HASWIDESTRING}
 
251
  initwidestringmanager;
 
252
{$endif HASWIDESTRING}
173
253
End.
174
254
 
175
255
{
176
256
  $Log: system.pp,v $
177
 
  Revision 1.14  2004/01/20 23:09:14  hajny
178
 
    * ExecuteProcess fixes, ProcessID and ThreadID added
179
 
 
180
 
  Revision 1.13  2004/01/01 14:16:55  marco
181
 
   * getcwd missed cdecl
182
 
 
183
 
  Revision 1.12  2003/12/31 20:20:57  marco
184
 
   * small additions for getcwd what we need for FPC_USE_LIBC
185
 
 
186
 
  Revision 1.11  2003/12/30 16:26:10  marco
187
 
   * some more fixes. Testing on idefix
188
 
 
189
 
  Revision 1.10  2003/12/30 15:43:20  marco
190
 
   * linux now compiles with FPC_USE_LIBC
191
 
 
192
 
  Revision 1.9  2003/12/30 12:36:56  marco
193
 
   * FPC_USE_LIBC
194
 
 
195
 
  Revision 1.8  2003/09/14 20:15:01  marco
196
 
   * Unix reform stage two. Remove all calls from Unix that exist in Baseunix.
197
 
 
198
 
  Revision 1.7  2003/04/30 22:11:06  florian
199
 
    + for a lot of x86-64 dependend files mostly dummies added
200
 
 
201
 
  Revision 1.6  2002/12/27 18:36:16  peter
202
 
    * Setup ExecPathStr for ParamStr(0)
203
 
 
204
 
  Revision 1.5  2002/12/18 20:42:29  peter
205
 
    * initial stacklen setup
206
 
 
207
 
  Revision 1.3  2002/12/18 16:44:09  marco
208
 
   * more new RTL
209
 
 
210
 
  Revision 1.7  2002/11/12 14:57:48  marco
211
 
   * Ugly hack to temporarily be able to use system.pp for Linux too
212
 
 
213
 
  Revision 1.6  2002/10/27 11:58:30  marco
214
 
   * Modifications from Saturday.
215
 
 
216
 
  Revision 1.5  2002/10/26 18:27:51  marco
217
 
   * First series POSIX calls commits. Including getcwd.
218
 
 
219
 
  Revision 1.4  2002/10/18 12:19:58  marco
220
 
   * Fixes to get the generic *BSD RTL compiling again + fixes for thread
221
 
     support. Still problems left in fexpand. (inoutres?) Therefore fixed
222
 
     sysposix not yet commited
223
 
 
224
 
  Revision 1.3  2002/10/13 09:25:39  florian
225
 
    + call to initvariantmanager inserted
226
 
 
227
 
  Revision 1.2  2002/09/07 16:01:17  peter
228
 
    * old logs removed and tabs fixed
229
 
 
230
 
  Revision 1.1  2002/08/19 12:29:11  marco
231
 
   * First working POSIX *BSD system unit.
 
257
  Revision 1.25  2005/04/24 21:19:22  peter
 
258
    * unblock signal in signalhandler, remove the sigprocmask call
 
259
      from setjmp
 
260
 
 
261
  Revision 1.24  2005/02/14 17:13:30  peter
 
262
    * truncate log
 
263
 
 
264
  Revision 1.23  2005/02/13 21:47:56  peter
 
265
    * include file cleanup part 2
 
266
 
 
267
  Revision 1.22  2005/02/06 11:20:52  peter
 
268
    * threading in system unit
 
269
    * removed systhrds unit
 
270
 
 
271
  Revision 1.21  2005/02/01 20:22:49  florian
 
272
    * improved widestring infrastructure manager
232
273
 
233
274
}