mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-07 16:06:16 +02:00
* all string internal routines fixed and tested (to my knowledge)
* bugfix of missing typecast with a call to halt with a word
This commit is contained in:
carl
parent
53d0f3d9af
commit
26d45eee6d
@ -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
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user