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

* all string internal routines fixed and tested (to my knowledge)

Browse Source 
* bugfix of missing typecast with a call to halt with a word
This commit is contained in:
carl 1998-06-05 12:28:58 +00:00
parent 53d0f3d9af
commit 26d45eee6d
1 changed files with 64 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
rtl/m68k/m68k.inc
View File

@ -121,10 +121,12 @@
4 main programm-Addr 4 main programm-Addr
0 %ebp 0 %ebp
} }
{ initialise self ? } { do we have to initialize self }
move.l a5,d0 { we just need to check for zero }
tst.l d0 { set flags } move.l a5,d0
bne @LHC_4 tst.l d0 { set flags }
bne @LHC_4
{ get memory, but save register first } { get memory, but save register first }
{ temporary variable } { temporary variable }
subq.l #4,sp subq.l #4,sp
@ -145,27 +147,27 @@
{ If no memory available : fail() } { If no memory available : fail() }
move.l a5,d0 move.l a5,d0
tst.l d0 { set flags for a5 } tst.l d0 { set flags for a5 }
beq @LHC_5 beq @LHC_5
{ init self for the constructor } { init self for the constructor }
move.l a5,12(a6) move.l a5,12(a6)
@LHC_4: @LHC_4:
{ is there a VMT address ? } { is there a VMT address ? }
move.l 8(a6),d0 move.l 8(a6),d0
or.l d0,d0 or.l d0,d0
bne @LHC_7 bne @LHC_7
{ In case the constructor doesn't do anything, the Zero-Flag } { In case the constructor doesn't do anything, the Zero-Flag }
{ can't be put, because this calls Fail() } { can't be put, because this calls Fail() }
add.l #1,d0 add.l #1,d0
rts rts
@LHC_7: @LHC_7:
{ set zero inside the object } { set zero inside the object }
{ Save Registers } { Save Registers }
movem.l d0-a7,-(sp) movem.l d0-a7,-(sp)
move.w #0,-(sp) move.w #0,-(sp)
move.l 8(a6),a0 move.l 8(a6),a0
move.l (a0),-(sp) move.l (a0),-(sp)
move.l a5,-(sp) move.l a5,-(sp)
{ } { }
jsr FILLOBJECT jsr FILLOBJECT
{ Restore all registers in the correct order } { Restore all registers in the correct order }
@ -202,10 +204,10 @@
move.l sp,d6 move.l sp,d6
{ Save Registers } { Save Registers }
movem.l d0-a7,-(sp) movem.l d0-a7,-(sp)
{ Should the object be resolved ? }
move.l 8(a6),d0 move.l 8(a6),d0 { Get the address of the vmt }
or.l d0,d0 or.l d0,d0 { Check if there is a vmt }
beq @LHD_3 beq @LHD_3
{ Yes, get size from SELF! } { Yes, get size from SELF! }
move.l 12(a6),a0 move.l 12(a6),a0
{ get VMT-pointer (from Self) to %ebx } { get VMT-pointer (from Self) to %ebx }
@ -221,7 +223,7 @@
move.l d6,a1 move.l d6,a1
move.l a0,(a1) move.l a0,(a1)
move.l a1,-(sp) move.l a1,-(sp)
jsr FREEMEM jsr FREEMEM
@LHD_3: @LHD_3:
{ Restore all registers in the correct order } { Restore all registers in the correct order }
movem.l (sp)+,d0-a7 movem.l (sp)+,d0-a7
@ -285,7 +287,7 @@
asm asm
XDEF CHECK_OBJECT XDEF CHECK_OBJECT
{ save important registers } { save important registers }
move.l a0/d0,-(sp) movem.l a0/d0,-(sp)
{ check if pointer is nil.... before trying to access it } { check if pointer is nil.... before trying to access it }
{ offset is 12 contrary to i386 because we save two registers } { offset is 12 contrary to i386 because we save two registers }
@ -362,7 +364,7 @@
erroraddr:=pointer(get_addr); erroraddr:=pointer(get_addr);
DoError:=True; DoError:=True;
ErrorBase:=get_error_bp; ErrorBase:=get_error_bp;
halt(errorcode); halt(byte(errorcode));
end; end;
procedure io1(addr : longint);[public,alias: 'IOCHECK']; procedure io1(addr : longint);[public,alias: 'IOCHECK'];
@ -421,22 +423,29 @@
andi.l #$ff,d0 { zero extend d0-byte } andi.l #$ff,d0 { zero extend d0-byte }
move.l d0,d1 { save length to copy } move.l d0,d1 { save length to copy }
move.b d0,(a1)+ { save new length } move.b d0,(a1)+ { save new length }
bra @LMSTRCOPY55 { Check if copying length is zero - if so then }
@LMSTRCOPY56: { exit without copying anything. }
tst.b d1
beq @Lend
bra @LMSTRCOPY55
@LMSTRCOPY56: { 68010 Fast loop mode }
move.b (a0)+,(a1)+ move.b (a0)+,(a1)+
@LMSTRCOPY55: @LMSTRCOPY55:
dbra d1,@LMSTRCOPY56 dbra d1,@LMSTRCOPY56
@Lend:
end; end;
end; end;
{ Concatenate Strings } { 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']; procedure strconcat(s1,s2 : pointer);[public,alias: 'STRCONCAT'];
begin begin
asm asm
move.b #255,d0 move.b #255,d0
move.l s1,a0 move.l s1,a0 { a0 = destination }
move.l s2,a1 move.l s2,a1 { a1 = source }
sub.b (a0),d0 { copyl:= 255 -length(s1) } sub.b (a0),d0 { copyl:= 255 -length(s1) }
move.b (a1),d6 move.b (a1),d6
cmp.b d0,d6 { if copyl > length(s2) then } cmp.b d0,d6 { if copyl > length(s2) then }
@ -448,37 +457,51 @@
lea 1(a0,d6),a0 { s1[length(s1)+1] } lea 1(a0,d6),a0 { s1[length(s1)+1] }
add.l #1,a1 { s2[1] } add.l #1,a1 { s2[1] }
move.b d0,d6 move.b d0,d6
{ Check if copying length is zero - if so then }
{ exit without copying anything. }
tst.b d6
beq @Lend
@Loop: @Loop:
move.b (a1)+,(a0)+ { s1[i] := s2[i]; } move.b (a1)+,(a0)+ { s1[i] := s2[i]; }
dbra d6,@Loop dbra d6,@Loop
move.l s1,a0 move.l s1,a0
add.b d0,(a0) { change to new string length } add.b d0,(a0) { change to new string length }
@Lend:
end ['d0','d1','a0','a1','d6']; end ['d0','d1','a0','a1','d6'];
end; end;
{ Compares strings } { Compares strings }
procedure strcmp(dstr,sstr : pointer);[public,alias: 'STRCMP']; { DO NOT CALL directly. }
{ a0 = pointer to first string to compare }
begin { a1 = pointer to second string to compare }
asm { ALL FLAGS are set appropriately. }
move.l 12(a6),a0 { ZF = strings are equal }
move.l 8(a6),a1 { Get address of both strings } { REGISTERS DESTROYED: a0, a1, d0, d1, d6 }
procedure strcmp; assembler;
asm
XDEF STRCMP
move.b (a0)+,d0 { Get length of first string } move.b (a0)+,d0 { Get length of first string }
move.b (a1)+,d6 { Get length of 2nd string } move.b (a1)+,d6 { Get length of 2nd string }
move.b d0,d1 move.b d6,d1 { Save length of string for final compare }
cmp.b d6,d1 { Get shortest string length }
cmp.b d0,d6 { Get shortest string length }
ble @LSTRCONCAT1 ble @LSTRCONCAT1
move.b d6,d1 move.b d0,d6 { Set length to shortest string }
@LSTRCONCAT1: @LSTRCONCAT1:
tst.b d1 { Both strings have a length of zero, exit } tst.b d6 { Both strings have a length of zero, exit }
beq @LSTRCONCAT2 beq @LSTRCONCAT2
andi.l #$ff,d6 andi.l #$ff,d6
or.l d1,d1 { Make sure to set Zerfo flag to 0 }
bra @LSTRCONCAT4 subq.l #1,d6 { subtract first attempt }
{ if value is -1 then don't loop and just compare lengths of }
{ both strings before exiting. }
bmi @LSTRCONCAT2
or.l d0,d0 { Make sure to set Zerfo flag to 0 }
@LSTRCONCAT5: @LSTRCONCAT5:
{ Workaroung for GAS v.134 bug } { Workaroung for GAS v.134 bug }
{ old: cmp.b (a1)+,(a0)+ } { old: cmp.b (a1)+,(a0)+ }
@ -487,10 +510,11 @@
dbne d6,@LSTRCONCAT5 { Repeat until not equal } dbne d6,@LSTRCONCAT5 { Repeat until not equal }
bne @LSTRCONCAT3 bne @LSTRCONCAT3
@LSTRCONCAT2: @LSTRCONCAT2:
cmp.b d6,d0 { Compare length - set flag if equal length strings } { If length of both string are equal }
{ Then set zero flag }
cmp.b d1,d0 { Compare length - set flag if equal length strings }
@LSTRCONCAT3: @LSTRCONCAT3:
end; end;
end;
Function strpas(p: pchar): string; Function strpas(p: pchar): string;
@ -724,9 +748,9 @@ XDEF RE_BOUNDS_CHECK
{ {
$Log$ $Log$
Revision 1.4 1998-05-25 12:18:48 carl Revision 1.5 1998-06-05 12:28:58 carl
* strcopy bugfix * all string internal routines fixed and tested (to my knowledge)
* co bugfix with stack * bugfix of missing typecast with a call to halt with a word
Revision 1.2 1998/03/27 23:48:06 carl Revision 1.2 1998/03/27 23:48:06 carl
* bugfix of STRCONCAT alignment problem * bugfix of STRCONCAT alignment problem