+ added currency and widestring support to TWriter and TReader

This commit is contained in:
florian 2004-05-23 12:42:42 +00:00
parent d4576c1075
commit cd81fa77ea

View File

@ -34,23 +34,54 @@ procedure fpc_cpuinit;
begin
end;
{ Don't call the following routines directly. }
Procedure Hlt;[public,alias: 'FPC_HALT_ERROR'];
{ called by code generator on run-time errors. }
{ on entry contains d0 = error code. }
var
b:byte; { only byte is used... }
{$define FPC_SYSTEM_HAS_GET_FRAME}
function get_frame : pointer; assembler;
asm
move.l a6,d0
end;
{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR}
function get_caller_addr(framebp : pointer) : pointer;
begin
asm
move.b d0,b
end;
HandleError(b);
move.l FRAMEBP,a0
cmp.l #0,a0
beq @Lnul_address
move.l 4(a0),a0
@Lnul_address:
move.l a0,@RESULT
end ['a0'];
end;
{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME}
function get_caller_frame(framebp : pointer) : pointer;
begin
asm
move.l FRAMEBP,a0
cmp.l #0,a0
beq @Lnul_frame
move.l (a0),a0
@Lnul_frame:
move.l a0,@RESULT
end ['a0'];
end;
Procedure FillChar(var x;count:longint;value:byte);[public,alias: 'FPC_FILL_OBJECT'];
{$define FPC_SYSTEM_HAS_SPTR}
function Sptr : Longint;
begin
asm
move.l sp,d0
add.l #8,d0
move.l d0,@RESULT
end ['d0'];
end;
{$define FPC_SYSTEM_HAS_FILLCHAR}
procedure FillChar(var x;count:longint;value:byte);[public,alias: 'FPC_FILL_OBJECT'];
begin
asm
move.l 8(a6), a0 { destination }
@ -76,268 +107,8 @@ end;
end ['d0','d1','a0'];
end;
Procedure FillObject(var x; count: longint; value: byte);
begin
asm
move.l 8(a6), a0 { destination }
move.l 12(a6), d1 { number of bytes to fill }
move.w 16(a6),d0 { fill data }
cmp.l #65535, d1 { check, if this is a word move }
ble @LMEMSET3 { use fast dbra mode }
bra @LMEMSET2
@LMEMSET1:
move.b d0,(a0)+
@LMEMSET2:
subq.l #1,d1
cmp.l #-1,d1
bne @LMEMSET1
bra @LMEMSET5 { finished slow mode , exit }
@LMEMSET4: { fast loop mode section 68010+ }
move.b d0,(a0)+
@LMEMSET3:
dbra d1,@LMEMSET4
@LMEMSET5:
end ['d0','d1','a0'];
end;
procedure int_help_constructor;[public,alias:'FPC_HELP_CONSTRUCTOR'];
begin
asm
{ Entry without preamble, since we need the ESP of the
constructor }
{ Stack (relative to %ebp):
12 Self
8 VMT-Address
4 main programm-Addr
0 %ebp
}
{ do we have to initialize self }
{ we just need to check for zero }
move.l a5,d0
tst.l d0 { set flags }
bne @LHC_4
{ get memory, but save register first }
{ temporary variable }
subq.l #4,sp
move.l sp,a5
{ Save Registers }
movem.l d0-a7,-(sp)
{ Memory size }
move.l 8(a6),a0
move.l (a0),-(sp)
{ push method pointer }
move.l a5,-(sp)
jsr FPC_GETMEM
{ Restore all registers in the correct order }
movem.l (sp)+,d0-a7
{ Memory position to a5 }
move.l (a5),a5
addq.l #4,sp
{ If no memory available : fail() }
move.l a5,d0
tst.l d0 { set flags for a5 }
beq @LHC_5
{ init self for the constructor }
move.l a5,12(a6)
@LHC_4:
{ is there a VMT address ? }
move.l 8(a6),d0
or.l d0,d0
bne @LHC_7
{ In case the constructor doesn't do anything, the Zero-Flag }
{ can't be put, because this calls Fail() }
add.l #1,d0
rts
@LHC_7:
{ set zero inside the object }
{ Save Registers }
movem.l d0-a7,-(sp)
move.w #0,-(sp)
move.l 8(a6),a0
move.l (a0),-(sp)
move.l a5,-(sp)
{ }
jsr FPC_FILLOBJECT
{ Restore all registers in the correct order }
movem.l (sp)+,d0-a7
{ set the VMT address for the new created object }
{$ifdef OBJECTVMTOFFSET}
{ the offset is in %edi since the calling and has not been changed !! }
move.l 8(a6),d1
move.l d1,(a5,d0.l)
{$else OBJECTVMTOFFSET}
move.l 8(a6),d0
move.l d0,(a5)
{$endif OBJECTVMTOFFSET}
or.l d0,d0
@LHC_5:
rts
end;
end;
procedure help_fail;
begin
asm
end;
end;
procedure int_help_destructor;[public,alias:'FPC_HELP_DESTRUCTOR'];
begin
asm
{ Stack (relative to %ebp):
12 Self
8 VMT-Address
4 Main program-Addr
0 %ebp
d0 contains vmt_offset
}
{ temporary Variable }
subq.l #4,sp
move.l sp,d6
{ Save Registers }
movem.l d0-a7,-(sp)
move.l 8(a6),d1 { Get the address of the vmt }
or.l d1,d1 { Check if there is a vmt }
beq @LHD_3
{ Yes, get size from SELF! }
move.l 12(a6),a0
{ get VMT-pointer (from Self) to %ebx }
{$ifdef OBJECTVMTOFFSET}
{ the offset is in d0 since the calling and has not been changed !! }
move.l (a0,d0.l),a1
{$else OBJECTVMTOFFSET}
move.l (a0),a1
{$endif OBJECTVMTOFFSET}
{ And put size on the Stack }
move.l (a1),-(sp)
{ SELF }
{ I think for precaution }
{ that we should clear the VMT here }
clr.l (a0)
{ get address of local variable into }
{ address register }
move.l d6,a1
move.l a0,(a1)
move.l a1,-(sp)
jsr FPC_FREEMEM
@LHD_3:
{ Restore all registers in the correct order }
movem.l (sp)+,d0-a7
add.l #4,sp
rts
end;
end;
procedure new_class;assembler;[public,alias:'FPC_NEW_CLASS'];
asm
{ create class ? }
move.l 8(a6), d0
tst.l d0
{ check for nil... }
beq @NEW_CLASS1
{ a5 contains vmt }
move.l a5,-(sp)
{ call newinstance (class method!) }
jsr 16(a5)
{ new instance returns a pointer to the new created }
{ instance in d0 }
{ load a5 and insert self }
move.l d0,8(a6)
move.l d0,a5
bra @end
@NEW_CLASS1:
move.l a5,8(a6)
@end:
end;
procedure dispose_class;assembler;[public,alias:'FPC_DISPOSE_CLASS'];
asm
{ destroy class ? }
move.l 8(a6),d0
{ save self }
move.l a5,8(a6)
tst.l d0
beq @DISPOSE_CLASS
{ no inherited call }
move.l (a5),d0
{ push self }
move.l a5,-(sp)
{ call freeinstance }
move.l d0,a0
jsr 20(a0)
@DISPOSE_CLASS:
{ load self }
move.l 8(a6),a5
end;
{ checks for a correct vmt pointer }
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
move.l d0,-(sp)
tst.l a0
{ z flag set if zero }
beq @co_re
move.l (a0),d0
add.l 4(a0),d0
bne @co_re
bra @end
@co_re:
move.l (sp)+,d0
move.b #210,d0
jsr FPC_HALT_ERROR
@end:
move.l (sp)+,d0
end;
function get_frame : longint; assembler;
asm
move.l a6,d0
end;
function get_caller_addr(framebp:longint):longint;
begin
asm
move.l FRAMEBP,a0
cmp.l #0,a0
beq @Lnul_address
move.l 4(a0),a0
@Lnul_address:
move.l a0,@RESULT
end ['a0'];
end;
function get_caller_frame(framebp:longint):longint;
begin
asm
move.l FRAMEBP,a0
cmp.l #0,a0
beq @Lnul_frame
move.l (a0),a0
@Lnul_frame:
move.l a0,@RESULT
end ['a0'];
end;
{$ifdef dummy}
{ procedure strcopy(dstr,sstr : pointer;len : longint);[public,alias: 'STRCOPY'];}
procedure strcopy; assembler;[public,alias: 'FPC_STRCOPY'];
{---------------------------------------------------}
@ -377,11 +148,11 @@ end;
@Lend:
end;
{ Concatenate Strings }
{ PARAMETERS ARE REVERSED COMPARED TO NORMAL! }
{ therefore online assembler may not parse the params as normal }
procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
begin
asm
move.b #255,d0
@ -458,37 +229,10 @@ end;
cmp.b d1,d0 { Compare length - set flag if equal length strings }
@LSTRCONCAT3:
end;
{$endif dummy}
Function strpas(p: pchar): string;
{ only 255 first characters are actually copied. }
var
counter : byte;
str: string;
Begin
counter := 0;
str := '';
while (ord(p[counter]) <> 0) and (counter < 255) do
begin
counter:=counter+1;
str[counter] := char(p[counter-1]);
end;
str[0] := char(counter);
strpas := str;
end;
function strlen(p : pchar) : longint;
var
counter : longint;
Begin
counter := 0;
repeat
counter:=counter+1;
until ord(p[counter]) = 0;
strlen := counter;
end;
{$define FPC_SYSTEM_HAS_MOVE}
procedure move(var source;var dest;count : longint);
{ base pointer+8 = source }
{ base pointer+12 = destination }
@ -545,8 +289,8 @@ end;
end;
{$define FPC_SYSTEM_HAS_FILLWORD}
procedure fillword(var x;count : longint;value : word);
begin
asm
move.l 8(a6), a0 { destination }
@ -563,8 +307,8 @@ end;
end;
{$define FPC_SYSTEM_HAS_ABS_LONGINT}
function abs(l : longint) : longint;
begin
asm
move.l 8(a6),d0
@ -576,123 +320,13 @@ end;
end ['d0'];
end;
function odd(l : longint) : boolean;
begin
if (l and $01) = $01 then
odd := TRUE
else
odd := FALSE;
end;
function sqr(l : longint) : longint;
begin
sqr := l*l;
end;
procedure int_str(l : longint;var s : string);
var
value: longint;
negative: boolean;
begin
negative := false;
s:='';
{ Workaround: }
if l=$80000000 then
begin
s:='-2147483648';
exit;
end;
{ handle case where l = 0 }
if l = 0 then
begin
s:='0';
exit;
end;
If l < 0 then
begin
negative := true;
value:=abs(l);
end
else
value:=l;
{ handle non-zero case }
while value>0 do
begin
s:=char((value mod 10)+ord('0'))+s;
value := value div 10;
end;
if negative then
s := '-' + s;
end;
Function Sptr : Longint;
begin
asm
move.l sp,d0
add.l #8,d0
move.l d0,@RESULT
end ['d0'];
end;
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 }
{ inline. }
{ On Entry: }
{ A1 = address contaning min and max indexes }
{ D0 = value of current index to check. }
asm
cmp.l (A1),D0 { lower bound ... }
bmi @rebounderr { is index lower ... }
add.l #4,A1
cmp.l (A1),D0
bmi @reboundend
beq @reboundend
@rebounderr:
move.l #201,d0
jsr FPC_HALT_ERROR
@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.4 2004-01-02 17:22:14 jonas
Revision 1.5 2004-05-23 12:42:42 florian
+ added currency and widestring support to TWriter and TReader
Revision 1.4 2004/01/02 17:22:14 jonas
+ fpc_cpuinit procedure to allow cpu/fpu initialisation before any unit
initialises
+ fpu exceptions for invalid operations and division by zero enabled for
@ -700,5 +334,4 @@ end;
Revision 1.3 2002/09/07 16:01:20 peter
* old logs removed and tabs fixed
}