paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2026-02-04 06:34:52 +01:00
Code Issues Packages Projects Releases Wiki Activity

* FPC_ names

Browse Source 
* Heap manager is now system independent
This commit is contained in:
peter 1998-09-14 10:48:00 +00:00
parent 181d4769a2
commit 4620a73a9b
27 changed files with 752 additions and 2369 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
rtl/amiga/sysamiga.pas
View File

@ -885,6 +885,18 @@ const
randseed:=time.ds_tick;
end;
function getheapstart:pointer;assembler;
asm
lea.l HEAP,a0
move.l a0,d0
end;
function getheapsize:longint;assembler;
asm
move.l HEAP_SIZE,d0
end ['D0'];
{ This routine is used to grow the heap. }
{ But here we do a trick, we say that the }
{ heap cannot be regrown! }
@ -1645,15 +1657,15 @@ end;
path:=path+':';
end;
len := len + elen;
len := len + elen;
UnLock(lock);
lock := newlock;
UnLock(lock);
lock := newlock;
end;
if (lock <> 0) then
Begin
UnLock(lock);
path := '';
UnLock(lock);
path := '';
end;
if assigned(fib) then dispose(fib);
end;
@ -1800,7 +1812,11 @@ end.
{
$Log$
Revision 1.9 1998-08-17 12:34:22 carl
Revision 1.10 1998-09-14 10:48:00 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.9 1998/08/17 12:34:22 carl
* chdir accepts .. characters
+ added ctrl-c checking
+ implemented sbrk

22
rtl/atari/sysatari.pas
View File

@ -36,7 +36,7 @@ unit sysatari;
{$I heaph.inc}
const
UnusedHandle = $ffff;
UnusedHandle = $ffff;
StdInputHandle = 0;
StdOutputHandle = 1;
StdErrorHandle = $ffff;
@ -234,6 +234,18 @@ const
randseed:=hl;
end;
function getheapstart:pointer;assembler;
asm
lea.l HEAP,a0
move.l a0,d0
end;
function getheapsize:longint;assembler;
asm
move.l HEAP_SIZE,d0
end ['D0'];
{ This routine is used to grow the heap. }
{ But here we do a trick, we say that the }
{ heap cannot be regrown! }
@ -697,7 +709,7 @@ end;
{*****************************************************************************
SystemUnit Initialization
*****************************************************************************}
begin
{ Initialize ExitProc }
@ -719,7 +731,11 @@ end.
{
$Log$
Revision 1.8 1998-07-15 12:11:59 carl
Revision 1.9 1998-09-14 10:48:02 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.8 1998/07/15 12:11:59 carl
* hmmm... can't remember! :(...
Revision 1.5 1998/07/13 12:34:13 carl

28
rtl/dos/go32v1/system.pp
View File

@ -98,7 +98,7 @@ implementation
{$I system.inc}
{$ASMMODE DIRECT}
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
procedure int_stackcheck(stack_size:longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'STACKCHECK'];
begin
{ called when trying to get local stack
if the compiler directive $S is set
@ -183,6 +183,18 @@ end;
Heap Management
*****************************************************************************}
function getheapstart:pointer;assembler;
asm
leal HEAP,%eax
end ['EAX'];
function getheapsize:longint;assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
function Sbrk(size : longint) : longint;assembler;
asm
movl size,%ebx
@ -458,11 +470,11 @@ asm
popl %ebp
jnc .LDOSDEVICE
movw %ax,inoutres
xorl %edx,%edx
xorl %edx,%edx
.LDOSDEVICE:
movl %edx,%eax
shrl $7,%eax
andl $1,%eax
movl %edx,%eax
shrl $7,%eax
andl $1,%eax
end;
@ -597,7 +609,11 @@ Begin
End.
{
$Log$
Revision 1.8 1998-07-30 13:28:33 michael
Revision 1.9 1998-09-14 10:48:03 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.8 1998/07/30 13:28:33 michael
+ Added support for errorproc. Changed runerror to HandleError
Revision 1.7 1998/07/07 12:30:20 carl

23
rtl/dos/go32v2/system.pp
View File

@ -29,7 +29,7 @@ interface
const
{ Default filehandles }
UnusedHandle = $ffff;
UnusedHandle = -1;
StdInputHandle = 0;
StdOutputHandle = 1;
StdErrorHandle = 2;
@ -134,7 +134,6 @@ var
procedure halt(errnum : byte);
begin
do_exit;
flush(stderr);
asm
movzbw errnum,%ax
pushw %ax
@ -143,7 +142,7 @@ begin
end;
procedure int_stackcheck(stack_size:longint);[public,alias: 'STACKCHECK'];
procedure int_stackcheck(stack_size:longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'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
@ -563,6 +562,18 @@ end;
{$ASMMODE DIRECT}
function getheapstart:pointer;assembler;
asm
leal HEAP,%eax
end ['EAX'];
function getheapsize:longint;assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
function Sbrk(size : longint):longint;assembler;
asm
movl size,%eax
@ -1106,7 +1117,11 @@ Begin
End.
{
$Log$
Revision 1.18 1998-08-28 10:48:04 peter
Revision 1.19 1998-09-14 10:48:05 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.18 1998/08/28 10:48:04 peter
* fixed chdir with drive changing
* updated checklfn from mailinglist

16
rtl/i386/cpu.pp
View File

@ -5,7 +5,7 @@
This unit contains some routines to get informations about the
processor
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -29,12 +29,8 @@ unit cpu;
implementation
{$ifdef VER0_99_5}
{$I386_INTEL}
{$endif}
{$ASMMODE INTEL}
function cpuid_support : boolean;assembler;
{
@ -64,7 +60,7 @@ unit cpu;
DB 0Fh,20h,0C0h
{ mov eax,cr0
special registers are not allowed in the assembler
parsers }
parsers }
end;
@ -79,7 +75,11 @@ end.
{
$Log$
Revision 1.4 1998-08-11 00:04:46 peter
Revision 1.5 1998-09-14 10:48:06 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.4 1998/08/11 00:04:46 peter
* $ifdef ver0_99_5 updates
Revision 1.3 1998/05/25 10:51:27 pierre

208
rtl/i386/i386.inc
View File

@ -89,7 +89,7 @@ begin
end;
Procedure FillChar(var x;count:longint;value:byte);[alias: 'FILL_OBJECT'];
Procedure FillChar(var x;count:longint;value:byte);[alias: 'FPC_FILL_OBJECT'];
begin
asm
cld
@ -151,7 +151,7 @@ end;
{$ASMMODE DIRECT}
procedure int_help_constructor;assembler; [public,alias:'HELP_CONSTRUCTOR'];
procedure int_help_constructor;assembler; [public,alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'HELP_CONSTRUCTOR'];
asm
{ Entry without preamble, since we need the ESP of the constructor
Stack (relative to %ebp):
@ -173,7 +173,11 @@ asm
{ Memory size }
pushl (%eax)
pushl %esi
{$ifdef FPCNAMES}
call FPC_GETMEM
{$else}
call GETMEM
{$endif}
popal
{ Memory size to %esi }
movl (%esi),%esi
@ -197,7 +201,7 @@ asm
pushw $0
pushl (%eax)
pushl %esi
call FILL_OBJECT
call FPC_FILL_OBJECT
popal
{ set the VMT address for the new created object }
movl %eax,(%esi)
@ -211,7 +215,7 @@ asm
end;
procedure int_new_class;assembler;[public,alias:'NEW_CLASS'];
procedure int_new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
asm
{ create class ? }
movl 8(%ebp),%edi
@ -232,7 +236,7 @@ asm
end;
procedure int_dispose_class;assembler;[public,alias:'DISPOSE_CLASS'];
procedure int_dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS'];
asm
{ destroy class ? }
movl 8(%ebp),%edi
@ -253,7 +257,7 @@ end;
{ checks for a correct vmt pointer }
procedure int_check_object;assembler;[public,alias:'CHECK_OBJECT'];
procedure int_check_object;assembler;[public,alias:'FPC_CHECK_OBJECT'];
asm
pushl %edi
movl 8(%esp),%edi
@ -273,11 +277,11 @@ asm
ret $4
.Lco_re:
pushl $210
call handleerror
call FPC_HANDLEERROR
end;
procedure int_help_destructor;assembler;[public,alias:'HELP_DESTRUCTOR'];
procedure int_help_destructor;assembler;[public,alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'HELP_DESTRUCTOR'];
asm
{ Stack (relative to %ebp):
12 Self
@ -305,7 +309,11 @@ asm
movl $0,(%eax)
movl %eax,(%edi)
pushl %edi
{$ifdef FPCNAMES}
call FPC_FREEMEM
{$else}
call FREEMEM
{$endif}
.LHD_3:
popal
addl $4,%esp
@ -318,7 +326,7 @@ end;
String
****************************************************************************}
procedure strcopy(dstr,sstr:pointer;len:longint);[public,alias:'STRCOPY'];
procedure strcopy(dstr,sstr:pointer;len:longint);[public,alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'STRCOPY'];
{
this procedure must save all modified registers except EDI and ESI !!!
}
@ -360,7 +368,7 @@ begin
end;
procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
procedure strconcat(s1,s2 : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'STRCONCAT'];
begin
asm
xorl %ecx,%ecx
@ -399,7 +407,7 @@ begin
end;
procedure strcmp(dstr,sstr : pointer);[public,alias: 'STRCMP'];
procedure strcmp(dstr,sstr : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'STRCMP'];
begin
asm
cld
@ -499,13 +507,20 @@ asm
subl %ecx,%eax
end ['EDI','ECX','EAX'];
{****************************************************************************
Other
Caller/StackFrame Helpers
****************************************************************************}
function get_addr(addrbp:longint):longint;assembler;
function get_frame:longint;assembler;
asm
movl addrbp,%eax
movl %ebp,%eax
end ['EAX'];
function get_caller_addr(framebp:longint):longint;assembler;
asm
movl framebp,%eax
orl %eax,%eax
jz .Lg_a_null
movl 4(%eax),%eax
@ -513,7 +528,7 @@ asm
end ['EAX'];
function get_next_frame(framebp:longint):longint;assembler;
function get_caller_frame(framebp:longint):longint;assembler;
asm
movl framebp,%eax
orl %eax,%eax
@ -523,101 +538,9 @@ asm
end ['EAX'];
Procedure HandleError (Errno : longint);[alias : 'handleerror'];
{
Procedure to handle internal errors, i.e. not user-invoked errors
Internal function should ALWAYS call HandleError instead of RunError.
}
function get_addr : Pointer;assembler;
asm
movl (%ebp),%eax
movl 4(%eax),%eax
end;
function get_error_bp : Longint;assembler;
asm
movl (%ebp),%eax
end;
begin
If ErrorProc<>Nil then
TErrorProc (ErrorProc)(Errno,get_addr);
errorcode:=Errno;
exitcode:=Errno;
erroraddr:=Get_addr;
DoError := TRUE;
errorbase:=get_error_bp;
halt(errorcode);
end;
procedure runerror(w : word);[alias: 'runerror'];
function get_addr : Pointer;assembler;
asm
movl (%ebp),%eax
movl 4(%eax),%eax
end;
function get_error_bp : Longint;assembler;
asm
movl (%ebp),%eax {%ebp of run_error}
end;
begin
errorcode:=w;
exitcode:=w;
erroraddr:=pointer(get_addr);
DoError := TRUE;
errorbase:=get_error_bp;
halt(errorcode);
end;
procedure int_iocheck(addr : longint);[public,alias: 'IOCHECK'];
var
l : longint;
begin
{ Since IOCHECK is called directly and only later the optimiser }
{ Maybe also save global registers }
asm
pushal
end;
l:=ioresult;
if l<>0 then
begin
If ErrorProc<>Nil then
TErrorProc(Errorproc)(l,pointer(addr));
{$ifndef RTLLITE}
writeln('IO-Error ',l,' at 0x',HexStr(addr,8));
{$else}
writeln('IO-Error ',l,' at ',addr);
{$endif}
Halt(byte(l));
end;
asm
popal
end;
end;
procedure int_re_overflow;[public,alias: 'RE_OVERFLOW'];
var
addr : longint;
begin
{ Overflow was shortly before the return address }
asm
movl 4(%ebp),%edi
movl %edi,addr
end;
If ErrorProc<>Nil then
TErrorProc (ErrorProc)(215,Pointer(Addr));
{$ifndef RTLLITE}
writeln('Overflow at 0x',HexStr(addr,8));
{$else}
writeln('Overflow at ',addr);
{$endif}
HandleError(215);
end;
{****************************************************************************
Math
****************************************************************************}
function abs(l:longint):longint;assembler;{$ifdef INTERNCONST}[internconst:in_const_abs];{$endif}
asm
@ -644,6 +567,20 @@ asm
end ['EAX'];
Function Sptr : Longint;
begin
asm
movl %esp,%eax
addl $8,%eax
movl %eax,-4(%ebp)
end ['EAX'];
end;
{****************************************************************************
Str()
****************************************************************************}
procedure int_str(l : longint;var s : string);
var
@ -719,40 +656,43 @@ end ['EAX'];
end;
end;
{$ifdef VER0_99_5}
procedure f1;[public,alias: 'FLUSH_STDOUT'];
begin
asm
pushal
end;
FileFunc(textrec(output).flushfunc)(textrec(output));
asm
popal
end;
end;
{$endif VER0_99_5}
{****************************************************************************
IoCheck
****************************************************************************}
Function Sptr : Longint;
procedure int_iocheck(addr : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'IOCHECK'];
var
l : longint;
begin
asm
movl %esp,%eax
addl $8,%eax
movl %eax,-4(%ebp)
end ['EAX'];
pushal
end;
if InOutRes<>0 then
begin
l:=InOutRes;
InOutRes:=0;
If ErrorProc<>Nil then
TErrorProc(Errorproc)(l,pointer(addr));
{$ifndef RTLLITE}
writeln('IO-Error ',l,' at 0x',HexStr(addr,8));
{$endif}
Halt(byte(l));
end;
asm
popal
end;
end;
{$ifdef VER_0_99_5}
{$I386_DIRECT}
{$endif}
{$ASMMODE ATT}
{
$Log$
Revision 1.20 1998-09-11 17:38:48 pierre
Revision 1.21 1998-09-14 10:48:08 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.20 1998/09/11 17:38:48 pierre
merge for fixes branch
Revision 1.19.2.1 1998/09/11 17:37:24 pierre

2
rtl/i386/makefile.cpu
View File

@ -2,6 +2,6 @@
# Here we set processor dependent include file names.
#
CPUNAMES=i386 heap math set rttip setjump setjumph
CPUNAMES=i386 math set rttip setjump setjumph
CPUINCNAMES=$(addsuffix .inc,$(CPUNAMES))

428
rtl/i386/rttip.inc
View File

@ -16,352 +16,356 @@
{ Run-Time type information routines - processor dependent part }
{$ASMMODE DIRECT}
Procedure Initialize (Data,TypeInfo : pointer);[Public,Alias : 'INITIALIZE'];assembler;
Procedure Initialize (Data,TypeInfo : pointer);[Public,Alias : 'FPC_INITIALIZE'];assembler;
asm
# Save registers
push %eax
push %ebx
push %ecx
push %edx
push %ebx
push %ecx
push %edx
# decide what type it is
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringInit
decb %al
jz .DoAnsiStringInit
subb $2,%al
jz .DoArrayInit
decb %al
jz .DoRecordInit
decb %al
decb %al
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringInit
decb %al
jz .DoAnsiStringInit
subb $2,%al
jz .DoArrayInit
decb %al
jz .DoRecordInit
decb %al
decb %al
jz .DoObjectInit
decb %al
decb %al
jz .DoClassInit
jmp .ExitInitialize
jmp .ExitInitialize
.DoObjectInit:
.DoClassInit:
.DoRecordInit:
incl %ebx
movzbl (%ebx),%eax
incl %ebx
movzbl (%ebx),%eax
# Skip also recordsize.
addl $5,%eax
addl %eax,%ebx
addl $5,%eax
addl %eax,%ebx
# %ebx points to element count. Set in %edx
movl (%ebx),%edx
addl $4,%ebx
movl (%ebx),%edx
addl $4,%ebx
# %ebx points to First element in record
.MyRecordInitLoop:
decl %edx
jl .ExitInitialize
decl %edx
jl .ExitInitialize
# Calculate data
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
# Push type
pushl (%ebx)
addl $4,%ebx
pushl (%ebx)
addl $4,%ebx
# push data
pushl %eax
call INITIALIZE
jmp .MyRecordInitLoop
pushl %eax
call FPC_INITIALIZE
jmp .MyRecordInitLoop
# Array handling
.DoArrayInit:
# %ebx points to size. Put size in ecx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
# %ebx points to type. Put into ebx.
# Start treating elements.
.MyArrayInitLoop:
decl %edx
jl .ExitInitialize
decl %edx
jl .ExitInitialize
# push type
pushl (%ebx)
# calculate data
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
# push data
pushl %eax
call INITIALIZE
jmp .MyArrayInitLoop
# AnsiString handling :
pushl %eax
call FPC_INITIALIZE
jmp .MyArrayInitLoop
# AnsiString handling :
.DoAnsiStringInit:
movl $0,8(%ebp)
movl $0,8(%ebp)
.ExitInitialize:
pop %edx
pop %ecx
pop %ebx
pop %eax
pop %ecx
pop %ebx
pop %eax
end;
Procedure Finalize (Data,TypeInfo: Pointer);[Public,Alias : 'FINALIZE']; assembler;
Procedure Finalize (Data,TypeInfo: Pointer);[Public,Alias : 'FPC_FINALIZE']; assembler;
asm
push %eax
push %ebx
push %ecx
push %edx
push %ebx
push %ecx
push %edx
# decide what type it is
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringFinal
decb %al
jz .DoAnsiStringFinal
subb $2,%al
jz .DoArrayFinal
decb %al
jz .DoRecordFinal
decb %al
decb %al
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringFinal
decb %al
jz .DoAnsiStringFinal
subb $2,%al
jz .DoArrayFinal
decb %al
jz .DoRecordFinal
decb %al
decb %al
jz .DoObjectFinal
decb %al
decb %al
jz .DoClassFinal
jmp .ExitFinalize
jmp .ExitFinalize
.DoClassFinal:
.DoObjectFinal:
.DoRecordFinal:
incl %ebx
movzbl (%ebx),%eax
incl %ebx
movzbl (%ebx),%eax
# Skip also recordsize.
addl $5,%eax
addl %eax,%ebx
addl %eax,%ebx
# %ebx points to element count. Set in %edx
movl (%ebx),%edx
addl $4,%ebx
movl (%ebx),%edx
addl $4,%ebx
# %ebx points to First element in record
.MyRecordFinalLoop:
decl %edx
jl .ExitFinalize
decl %edx
jl .ExitFinalize
# Calculate data
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
# Push type
pushl (%ebx)
addl $4,%ebx
pushl (%ebx)
addl $4,%ebx
# push data
pushl %eax
call FINALIZE
jmp .MyRecordFinalLoop
pushl %eax
call FPC_FINALIZE
jmp .MyRecordFinalLoop
# Array handling
.DoArrayFinal:
# %ebx points to size. Put size in ecx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
# %ebx points to type. Put into ebx.
# Start treating elements.
.MyArrayFinalLoop:
decl %edx
jl .ExitFinalize
decl %edx
jl .ExitFinalize
# push type
pushl (%ebx)
# calculate data
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
# push data
pushl %eax
call FINALIZE
jmp .MyArrayFinalLoop
# AnsiString handling :
pushl %eax
call FPC_FINALIZE
jmp .MyArrayFinalLoop
# AnsiString handling :
.DoAnsiStringFinal:
movl 8(%ebp),%eax
pushl %eax
call DECR_ANSI_REF
movl 8(%ebp),%eax
pushl %eax
call FPC_DECR_ANSI_REF
.ExitFinalize:
pop %edx
pop %ecx
pop %ebx
pop %eax
pop %ecx
pop %ebx
pop %eax
end;
Procedure Addref (Data,TypeInfo : Pointer); [Public,alias : 'ADDREF'];Assembler;
Procedure Addref (Data,TypeInfo : Pointer); [Public,alias : 'FPC_ADDREF'];Assembler;
asm
# Save registers
push %eax
push %ebx
push %ecx
push %edx
push %ebx
push %ecx
push %edx
# decide what type it is
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringAddRef
decb %al
jz .DoAnsiStringAddRef
subb $2,%al
jz .DoArrayAddRef
decb %al
jz .DoRecordAddRef
decb %al
decb %al
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringAddRef
decb %al
jz .DoAnsiStringAddRef
subb $2,%al
jz .DoArrayAddRef
decb %al
jz .DoRecordAddRef
decb %al
decb %al
jz .DoObjectAddRef
decb %al
decb %al
jz .DoClassAddRef
jmp .ExitAddRef
jmp .ExitAddRef
.DoClassAddRef:
.DoObjectAddRef:
.DoRecordAddRef:
incl %ebx
movzbl (%ebx),%eax
incl %ebx
movzbl (%ebx),%eax
# Skip also recordsize.
addl $5,%eax
addl %eax,%ebx
addl %eax,%ebx
# %ebx points to element count. Set in %edx
movl (%ebx),%edx
addl $4,%ebx
movl (%ebx),%edx
addl $4,%ebx
# %ebx points to First element in record
.MyRecordAddRefLoop:
decl %edx
jl .ExitAddRef
decl %edx
jl .ExitAddRef
# Calculate data
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
# Push type
pushl (%ebx)
addl $4,%ebx
pushl (%ebx)
addl $4,%ebx
# push data
pushl %eax
call ADDREF
jmp .MyRecordAddRefLoop
pushl %eax
call FPC_ADDREF
jmp .MyRecordAddRefLoop
# Array handling
.DoArrayAddRef:
# %ebx points to size. Put size in ecx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
# %ebx points to type. Put into ebx.
# Start treating elements.
.MyArrayAddRefLoop:
decl %edx
jl .ExitAddRef
decl %edx
jl .ExitAddRef
# push type
pushl (%ebx)
# calculate data
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
# push data
pushl %eax
call ADDREF
jmp .MyArrayAddRefLoop
# AnsiString handling :
pushl %eax
call FPC_ADDREF
jmp .MyArrayAddRefLoop
# AnsiString handling :
.DoAnsiStringAddRef:
movl 8(%ebp),%eax
pushl %eax
call INCR_ANSI_REF
movl 8(%ebp),%eax
pushl %eax
call FPC_INCR_ANSI_REF
.ExitAddRef:
pop %edx
pop %ecx
pop %ebx
pop %eax
pop %ecx
pop %ebx
pop %eax
end;
Procedure DecRef (Data,TypeInfo : Pointer); [Public,alias : 'DECREF'];Assembler;
Procedure DecRef (Data,TypeInfo : Pointer); [Public,alias : 'FPC_DECREF'];Assembler;
asm
# Save registers
push %eax
push %ebx
push %ecx
push %edx
push %ebx
push %ecx
push %edx
# decide what type it is
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringDecRef
decb %al
jz .DoAnsiStringDecRef
subb $2,%al
jz .DoArrayDecRef
decb %al
jz .DoRecordDecRef
decb %al
decb %al
movl 12(%ebp),%ebx
movb (%ebx),%al
subb $10,%al
jz .DoAnsiStringDecRef
decb %al
jz .DoAnsiStringDecRef
subb $2,%al
jz .DoArrayDecRef
decb %al
jz .DoRecordDecRef
decb %al
decb %al
jz .DoObjectDecRef
decb %al
decb %al
jz .DoClassDecRef
jmp .ExitDecRef
jmp .ExitDecRef
.DoClassDecRef:
.DoObjectDecRef:
.DoRecordDecRef:
incl %ebx
movzbl (%ebx),%eax
incl %ebx
movzbl (%ebx),%eax
# Skip also recordsize.
addl $5,%eax
addl %eax,%ebx
addl %eax,%ebx
# %ebx points to element count. Set in %edx
movl (%ebx),%edx
addl $4,%ebx
movl (%ebx),%edx
addl $4,%ebx
# %ebx points to First element in record
.MyRecordDecRefLoop:
decl %edx
jl .ExitDecRef
decl %edx
jl .ExitDecRef
# Calculate data
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
movl 8(%ebp),%eax
addl (%ebx),%eax
addl $4,%ebx
# Push type
pushl (%ebx)
addl $4,%ebx
pushl (%ebx)
addl $4,%ebx
# push data
pushl %eax
call DECREF
jmp .MyRecordDecRefLoop
pushl %eax
call FPC_DECREF
jmp .MyRecordDecRefLoop
# Array handling
.DoArrayDecRef:
# %ebx points to size. Put size in ecx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
movl (%ebx),%ecx
addl $4, %ebx
# %ebx points to count. Put count in %edx
movl (%ebx),%edx
addl $4, %ebx
# %ebx points to type. Put into ebx.
# Start treating elements.
.MyArrayDecRefLoop:
decl %edx
jl .ExitDecRef
decl %edx
jl .ExitDecRef
# push type
pushl (%ebx)
# calculate data
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
movl %ecx,%eax
imull %edx,%eax
addl 8(%ebp),%eax
# push data
pushl %eax
call DECREF
jmp .MyArrayDecRefLoop
# AnsiString handling :
pushl %eax
call FPC_DECREF
jmp .MyArrayDecRefLoop
# AnsiString handling :
.DoAnsiStringDecRef:
movl 8(%ebp),%eax
pushl %eax
call DECR_ANSI_REF
movl 8(%ebp),%eax
pushl %eax
call FPC_DECR_ANSI_REF
.ExitDecRef:
pop %edx
pop %ecx
pop %ebx
pop %eax
pop %ecx
pop %ebx
pop %eax
end;
{$ASMMODE DEFAULT}
{
$Log$
Revision 1.6 1998-08-23 20:58:50 florian
Revision 1.7 1998-09-14 10:48:11 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.6 1998/08/23 20:58:50 florian
+ rtti for objects and classes
+ TObject.GetClassName implemented

38
rtl/i386/set.inc
View File

@ -16,7 +16,7 @@
{$ASMMODE ATT}
procedure do_load_small(p : pointer;l:longint);[public,alias: 'SET_LOAD_SMALL'];
procedure do_load_small(p : pointer;l:longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_LOAD_SMALL'];
{
load a set from an
}
@ -34,7 +34,7 @@ begin
end;
procedure do_set_byte(p : pointer;b : byte); [public,alias: 'SET_SET_BYTE'];
procedure do_set_byte(p : pointer;b : byte); [public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SET_BYTE'];
{
add the element b to the set pointed by p
}
@ -57,7 +57,7 @@ begin
end;
procedure do_set_range(p : pointer;l,h : byte);[public,alias: 'SET_SET_RANGE'];
procedure do_set_range(p : pointer;l,h : byte);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SET_RANGE'];
{
bad implementation, but it's very seldom used
}
@ -86,7 +86,7 @@ begin
end;
procedure do_in_byte(p : pointer;b : byte);[public,alias: 'SET_IN_BYTE'];
procedure do_in_byte(p : pointer;b : byte);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_IN_BYTE'];
{
tests if the element b is in the set p the carryflag is set if it present
}
@ -110,7 +110,7 @@ end;
procedure do_add_sets(set1,set2,dest : pointer);[public,alias: 'SET_ADD_SETS'];
procedure do_add_sets(set1,set2,dest : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_ADD_SETS'];
{
adds set1 and set2 into set dest
}
@ -134,7 +134,7 @@ end;
{ multiplies (i.E. takes common elements of) set1 and set2 }
{ result put in dest }
procedure do_mul_sets(set1,set2,dest : pointer);[public,alias: 'SET_MUL_SETS'];
procedure do_mul_sets(set1,set2,dest : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_MUL_SETS'];
begin
asm
movl 8(%ebp),%esi
@ -152,7 +152,7 @@ begin
end;
procedure do_sub_sets(set1,set2,dest : pointer);[public,alias: 'SET_SUB_SETS'];
procedure do_sub_sets(set1,set2,dest : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SUB_SETS'];
{
computes the diff from set1 to set2 result in dest
}
@ -175,7 +175,7 @@ begin
end;
procedure do_symdif_sets(set1,set2,dest : pointer);[public,alias: 'SET_SYMDIF_SETS'];
procedure do_symdif_sets(set1,set2,dest : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SYMDIF_SETS'];
{
computes the symetric diff from set1 to set2 result in dest
}
@ -196,7 +196,7 @@ begin
end;
end;
procedure do_comp_sets(set1,set2 : pointer);[public,alias: 'SET_COMP_SETS'];
procedure do_comp_sets(set1,set2 : pointer);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_COMP_SETS'];
{
compares set1 and set2 zeroflag is set if they are equal
}
@ -223,7 +223,7 @@ end;
{$ifdef LARGESETS}
procedure do_set(p : pointer;b : word);[public,alias: 'SET_SET_WORD'];
procedure do_set(p : pointer;b : word);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SET_WORD'];
{
sets the element b in set p works for sets larger than 256 elements
not yet use by the compiler so
@ -244,7 +244,7 @@ begin
end;
procedure do_in(p : pointer;b : word);[public,alias: 'SET_IN_WORD'];
procedure do_in(p : pointer;b : word);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_IN_WORD'];
{
tests if the element b is in the set p the carryflag is set if it present
works for sets larger than 256 elements
@ -265,7 +265,7 @@ begin
end;
procedure add_sets(set1,set2,dest : pointer;size : longint);[public,alias: 'SET_ADD_SETS_SIZE'];
procedure add_sets(set1,set2,dest : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_ADD_SETS_SIZE'];
{
adds set1 and set2 into set dest size is the number of bytes in the set
}
@ -287,7 +287,7 @@ begin
end;
procedure mul_sets(set1,set2,dest : pointer;size : longint);[public,alias: 'SET_MUL_SETS_SIZE'];
procedure mul_sets(set1,set2,dest : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_MUL_SETS_SIZE'];
{
multiplies (i.E. takes common elements of) set1 and set2 result put in
dest size is the number of bytes in the set
@ -309,7 +309,7 @@ begin
end;
procedure sub_sets(set1,set2,dest : pointer;size : longint);[public,alias: 'SET_SUB_SETS_SIZE'];
procedure sub_sets(set1,set2,dest : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SUB_SETS_SIZE'];
begin
asm
movl 8(%ebp),%esi
@ -329,7 +329,7 @@ begin
end;
procedure sym_sub_sets(set1,set2,dest : pointer;size : longint);[public,alias: 'SET_SYMDIF_SETS_SIZE'];
procedure sym_sub_sets(set1,set2,dest : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_SYMDIF_SETS_SIZE'];
{
computes the symetric diff from set1 to set2 result in dest
}
@ -351,7 +351,7 @@ begin
end;
procedure comp_sets(set1,set2 : pointer;size : longint);[public,alias: 'SET_COMP_SETS_SIZE'];
procedure comp_sets(set1,set2 : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'SET_COMP_SETS_SIZE'];
begin
asm
movl 8(%ebp),%esi
@ -376,7 +376,11 @@ end;
{
$Log$
Revision 1.3 1998-08-14 18:13:44 peter
Revision 1.4 1998-09-14 10:48:12 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.3 1998/08/14 18:13:44 peter
+ set_load_small
* fixed set_set_range

14
rtl/i386/setjump.inc
View File

@ -4,7 +4,7 @@
Copyright (c) 1998 by the Free Pascal development team
SetJmp and LongJmp implementation for exception handling
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -14,12 +14,8 @@
**********************************************************************}
{$ifdef VER0_99_5}
{$I386_DIRECT}
{$endif}
{$ASMMODE DIRECT}
Function SetJmp (Var S : Jmp_buf) : longint;assembler;[Public, alias : 'FPC_SETJMP'];
asm
movl 8(%ebp),%eax
@ -56,7 +52,11 @@ end;
{
$Log$
Revision 1.3 1998-08-11 00:04:52 peter
Revision 1.4 1998-09-14 10:48:13 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.3 1998/08/11 00:04:52 peter
* $ifdef ver0_99_5 updates
}

74
rtl/inc/astrings.pp
View File

@ -18,11 +18,11 @@
{
This file contains the implementation of the LongString type,
This file contains the implementation of the LongString type,
and all things that are needed for it.
AnsiSTring is defined as a 'silent' pchar :
a pchar that points to :
@-12 : Longint for maximum size;
@-8 : Longint for size;
@-4 : Longint for reference count;
@ -61,7 +61,7 @@ Type TAnsiRec = Record
Const AnsiRecLen = SizeOf(TAnsiRec);
FirstOff = SizeOf(TAnsiRec)-1;
{ ---------------------------------------------------------------------
Internal functions, not in interface.
---------------------------------------------------------------------}
@ -79,7 +79,7 @@ begin
Writeln ('Maxlen : ',maxlen);
Writeln ('Len : ',len);
Writeln ('Ref : ',ref);
end;
end;
end;
end;
@ -118,45 +118,45 @@ begin
end;
Procedure Decr_Ansi_Ref (Var S : AnsiString);[Alias : 'DECR_ANSI_REF'];
Procedure Decr_Ansi_Ref (Var S : AnsiString);[Alias : 'FPC_DECR_ANSI_REF'];
{
Decreases the ReferenceCount of a non constant ansistring;
Decreases the ReferenceCount of a non constant ansistring;
If the reference count is zero, deallocate the string;
}
Type plongint = ^longint;
Var l : plongint;
Var l : plongint;
Begin
// dumpansirec(s);
If Pointer(S)=Nil then exit; { Zero string }
{ check for constant strings ...}
l:=Pointer(S)-FirstOff+8;
If l^<0 then exit;
l^:=l^-1;
// dumpansirec(s);
If l^=0 then
If l^=0 then
{ Ref count dropped to zero }
begin
// Writeln ('CAlling disposestring');
// Writeln ('CAlling disposestring');
DisposeAnsiString (S); { Remove...}
end
end;
Procedure Incr_Ansi_Ref (Var S : AnsiString);[Alias : 'INCR_ANSI_REF'];
Procedure Incr_Ansi_Ref (Var S : AnsiString);[Alias : 'FPC_INCR_ANSI_REF'];
Begin
If Pointer(S)=Nil then exit;
{ Let's be paranoid : Constant string ??}
If PansiRec(Pointer(S)-FirstOff)^.Ref<0 then exit;
If PansiRec(Pointer(S)-FirstOff)^.Ref<0 then exit;
inc(PAnsiRec(Pointer(S)-FirstOff)^.Ref);
end;
Procedure UniqueAnsiString (Var S : AnsiString);
{
Make sure reference count of S is 1,
Make sure reference count of S is 1,
using copy-on-write semantics.
}
@ -176,7 +176,7 @@ end;
Procedure AssignAnsiString (Var S1 : AnsiString; S2 : Pointer); [Public, Alias : 'ASSIGN_ANSI_STRING'];
Procedure AssignAnsiString (Var S1 : AnsiString; S2 : Pointer); [Public, Alias : 'FPC_ASSIGN_ANSI_STRING'];
{
Assigns S2 to S1 (S1:=S2), taking in account reference counts.
If S2 is a constant string, a new S1 is allocated on the heap.
@ -188,7 +188,7 @@ begin
begin
If PAnsiRec(S2-FirstOff)^.Ref<0 then
begin
{ S2 is a constant string, Create new string with copy. }
{ S2 is a constant string, Create new string with copy. }
Temp:=Pointer(NewAnsiString(PansiRec(S2-FirstOff)^.Len));
Move (S2^,Temp^,PAnsiRec(S2-FirstOff)^.len+1);
PAnsiRec(Temp-FirstOff)^.Len:=PAnsiRec(S2-FirstOff)^.len;
@ -207,7 +207,7 @@ end;
Procedure Ansi_String_Concat (Var S1 : AnsiString; Var S2 : AnsiString);
{
Concatenates 2 AnsiStrings : S1+S2.
Concatenates 2 AnsiStrings : S1+S2.
Result Goes to S1;
}
Var Size,Location : Longint;
@ -221,9 +221,9 @@ begin
Size:=PAnsiRec(Pointer(S2)-FirstOff)^.Len;
Location:=Length(S1);
{ Setlength takes case of uniqueness
and allocated memory. We need to use length,
and allocated memory. We need to use length,
to take into account possibility of S1=Nil }
//!! SetLength (S1,Size+Location);
//!! SetLength (S1,Size+Location);
Move (Pointer(S2)^,Pointer(Pointer(S1)+location)^,Size+1);
end;
end;
@ -241,10 +241,10 @@ begin
Size:=byte(S2[0]);
Location:=Length(S1);
If Size=0 then exit;
{ Setlength takes case of uniqueness
and alllocated memory. We need to use length,
{ Setlength takes case of uniqueness
and alllocated memory. We need to use length,
to take into account possibility of S1=Nil }
SetLength (S1,Size+Length(S1));
SetLength (S1,Size+Length(S1));
Move (S2[1],Pointer(Pointer(S1)+Location)^,Size);
PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero }
end;
@ -282,11 +282,11 @@ end;
Const EmptyChar : char = #0;
Function Ansi2pchar (S : Pointer) : Pchar; [Alias : 'ANSI2PCHAR'];
Function Ansi2pchar (S : Pointer) : Pchar; [Alias : 'FPC_ANSI2PCHAR'];
begin
If S<>Nil then
If S<>Nil then
Ansi2Pchar:=S
else
Ansi2Pchar:=@emptychar;
@ -313,7 +313,7 @@ begin
inc(i);
end;
if temp=0 then temp:=Length(S1)-Length(S2);
AnsiCompare:=Temp;
AnsiCompare:=Temp;
end;
@ -338,7 +338,7 @@ begin
Temp:= PByte(Pointer(S1)+I)^ - Byte(S2[i+1]);
inc(i);
end;
AnsiCompare:=Temp;
AnsiCompare:=Temp;
end;
@ -354,12 +354,12 @@ begin
end;
{ ---------------------------------------------------------------------
Public functions, In interface.
Public functions, In interface.
---------------------------------------------------------------------}
Function Length (Var S : AnsiString) : Longint;
{
Returns the length of an AnsiString.
Returns the length of an AnsiString.
Takes in acount that zero strings are NIL;
}
begin
@ -418,7 +418,7 @@ begin
dec(index);
{ Check Size. Accounts for Zero-length S }
if Length(S)<Index+Size then
Size:=Length(S)-Index;
Size:=Length(S)-Index;
If Size>0 then
begin
ResultAddress:=Pointer(NewAnsiString (Size));
@ -439,7 +439,7 @@ Function Pos (Var Substr : AnsiString; Var Source : AnsiString) : Longint;
var i,j : longint;
e : boolean;
s : Pointer;
begin
i := 0;
j := 0;
@ -464,7 +464,7 @@ end;
Procedure Val (var S : AnsiString; var R : real; Var Code : Integer);
Var SS : String;
begin
Ansi_To_ShortString (SS,S,255);
Val(SS,R,Code);
@ -668,7 +668,7 @@ begin
If Length(Source)=0 then exit;
if index <= 0 then index := 1;
s3 := Pointer(copy(s,index,length(s)));
if index > Length(s) then
if index > Length(s) then
index := Length(S)+1;
SetLength(s,index - 1);
s4 := Pointer ( NewAnsiString(PansiRec(Pointer(Source)-Firstoff)^.len) );
@ -683,7 +683,11 @@ end;
{
$Log$
Revision 1.13 1998-08-23 20:58:51 florian
Revision 1.14 1998-09-14 10:48:14 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.13 1998/08/23 20:58:51 florian
+ rtti for objects and classes
+ TObject.GetClassName implemented

85
rtl/inc/filerec.inc
View File

@ -21,16 +21,6 @@
unit without sacrificing TP compatibility.
}
{$ifndef VER0_99_5}
{$ifndef VER0_99_6}
{$define UNIFORM_FILEREC}
{$endif}
{$endif}
{$ifdef UNIFORM_FILEREC}
const
filerecnamelength = 255;
type
@ -43,78 +33,13 @@ type
name : array[0..filerecnamelength] of char;
End;
{$else UNIFORM_FILEREC}
{**********************************
Old style for 0.99.5/0.99.6
**********************************}
const
{$ifdef linux}
filerecnamelength = 255;
{$endif}
{$ifdef Win32}
filerecnamelength = 255;
{$endif}
{$ifdef MACOS}
filerecnamelength = 255;
{$endif}
{$ifdef AMIGA}
filerecnamelength = 255;
{$endif}
{$ifdef OS2}
filerecnamelength = 79;
{$endif}
{$ifdef GO32V2}
filerecnamelength = 79;
{$endif GO32V2}
{$ifdef GO32V1}
filerecnamelength = 79;
{$endif Go32v1}
{$ifdef ATARI}
filerecnamelength = 79;
{$endif}
Type
{$PACKRECORDS 2}
FileRec = Record
{$ifdef win32}
handle : longint;
{$endif win32}
{$ifdef amiga}
handle : longint;
{$endif amiga}
{$ifdef macos}
handle : longint;
{$endif macos}
{$ifdef linux}
handle : word;
{$endif}
{$ifdef go32v1}
handle : word;
{$endif go32v1}
{$ifdef go32v2}
handle : word;
{$endif go32v2}
{$ifdef atari}
handle : word;
{$endif atari}
{$ifdef os2}
handle : word;
{$endif os2}
Mode : word;
RecSize : word;
_private : array[1..26] of byte;
UserData : array[1..16] of byte;
name : array[0..filerecnamelength] of char;
End;
{$endif UNIFORM_FILEREC}
{
$Log$
Revision 1.4 1998-09-04 18:16:13 peter
Revision 1.5 1998-09-14 10:48:15 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.4 1998/09/04 18:16:13 peter
* uniform filerec/textrec (with recsize:longint and name:0..255)
Revision 1.3 1998/05/21 11:55:59 carl

92
rtl/i386/heap.inc → rtl/inc/heap.inc
View File

@ -5,7 +5,6 @@
functions for heap management in the data segment
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
@ -25,8 +24,6 @@
}
{$ASMMODE DIRECT}
const
max_size = 256;
maxblock = max_size div 8;
@ -113,28 +110,6 @@ const
{$endif TEMPHEAP}
{$ifndef OS2}
{ OS2 function getheapstart is in sysos2.pas }
function getheapstart : pointer;
begin
asm
leal HEAP,%eax
leave
ret
end ['EAX'];
end;
{$endif}
function getheapsize : longint;
begin
asm
movl HEAPSIZE,%eax
leave
ret
end ['EAX'];
end;
{*****************************************************************************
Heapsize,Memavail,MaxAvail
*****************************************************************************}
@ -244,12 +219,7 @@ end;
begin
Writeln('Marked memory at ',HexStr(longint(p),8),' released');
call_stack(p+sizeof(heap_mem_info));
asm
movl (%ebp),%eax
movl (%eax),%eax
movl %eax,ebp
end;
dump_stack(ebp);
dump_stack(get_caller_frame(get_frame));
end;
@ -339,8 +309,8 @@ end;
tempheap.heapsize:=tempheap.memavail;
getmem(tempheap.block,sizeof(tblocks));
getmem(tempheap.nblock,sizeof(tnblocks));
fillchar(tempheap.block^,sizeof(tblocks),0);
fillchar(tempheap.nblock^,sizeof(tnblocks),0);
fillchar(tempheap.block^,sizeof(tblocks),0);
fillchar(tempheap.nblock^,sizeof(tnblocks),0);
heapend:=baseheap.heapend;
internal_memavail:=calc_memavail;
baseheap.memavail:=internal_memavail;
@ -445,7 +415,7 @@ end;
begin
while assigned(hp^.next) do
hp:=hp^.next;
end;
end;
if tempheap.heapptr<>tempheap.heaporg then
begin
if hp<>nil then
@ -518,21 +488,11 @@ end;
GetMem
*****************************************************************************}
procedure getmem(var p : pointer;size : longint);[public,alias: 'GETMEM'];
{ changed to removed the OS conditionnals }
function call_heaperror(addr : pointer; size : longint) : integer;
begin
asm
pushl size
movl addr,%eax
{ movl HEAPERROR,%eax doesn't work !!}
call %eax
movw %ax,__RESULT
end;
end;
procedure getmem(var p : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'GETMEM'];
type
heaperrorproc=function(size:longint):integer;
var
proc : heaperrorproc;
last,hp : pfreerecord;
again : boolean;
s,hpsize : longint;
@ -658,7 +618,8 @@ begin
begin
if assigned(heaperror) then
begin
case call_heaperror(heaperror,size) of
proc:=heaperrorproc(heaperror);
case proc(size) of
0 : HandleError(203);
1 : p:=nil;
2 : again:=true;
@ -679,10 +640,6 @@ check_new:
test_memavail;
if trace then
begin
asm
movl (%ebp),%eax
movl %eax,bp
end;
pheap_mem_info(p)^.sig:=$DEADBEEF;
pheap_mem_info(p)^.previous:=last_assigned;
if last_assigned<>nil then
@ -690,10 +647,11 @@ check_new:
last_assigned:=p;
pheap_mem_info(p)^.next:=nil;
pheap_mem_info(p)^.size:=orsize;
bp:=get_caller_frame(get_frame);
for i:=1 to tracesize do
begin
pheap_mem_info(p)^.calls[i]:=get_addr(bp);
bp:=get_next_frame(bp);
pheap_mem_info(p)^.calls[i]:=get_caller_addr(bp);
bp:=get_caller_frame(bp);
end;
inc(p,sizeof(heap_mem_info));
end;
@ -705,7 +663,7 @@ end;
FreeMem
*****************************************************************************}
procedure freemem(var p : pointer;size : longint);[public,alias: 'FREEMEM'];
procedure freemem(var p : pointer;size : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'FREEMEM'];
var
hp : pfreerecord;
{$ifdef TEMPHEAP}
@ -960,7 +918,9 @@ end;
function growheap(size :longint) : integer;
var
Newlimit,
{$ifdef CHECKHEAP}
NewLimit,
{$endif CHECKHEAP}
NewPos,
wantedsize : longint;
hp : pfreerecord;
@ -1044,12 +1004,6 @@ begin
to get the memory PM }
internal_memavail:=calc_memavail;
{ set the total new heap size }
asm
movl Size,%ebx
movl HEAPSIZE,%eax
addl %ebx,%eax
movl %eax,HEAPSIZE
end;
inc(internal_heapsize,size);
{ try again }
GrowHeap:=2;
@ -1076,20 +1030,22 @@ begin
Curheap:=@baseheap;
Otherheap:=@tempheap;
{$endif TEMPHEAP}
internal_memavail:=GetHeapSize;
internal_heapsize:=GetHeapSize;
internal_memavail:=internal_heapsize;
HeapOrg:=GetHeapStart;
HeapPtr:=HeapOrg;
HeapEnd:=HeapOrg+internal_memavail;
HeapError:=@GrowHeap;
internal_heapsize:=longint(heapend)-longint(heaporg);
Freelist:=nil;
end;
{$ASMMODE ATT}
{
$Log$
Revision 1.18 1998-09-08 15:02:48 peter
Revision 1.1 1998-09-14 10:48:17 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.18 1998/09/08 15:02:48 peter
* much more readable :)
Revision 1.17 1998/09/04 17:27:48 pierre

14
rtl/inc/innr.inc
View File

@ -23,14 +23,6 @@ const
in_ord_x = 5;
in_length_string = 6;
in_chr_byte = 7;
{$ifdef VER0_99_5}
in_inc_byte = 8;
in_inc_word = 9;
in_inc_dword = 10;
in_dec_byte = 11;
in_dec_word = 12;
in_dec_dword = 13;
{$endif}
in_write_x = 14;
in_writeln_x = 15;
in_read_x = 16;
@ -74,7 +66,11 @@ const
{
$Log$
Revision 1.3 1998-09-01 17:36:19 peter
Revision 1.4 1998-09-14 10:48:17 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.3 1998/09/01 17:36:19 peter
+ internconst
}

2
rtl/inc/makefile.inc
View File

@ -6,7 +6,7 @@
# implementation files.
SYSNAMES=systemh heaph mathh filerec textrec system real2str sstrings innr \
file typefile version text rtti
file typefile version text rtti heap
SYSINCNAMES=$(addsuffix .inc,$(SYSNAMES))
# Other unit names which can be used for all systems

20
rtl/inc/sstrings.inc
View File

@ -217,7 +217,7 @@ end;
Str() Helpers
*****************************************************************************}
procedure int_str_real(d : real;len,fr : longint;var s : string);[public, alias : 'STR_REAL'];
procedure int_str_real(d : real;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_REAL'{$else}'STR_REAL'{$endif}];
begin
{$ifdef i386}
str_real(len,fr,d,rt_s64real,s);
@ -227,7 +227,7 @@ begin
end;
{$ifdef SUPPORT_SINGLE}
procedure int_str_single(d : single;len,fr : longint;var s : string);[public, alias : 'STR_SINGLE'];
procedure int_str_single(d : single;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_SINGLE'{$else}'STR_SINGLE'{$endif}];
begin
str_real(len,fr,d,rt_s32real,s);
end;
@ -235,7 +235,7 @@ end;
{$ifdef SUPPORT_EXTENDED}
procedure int_str_extended(d : extended;len,fr : longint;var s : string);[public, alias : 'STR_EXTENDED'];
procedure int_str_extended(d : extended;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_EXTENDED'{$else}'STR_EXTENDED'{$endif}];
begin
str_real(len,fr,d,rt_s80real,s);
end;
@ -243,7 +243,7 @@ end;
{$ifdef SUPPORT_COMP}
procedure int_str_comp(d : comp;len,fr : longint;var s : string);[public, alias : 'STR_COMP'];
procedure int_str_comp(d : comp;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_COMP'{$else}'STR_COMP'{$endif}];
begin
str_real(len,fr,d,rt_s64bit,s);
end;
@ -251,14 +251,14 @@ end;
{$ifdef SUPPORT_FIXED}
procedure int_str_fixed(d : fixed;len,fr : longint;var s : string);[public, alias : 'STR_FIXED'];
procedure int_str_fixed(d : fixed;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_FIXED'{$else}'STR_FIXED'{$endif}];
begin
str_real(len,fr,d,rt_f32bit,s);
end;
{$endif SUPPORT_FIXED}
procedure int_str_longint(v : longint;len : longint;var s : string);[public, alias : 'STR_LONGINT'];
procedure int_str_longint(v : longint;len : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_LONGINT'{$else}'STR_LONGINT'{$endif}];
begin
int_str(v,s);
if length(s)<len then
@ -266,7 +266,7 @@ begin
end;
procedure int_str_cardinal(v : cardinal;len : longint;var s : string);[public, alias : 'STR_CARDINAL'];
procedure int_str_cardinal(v : cardinal;len : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_CARDINAL'{$else}'STR_CARDINAL'{$endif}];
begin
int_str(v,s);
if length(s)<len then
@ -753,7 +753,11 @@ end;
{
$Log$
Revision 1.11 1998-08-11 21:39:07 peter
Revision 1.12 1998-09-14 10:48:19 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.11 1998/08/11 21:39:07 peter
* splitted default_extended from support_extended
Revision 1.10 1998/08/08 12:28:13 florian

189
rtl/inc/system.inc
View File

@ -54,24 +54,6 @@ Function lo(l : Longint) : Word; [INTERNPROC: In_lo_long];
Function hi(i : Integer) : byte; [INTERNPROC: In_hi_Word];
Function hi(w : Word) : byte; [INTERNPROC: In_hi_Word];
Function hi(l : Longint) : Word; [INTERNPROC: In_hi_long];
{$ifdef VER0_99_5}
Procedure Inc(var i : Cardinal); [INTERNPROC: In_Inc_DWord];
Procedure Inc(var i : Longint); [INTERNPROC: In_Inc_DWord];
Procedure Inc(var i : Integer); [INTERNPROC: In_Inc_Word];
Procedure Inc(var i : Word); [INTERNPROC: In_Inc_Word];
Procedure Inc(var i : shortint); [INTERNPROC: In_Inc_byte];
Procedure Inc(var i : byte); [INTERNPROC: In_Inc_byte];
Procedure Inc(var c : Char); [INTERNPROC: In_Inc_byte];
Procedure Inc(var p : PChar); [INTERNPROC: In_Inc_DWord];
Procedure Dec(var i : Cardinal); [INTERNPROC: In_Dec_DWord];
Procedure Dec(var i : Longint); [INTERNPROC: In_Dec_DWord];
Procedure Dec(var i : Integer); [INTERNPROC: In_Dec_Word];
Procedure Dec(var i : Word); [INTERNPROC: In_Dec_Word];
Procedure Dec(var i : shortint); [INTERNPROC: In_Dec_byte];
Procedure Dec(var i : byte); [INTERNPROC: In_Dec_byte];
Procedure Dec(var c : Char); [INTERNPROC: In_Dec_byte];
Procedure Dec(var p : PChar); [INTERNPROC: In_Dec_DWord];
{$endif VER0_99_5}
Function chr(b : byte) : Char; [INTERNPROC: In_chr_byte];
Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
@ -122,11 +104,11 @@ Type
{$else}
{ Provide dummy procedures needed for rtti}
Procedure decr_ansi_ref (P : pointer);[Alias : 'DECR_ANSI_REF'];
Procedure decr_ansi_ref (P : pointer);[Alias : 'FPC_DECR_ANSI_REF'];
begin
end;
Procedure incr_ansi_ref (P : pointer);[Alias : 'INCR_ANSI_REF'];
Procedure incr_ansi_ref (P : pointer);[Alias : 'FPC_INCR_ANSI_REF'];
begin
end;
@ -137,9 +119,8 @@ Procedure incr_ansi_ref (P : pointer);[Alias : 'INCR_ANSI_REF'];
Run-Time Type Information (RTTI)
****************************************************************************}
{$ifndef VER0_99_5}
{$i rtti.inc}
{$endif VER0_99_5}
{$i rtti.inc}
{****************************************************************************
Math Routines
@ -157,90 +138,6 @@ begin
Lo := b and $0f
end;
{$ifdef VER0_99_5}
Procedure Inc(var i : Cardinal;a: Longint);
Begin
I:=I+A;
End;
Procedure Dec(var i : Cardinal;a: Longint);
Begin
I:=I-A;
End;
Procedure Inc(var i : Longint;a : Longint);
Begin
i:=i+a;
End;
Procedure Dec(var i : Longint;a : Longint);
Begin
i:=i-a;
End;
Procedure Dec(var i : Word;a : Longint);
Begin
i:=i-a;
End;
Procedure Inc(var i : Word;a : Longint);
Begin
i:=i+a;
End;
Procedure Dec(var i : Integer;a : Longint);
Begin
i:=i-a;
End;
Procedure Inc(var i : Integer;a : Longint);
Begin
i:=i+a;
End;
Procedure Dec(var i : byte;a : Longint);
Begin
i:=i-a;
End;
Procedure Inc(var i : byte;a : Longint);
Begin
i:=i+a;
End;
Procedure Dec(var i : shortint;a : Longint);
Begin
i:=i-a;
End;
Procedure Inc(var i : shortint;a : Longint);
Begin
i:=i+a;
End;
Procedure Dec(var c : Char;a : Longint);
Begin
byte(c):=byte(c)-a;
End;
Procedure Inc(var c : Char;a : Longint);
Begin
Byte(c):=byte(c)+a;
End;
Procedure Dec(var p : PChar;a : Longint);
Begin
longint(p):=longint(p)-a;
End;
Procedure Inc(var p : PChar;a : Longint);
Begin
longint(p):=longint(p)+a;
End;
{$endif VER0_99_5}
Function swap (X : Word) : Word;{$ifdef INTERNCONST}[internconst:in_const_swap_word];{$endif}
Begin
swap:=(X and $ff) shl 8 + (X shr 8)
@ -265,7 +162,7 @@ End;
{****************************************************************************
Random function routines
This implements a very long cycle random number generator by combining
three independant generators. The technique was described in the March
1987 issue of Byte.
@ -370,12 +267,26 @@ End;
{$endif RTLLITE}
{*****************************************************************************
Miscellaneous
*****************************************************************************}
procedure int_overflow;[public,alias: {$ifdef FPCNAMES}'FPC_OVERFLOW'{$else}'RE_OVERFLOW'{$endif}];
var
addr : longint;
begin
addr:=get_caller_addr(get_frame);
If ErrorProc<>Nil then
TErrorProc (ErrorProc)(215,Pointer(Addr));
{$ifndef RTLLITE}
Writeln('Overflow at 0x',HexStr(addr,8));
{$endif}
HandleError(215);
end;
Function IOResult:Word;
function IOResult:Word;
Begin
IOResult:=InOutRes;
InOutRes:=0;
@ -392,6 +303,37 @@ end;
Init / Exit / ExitProc
*****************************************************************************}
Procedure HandleError (Errno : longint);[alias : 'FPC_HANDLEERROR'];
{
Procedure to handle internal errors, i.e. not user-invoked errors
Internal function should ALWAYS call HandleError instead of RunError.
}
var
addr : longint;
begin
addr:=get_caller_addr(get_frame);
If ErrorProc<>Nil then
TErrorProc (ErrorProc)(Errno,pointer(addr));
errorcode:=Errno;
exitcode:=Errno;
erroraddr:=pointer(addr);
errorbase:=get_caller_frame(get_frame);
DoError:=true;
halt(errorcode);
end;
procedure runerror(w : word);[alias: 'FPC_RUNERROR'];
begin
errorcode:=w;
exitcode:=w;
erroraddr:=pointer(get_caller_addr(get_frame));
errorbase:=get_caller_frame(get_frame);
DoError:=true;
halt(errorcode);
end;
Procedure RunError;
Begin
RunError (0);
@ -405,16 +347,6 @@ End;
Procedure dump_stack(bp : Longint);
Procedure dump_frame(addr : Longint);
Begin
{To be used by symify}
Writeln(stderr,' 0x',HexStr(addr,8));
{$ifdef VER0_99_5}
Flush(stderr);
{$endif VER0_99_5}
End;
var
i, prevbp : Longint;
Begin
@ -422,17 +354,17 @@ Begin
i:=0;
while bp > prevbp Do
Begin
dump_frame(get_addr(bp));
Writeln(stderr,' 0x',HexStr(get_caller_addr(bp),8));
Inc(i);
If i>max_frame_dump Then
exit;
prevbp:=bp;
bp:=get_next_frame(bp);
bp:=get_caller_frame(bp);
End;
End;
Procedure Do_exit;[Public,Alias: '__EXIT'];
Procedure do_exit;[Public,Alias: {$ifdef FPCNAMES}'FPC_DO_EXIT'{$else}'__EXIT'{$endif}];
{
Don't call this direct, the call is generated by the compiler
and by the halt procedure.
@ -458,9 +390,6 @@ Begin
Writeln('Run time error ',Errorcode,' at 0x',hexstr(Longint(Erroraddr),8));
dump_stack(ErrorBase);
End;
{$ifdef VER0_99_5}
Flush(stderr);
{$endif VER0_99_5}
End;
@ -500,8 +429,9 @@ Begin
ExitProc:=@DoExitProc;
End;
{*****************************************************************************
Assert() support.
Assert() support.
*****************************************************************************}
Procedure do_assert (Const Name,Msg : string; LineNo : Longint); [Public,Alias : 'FPC_DO_ASSERT'];
@ -511,7 +441,6 @@ begin
else
write (stderr,msg);
writeln (stderr,'(File : ',name,', line ',LineNo,'.');
flush (stderr);
HandleError (227);
end;
@ -533,7 +462,11 @@ end;
{
$Log$
Revision 1.29 1998-09-01 17:36:21 peter
Revision 1.30 1998-09-14 10:48:20 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.29 1998/09/01 17:36:21 peter
+ internconst
Revision 1.28 1998/08/17 12:24:16 carl

52
rtl/inc/systemh.inc
View File

@ -26,12 +26,6 @@
{$i version.inc}
{$ifndef VER0_99_5}
{$ifndef VER0_99_6}
{$define INTERNCONST}
{$endif}
{$endif}
{****************************************************************************
Global Types and Constants
@ -47,11 +41,7 @@ Type
{ at least declare Turbo Pascal real types }
{$ifdef i386}
StrLenInt = LongInt;
{$ifndef VER0_99_5}
{$ifndef VER0_99_6}
{$define DEFAULT_EXTENDED}
{$endif}
{$endif}
{$define DEFAULT_EXTENDED}
{$define SUPPORT_EXTENDED}
{$define SUPPORT_COMP}
{$define SUPPORT_SINGLE}
@ -158,40 +148,6 @@ Function Swap (X:Word):Word;
Function Swap (X:Integer):Integer;
Function Swap (X:Cardinal):Cardinal;
Function Swap (X:Longint):Longint;
{$ifdef VER0_99_5}
Procedure Inc(Var i:cardinal);
Procedure Inc(Var i:Longint);
Procedure Inc(Var i:Integer);
Procedure Inc(Var i:Word);
Procedure Inc(Var i:shortint);
Procedure Inc(Var i:byte);
Procedure Inc(Var c:Char);
Procedure Inc(Var p:PChar);
Procedure Dec(Var i:cardinal);
Procedure Dec(Var i:Longint);
Procedure Dec(Var i:Integer);
Procedure Dec(Var i:Word);
Procedure Dec(Var i:shortint);
Procedure Dec(Var i:byte);
Procedure Dec(Var c:Char);
Procedure Dec(Var p:PChar);
Procedure Dec(Var i:cardinal;a:Longint);
Procedure Inc(Var i:cardinal;a:Longint);
Procedure Dec(Var i:Longint;a:Longint);
Procedure Inc(Var i:Longint;a:Longint);
Procedure Dec(Var i:Word;a:Longint);
Procedure Inc(Var i:Word;a:Longint);
Procedure Dec(Var i:Integer;a:Longint);
Procedure Inc(Var i:Integer;a:Longint);
Procedure Dec(Var i:byte;a:Longint);
Procedure Inc(Var i:byte;a:Longint);
Procedure Dec(Var i:shortint;a:Longint);
Procedure Inc(Var i:shortint;a:Longint);
Procedure Dec(Var c:Char;a:Longint);
Procedure Inc(Var c:Char;a:Longint);
Procedure Dec(Var p:PChar;a:Longint);
Procedure Inc(Var p:PChar;a:Longint);
{$endif VER0_99_5}
{$endif RTLLITE}
Function Chr(b:byte):Char;
@ -430,7 +386,11 @@ Procedure halt;
{
$Log$
Revision 1.27 1998-09-08 15:03:28 peter
Revision 1.28 1998-09-14 10:48:22 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.27 1998/09/08 15:03:28 peter
* moved getmem/freemem/memavail/maxavail to heaph.inc
Revision 1.26 1998/09/04 18:16:14 peter

150
rtl/inc/text.inc
View File

@ -102,7 +102,7 @@ begin
end;
Procedure Close(var t : Text);[Public,Alias: 'CLOSE_TEXT',IOCheck];
Procedure Close(var t : Text);[IOCheck];
Begin
if InOutRes <> 0 then Exit;
If (TextRec(t).mode<>fmClosed) Then
@ -407,14 +407,14 @@ begin
end;
Procedure Write_End(var f:TextRec);[Public,Alias:'WRITE_END'];
Procedure Write_End(var f:TextRec);[Public,Alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_END'];
begin
if f.FlushFunc<>nil then
FileFunc(f.FlushFunc)(f);
end;
Procedure Writeln_End(var f:TextRec);[Public,Alias:'WRITELN_END'];
Procedure Writeln_End(var f:TextRec);[Public,Alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'WRITELN_END'];
const
{$IFDEF SHORT_LINEBREAK}
eollen=1;
@ -433,7 +433,7 @@ begin
end;
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias: 'WRITE_TEXT_STRING'];
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_STRING'];
Begin
If InOutRes <> 0 then exit;
If f.mode<>fmOutput Then
@ -446,7 +446,7 @@ End;
Type
array00 = array[0..0] Of Char;
Procedure Write_Array(Len : Longint;var f : TextRec;const p : array00);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_ARRAY'];
Procedure Write_Array(Len : Longint;var f : TextRec;const p : array00);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_PCHAR_AS_ARRAY'];
var
ArrayLen : longint;
Begin
@ -460,7 +460,7 @@ Begin
End;
Procedure Write_PChar(Len : Longint;var f : TextRec;p : PChar);[Public,Alias: 'WRITE_TEXT_PCHAR_AS_POINTER'];
Procedure Write_PChar(Len : Longint;var f : TextRec;p : PChar);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_PCHAR_AS_POINTER'];
var
PCharLen : longint;
Begin
@ -474,7 +474,7 @@ Begin
End;
{$ifdef UseAnsiStrings}
Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; Var S : AnsiString);[Public, alias: 'WRITE_TEXT_ANSISTRING'];
Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; Var S : AnsiString);[Public, alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_ANSISTRING'];
{
Writes a AnsiString to the Text file T
}
@ -490,7 +490,7 @@ end;
{$endif}
Procedure Write_LongInt(Len : Longint;var t : TextRec;l : Longint);[Public,Alias: 'WRITE_TEXT_LONGINT'];
Procedure Write_LongInt(Len : Longint;var t : TextRec;l : Longint);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_LONGINT'];
var
s : String;
Begin
@ -500,7 +500,7 @@ Begin
End;
Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias: 'WRITE_TEXT_REAL'];
Procedure Write_Real(fixkomma,Len : Longint;var t : TextRec;r : real);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_REAL'];
var
s : String;
Begin
@ -514,7 +514,7 @@ Begin
End;
Procedure Write_Cardinal(Len : Longint;var t : TextRec;l : cardinal);[Public,Alias: 'WRITE_TEXT_CARDINAL'];
Procedure Write_Cardinal(Len : Longint;var t : TextRec;l : cardinal);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_CARDINAL'];
var
s : String;
Begin
@ -524,7 +524,7 @@ Begin
End;
{$ifdef SUPPORT_SINGLE}
Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias: 'WRITE_TEXT_SINGLE'];
Procedure Write_Single(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_SINGLE'];
var
s : String;
Begin
@ -536,7 +536,7 @@ End;
{$ifdef SUPPORT_EXTENDED}
Procedure Write_Extended(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias: 'WRITE_TEXT_EXTENDED'];
Procedure Write_Extended(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_EXTENDED'];
var
s : String;
Begin
@ -548,7 +548,7 @@ End;
{$ifdef SUPPORT_COMP}
Procedure Write_Comp(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias: 'WRITE_TEXT_COMP'];
Procedure Write_Comp(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_COMP'];
var
s : String;
Begin
@ -560,7 +560,7 @@ End;
{$ifdef SUPPORT_FIXED}
Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed);[Public,Alias: 'WRITE_TEXT_FIXED'];
Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_FIXED'];
var
s : String;
Begin
@ -571,7 +571,7 @@ End;
{$endif SUPPORT_FIXED}
Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias: 'WRITE_TEXT_BOOLEAN'];
Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_BOOLEAN'];
Begin
If InOutRes <> 0 then exit;
{ Can't use array[boolean] because b can be >0 ! }
@ -582,7 +582,7 @@ Begin
End;
Procedure Write_Char(Len : Longint;var t : TextRec;c : Char);[Public,Alias: 'WRITE_TEXT_CHAR'];
Procedure Write_Char(Len : Longint;var t : TextRec;c : Char);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'WRITE_TEXT_CHAR'];
Begin
If InOutRes <> 0 then exit;
If t.mode<>fmOutput Then
@ -596,22 +596,6 @@ Begin
End;
{$ifdef VER0_99_5}
Procedure w(var t : TextRec);[Public,Alias: 'WRITELN_TEXT'];
var
hs : String;
Begin
If InOutRes <> 0 then exit;
{$IFDEF SHORT_LINEBREAK}
hs:=#10;
{$ELSE}
hs:=#13#10;
{$ENDIF}
Write_Str(0,t,hs);
End;
{$endif VER0_99_5}
{*****************************************************************************
Read(Ln)
*****************************************************************************}
@ -709,14 +693,14 @@ begin
end;
Procedure Read_End(var f:TextRec);[Public,Alias:'READ_END'];
Procedure Read_End(var f:TextRec);[Public,Alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'READ_END'];
begin
if f.FlushFunc<>nil then
FileFunc(f.FlushFunc)(f);
end;
Procedure ReadLn_End(var f : TextRec);[Public,Alias: 'READLN_END'];
Procedure ReadLn_End(var f : TextRec);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READLN_END'];
Begin
If InOutRes <> 0 then exit;
if not OpenInput(f) then
@ -736,52 +720,7 @@ Begin
End;
{$ifdef VER0_99_5}
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias: 'READ_TEXT_STRING'];
var
Temp,sPos : Word;
Begin
{ Delete the string }
s:='';
If InOutRes <> 0 then exit;
if not OpenInput(f) then
exit;
Temp:=f.BufPos;
sPos:=1;
while (f.BufPos<f.BufEnd) and (f.Bufptr^[Temp]<>#10) Do
Begin
{ search linefeed }
while (f.Bufptr^[Temp]<>#10) and (Temp<f.BufEnd) Do
Inc(Temp);
{ copy String. Take 255 char limit in account.}
If sPos+Temp-f.BufPos<=255 Then
Begin
Move (f.Bufptr^[f.BufPos],s[sPos],Temp-f.BufPos);
sPos:=sPos+Temp-f.BufPos;
{ Remove #13 from a #13#10 break }
If s[sPos-1]=#13 Then
dec(sPos);
End
else
Begin
If (sPos<=255) Then
Move(f.Bufptr^[f.BufPos],s[sPos],256-sPos);
sPos:=256
End;
{ update f.BufPos }
f.BufPos:=Temp;
If Temp>=f.BufEnd Then
Begin
FileFunc(f.InOutFunc)(f);
Temp:=f.BufPos;
End
End;
s[0]:=chr(sPos-1);
End;
{$else VER0_99_5}
Procedure Read_String(Maxlen : Longint;var f : TextRec;var s : String);[Public,Alias:'READ_TEXT_STRING'];
Procedure Read_String(Maxlen : Longint;var f : TextRec;var s : String);[Public,Alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_STRING'];
var
Temp,sPos,nrread : Word;
Begin
@ -826,10 +765,9 @@ Begin
End;
s[0]:=chr(sPos-1);
End;
{$endif VER0_99_5}
Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias: 'READ_TEXT_CHAR'];
Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_CHAR'];
Begin
c:=#0;
If InOutRes <> 0 then exit;
@ -843,7 +781,7 @@ Begin
End;
Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:'READ_TEXT_PCHAR_AS_POINTER'];
Procedure Read_PChar(var f : TextRec;var s : PChar);[Public,Alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_PCHAR_AS_POINTER'];
var
p : PChar;
Temp : byte;
@ -877,7 +815,7 @@ Begin
End;
Procedure Read_Array(var f : TextRec;var s : array00);[Public,Alias:'READ_TEXT_PCHAR_AS_ARRAY'];
Procedure Read_Array(var f : TextRec;var s : array00);[Public,Alias:{$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_PCHAR_AS_ARRAY'];
var
p : PChar;
Temp : byte;
@ -912,7 +850,7 @@ End;
{$ifdef useansistrings}
Procedure Read_String(Maxlen : Longint;var f : TextRec;var s : AnsiString);[Public,Alias: 'READ_TEXT_ANSISTRING'];
Procedure Read_String(Maxlen : Longint;var f : TextRec;var s : AnsiString);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_ANSISTRING'];
var
p : PChar;
Temp : byte;
@ -952,7 +890,7 @@ End;
{$endif}
Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias: 'READ_TEXT_LONGINT'];
Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_LONGINT'];
var
hs : String;
code : Word;
@ -971,7 +909,7 @@ Begin
End;
Procedure Read_Integer(var f : TextRec;var l : Integer);[Public,Alias: 'READ_TEXT_INTEGER'];
Procedure Read_Integer(var f : TextRec;var l : Integer);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_INTEGER'];
var
ll : Longint;
Begin
@ -984,7 +922,7 @@ Begin
End;
Procedure Read_Word(var f : TextRec;var l : Word);[Public,Alias: 'READ_TEXT_WORD'];
Procedure Read_Word(var f : TextRec;var l : Word);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_WORD'];
var
ll : Longint;
Begin
@ -997,7 +935,7 @@ Begin
End;
Procedure Read_Byte(var f : TextRec;var l : byte);[Public,Alias: 'READ_TEXT_BYTE'];
Procedure Read_Byte(var f : TextRec;var l : byte);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_BYTE'];
var
ll : Longint;
Begin
@ -1010,7 +948,7 @@ Begin
End;
Procedure Read_Shortint(var f : TextRec;var l : shortint);[Public,Alias: 'READ_TEXT_SHORTINT'];
Procedure Read_Shortint(var f : TextRec;var l : shortint);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_SHORTINT'];
var
ll : Longint;
Begin
@ -1023,7 +961,7 @@ Begin
End;
Procedure Read_Cardinal(var f : TextRec;var l : cardinal);[Public,Alias: 'READ_TEXT_CARDINAL'];
Procedure Read_Cardinal(var f : TextRec;var l : cardinal);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_CARDINAL'];
var
hs : String;
code : Word;
@ -1042,7 +980,7 @@ Begin
End;
Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias: 'READ_TEXT_REAL'];
Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_REAL'];
var
hs : String;
code : Word;
@ -1081,7 +1019,7 @@ End;
{$ifdef SUPPORT_EXTENDED}
Procedure Read_Extended(var f : TextRec;var d : extended);[Public,Alias: 'READ_TEXT_EXTENDED'];
Procedure Read_Extended(var f : TextRec;var d : extended);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_EXTENDED'];
var
hs : String;
code : Word;
@ -1121,7 +1059,7 @@ End;
{$ifdef SUPPORT_COMP}
Procedure Read_Comp(var f : TextRec;var d : comp);[Public,Alias: 'READ_TEXT_COMP'];
Procedure Read_Comp(var f : TextRec;var d : comp);[Public,Alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'READ_TEXT_COMP'];
var
hs : String;
code : Word;
@ -1160,24 +1098,6 @@ End;
{$endif SUPPORT_COMP}
{$ifdef VER0_99_5}
Procedure r(var f : TextRec);[Public,Alias: 'READLN_TEXT'];
Begin
If InOutRes <> 0 then exit;
if not OpenInput(f) then
exit;
while (f.BufPos<f.BufEnd) do
begin
inc(f.BufPos);
if (f.BufPtr^[f.BufPos-1]=#10) then
exit;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
end;
End;
{$endif VER0_99_5}
{*****************************************************************************
Initializing
*****************************************************************************}
@ -1202,7 +1122,11 @@ end;
{
$Log$
Revision 1.24 1998-09-08 10:14:06 peter
Revision 1.25 1998-09-14 10:48:23 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.24 1998/09/08 10:14:06 peter
+ textrecbufsize
Revision 1.23 1998/08/26 15:33:28 peter

97
rtl/inc/textrec.inc
View File

@ -21,16 +21,6 @@
unit without sacrificing TP compatibility.
}
{$ifndef VER0_99_5}
{$ifndef VER0_99_6}
{$define UNIFORM_TEXTREC}
{$endif}
{$endif}
{$ifdef UNIFORM_TEXTREC}
const
TextRecNameLength = 256;
TextRecBufSize = 256;
@ -53,90 +43,13 @@ type
buffer : textbuf;
End;
{$else UNIFORM_TEXTREC}
{**********************************
Old style for 0.99.5/0.99.6
**********************************}
Const
{$ifdef linux}
textrecnamelength = 256;
{$endif}
{$ifdef Win32}
textrecnamelength = 256;
{$endif}
{$ifdef MACOS}
textrecnamelength = 256;
{$endif}
{$ifdef AMIGA}
textrecnamelength = 256;
{$endif}
{$ifdef OS2}
textrecnamelength = 80;
{$endif}
{$ifdef Go32v1}
textrecnamelength = 80;
{$endif Go32v1}
{$ifdef Go32v2}
textrecnamelength = 80;
{$endif Go32v2}
{$ifdef ATARI}
textrecnamelength = 80;
{$endif}
TextRecBufSize = 128;
type
textbuf = array[0..TextRecBufSize-1] of char;
{$PACKRECORDS 2}
textrec = record
{$ifdef win32}
handle : longint;
{$endif win32}
{$ifdef amiga}
handle : longint;
{$endif amiga}
{$ifdef macos}
handle : longint;
{$endif macos}
{$ifdef linux}
handle : word;
{$endif}
{$ifdef Go32v1}
handle : word;
{$endif Go32v1}
{$ifdef Go32v2}
handle : word;
{$endif Go32v2}
{$ifdef atari}
handle : word;
{$endif atari}
{$ifdef os2}
handle : word;
{$endif os2}
mode : word;
bufsize,
_private,
bufpos,
bufend : word;
bufptr : ^textbuf;
openfunc,
inoutfunc,
flushfunc,
closefunc : pointer;
userdata : array[1..16] of byte;
name : array[0..textrecnamelength-1] of char;
buffer : textbuf;
end;
{$endif UNIFORM_TEXTREC}
{
$Log$
Revision 1.5 1998-09-08 10:14:07 peter
Revision 1.6 1998-09-14 10:48:25 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.5 1998/09/08 10:14:07 peter
+ textrecbufsize
Revision 1.4 1998/09/04 18:16:15 peter

26
rtl/inc/typefile.inc
View File

@ -46,32 +46,36 @@ begin
end;
Procedure Int_Typed_Reset(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias: 'RESET_TYPED'];
Procedure Int_Typed_Reset(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias: {$ifdef FPCNAMES}'FPC_RESET_TYPED'{$else}'RESET_TYPED'{$endif}];
Begin
If InOutRes <> 0 then exit;
If InOutRes <> 0 then
exit;
Reset(UnTypedFile(f),Size);
End;
Procedure Int_Typed_Rewrite(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias: 'REWRITE_TYPED'];
Procedure Int_Typed_Rewrite(var f : TypedFile;Size : Longint);[Public,IOCheck, Alias: {$ifdef FPCNAMES}'FPC_REWRITE_TYPED'{$else}'REWRITE_TYPED'{$endif}];
Begin
If InOutRes <> 0 then exit;
If InOutRes <> 0 then
exit;
Rewrite(UnTypedFile(f),Size);
End;
Procedure Int_Typed_Write(TypeSize : Longint;var f : TypedFile;var Buf);[IOCheck, Public, Alias : 'TYPED_WRITE'];
Procedure Int_Typed_Write(TypeSize : Longint;var f : TypedFile;var Buf);[IOCheck, Public, Alias : {$ifdef FPCNAMES}'FPC_TYPED_WRITE'{$else}'TYPED_WRITE'{$endif}];
Begin
If InOutRes <> 0 then exit;
If InOutRes <> 0 then
exit;
Do_Write(FileRec(f).Handle,Longint(@Buf),TypeSize);
End;
Procedure Int_Typed_Read(TypeSize : Longint;var f : TypedFile;var Buf);[IOCheck, Public, Alias : 'TYPED_READ'];
Procedure Int_Typed_Read(TypeSize : Longint;var f : TypedFile;var Buf);[IOCheck, Public, Alias : {$ifdef FPCNAMES}'FPC_TYPED_READ'{$else}'TYPED_READ'{$endif}];
var
Result : Longint;
Begin
If InOutRes <> 0 then exit;
If InOutRes <> 0 then
exit;
Result:=Do_Read(FileRec(f).Handle,Longint(@Buf),TypeSize);
If Result<TypeSize Then
InOutRes:=100;
@ -79,7 +83,11 @@ End;
{
$Log$
Revision 1.4 1998-07-02 12:16:28 carl
Revision 1.5 1998-09-14 10:48:26 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.4 1998/07/02 12:16:28 carl
* IoCheck routines now check for InOutRes before executing, just like TP
Revision 1.3 1998/05/21 19:31:02 peter

54
rtl/linux/syslinux.pp
View File

@ -47,7 +47,7 @@ const
{$endif}
{$else}
UnusedHandle = $ffff;
{$endif}
{$endif}
StdInputHandle = 0;
StdOutputHandle = 1;
StdErrorHandle = 2;
@ -96,7 +96,9 @@ Implementation
Misc. System Dependent Functions
*****************************************************************************}
{$ASMMODE DIRECT}
{$ifdef i386}
{$ASMMODE DIRECT}
{$endif}
Procedure Halt(ErrNum: Byte);
Begin
@ -108,6 +110,9 @@ Begin
jmp _haltproc
end;
{$else}
asm
jmp _haltproc
end;
{$endif}
End;
@ -150,7 +155,7 @@ Begin
if pp^<>nil then
Paramstr:=StrPas(pp^)
else
ParamStr:='';
ParamStr:='';
{$endif}
End;
@ -169,6 +174,31 @@ End;
Heap Management
*****************************************************************************}
function getheapstart:pointer;assembler;
{$ifdef i386}
asm
leal HEAP,%eax
end ['EAX'];
{$else}
asm
lea.l HEAP,a0
move.l a0,d0
end;
{$endif}
function getheapsize:longint;assembler;
{$ifdef i386}
asm
movl HEAPSIZE,%eax
end ['EAX'];
{$else}
asm
move.l HEAP_SIZE,d0
end ['D0'];
{$endif}
{ ___fpc_brk_addr is defined and allocated in prt1.as }
Function Get_Brk_addr : longint;assembler;
@ -178,7 +208,8 @@ asm
end ['EAX'];
{$else}
asm
end;
move.l ___fpc_brk_addr,d0
end ['D0'];
{$endif}
@ -190,10 +221,14 @@ asm
end ['EAX'];
{$else}
asm
end;
move.l NewAddr,d0
move.l d0,___fpc_brk_addr
end ['D0'];
{$endif}
{$ASMMODE ATT}
{$ifdef i386}
{$ASMMODE ATT}
{$endif}
Function brk(Location : longint) : Longint;
{ set end of data segment to location }
@ -235,6 +270,7 @@ begin
exit(-1);
end;
{ include standard heap management }
{$I heap.inc}
@ -697,7 +733,11 @@ End.
{
$Log$
Revision 1.15 1998-09-06 19:41:40 peter
Revision 1.16 1998-09-14 10:48:27 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.15 1998/09/06 19:41:40 peter
* fixed unusedhandle for 0.99.5
Revision 1.14 1998/09/04 18:16:16 peter

1122
rtl/m68k/heap.inc
View File

File diff suppressed because it is too large Load Diff

258
rtl/m68k/m68k.inc
View File

@ -31,7 +31,7 @@
{ Don't call the following routines directly. }
Procedure Hlt;[public,alias: 'HALT_ERROR'];
Procedure Hlt;[public,alias: 'FPC_HALT_ERROR'];
{ called by code generator on run-time errors. }
{ on entry contains d0 = error code. }
var
@ -98,11 +98,10 @@
end ['d0','d1','a0'];
end;
procedure int_help_constructor;
procedure int_help_constructor;[public,alias:'FPC_HELP_CONSTRUCTOR'];
begin
asm
XDEF HELP_CONSTRUCTOR
{ Entry without preamble, since we need the ESP of the
constructor }
{ Stack (relative to %ebp):
@ -178,7 +177,7 @@
end;
end;
procedure int_help_destructor;
procedure int_help_destructor;[public,alias:'FPC_HELP_DESTRUCTOR'];
begin
asm
@ -189,7 +188,6 @@
0 %ebp
}
{ temporary Variable }
XDEF HELP_DESTRUCTOR
subq.l #4,sp
move.l sp,d6
{ Save Registers }
@ -222,10 +220,9 @@
end;
end;
procedure new_class;assembler;
procedure new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
asm
XDEF NEW_CLASS
{ create class ? }
move.l 8(a6), d0
tst.l d0
@ -249,10 +246,9 @@
procedure dispose_class;assembler;
procedure dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS'];
asm
XDEF DISPOSE_CLASS
{ destroy class ? }
move.l 8(a6),d0
{ save self }
@ -272,12 +268,11 @@
end;
{ checks for a correct vmt pointer }
procedure co;assembler;
procedure int_check_object;assembler;[public,alias:'FPC_CHECK_OBJECT'];
{ ON ENTRY: a0 -> Pointer to the VMT }
{ Nota: All registers must be preserved including }
{ A0 itself! }
asm
XDEF CHECK_OBJECT
move.l d0,-(sp)
tst.l a0
{ z flag set if zero }
@ -296,8 +291,13 @@
end;
function get_frame : longint; assembler;
asm
move.l a6,d0
end;
function get_addr(BP : longint) : longint;
function get_caller_addr(BP : longint) : longint;
begin
asm
move.l BP,a0
@ -309,7 +309,7 @@
end ['a0'];
end;
function get_next_frame(bp : longint) : longint;
function get_caller_frame(bp : longint) : longint;
begin
asm
@ -322,113 +322,8 @@
end ['a0'];
end;
Procedure HandleError (Errno : longint);[alias : 'handleerror'];
{
Procedure to handle internal errors, i.e. not user-invoked errors
Internal function should ALWAYS call HandleError instead of RunError.
}
function get_addr : pointer;
begin
asm
move.l (a6),a0
move.l 4(a0),a0
move.l a0,@RESULT
end ['a0'];
end;
function get_error_bp : longint;
begin
asm
{ get base pointer of error }
move.l (a6),d0
move.l d0,@RESULT
end ['d0'];
end;
begin
If ErrorProc<>Nil then
TErrorProc (ErrorProc)(Errno,get_addr);
errorcode:=Errno;
exitcode:=Errno;
erroraddr:=Get_addr;
DoError := TRUE;
errorbase:=get_error_bp;
halt(errorcode);
end;
procedure runerror(w : word);
function get_addr : longint;
begin
asm
move.l (a6),a0
move.l 4(a0),a0
move.l a0,@RESULT
end ['a0'];
end;
function get_error_bp : longint;
begin
asm
{ get base pointer of error }
move.l (a6),d0
move.l d0,@RESULT
end ['d0'];
end;
begin
errorcode:=w;
exitcode:=w;
erroraddr:=pointer(get_addr);
DoError:=True;
ErrorBase:=get_error_bp;
halt(byte(errorcode));
end;
procedure io1(addr : longint);[public,alias: 'IOCHECK'];
var
l : longint;
begin
{ Since IOCHECK is called directly and only later the optimiser }
{ Maybe also save global registers }
asm
movem.l d0-a7,-(sp)
end;
l:=ioresult;
if l<>0 then
begin
writeln('IO-Error ',l,' at 0x',HexStr(addr,8));
halt(byte(l));
end;
asm
{ the register are put back in the correct order }
movem.l (sp)+,d0-a7
end;
end;
procedure re_overflow;[public,alias: 'RE_OVERFLOW'];
var
addr : longint;
begin
{ Overflow was shortly before the return address }
asm
move.l 4(a6),d0
move.l d0,addr
end;
writeln('Overflow at 0x',HexStr(addr,8));
HandleError(215);
end;
{ procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];}
procedure strcopy; assembler;
procedure strcopy; assembler;[public,alias: 'FPC_STRCOPY'];
{---------------------------------------------------}
{ Low-level routine to copy a string to another }
{ string with maximum length. Never call directly! }
@ -439,7 +334,6 @@ end;
{ registers destroyed: a0,a1,d0,d1 }
{---------------------------------------------------}
asm
XDEF STRCOPY
{ move.l 12(a6),a0
move.l 16(a6),a1
move.l 8(a6),d1 }
@ -512,10 +406,8 @@ end;
{ ALL FLAGS are set appropriately. }
{ ZF = strings are equal }
{ REGISTERS DESTROYED: a0, a1, d0, d1, d6 }
procedure strcmp; assembler;
procedure strcmp; assembler;[public,alias:'FPC_STRCMP'];
asm
XDEF STRCMP
move.b (a0)+,d0 { Get length of first string }
move.b (a1)+,d6 { Get length of 2nd string }
@ -722,22 +614,6 @@ end;
end;
{$IFNDEF NEW_READWRITE}
procedure f1;[public,alias: 'FLUSH_STDOUT'];
begin
asm
{ Save Registers }
movem.l d0-a7,-(sp)
end;
FileFunc(textrec(output).flushfunc)(textrec(output));
asm
{ Restore all registers in the correct order }
movem.l (sp)+,d0-a7
end;
end;
{$ENDIF NEW_READWRITE}
Function Sptr : Longint;
begin
asm
@ -750,7 +626,7 @@ end;
Procedure BoundsCheck;assembler;
Procedure BoundsCheck;assembler;[public,alias:'FPC_RE_BOUNDS_CHECK'];
{ called by code generator with R+ state to }
{ determine if a range check occured. }
{ Only in 68000 mode, in 68020 mode this is }
@ -759,7 +635,6 @@ end;
{ A1 = address contaning min and max indexes }
{ D0 = value of current index to check. }
asm
XDEF RE_BOUNDS_CHECK
cmp.l (A1),D0 { lower bound ... }
bmi @rebounderr { is index lower ... }
add.l #4,A1
@ -772,9 +647,40 @@ XDEF RE_BOUNDS_CHECK
@reboundend:
end;
{****************************************************************************
IoCheck
****************************************************************************}
procedure int_iocheck(addr : longint);[public,alias: {$ifdef FPCNAMES}'FPC_'+{$endif}'IOCHECK'];
var
l : longint;
begin
asm
movem.l d0-a7,-(sp)
end;
if InOutRes<>0 then
begin
l:=InOutRes;
InOutRes:=0;
If ErrorProc<>Nil then
TErrorProc(Errorproc)(l,pointer(addr));
{$ifndef RTLLITE}
writeln('IO-Error ',l,' at 0x',HexStr(addr,8));
{$endif}
Halt(byte(l));
end;
asm
movem.l (sp)+,d0-a7
end;
end;
{
$Log$
Revision 1.10 1998-08-17 12:26:04 carl
Revision 1.11 1998-09-14 10:48:29 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.10 1998/08/17 12:26:04 carl
+ simple cleanup of comments
Revision 1.9 1998/07/30 13:26:14 michael
@ -793,72 +699,4 @@ XDEF RE_BOUNDS_CHECK
* strcopy bugfix was using signed comparison
+ STRCOPY uses register calling conventions
* FillChar bugfix was loading a word instead of a byte
Revision 1.2 1998/03/27 23:48:06 carl
* bugfix of STRCONCAT alignment problem
Revision 1.18 1998/03/02 04:17:24 carl
* problem with CHECK_OBJECT fixed, will probably only work with
GNU tools, as the VMT pointer is an .lcomm and might not be
zeroed automatically by other loaders.
* CHECK_OBJECT was not jumping on right condition
Revision 1.17 1998/02/23 02:26:06 carl
* bugfix to make it link without problems
Revision 1.13 1998/02/06 16:35:35 carl
* oops commited wrong file
Revision 1.11 1998/01/26 12:01:32 michael
+ Added log at the end
Working file: rtl/m68k/m68k.inc
description:
----------------------------
revision 1.10
date: 1998/01/19 10:21:36; author: michael; state: Exp; lines: +1 -12
* moved Fillchar t(..,char) to system.inc
----------------------------
revision 1.9
date: 1998/01/13 03:47:39; author: carl; state: Exp; lines: +3 -3
* bugfix of BoundsCheck invalid opcodes
----------------------------
revision 1.8
date: 1998/01/13 03:24:58; author: carl; state: Exp; lines: +2 -2
* moveq.l #201 bugfix (This is of course an impossible opcode)
----------------------------
revision 1.7
date: 1998/01/12 15:24:47; author: carl; state: Exp; lines: +1 -20
* bugfix, a function was being duplicated.
----------------------------
revision 1.6
date: 1998/01/12 03:40:11; author: carl; state: Exp; lines: +2 -2
* bugfix of RE_OVERFLOW, now gives out a runerror(215)
----------------------------
revision 1.5
date: 1998/01/05 00:31:43; author: carl; state: Exp; lines: +206 -119
* Bugfix of syntax errors
----------------------------
revision 1.4
date: 1998/01/01 16:50:16; author: michael; state: Exp; lines: +1 -21
- Moved Do_exit to system.inc. Now processor independent.
----------------------------
revision 1.3
date: 1997/12/10 12:15:05; author: michael; state: Exp; lines: +2 -2
* changed dateifunc to FileFunc.
----------------------------
revision 1.2
date: 1997/12/01 12:37:21; author: michael; state: Exp; lines: +14 -0
+ added copyright reference in header.
----------------------------
revision 1.1
date: 1997/11/27 08:33:48; author: michael; state: Exp;
Initial revision
----------------------------
revision 1.1.1.1
date: 1997/11/27 08:33:48; author: michael; state: Exp; lines: +0 -0
FPC RTL CVS start
=============================================================================
}

2
rtl/m68k/makefile.cpu
View File

@ -2,6 +2,6 @@
# Here we set processor dependent include file names.
#
CPUNAMES=m68k heap lowmath math set
CPUNAMES=m68k lowmath math set
CPUINCNAMES=$(addsuffix .inc,$(CPUNAMES))

7
rtl/os2/sysos2.pas
View File

@ -243,7 +243,12 @@ function getheapstart:pointer;assembler;
asm
movl __heap_base,%eax
end ['EAX'];
{$ASMMODE att}
function getheapsize:longint;assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
{$ASMMODE ATT}
{$i heap.inc}

70
rtl/win32/syswin32.pp
View File

@ -19,19 +19,15 @@ unit syswin32;
{$I os.inc}
{.$DEFINE WINHEAP} { Use windows heap manager, if not set use FPC heap }
interface
{ include system-independent routine headers }
{$I systemh.inc}
{$ifndef WinHeap}
{ include heap support headers }
{$I heaph.inc}
{$endif}
{ include heap support headers }
{$I heaph.inc}
const
{ Default filehandles }
@ -72,15 +68,9 @@ var
hinstance,
cmdshow : longint;
{$ifdef WinHeap}
var
heaperror : pointer;
function HeapSize:longint;
{$endif}
implementation
{ include system independent routines }
{$I system.inc}
@ -234,33 +224,29 @@ end;
Heap Management
*****************************************************************************}
{$ifdef WinHeap}
{$i winheap.inc}
{$else}
{ memory functions }
function GlobalAlloc(mode,size:longint):longint;
external 'kernel32' name 'GlobalAlloc';
function GlobalReAlloc(mode,size:longint):longint;
external 'kernel32' name 'GlobalReAlloc';
function GlobalHandle(p:pointer):longint;
external 'kernel32' name 'GlobalHandle';
function GlobalLock(handle:longint):pointer;
external 'kernel32' name 'GlobalLock';
function GlobalUnlock(h:longint):longint;
external 'kernel32' name 'GlobalUnlock';
function GlobalFree(h:longint):longint;
external 'kernel32' name 'GlobalFree';
{$ifdef SYSTEMDEBUG}
function GlobalSize(h:longint):longint;
external 'kernel32' name 'GlobalSize';
procedure GlobalMemoryStatus(p:pointer);
external 'kernel32' name 'GlobalMemoryStatus';
function LocalAlloc(uFlags : UINT;uBytes :UINT) : HLOCAL;
external 'kernel32' name 'LocalAlloc';
function LocalFree(hMem:HLOCAL):HLOCAL;
external 'kernel32' name 'LocalFree';
{$endif}
{$ASMMODE DIRECT}
function getheapstart:pointer;assembler;
asm
leal HEAP,%eax
end ['EAX'];
function getheapsize:longint;assembler;
asm
movl HEAPSIZE,%eax
end ['EAX'];
{$ASMMODE ATT}
function Sbrk(size : longint):longint;
var
@ -268,17 +254,17 @@ var
begin
h:=GlobalAlloc(258,size);
l:=longint(GlobalLock(h));
if l=0 then l:=-1;
if l=0 then
l:=-1;
{$ifdef SYSTEMDEBUG}
Writeln('new heap part at $',hexstr(l,8), ' size = ',GlobalSize(h));
{$endif}
sbrk:=l;
end;
{ include standard heap management }
{$I heap.inc}
{$endif WinHeap}
{*****************************************************************************
Low Level File Routines
*****************************************************************************}
@ -742,9 +728,7 @@ begin
{ real test stack depth }
{ stacklimit := setupstack; }
{ Setup heap }
{$ifndef WinHeap}
InitHeap;
{$endif WinHeap}
{ Setup stdin, stdout and stderr }
StdInputHandle:=longint(GetStdHandle(STD_INPUT_HANDLE));
StdOutputHandle:=longint(GetStdHandle(STD_OUTPUT_HANDLE));
@ -762,7 +746,11 @@ end.
{
$Log$
Revision 1.19 1998-09-02 09:03:46 pierre
Revision 1.20 1998-09-14 10:48:33 peter
* FPC_ names
* Heap manager is now system independent
Revision 1.19 1998/09/02 09:03:46 pierre
* do_open sometimes returns -1 as handle on fail
was not checked correctly