← Back to branch summary

~ubuntu-branches/debian/lenny/fpc/lenny

« back to all changes in this revision

Viewing changes to rtl/beos/system.pp

  • Committer: Bazaar Package Importer
  • Author(s): Mazen Neifer, Torsten Werner, Mazen Neifer
  • Date: 2008-05-17 17:12:11 UTC
  • mfrom: (3.1.9 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080517171211-9qi33xhd9evfa0kg
Tags: 2.2.0-dfsg1-9
http://bugs.debian.org/477743
[ Torsten Werner ]
* Add Mazen Neifer to Uploaders field.

[ Mazen Neifer ]
* Moved FPC sources into a version dependent directory from /usr/share/fpcsrc
  to /usr/share/fpcsrc/${FPCVERSION}. This allow installing more than on FPC
  release.
* Fixed far call issue in compiler preventing building huge binearies.
  (closes: #477743)
* Updated building dependencies, recomennded and suggested packages.
* Moved fppkg to fp-utils as it is just a helper tool and is not required by
  compiler.

Show diffs side-by-side

added added

removed removed

Lines of Context:
rtl/beos/system.pp
1
 
{
2
 
    $Id: system.pp,v 1.12 2004/04/22 21:10:56 peter Exp $
3
 
    This file is part of the Free Pascal run time library.
4
 
    Copyright (c) 1999-2000 by the Free Pascal development team.
5
 
 
6
 
    This is a prototype file to show all function that need to be implemented
7
 
    for a new operating system (provided the processor specific
8
 
    function are already implemented !)
9
 
 
10
 
    See the file COPYING.FPC, included in this distribution,
11
 
    for details about the copyright.
12
 
 
13
 
    This program is distributed in the hope that it will be useful,
14
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
15
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
16
 
 
17
 
 **********************************************************************}
18
 
{ no stack check in system }
19
 
 
20
 
{$DEFINE SHORT_LINEBREAK}
21
 
{$S-}
22
 
unit System;
23
 
 
24
 
interface
25
 
 
26
 
{ include system-independent routine headers }
27
 
 
28
 
{$I systemh.inc}
29
 
 
30
 
type
31
 
 THandle = longint;
32
 
 
33
 
{ include heap support headers }
34
 
 
35
 
{$I heaph.inc}
36
 
 
37
 
{Platform specific information}
38
 
const
39
 
 LineEnding = #10;
40
 
 LFNSupport = true;
41
 
 DirectorySeparator = '/';
42
 
 DriveSeparator = ':';
43
 
 PathSeparator = ':';
44
 
{ FileNameCaseSensitive is defined separately below!!! }
45
 
 
46
 
const
47
 
  FileNameCaseSensitive : boolean = true;
48
 
 
49
 
  sLineBreak : string[1] = LineEnding;
50
 
  DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsLF;
51
 
 
52
 
var
53
 
  argc : longint;
54
 
  argv : ppchar;
55
 
  envp : ppchar;
56
 
  errno : longint;              // MvdV: yuckie
57
 
 
58
 
  UnusedHandle:longint;
59
 
  StdInputHandle:longint;
60
 
  StdOutputHandle:longint;
61
 
  StdErrorHandle:longint;
62
 
 
63
 
implementation
64
 
 
65
 
{$I sysfiles.inc}
66
 
 
67
 
function sys_unlink (a:cardinal;name:pchar):longint; cdecl; external name 'sys_unlink';
68
 
function sys_rename (a:cardinal;p1:pchar;b:cardinal;p2:pchar):longint; cdecl; external name 'sys_rename';
69
 
function sys_create_area (name:pchar; var start:pointer; a,b,c,d:longint):longint; cdecl; external name 'sys_create_area';
70
 
function sys_resize_area (handle:cardinal; size:longint):longint; cdecl; external name 'sys_resize_area';
71
 
function sys_mkdir (a:cardinal; name:pchar; mode:cardinal):longint; cdecl; external name 'sys_mkdir';
72
 
function sys_chdir (a:cardinal; name:pchar):longint; cdecl; external name 'sys_chdir';
73
 
function sys_rmdir (a:cardinal; name:pchar):longint; cdecl; external name 'sys_rmdir';
74
 
 
75
 
{$I system.inc}
76
 
 
77
 
 
78
 
{*****************************************************************************
79
 
                         System Dependent Exit code
80
 
*****************************************************************************}
81
 
procedure prthaltproc;external name '_haltproc';
82
 
 
83
 
procedure system_exit;
84
 
begin
85
 
  asm
86
 
    jmp prthaltproc
87
 
  end;
88
 
End;
89
 
 
90
 
{*****************************************************************************
91
 
                         Stack check code
92
 
*****************************************************************************}
93
 
{ cheking the stack is done system independend in 1.1
94
 
procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
95
 
{
96
 
  called when trying to get local stack if the compiler directive $S
97
 
  is set this function must preserve esi !!!! because esi is set by
98
 
  the calling proc for methods it must preserve all registers !!
99
 
 
100
 
  With a 2048 byte safe area used to write to StdIo without crossing
101
 
  the stack boundary
102
 
}
103
 
begin
104
 
end;
105
 
}
106
 
 
107
 
{*****************************************************************************
108
 
                              ParamStr/Randomize
109
 
*****************************************************************************}
110
 
 
111
 
{ number of args }
112
 
function paramcount : longint;
113
 
begin
114
 
  paramcount := argc - 1;
115
 
end;
116
 
 
117
 
{ argument number l }
118
 
function paramstr(l : longint) : string;
119
 
begin
120
 
  if (l>=0) and (l+1<=argc) then
121
 
   paramstr:=strpas(argv[l])
122
 
  else
123
 
   paramstr:='';
124
 
end;
125
 
 
126
 
{ set randseed to a new pseudo random value }
127
 
procedure randomize;
128
 
begin
129
 
  {regs.realeax:=$2c00;
130
 
  sysrealintr($21,regs);
131
 
  hl:=regs.realedx and $ffff;
132
 
  randseed:=hl*$10000+ (regs.realecx and $ffff);}
133
 
  randseed:=0;
134
 
end;
135
 
 
136
 
{*****************************************************************************
137
 
                              Heap Management
138
 
*****************************************************************************}
139
 
 
140
 
var myheapstart:pointer;
141
 
    myheapsize:longint;
142
 
    myheaprealsize:longint;
143
 
    heap_handle:longint;
144
 
    zero:longint;
145
 
 
146
 
{ first address of heap }
147
 
function getheapstart:pointer;
148
 
begin
149
 
   getheapstart:=myheapstart;
150
 
end;
151
 
 
152
 
{ current length of heap }
153
 
function getheapsize:longint;
154
 
begin
155
 
   getheapsize:=myheapsize;
156
 
end;
157
 
 
158
 
{ function to allocate size bytes more for the program }
159
 
{ must return the first address of new data space or nil if fail }
160
 
function Sbrk(size : longint):pointer;
161
 
var newsize,newrealsize:longint;
162
 
begin
163
 
  if (myheapsize+size)<=myheaprealsize then begin
164
 
    Sbrk:=myheapstart+myheapsize;
165
 
    myheapsize:=myheapsize+size;
166
 
    exit;
167
 
  end;
168
 
  newsize:=myheapsize+size;
169
 
  newrealsize:=(newsize and $FFFFF000)+$1000;
170
 
  if sys_resize_area(heap_handle,newrealsize)=0 then begin
171
 
        Sbrk:=myheapstart+myheapsize;
172
 
        myheapsize:=newsize;
173
 
        myheaprealsize:=newrealsize;
174
 
        exit;
175
 
  end;
176
 
  Sbrk:=nil;
177
 
end;
178
 
 
179
 
 
180
 
{ include standard heap management }
181
 
{$I heap.inc}
182
 
 
183
 
 
184
 
{****************************************************************************
185
 
                        Low level File Routines
186
 
       All these functions can set InOutRes on errors
187
 
 ****************************************************************************}
188
 
 
189
 
 
190
 
 
191
 
{ close a file from the handle value }
192
 
procedure do_close(handle : longint);
193
 
begin
194
 
{  writeln ('CLOSE ',handle);}
195
 
  if handle<=2 then exit;
196
 
  InOutRes:=sys_close(handle);
197
 
end;
198
 
 
199
 
 
200
 
procedure do_erase(p : pchar);
201
 
begin
202
 
  if sys_unlink($FF000000,p)<>0 then InOutRes:=1
203
 
  else InOutRes:=0;
204
 
end;
205
 
 
206
 
procedure do_rename(p1,p2 : pchar);
207
 
begin
208
 
  InOutRes:=sys_rename($FF000000,p1,$FF000000,p2);
209
 
end;
210
 
 
211
 
function do_write(h:longint;addr:pointer;len : longint) : longint;
212
 
begin
213
 
{  if h>0 then begin
214
 
    sys_write ('WRITE handle=%d ',h);
215
 
    printf ('addr=%x ',addr);
216
 
    printf ('len=%d',len);
217
 
    printf ('%c',10);
218
 
  end;}
219
 
  do_write:=sys_write (h,addr,len,zero);
220
 
  if (do_write<0) then begin
221
 
    InOutRes:=do_write;
222
 
    do_write:=0;
223
 
  end else InOutRes:=0;
224
 
end;
225
 
 
226
 
function do_read(h:longint;addr:pointer;len : longint) : longint;
227
 
begin
228
 
{  if h>2 then begin
229
 
    printf ('READ handle=%d ',h);
230
 
    printf ('addr=%x ',addr);
231
 
    printf ('len=%d',len);
232
 
  end;}
233
 
  do_read:=sys_read (h,addr,len,zero);
234
 
  if (do_read<0) then begin
235
 
    InOutRes:=do_read;
236
 
    do_read:=0;
237
 
  end else InOutRes:=0;
238
 
end;
239
 
 
240
 
function do_filepos(handle : longint) : longint;
241
 
begin
242
 
  do_filepos:=sys_lseek(handle,0,1); {1=SEEK_CUR}
243
 
  if (do_filepos<0) then begin
244
 
    InOutRes:=do_filepos;
245
 
    do_filepos:=0;
246
 
  end else InOutRes:=0;
247
 
end;
248
 
 
249
 
procedure do_seek(handle,pos : longint);
250
 
begin
251
 
  InOutRes:=sys_lseek(handle,pos,0);
252
 
  if InOutRes>0 then InOutRes:=0;
253
 
end;
254
 
 
255
 
function do_seekend(handle:longint):longint;
256
 
begin
257
 
  do_seekend:=sys_lseek (handle,0,2); {2=SEEK_END}
258
 
  if do_seekend<0 then begin
259
 
    InOutRes:=do_seekend;
260
 
    do_seekend:=0;
261
 
  end else InOutRes:=0;
262
 
end;
263
 
 
264
 
function do_filesize(handle : longint) : longint;
265
 
var cur:longint;
266
 
begin
267
 
  cur:=sys_lseek (handle,0,1); {1=SEEK_CUR}
268
 
  if cur<0 then begin
269
 
    InOutRes:=cur;
270
 
    do_filesize:=0;
271
 
    exit;
272
 
  end;
273
 
  do_filesize:=sys_lseek (handle,0,2); {2=SEEK_END}
274
 
  if do_filesize<0 then begin
275
 
    InOutRes:=do_filesize;
276
 
    do_filesize:=0;
277
 
    exit;
278
 
  end;
279
 
  cur:=sys_lseek (handle,cur,0); {0=SEEK_POS}
280
 
  if cur<0 then begin
281
 
    InOutRes:=cur;
282
 
    do_filesize:=0;
283
 
    exit;
284
 
  end;
285
 
end;
286
 
 
287
 
{ truncate at a given position }
288
 
procedure do_truncate (handle,pos:longint);
289
 
begin
290
 
  InOutRes:=1;
291
 
end;
292
 
 
293
 
procedure do_open(var f;p:pchar;flags:longint);
294
 
{
295
 
  filerec and textrec have both handle and mode as the first items so
296
 
  they could use the same routine for opening/creating.
297
 
  when (flags and $100)   the file will be append
298
 
  when (flags and $1000)  the file will be truncate/rewritten
299
 
  when (flags and $10000) there is no check for close (needed for textfiles)
300
 
}
301
 
var m:longint;
302
 
    mode,h:longint;
303
 
begin
304
 
{  printf ('OPEN %d ',longint(f));
305
 
  printf (' %s',longint(p));
306
 
  printf (' %x',flags);}
307
 
 
308
 
  m:=0;
309
 
  case (flags and $3) of
310
 
        $0: begin m:=m or O_RDONLY; mode:=fminput;  end;
311
 
        $1: begin m:=m or O_WRONLY; mode:=fmoutput;end;
312
 
        $2: begin m:=m or O_RDWR; mode:=fminout; end;
313
 
  end;
314
 
 
315
 
  if (flags and $100)<>0 then m:=m or O_APPEND;
316
 
  if (flags and $1000)<>0 then m:=m or O_TRUNC or O_CREAT;
317
 
 
318
 
{  if (flags and $10000)<>0 then m:=m or O_TEXT else m:=m or O_BINARY;}
319
 
 
320
 
  h:=sys_open($FF000000,p,m,0,0);
321
 
 
322
 
  if h<0 then InOutRes:=h
323
 
  else InOutRes:=0;
324
 
 
325
 
  if InOutRes=0 then begin
326
 
    FileRec(f).handle:=h;
327
 
    FileRec(f).mode:=mode;
328
 
  end;
329
 
end;
330
 
 
331
 
function do_isdevice(handle:longint):boolean;
332
 
begin
333
 
  do_isdevice:=false;
334
 
  InOutRes:=0;
335
 
end;
336
 
 
337
 
 
338
 
{*****************************************************************************
339
 
                           UnTyped File Handling
340
 
*****************************************************************************}
341
 
 
342
 
{$i file.inc}
343
 
 
344
 
{*****************************************************************************
345
 
                           Typed File Handling
346
 
*****************************************************************************}
347
 
 
348
 
{$i typefile.inc}
349
 
 
350
 
{*****************************************************************************
351
 
                           Text File Handling
352
 
*****************************************************************************}
353
 
 
354
 
{ should we consider #26 as the  end of a file ? }
355
 
{?? $DEFINE EOF_CTRLZ}
356
 
 
357
 
{$i text.inc}
358
 
 
359
 
{*****************************************************************************
360
 
                           Directory Handling
361
 
*****************************************************************************}
362
 
procedure mkdir(const s : string);[IOCheck];
363
 
var t:string;
364
 
begin
365
 
  t:=s+#0;
366
 
  InOutRes:=sys_mkdir ($FF000000,@t[1],493);
367
 
end;
368
 
 
369
 
procedure rmdir(const s : string);[IOCheck];
370
 
var t:string;
371
 
begin
372
 
  t:=s+#0;
373
 
  InOutRes:=sys_rmdir ($FF000000,@t[1]);
374
 
end;
375
 
 
376
 
procedure chdir(const s : string);[IOCheck];
377
 
var t:string;
378
 
begin
379
 
  t:=s+#0;
380
 
  InOutRes:=sys_chdir ($FF000000,@t[1]);
381
 
end;
382
 
 
383
 
{*****************************************************************************
384
 
                             getdir procedure
385
 
*****************************************************************************}
386
 
type dirent = packed record
387
 
        d_dev:longint;
388
 
        d_pdev:longint;
389
 
        d_ino:int64;
390
 
        d_pino:int64;
391
 
        d_reclen:word;
392
 
        d_name:array[0..255] of char;
393
 
  end;
394
 
 
395
 
    stat = packed record
396
 
      dev:longint;     {"device" that this file resides on}
397
 
      ino:int64;       {this file's inode #, unique per device}
398
 
      mode:dword;      {mode bits (rwx for user, group, etc)}
399
 
      nlink:longint;   {number of hard links to this file}
400
 
      uid:dword;       {user id of the owner of this file}
401
 
      gid:dword;       {group id of the owner of this file}
402
 
      size:int64;      {size of this file (in bytes)}
403
 
      rdev:longint;    {device type (not used)}
404
 
      blksize:longint; {preferref block size for i/o}
405
 
      atime:longint;   {last access time}
406
 
      mtime:longint;   {last modification time}
407
 
      ctime:longint;   {last change time, not creation time}
408
 
      crtime:longint;  {creation time}
409
 
    end;
410
 
    pstat = ^stat;
411
 
 
412
 
function sys_stat (a:cardinal;path:pchar;info:pstat;n:longint):longint; cdecl; external name 'sys_stat';
413
 
 
414
 
function FStat(Path:String;Var Info:stat):Boolean;
415
 
{
416
 
  Get all information on a file, and return it in Info.
417
 
}
418
 
var tmp:string;
419
 
var p:pchar;
420
 
begin
421
 
  tmp:=path+#0;
422
 
  p:=@tmp[1];
423
 
  FStat:=(sys_stat($FF000000,p,@Info,0)=0);
424
 
end;
425
 
 
426
 
 
427
 
function sys_opendir (a:cardinal;path:pchar;b:longint):longint; cdecl; external name 'sys_opendir';
428
 
function sys_readdir (fd:longint;var de:dirent;a:longint;b:byte):longint; cdecl; external name 'sys_readdir';
429
 
 
430
 
function parentdir(fd:longint;dev:longint;ino:int64;var err:longint):string;
431
 
var len:longint;
432
 
    ent:dirent;
433
 
    name:string;
434
 
begin
435
 
  err:=0;
436
 
  parentdir:='';
437
 
  if sys_readdir(fd,ent,$11C,1)=0 then begin
438
 
    err:=1;
439
 
    exit;
440
 
  end;
441
 
 
442
 
  len:=StrLen(@ent.d_name);
443
 
  Move(ent.d_name,name[1],len);
444
 
  name[0]:=chr(len);
445
 
{  writeln ('NAME: "',name,'" = ',ent.d_dev,',',ent.d_ino);}
446
 
  if (dev=ent.d_dev) and (ino=ent.d_ino) then begin
447
 
    err:=0;
448
 
    parentdir:='/'+name;
449
 
    exit;
450
 
  end;
451
 
 
452
 
  err:=0;
453
 
end;
454
 
 
455
 
 
456
 
function getdir2:string;
457
 
var tmp:string;
458
 
    info:stat;
459
 
    info2:stat;
460
 
    fd:longint;
461
 
    name:string;
462
 
        cur:string;
463
 
        res:string;
464
 
        err:longint;
465
 
begin
466
 
  res:='';
467
 
  cur:='';
468
 
 
469
 
  repeat
470
 
 
471
 
  FStat(cur+'.',info);
472
 
  FStat(cur+'..',info2);
473
 
{  writeln ('"." = ',info.dev,',',info.ino);}
474
 
  if ((info.dev=info2.dev) and (info.ino=info2.ino)) then begin
475
 
    if res='' then getdir2:='/' else getdir2:=res;
476
 
    exit;
477
 
  end;
478
 
 
479
 
  tmp:=cur+'..'+#0;
480
 
  fd:=sys_opendir ($FF000000,@tmp[1],0);
481
 
  repeat
482
 
    name:=parentdir(fd,info.dev,info.ino,err);
483
 
  until (err<>0) or (name<>'');
484
 
  if err<>0 then begin
485
 
    getdir2:='';
486
 
    exit;
487
 
  end;
488
 
  res:=name+res;
489
 
{  writeln(res);}
490
 
  cur:=cur+'../';
491
 
  until false;
492
 
end;
493
 
 
494
 
procedure getdir(drivenr : byte;var dir : shortstring);
495
 
begin
496
 
  drivenr:=0;
497
 
  dir:=getdir2;
498
 
end;
499
 
 
500
 
 
501
 
{*****************************************************************************
502
 
                         SystemUnit Initialization
503
 
*****************************************************************************}
504
 
 
505
 
procedure SysInitStdIO;
506
 
begin
507
 
  { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
508
 
    displayed in and messagebox }
509
 
  StdInputHandle:=0;
510
 
  StdOutputHandle:=1;
511
 
  StdErrorHandle:=2;
512
 
  OpenStdIO(Input,fmInput,StdInputHandle);
513
 
  OpenStdIO(Output,fmOutput,StdOutputHandle);
514
 
  OpenStdIO(StdOut,fmOutput,StdOutputHandle);
515
 
  OpenStdIO(StdErr,fmOutput,StdErrorHandle);
516
 
end;
517
 
 
518
 
begin
519
 
{ Setup heap }
520
 
  zero:=0;
521
 
  myheapsize:=$2000;
522
 
  myheaprealsize:=$2000;
523
 
  myheapstart:=nil;
524
 
  heap_handle:=sys_create_area('fpcheap',myheapstart,0,myheaprealsize,0,3);//!!
525
 
  if heap_handle>0 then begin
526
 
    InitHeap;
527
 
  end else system_exit;
528
 
  SysInitExceptions;
529
 
 
530
 
{ Setup IO }
531
 
  SysInitStdIO;
532
 
 
533
 
{ Reset IO Error }
534
 
  InOutRes:=0;
535
 
(* This should be changed to a real value during *)
536
 
(* thread driver initialization if appropriate.  *)
537
 
  ThreadID := 1;
538
 
{$ifdef HASVARIANT}
539
 
  initvariantmanager;
540
 
{$endif HASVARIANT}
541
 
end.
542
 
{
543
 
  $Log: system.pp,v $
544
 
  Revision 1.12  2004/04/22 21:10:56  peter
545
 
    * do_read/do_write addr argument changed to pointer
546
 
 
547
 
  Revision 1.11  2004/01/20 23:09:14  hajny
548
 
    * ExecuteProcess fixes, ProcessID and ThreadID added
549
 
 
550
 
  Revision 1.10  2003/10/25 23:42:35  hajny
551
 
    * THandle in sysutils common using System.THandle
552
 
 
553
 
  Revision 1.9  2003/09/27 11:52:35  peter
554
 
    * sbrk returns pointer
555
 
 
556
 
  Revision 1.8  2003/01/08 22:32:28  marco
557
 
   * Small fixes and quick merge with 1.0.x. At least the compiler builds now,
558
 
      but it could crash hard, since there are lots of unimplemented funcs.
559
 
 
560
 
  Revision 1.7  2003/01/05 20:22:24  florian
561
 
    - removed stack check, it's system independend in 1.1
562
 
 
563
 
  Revision 1.6  2003/01/05 20:06:30  florian
564
 
    + fixed missing SysInitStdIO
565
 
 
566
 
  Revision 1.5  2002/10/13 09:25:31  florian
567
 
    + call to initvariantmanager inserted
568
 
 
569
 
  Revision 1.4  2002/09/07 16:01:17  peter
570
 
    * old logs removed and tabs fixed
571
 
 
572
 
}
 
 
b'\\ No newline at end of file'