paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 20:29:24 +02:00
Code Issues Packages Projects Releases Wiki Activity

* sbrk returns pointer

Browse Source
This commit is contained in:
peter 2003-09-27 11:52:35 +00:00
parent 3bf916415a
commit 3d8d9c96f8
16 changed files with 212 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
rtl/amiga/system.pas
View File

@ -914,7 +914,7 @@ end ['D0'];
{ This routine is used to grow the heap. }
{ But here we do a trick, we say that the }
{ heap cannot be regrown! }
function sbrk( size: longint): longint;
function sbrk( size: longint): pointer;
var
{ on exit -1 = if fails. }
p: longint;
@ -925,13 +925,13 @@ end ['D0'];
if pointerlist[8] <> 0 then
begin
{ yes, then don't allocate and simply exit }
sbrk:=-1;
sbrk:=nil;
exit;
end;
{ Allocate best available memory }
p:=AllocVec(size,0);
if p = 0 then
sbrk:=-1
sbrk:=nil
else
Begin
i:=1;
@ -940,7 +940,7 @@ end ['D0'];
while (i < 8) and (pointerlist[i] <> 0) do
i:=i+1;
pointerlist[i]:=p;
sbrk:=p;
sbrk:=pointer(p);
end;
end;
@ -1826,7 +1826,10 @@ end.
{
$Log$
Revision 1.6 2002-10-20 12:00:52 carl
Revision 1.7 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.6 2002/10/20 12:00:52 carl
- remove objinc.inc (unused file)
* update makefiles accordingly

11
rtl/atari/system.pas
View File

@ -259,10 +259,10 @@ end ['D0'];
{ This routine is used to grow the heap. }
{ But here we do a trick, we say that the }
{ heap cannot be regrown! }
function sbrk( size: longint): longint;
{ on exit -1 = if fails. }
function sbrk( size: longint): pointer;
{ on exit nil = if fails. }
Begin
sbrk:=-1;
sbrk:=nil;
end;
{$I heap.inc}
@ -758,7 +758,10 @@ end.
{
$Log$
Revision 1.6 2002-10-20 12:00:52 carl
Revision 1.7 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.6 2002/10/20 12:00:52 carl
- remove objinc.inc (unused file)
* update makefiles accordingly

21
rtl/beos/system.pp
View File

@ -63,7 +63,7 @@ implementation
function sys_unlink (a:cardinal;name:pchar):longint; cdecl; external name 'sys_unlink';
function sys_rename (a:cardinal;p1:pchar;b:cardinal;p2:pchar):longint; cdecl; external name 'sys_rename';
function sys_create_area (name:pchar; var start:longint; a,b,c,d:longint):longint; cdecl; external name 'sys_create_area';
function sys_create_area (name:pchar; var start:pointer; a,b,c,d:longint):longint; cdecl; external name 'sys_create_area';
function sys_resize_area (handle:cardinal; size:longint):longint; cdecl; external name 'sys_resize_area';
function sys_mkdir (a:cardinal; name:pchar; mode:cardinal):longint; cdecl; external name 'sys_mkdir';
function sys_chdir (a:cardinal; name:pchar):longint; cdecl; external name 'sys_chdir';
@ -134,7 +134,7 @@ end;
Heap Management
*****************************************************************************}
var myheapstart:longint;
var myheapstart:pointer;
myheapsize:longint;
myheaprealsize:longint;
heap_handle:longint;
@ -143,7 +143,7 @@ var myheapstart:longint;
{ first address of heap }
function getheapstart:pointer;
begin
getheapstart:=pointer(myheapstart);
getheapstart:=myheapstart;
end;
{ current length of heap }
@ -153,8 +153,8 @@ begin
end;
{ function to allocate size bytes more for the program }
{ must return the first address of new data space or -1 if fail }
function Sbrk(size : longint):longint;
{ must return the first address of new data space or nil if fail }
function Sbrk(size : longint):pointer;
var newsize,newrealsize:longint;
begin
if (myheapsize+size)<=myheaprealsize then begin
@ -170,7 +170,7 @@ begin
myheaprealsize:=newrealsize;
exit;
end;
Sbrk:=-1;
Sbrk:=nil;
end;
@ -517,8 +517,8 @@ begin
zero:=0;
myheapsize:=$2000;
myheaprealsize:=$2000;
myheapstart:=0;
heap_handle:=sys_create_area('fpcheap',myheapstart,0,myheaprealsize,0,3);
myheapstart:=nil;
heap_handle:=sys_create_area('fpcheap',myheapstart,0,myheaprealsize,0,3);//!!
if heap_handle>0 then begin
InitHeap;
end else system_exit;
@ -535,7 +535,10 @@ begin
end.
{
$Log$
Revision 1.8 2003-01-08 22:32:28 marco
Revision 1.9 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.8 2003/01/08 22:32:28 marco
* Small fixes and quick merge with 1.0.x. At least the compiler builds now,
but it could crash hard, since there are lots of unimplemented funcs.

11
rtl/emx/system.pas
View File

@ -295,10 +295,10 @@ end;
{ this function allows to extend the heap by calling
syscall $7f00 resizes the brk area}
function sbrk(size:longint):longint;
function sbrk(size:longint):pointer;
{$IFDEF DUMPGROW}
var
L: longint;
L: longword;
begin
WriteLn ('Trying to grow heap by ', Size, ' to ', HeapSize + Size);
{$IFDEF CONTHEAP}
@ -311,7 +311,7 @@ begin
mov %eax,L
end;
WriteLn ('New heap at ', L);
Sbrk := L;
Sbrk := pointer(L);
end;
{$ELSE DUMPGROW}
assembler;
@ -1241,7 +1241,10 @@ begin
end.
{
$Log$
Revision 1.6 2003-09-24 11:13:09 yuri
Revision 1.7 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.6 2003/09/24 11:13:09 yuri
* Cosmetic changes
* Slightly improved emx.pas

9
rtl/go32v2/system.pp
View File

@ -846,12 +846,12 @@ end;
function ___sbrk(size:longint):longint;cdecl;external name '___sbrk';
function Sbrk(size : longint):longint;assembler;
function Sbrk(size : longint):pointer;assembler;
asm
{$ifdef SYSTEMDEBUG}
cmpb $1,accept_sbrk
je .Lsbrk
movl $-1,%eax
movl $0,%eax
jmp .Lsbrk_fail
.Lsbrk:
{$endif}
@ -1494,7 +1494,10 @@ Begin
End.
{
$Log$
Revision 1.23 2002-10-14 19:39:16 peter
Revision 1.24 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.23 2002/10/14 19:39:16 peter
* threads unit added for thread support
Revision 1.22 2002/10/13 09:28:44 florian

7
rtl/go32v2/v2prt0.as
View File

@ -481,7 +481,7 @@ brk_nochange: /* successful return */
brk_error: /* error return */
movl __what_we_return_to_app_as_old_size, %eax
movl %eax, __what_size_app_thinks_it_is
movl $-1, %eax
movl $0, %eax
brk_return:
popl %ebx
@ -935,7 +935,10 @@ ___PROXY_LEN:
/*
$Log$
Revision 1.6 2002-09-08 09:16:15 jonas
Revision 1.7 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.6 2002/09/08 09:16:15 jonas
* added closing of comment for logs to avoid warning
Revision 1.5 2002/09/07 16:01:19 peter

25
rtl/inc/heap.inc
View File

@ -1132,8 +1132,8 @@ end;
function growheap(size : SizeInt) : integer;
var
sizeleft,s1,
NewPos : SizeInt;
sizeleft,s1 : longword;
NewPos : pointer;
pcurr : pfreerecord;
begin
{$ifdef DUMPGROW}
@ -1146,7 +1146,7 @@ begin
if size<=GrowHeapSize1 then
begin
NewPos:=Sbrk(GrowHeapSize1);
if NewPos>=0 then
if NewPos<>nil then
size:=GrowHeapSize1;
end
else
@ -1154,17 +1154,17 @@ begin
if size<=GrowHeapSize2 then
begin
NewPos:=Sbrk(GrowHeapSize2);
if NewPos>=0 then
if NewPos<>nil then
size:=GrowHeapSize2;
end
{ else alloate the needed bytes }
else
NewPos:=SBrk(size);
{ try again }
if NewPos<0 then
if NewPos=nil then
begin
NewPos:=Sbrk(size);
if NewPos<0 then
if NewPos<>nil then
begin
if ReturnNilIfGrowHeapFails then
GrowHeap:=1
@ -1174,9 +1174,9 @@ begin
end;
end;
{ increase heapend or add to freelist }
if heapend=pointer(newpos) then
if heapend=newpos then
begin
heapend:=pointer(newpos+size);
heapend:=newpos+size;
end
else
begin
@ -1200,8 +1200,8 @@ begin
{$endif SYSTEMDEBUG}
end;
{ now set the new heapptr,heapend to the new block }
heapptr:=pointer(newpos);
heapend:=pointer(newpos+size);
heapptr:=newpos;
heapend:=newpos+size;
end;
{ set the total new heap size }
inc(internal_memavail,size);
@ -1265,7 +1265,10 @@ end;
{
$Log$
Revision 1.21 2003-05-23 14:53:48 peter
Revision 1.22 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.21 2003/05/23 14:53:48 peter
* check newpos < 0 instead of = -1
Revision 1.20 2003/05/01 08:05:23 florian

12
rtl/linux/ossysc.inc
View File

@ -380,12 +380,11 @@ begin
Fpmunmap:=do_syscall(syscall_nr_munmap,TSysParam(Adr),TSysParam(Len));
end;
Function sbrk(size : longint) : longint;
Function sbrk(size : longint) : pointer;
begin
sbrk:=longint(Fpmmap(0,Size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
if sbrk<>-1 then
sbrk:=pointer(Fpmmap(0,Size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
if sbrk<>nil then
errno:=0;
{! It must be -1, not 0 as before, see heap.inc. Should be in sysmmap?}
end;
{
@ -454,7 +453,10 @@ end;
{
$Log$
Revision 1.5 2003-09-15 20:29:50 marco
Revision 1.6 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.5 2003/09/15 20:29:50 marco
* small fix
Revision 1.4 2003/09/14 20:15:01 marco

74
rtl/macos/system.pp
View File

@ -50,7 +50,7 @@ var
implementation
{$define MACOS_USE_STDCLIB}
{ include system independent routines }
{$I system.inc}
@ -61,7 +61,7 @@ implementation
ensure it is a supported version. }
{Below is some MacOS API routines needed for internal use.
Note, because the System unit is the most low level, it should not
Note, because the System unit is the most low level, it should not
depend on any other units, and in particcular not the MacOS unit.
Note: Types like Mac_XXX corresponds to the type XXX defined
@ -94,8 +94,8 @@ const
fsFromStart = 1;
fsFromLEOF = 2;
function NewPtr(logicalSize: Longint): Mac_Ptr ;
external 'InterfaceLib';
function Sbrk(logicalSize: Longint): Mac_Ptr ;
external 'InterfaceLib' name 'NewPtr';
procedure DisposeHandle(hdl: Mac_Handle);
external 'InterfaceLib';
@ -164,15 +164,15 @@ external 'InterfaceLib';
{The reason StdCLib is used is that it can easily be connected
to either SIOW or, in case of MPWTOOL, to MPW }
{The prefix C_ or c_ is used where names conflicts with pascal
{The prefix C_ or c_ is used where names conflicts with pascal
keywords and names. Suffix Ptr is added for pointer to a type.}
type
size_t = Longint;
off_t = Longint;
C_int = Longint;
C_short = Integer;
C_long = Longint;
C_short = Integer;
C_long = Longint;
C_unsigned_int = Cardinal;
var
@ -204,16 +204,16 @@ const
FIOINTERACTIVE = $00006602; // If device is interactive
FIOBUFSIZE = $00006603; // Return optimal buffer size
FIOFNAME = $00006604; // Return filename
FIOREFNUM = $00006605; // Return fs refnum
FIOSETEOF = $00006606; // Set file length
FIOFNAME = $00006604; // Return filename
FIOREFNUM = $00006605; // Return fs refnum
FIOSETEOF = $00006606; // Set file length
TIOFLUSH = $00007408; // discard unread input. arg is ignored
TIOFLUSH = $00007408; // discard unread input. arg is ignored
function C_open(path: PChar; oflag: C_int): C_int;
external 'StdCLib' name 'open';
function C_close(filedes: C_int): C_int;
function C_close(filedes: C_int): C_int;
external 'StdCLib' name 'close';
function C_write(filedes: C_int; buf: pointer; nbyte: size_t): size_t;
@ -354,7 +354,7 @@ end;
*****************************************************************************}
var
{ Pointer to a block allocated with the MacOS Memory Manager, which
{ Pointer to a block allocated with the MacOS Memory Manager, which
is used as the initial FPC heap. }
theHeap: Mac_Ptr;
intern_heapsize : longint;external name 'HEAPSIZE';
@ -371,21 +371,6 @@ begin
getheapsize:= intern_heapsize ;
end;
{ function to allocate size bytes more for the program }
{ must return the first address of new data space or -1 if fail }
function Sbrk(size : longint):longint;
var
p: Mac_Ptr;
begin
p:= NewPtr(size);
if p = nil then
Sbrk:= -1 //Tell its failed
else
Sbrk:= longint(p)
end;
{ include standard heap management }
{$I heap.inc}
@ -417,7 +402,7 @@ begin
remove(p);
Errno2InoutRes;
{$else}
InOutRes:=1;
InOutRes:=1;
{$endif}
end;
@ -427,7 +412,7 @@ begin
c_rename(p1,p2);
Errno2InoutRes;
{$else}
InOutRes:=1;
InOutRes:=1;
{$endif}
end;
@ -437,9 +422,9 @@ begin
do_write:= C_write(h, pointer(addr), len);
Errno2InoutRes;
{$else}
InOutRes:=1;
InOutRes:=1;
if FSWrite(h, len, Mac_Ptr(addr)) = noErr then
InOutRes:=0;
InOutRes:=0;
do_write:= len;
{$endif}
end;
@ -464,7 +449,7 @@ begin
{$else}
InOutRes:=1;
if FSread(h, len, Mac_Ptr(addr)) = noErr then
InOutRes:=0;
InOutRes:=0;
do_read:= len;
{$endif}
end;
@ -523,7 +508,7 @@ begin
begin
do_filesize := lseek(handle, 0, SEEK_END);
Errno2InOutRes; {Report the error from this operation.}
lseek(handle, aktfilepos, SEEK_SET); {Always try to move back,
lseek(handle, aktfilepos, SEEK_SET); {Always try to move back,
even in presence of error.}
end
else
@ -544,7 +529,7 @@ begin
Errno2InoutRes;
{$else}
InOutRes:=1;
do_seek(handle,pos); //TODO: Is this needed (Does the user anticipate the filemarker is at the end?)
do_seek(handle,pos); //TODO: Is this needed (Does the user anticipate the filemarker is at the end?)
if SetEOF(handle, pos) = noErr then
InOutRes:=0;
{$endif}
@ -566,7 +551,7 @@ begin
fullPath, nullString, nullString, alias);
if res = noErr then
begin
res:= ResolveAlias(nil, alias, spec, wasChanged);
res:= ResolveAlias(nil, alias, spec, wasChanged);
DisposeHandle(Mac_Handle(alias));
end;
FSpLocationFromFullPath:= res;
@ -671,10 +656,10 @@ begin
{$else}
InOutRes:=1;
//creator:= $522A6368; {'MPS ' -- MPW}
//creator:= $74747874; {'ttxt'}
creator:= $522A6368; {'R*ch' -- BBEdit}
fileType:= $54455854; {'TEXT'}
//creator:= $522A6368; {'MPS ' -- MPW}
//creator:= $74747874; {'ttxt'}
creator:= $522A6368; {'R*ch' -- BBEdit}
fileType:= $54455854; {'TEXT'}
{ reset file handle }
filerec(f).handle:=UnusedHandle;
@ -787,7 +772,7 @@ end;
begin
if false then //To save it from the dead code stripper
begin
//Included only to make them available for debugging in asm.
//Included only to make them available for debugging in asm.
Debugger;
DebugStr('');
end;
@ -802,7 +787,7 @@ begin
{ Setup heap }
if Mac_FreeMem - intern_heapsize < 30000 then
Halt(3);
theHeap:= NewPtr(intern_heapsize);
theHeap:= Sbrk(intern_heapsize);
if theHeap = nil then
Halt(3); //According to MPW
InitHeap;
@ -822,7 +807,10 @@ end.
{
$Log$
Revision 1.6 2003-09-12 12:45:15 olle
Revision 1.7 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.6 2003/09/12 12:45:15 olle
+ filehandling complete
+ heaphandling complete
+ support for random

28
rtl/netware/system.pp
View File

@ -253,24 +253,21 @@ var HeapSbrkBlockList : ^THeapSbrkBlockList = nil;
HeapSbrkAllocated : dword = 0;
{ function to allocate size bytes more for the program }
{ must return the first address of new data space or -1 if fail }
{ must return the first address of new data space or nil if fail }
{ for netware all allocated blocks are saved to free them at }
{ exit (to avoid message "Module did not release xx resources") }
Function Sbrk(size : longint):longint;
var P,P2 : POINTER;
Function Sbrk(size : longint):pointer;
var P2 : POINTER;
begin
P := _malloc (size);
if P = nil then
Sbrk := -1
else begin
Sbrk := LONGINT (P);
Sbrk := _malloc (size);
if Sbrk <> nil then begin
if HeapSbrkBlockList = nil then
begin
Pointer (HeapSbrkBlockList) := _malloc (sizeof (HeapSbrkBlockList^));
if HeapSbrkBlockList = nil then
begin
_free (P);
Sbrk := -1;
_free (Sbrk);
Sbrk := nil;
exit;
end;
fillchar (HeapSbrkBlockList^,sizeof(HeapSbrkBlockList^),0);
@ -281,14 +278,14 @@ begin
p2 := _realloc (HeapSbrkBlockList, HeapSbrkAllocated + HeapInitialMaxBlocks);
if p2 = nil then
begin
_free (P);
Sbrk := -1;
_free (Sbrk);
Sbrk := nil;
exit;
end;
inc (HeapSbrkAllocated, HeapInitialMaxBlocks);
end;
inc (HeapSbrkLastUsed);
HeapSbrkBlockList^[HeapSbrkLastUsed] := P;
HeapSbrkBlockList^[HeapSbrkLastUsed] := Sbrk;
end;
end;
@ -815,7 +812,10 @@ Begin
End.
{
$Log$
Revision 1.17 2003-03-25 18:17:54 armin
Revision 1.18 2003-09-27 11:52:35 peter
* sbrk returns pointer
Revision 1.17 2003/03/25 18:17:54 armin
* support for fcl, support for linking without debug info
* renamed winsock2 to winsock for win32 compatinility
* new sockets unit for netware

11
rtl/os2/system.pas
View File

@ -295,10 +295,10 @@ end;
{ this function allows to extend the heap by calling
syscall $7f00 resizes the brk area}
function sbrk(size:longint):longint;
function sbrk(size:longint):pointer;
{$IFDEF DUMPGROW}
var
L: longint;
L: longword;
begin
WriteLn ('Trying to grow heap by ', Size, ' to ', HeapSize + Size);
{$IFDEF CONTHEAP}
@ -311,7 +311,7 @@ begin
mov %eax,L
end;
WriteLn ('New heap at ', L);
Sbrk := L;
Sbrk := pointer(L);
end;
{$ELSE DUMPGROW}
assembler;
@ -1241,7 +1241,10 @@ begin
end.
{
$Log$
Revision 1.32 2003-03-30 09:20:30 hajny
Revision 1.33 2003-09-27 11:52:36 peter
* sbrk returns pointer
Revision 1.32 2003/03/30 09:20:30 hajny
* platform extension unification
Revision 1.31 2003/01/15 22:16:12 hajny

11
rtl/template/system.pp
View File

@ -127,8 +127,8 @@ begin
end;
{ function to allocate size bytes more for the program }
{ must return the first address of new data space or -1 if fail }
function Sbrk(size : longint):longint;{assembler;
{ must return the first address of new data space or nil if fail }
function Sbrk(size : longint):pointer;{assembler;
asm
movl size,%eax
pushl %eax
@ -136,7 +136,7 @@ asm
addl $4,%esp
end;}
begin
Sbrk:=-1;
Sbrk:=nil;
end;
@ -291,7 +291,10 @@ Begin
End.
{
$Log$
Revision 1.8 2002-09-07 16:01:27 peter
Revision 1.9 2003-09-27 11:52:36 peter
* sbrk returns pointer
Revision 1.8 2002/09/07 16:01:27 peter
* old logs removed and tabs fixed
Revision 1.7 2002/04/21 15:55:14 carl

12
rtl/unix/sysunix.inc
View File

@ -161,12 +161,11 @@ end;
{$endif not fpc_getheapsize_ok}
Function sbrk(size : longint) : Longint;
Function sbrk(size : longint) : pointer;
begin
sbrk:=Sys_mmap(0,Size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0);
if sbrk<>-1 then
sbrk:=pointer(Sys_mmap(0,Size,3,MAP_PRIVATE+MAP_ANONYMOUS,-1,0));
if sbrk<>nil then
errno:=0;
{! It must be -1, not 0 as before, see heap.inc. Should be in sysmmap?}
end;
@ -804,7 +803,10 @@ End.
{
$Log$
Revision 1.33 2003-09-03 14:09:37 florian
Revision 1.34 2003-09-27 11:52:36 peter
* sbrk returns pointer
Revision 1.33 2003/09/03 14:09:37 florian
* arm fixes to the common rtl code
* some generic math code fixed
* ...

69
rtl/watcom/prt0.asm
View File

@ -5,47 +5,50 @@
.387
.386p
name cstart
assume nothing
extrn PASCALMAIN : near
public _cstart_
public ___exit
public ___sbrk
name prt0
assume nothing
extrn PASCALMAIN : near
public start
public ___exit
public ___sbrk
.STACK 1000h
.CODE
_cstart_ proc near
jmp short main
db "WATCOM"
main:
push ds
pop es
push ds
pop fs
call PASCALMAIN
_cstart_ endp
start proc near
jmp short main
db "WATCOM"
main:
push ds
pop es
push ds
pop fs
call PASCALMAIN
mov ah,4Ch
int 21h
start endp
___exit proc near
pop eax
mov ah,4Ch
int 21h
pop eax
mov ah,4Ch
int 21h
___exit endp
___sbrk proc near
mov ebx,dword ptr [esp+4]
mov ecx,ebx
shr ebx,16
mov ax,501h
int 31h
jnc sbrk_ok
mov eax,-1
ret
sbrk_ok:
shl ebx,16
mov bx,cx
mov eax,ebx
ret
mov ebx,dword ptr [esp+4] ; size
mov cx,bx
shr ebx,16
mov ax,501h
int 31h
jnc sbrk_ok
sbrk_failed:
xor eax,eax
ret
sbrk_ok:
shl ebx,16
mov bx,cx
mov eax,ebx
ret
___sbrk endp
end _cstart_
end start

130
rtl/watcom/system.pp
View File

@ -49,6 +49,9 @@ const
FileNameCaseSensitive : boolean = false;
sLineBreak = LineEnding;
DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
{ Default memory segments (Tp7 compatibility) }
seg0040 = $0040;
segA000 = $A000;
@ -93,7 +96,6 @@ Const
procedure sysrealintr(intnr : word;var regs : trealregs);
var tb:longint;
transfer_buffer:longint absolute tb;
tb_segment:word;
const tb_offset=0;
@ -115,11 +117,9 @@ type
segment : word;
end;
{$ifndef EXCEPTIONS_IN_SYSTEM}
var
old_int00 : tseginfo;cvar;
old_int75 : tseginfo;cvar;
{$endif ndef EXCEPTIONS_IN_SYSTEM}
{$asmmode ATT}
@ -390,23 +390,23 @@ begin
if h>=5 then
do_close(h);
end;
{ halt is not always called !! }
{ halt is not allways called !! }
{ not on normal exit !! PM }
{$ifndef EXCEPTIONS_IN_SYSTEM}
set_pm_interrupt($00,old_int00);
{$ifndef EXCEPTIONS_IN_SYSTEM}
set_pm_interrupt($75,old_int75);
{$endif EXCEPTIONS_IN_SYSTEM}
___exit(exitcode);
end;
{$ifndef EXCEPTIONS_IN_SYSTEM}
procedure new_int00;
begin
HandleError(200);
end;
{$ifndef EXCEPTIONS_IN_SYSTEM}
procedure new_int75;
begin
asm
@ -424,44 +424,6 @@ end;
var
__stkbottom : longint;//###########external name '__stkbottom';
procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
{
called when trying to get local stack if the compiler directive $S
is set this function must preserve esi !!!! because esi is set by
the calling proc for methods it must preserve all registers !!
With a 2048 byte safe area used to write to StdIo without crossing
the stack boundary
}
begin
asm
pushl %eax
pushl %ebx
movl stack_size,%ebx
addl $2048,%ebx
movl %esp,%eax
subl %ebx,%eax
{$ifdef SYSTEMDEBUG}
movl loweststack,%ebx
cmpl %eax,%ebx
jb .L_is_not_lowest
movl %eax,loweststack
.L_is_not_lowest:
{$endif SYSTEMDEBUG}
movl __stkbottom,%ebx
cmpl %eax,%ebx
jae .L__short_on_stack
popl %ebx
popl %eax
leave
ret $4
.L__short_on_stack:
{ can be usefull for error recovery !! }
popl %ebx
popl %eax
end['EAX','EBX'];
HandleError(202);
end;
{*****************************************************************************
@ -512,14 +474,14 @@ begin
getheapsize:=int_heapsize;
end;
function ___sbrk(size:longint):longint;cdecl; external name '___sbrk';
function ___sbrk(size:longint):pointer;cdecl; external name '___sbrk';
function Sbrk(size : longint):longint;assembler;
function Sbrk(size : longint):pointer;assembler;
asm
{$ifdef SYSTEMDEBUG}
cmpb $1,accept_sbrk
je .Lsbrk
movl $-1,%eax
movl $0,%eax
jmp .Lsbrk_fail
.Lsbrk:
{$endif}
@ -581,11 +543,9 @@ begin
syscopytodos(longint(p),strlen(p)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax:=$7141
else
{$endif RTLLITE}
regs.realeax:=$4100;
regs.realesi:=0;
regs.realecx:=0;
@ -608,11 +568,9 @@ begin
regs.realedx:=tb_offset + strlen(p2)+2;
regs.realds:=tb_segment;
regs.reales:=tb_segment;
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax:=$7156
else
{$endif RTLLITE}
regs.realeax:=$5600;
regs.realecx:=$ff; { attribute problem here ! }
sysrealintr($21,regs);
@ -769,7 +727,6 @@ begin
GetInOutRes(lo(regs.realeax));
end;
{$ifndef RTLLITE}
const
FileHandleCount : longint = 20;
@ -789,7 +746,6 @@ begin
else
Increase_file_handle_count:=true;
end;
{$endif not RTLLITE}
procedure do_open(var f;p:pchar;flags:longint);
{
@ -847,11 +803,9 @@ begin
end;
{ real dos call }
syscopytodos(longint(p),strlen(p)+1);
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax:=$716c
else
{$endif RTLLITE}
regs.realeax:=$6c00;
regs.realedx:=action;
regs.realds:=tb_segment;
@ -859,7 +813,6 @@ begin
regs.realebx:=$2000+(flags and $ff);
regs.realecx:=$20;
sysrealintr($21,regs);
{$ifndef RTLLITE}
if (regs.realflags and carryflag) <> 0 then
if lo(regs.realeax)=4 then
if Increase_file_handle_count then
@ -876,7 +829,6 @@ begin
regs.realecx:=$20;
sysrealintr($21,regs);
end;
{$endif RTLLITE}
if (regs.realflags and carryflag) <> 0 then
begin
GetInOutRes(lo(regs.realeax));
@ -885,11 +837,9 @@ begin
else
begin
filerec(f).handle:=lo(regs.realeax);
{$ifndef RTLLITE}
{ for systems that have more then 20 by default ! }
if lo(regs.realeax)>FileHandleCount then
FileHandleCount:=lo(regs.realeax);
{$endif RTLLITE}
end;
if lo(regs.realeax)<max_files then
begin
@ -977,11 +927,9 @@ begin
syscopytodos(longint(@buffer),length(s)+1);
regs.realedx:=tb_offset;
regs.realds:=tb_segment;
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax:=$7100+func
else
{$endif RTLLITE}
regs.realeax:=func shl 8;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
@ -1045,11 +993,9 @@ begin
regs.realedx:=drivenr;
regs.realesi:=tb_offset;
regs.realds:=tb_segment;
{$ifndef RTLLITE}
if LFNSupport then
regs.realeax:=$7147
else
{$endif RTLLITE}
regs.realeax:=$4700;
sysrealintr($21,regs);
if (regs.realflags and carryflag) <> 0 then
@ -1092,7 +1038,6 @@ end;
SystemUnit Initialization
*****************************************************************************}
{$ifndef RTLLITE}
function CheckLFN:boolean;
var
regs : TRealRegs;
@ -1109,77 +1054,76 @@ begin
regs.realds:=tb_segment;
regs.realedx:=tb_offset;
regs.realflags:=carryflag;
sysrealintr($21,regs);
//!! sysrealintr($21,regs); //!!wik
{ If carryflag=0 and LFN API bit in ebx is set then use Long file names }
CheckLFN:=(regs.realflags and carryflag=0) and (regs.realebx and $4000=$4000);
end;
{$endif RTLLITE}
{$ifdef MT}
{$I thread.inc}
{$endif MT}
{$ifndef RTLLITE}
{$ifdef EXCEPTIONS_IN_SYSTEM}
{$define IN_SYSTEM}
{$i dpmiexcp.pp}
{$endif EXCEPTIONS_IN_SYSTEM}
{$endif RTLLITE}
procedure SysInitStdIO;
begin
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
end;
var
temp_int : tseginfo;
Begin
alloc_tb;
{$ifndef EXCEPTIONS_IN_SYSTEM}
StackLength := InitialStkLen;
StackBottom := __stkbottom;
{ To be set if this is a GUI or console application }
IsConsole := TRUE;
{ To be set if this is a library and not a program }
IsLibrary := FALSE;
{ save old int 0 and 75 }
get_pm_interrupt($00,old_int00);
get_pm_interrupt($75,old_int75);
temp_int.segment:=get_cs;
temp_int.offset:=@new_int00;
set_pm_interrupt($00,temp_int);
{$ifndef EXCEPTIONS_IN_SYSTEM}
temp_int.offset:=@new_int75;
set_pm_interrupt($75,temp_int);
{$endif EXCEPTIONS_IN_SYSTEM}
{$IFDEF SYSTEMDEBUG}
{ to test stack depth }
loweststack:=maxlongint;
{$ENDIF}
{ Setup heap }
InitHeap;
{$ifdef MT}
{ before this, you can't use thread vars !!!! }
{ threadvarblocksize is calculate before the initialization }
{ of the system unit }
mainprogramthreadblock := sysgetmem(threadvarblocksize);
{$endif MT}
InitExceptions;
SysInitExceptions;
{ Setup stdin, stdout and stderr }
OpenStdIO(Input,fmInput,StdInputHandle);
OpenStdIO(Output,fmOutput,StdOutputHandle);
OpenStdIO(StdOut,fmOutput,StdOutputHandle);
OpenStdIO(StdErr,fmOutput,StdErrorHandle);
SysInitStdIO;
{ Setup environment and arguments }
Setup_Environment;
Setup_Arguments;
// Setup_Environment;
// Setup_Arguments;
{ Use LFNSupport LFN }
LFNSupport:=CheckLFN;
if LFNSupport then
FileNameCaseSensitive:=true;
{ Reset IO Error }
InOutRes:=0;
{$ifndef RTLLITE}
{$ifdef EXCEPTIONS_IN_SYSTEM}
InitDPMIExcp;
InstallDefaultHandlers;
{$endif EXCEPTIONS_IN_SYSTEM}
{$endif RTLLITE}
{$ifdef HASVARIANT}
initvariantmanager;
{$endif HASVARIANT}
End.
END.
{
$Log$
Revision 1.2 2003-09-07 22:29:26 hajny
Revision 1.3 2003-09-27 11:52:36 peter
* sbrk returns pointer
Revision 1.2 2003/09/07 22:29:26 hajny
* syswat renamed to system, CVS log added

13
rtl/win32/system.pp
View File

@ -271,17 +271,15 @@ asm
end ['EAX'];
function Sbrk(size : longint):longint;
function Sbrk(size : longint):pointer;
var
l : longint;
l : longword;
begin
l := HeapAlloc(GetProcessHeap(), 0, size);
if (l = 0) then
l := -1;
{$ifdef DUMPGROW}
Writeln('new heap part at $',hexstr(l,8), ' size = ',WinAPIHeapSize(GetProcessHeap()));
{$endif}
sbrk:=l;
sbrk:=pointer(l);
end;
{ include standard heap management }
@ -1532,7 +1530,10 @@ end.
{
$Log$
Revision 1.43 2003-09-26 07:30:34 michael
Revision 1.44 2003-09-27 11:52:36 peter
* sbrk returns pointer
Revision 1.43 2003/09/26 07:30:34 michael
+ Win32 Do_open crahs on append
Revision 1.42 2003/09/17 15:06:36 peter