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

* removed temp defines

Browse Source
This commit is contained in:
peter 1999-07-05 20:04:21 +00:00
parent fcd419b84a
commit ebd738f2f5
9 changed files with 185 additions and 1411 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

297
rtl/inc/astrings.inc
View File

@ -15,6 +15,9 @@
**********************************************************************}
{ This will release some functions for special shortstring support }
{ define EXTRAANSISHORT}
{
This file contains the implementation of the AnsiString type,
and all things that are needed for it.
@ -159,14 +162,11 @@ Procedure AnsiStr_Concat (S1,S2 : Pointer;var S3 : Pointer);[Public, alias: 'FPC
}
Var
Size,Location : Longint;
begin
{ create new result }
if S3<>nil then
begin
AnsiStr_Decr_Ref(S3);
S3:=nil;
end;
AnsiStr_Decr_Ref(S3);
{ only assign if s1 or s2 is empty }
if (S1=Nil) then
AnsiStr_Assign(S3,S2)
else
@ -183,6 +183,7 @@ begin
end;
{$ifdef EXTRAANSISHORT}
Procedure AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString);
{
Concatenates a Ansi with a short string; : S2 + S2
@ -201,6 +202,7 @@ begin
Move (S2[1],Pointer(Pointer(S1)+Location)^,Size);
PByte( Pointer(S1)+length(S1) )^:=0; { Terminating Zero }
end;
{$endif EXTRAANSISHORT}
Procedure AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer);[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR'];
@ -342,6 +344,7 @@ begin
end;
{$ifdef EXTRAANSISHORT}
Function AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): Longint;
{
Compares a AnsiString with a ShortString;
@ -365,6 +368,7 @@ begin
end;
AnsiStr_ShortStr_Compare:=Temp;
end;
{$endif EXTRAANSISHORT}
{*****************************************************************************
@ -435,13 +439,13 @@ begin
If Pointer(S)=Nil then
exit;
if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then
begin
SNew:=NewAnsiString (PAnsiRec(Pointer(S)-FirstOff)^.len);
Move (Pointer(S)^,SNew^,PAnsiRec(Pointer(S)-FirstOff)^.len+1);
PAnsiRec(SNew-FirstOff)^.len:=PAnsiRec(Pointer(S)-FirstOff)^.len;
ansistr_decr_ref (Pointer(S)); { Thread safe }
Pointer(S):=SNew;
end;
begin
SNew:=NewAnsiString (PAnsiRec(Pointer(S)-FirstOff)^.len);
Move (Pointer(S)^,SNew^,PAnsiRec(Pointer(S)-FirstOff)^.len+1);
PAnsiRec(SNew-FirstOff)^.len:=PAnsiRec(Pointer(S)-FirstOff)^.len;
ansistr_decr_ref (Pointer(S)); { Thread safe }
Pointer(S):=SNew;
end;
end;
@ -453,30 +457,29 @@ 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
If Index<0 Then
begin
If Index<0 Then
Index:=0;
ResultAddress:=Pointer(NewAnsiString (Size));
if ResultAddress<>Nil then
ResultAddress:=Pointer(NewAnsiString (Size));
if ResultAddress<>Nil then
begin
Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size);
PAnsiRec(ResultAddress-FirstOff)^.Len:=Size;
PByte(ResultAddress+Size)^:=0;
Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size);
PAnsiRec(ResultAddress-FirstOff)^.Len:=Size;
PByte(ResultAddress+Size)^:=0;
end;
end;
end;
Pointer(Copy):=ResultAddress;
end;
Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint;
var
i,j : longint;
e : boolean;
S : AnsiString;
se : Pointer;
e : boolean;
S : AnsiString;
se : Pointer;
begin
i := 0;
j := 0;
@ -497,8 +500,6 @@ begin
end;
{$IfDef ValInternCompiled}
Function ValAnsiFloat(Const S : AnsiString; Var Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR'];
Var
SS : String;
@ -537,110 +538,6 @@ end;
{$EndIf SUPPORT_FIXED}
{$Else ValInternCompiled}
Procedure Val (Const S : AnsiString; var R : real; Var Code : Integer);
Var
SS : String;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,R,Code);
end;
{
Procedure Val (var S : AnsiString; var D : Double; Var Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,S);
Val(SS,D,Code);
end;
}
Procedure Val (Const S : AnsiString; var E : Extended; Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,E,Code);
end;
Procedure Val (Const S : AnsiString; var C : Cardinal; Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,C,Code);
end;
Procedure Val (Const S : AnsiString; var L : Longint; Var Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,L,Code);
end;
Procedure Val (Const S : AnsiString; var W : Word; Var Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,W,Code);
end;
Procedure Val (Const S : AnsiString; var I : Integer; Var Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,I,Code);
end;
Procedure Val (Const S : AnsiString; var B : Byte; Var Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,B,Code);
end;
Procedure Val (Const S : AnsiString; var SI : ShortInt; Var Code : Integer);
Var SS : ShortString;
begin
AnsiStr_To_ShortStr (SS,Pointer(S));
Val(SS,SI,Code);
end;
{$EndIf ValInternCompiled}
{$ifdef INTERNDOUBLE}
procedure AnsiStr_Float(d : ValReal;len,fr,rt : longint;var s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT'];
var
ss : shortstring;
@ -649,73 +546,10 @@ begin
s:=ss;
end;
{$else INTERNDOUBLE}
Procedure ACoStr (Co : Comp;Len,fr: Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI_'{$endif}+'COMP'];
Var SS : ShortString;
begin
ShortStr_comp (Co,Len,fr,SS);
S:=SS;
end;
Procedure ASiStr (Si : Single;Len,fr: Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_SINGLE'];
Var SS : ShortString;
begin
ShortStr_Single (Si,Len,fr,SS);
S:=SS;
end;
{$IfDef Support_Fixed}
Procedure AFiStr (fi : Comp;Len,fr: Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_FIXED'];
Var SS : ShortString;
begin
ShortStr_Fixed (fi,Len,fr,SS);
S:=SS;
end;
{$EndIf Support_Fixed}
Procedure ARStr (D : Real;Len,fr: Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_REAL'];
Var SS : ShortString;
begin
ShortStr_real (D,Len,fr,SS);
S:=SS;
end;
Procedure AEStr (E : Extended;Len,Fr: Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_EXTENDED'];
Var SS : ShortString;
begin
ShortStr_Extended (E,Len,fr,SS);
S:=SS;
end;
{$endif INTERNDOUBLE}
Procedure ACStr (C : Cardinal;Len : Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_CARDINAL'];
Var SS : ShortString;
Procedure AnsiStr_Cardinal(C : Cardinal;Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_CARDINAL'];
Var
SS : ShortString;
begin
int_str_cardinal(C,Len,SS);
S:=SS;
@ -723,54 +557,54 @@ end;
Procedure ALStr (L : Longint; Len : Longint; Var S : AnsiString);
[Public,Alias : 'FPC_'+{$ifdef NOSTRANSI}'ANSISTR'{$else}'STRANSI'{$endif}+'_LONGINT'];
Var SS : ShortString;
Procedure AnsiStr_Longint(L : Longint; Len : Longint; Var S : AnsiString);[Public,Alias : 'FPC_ANSISTR_LONGINT'];
Var
SS : ShortString;
begin
int_Str_Longint (L,Len,SS);
S:=SS;
int_Str_Longint (L,Len,SS);
S:=SS;
end;
Procedure Delete (Var S : AnsiString; Index,Size: Longint);
Var LS : Longint;
Var
LS : Longint;
begin
If Length(S)=0 then exit;
If Length(S)=0 then
exit;
if index<=0 then
begin
Size:=Size+index-1;
index:=1;
end;
begin
inc(Size,index-1);
index:=1;
end;
LS:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
if (Index<=LS) and (Size>0) then
begin
UniqueAnsiString (S);
if Size+Index>LS then
begin
UniqueAnsiString (S);
if Size+Index>LS then
Size:=LS-Index+1;
if Index+Size<=LS then
if Index+Size<=LS then
begin
Dec(Index);
Move(PByte(Pointer(S))[Index+Size],
PByte(Pointer(S))[Index],LS-Index+1);
Dec(Index);
Move(PByte(Pointer(S))[Index+Size],PByte(Pointer(S))[Index],LS-Index+1);
end;
Setlength(s,LS-Size);
end;
Setlength(s,LS-Size);
end;
end;
Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint);
var Temp : AnsiString;
LS : Longint;
var
Temp : AnsiString;
LS : Longint;
begin
If Length(Source)=0 then exit;
if index <= 0 then index := 1;
If Length(Source)=0 then
exit;
if index <= 0 then
index := 1;
Ls:=Length(S);
if index > LS then index := LS+1;
if index > LS then
index := LS+1;
Dec(Index);
Pointer(Temp) := NewAnsiString(Length(Source)+LS);
SetLength(Temp,Length(Source)+LS);
@ -785,7 +619,10 @@ end;
{
$Log$
Revision 1.29 1999-06-14 00:47:33 peter
Revision 1.30 1999-07-05 20:04:21 peter
* removed temp defines
Revision 1.29 1999/06/14 00:47:33 peter
* merged
Revision 1.28.2.1 1999/06/14 00:39:07 peter

16
rtl/inc/generic.inc
View File

@ -217,7 +217,6 @@ end;
{$endif ndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT}
{$ifdef FPC_TESTOBJEXT}
{ checks for a correct vmt pointer }
{ deeper check to see if the current object is }
{ really related to the true }
@ -246,8 +245,6 @@ end;
{$endif ndef FPC_SYSTEM_HAS_FPC_CHECK_OBJECT_EXT}
{$endif FPC_TESTOBJEXT}
{****************************************************************************
String
@ -396,10 +393,6 @@ end;
function strpas(p:pchar):string;[public,alias:'FPC_PCHAR_TO_SHORTSTR'];
begin
{$ifndef NEWATT}
{ remove warning }
strpas:='';
{$endif}
asm
cld
movl p,%edi
@ -415,11 +408,7 @@ begin
scasb
.LStrPasNil:
movl %ecx,%eax
{$ifdef NEWATT}
movl __RESULT,%edi
{$else}
movl 8(%ebp),%edi
{$endif}
notb %al
decl %eax
stosb
@ -611,7 +600,10 @@ end;
{
$Log$
Revision 1.1 1999-05-31 21:59:58 pierre
Revision 1.2 1999-07-05 20:04:22 peter
* removed temp defines
Revision 1.1 1999/05/31 21:59:58 pierre
+ generic.inc added
}

7
rtl/inc/int64.inc
View File

@ -54,7 +54,7 @@
var
shift,lzz,lzn : longint;
one : qword;
{ one : qword; }
begin
divqword:=0;
@ -302,7 +302,10 @@
{
$Log$
Revision 1.12 1999-07-04 16:34:45 florian
Revision 1.13 1999-07-05 20:04:23 peter
* removed temp defines
Revision 1.12 1999/07/04 16:34:45 florian
+ str routines added
Revision 1.11 1999/07/02 17:01:29 florian

13
rtl/inc/objpas.inc
View File

@ -221,11 +221,7 @@
pushl message
pushl %esi
movl p,%edi
{$ifdef ver0_99_10}
call %edi
{$else ver0_99_10}
call *%edi
{$endif ver0_99_10}
end;
exit;
end;
@ -264,11 +260,7 @@
pushl message
pushl %esi
movl p,%edi
{$ifdef ver0_99_10}
call %edi
{$else ver0_99_10}
call *%edi
{$endif ver0_99_10}
end;
exit;
end;
@ -325,7 +317,10 @@
{
$Log$
Revision 1.4 1999-05-19 13:20:09 peter
Revision 1.5 1999-07-05 20:04:24 peter
* removed temp defines
Revision 1.4 1999/05/19 13:20:09 peter
* fixed dispatchstr
Revision 1.3 1999/05/17 21:52:37 florian

656
rtl/inc/sstrings.inc
View File

@ -282,67 +282,21 @@ end;
Str() Helpers
*****************************************************************************}
{$ifdef INTERNDOUBLE}
procedure ShortStr_Float(d : ValReal;len,fr,rt : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_FLOAT'];
begin
str_real(len,fr,d,treal_type(rt),s);
end;
{$else}
{$ifdef SUPPORT_SINGLE}
procedure ShortStr_Single(d : single;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'S32REAL'{$else}'SINGLE'{$endif}];
procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_LONGINT'];
begin
str_real(len,fr,d,rt_s32real,s);
end;
{$endif}
{$ifdef SUPPORT_DOUBLE}
procedure ShortStr_Real(d : real;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'S64'+{$endif}'REAL'];
begin
str_real(len,fr,d,rt_s64real,s);
end;
{$endif SUPPORT_S64REAL}
{$ifdef SUPPORT_EXTENDED}
procedure ShortStr_Extended(d : extended;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'S80REAL'{$else}'EXTENDED'{$endif}];
begin
str_real(len,fr,d,rt_s80real,s);
end;
{$endif SUPPORT_S80REAL}
{$ifdef SUPPORT_COMP}
procedure ShortStr_Comp(d : comp;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'C64BIT'{$else}'COMP'{$endif}];
begin
str_real(len,fr,d,rt_c64bit,s);
end;
{$endif SUPPORT_C64BIT}
{$ifdef SUPPORT_FIXED}
procedure ShortStr_Fixed(d : fixed;len,fr : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_'+{$ifdef INTERNDOUBLE}'F16BIT'{$else}'FIXED'{$endif}];
begin
str_real(len,fr,d,rt_f32bit,s);
end;
{$endif SUPPORT_F16BIT}
{$endif}
procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_LONGINT'];
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure int_str_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_'+{$ifdef NOSTRANSI}'SHORT'+{$endif}'STR_CARDINAL'];
procedure int_str_cardinal(v : cardinal;len : longint;var s : shortstring);[public,alias:'FPC_SHORTSTR_CARDINAL'];
begin
int_str(v,s);
if length(s)<len then
@ -381,11 +335,6 @@ begin
repeat
inc(code);
until (code>=length(s)) or (s[code]<>'0');
{The following isn't correct anymore for 64 bit integers! (JM)}
{$IfNDef ValInternCompiled}
if length(s)-code>7 then
code:=code+8;
{$EndIf ValInternCompiled}
end;
'%' : begin
base:=2;
@ -397,8 +346,6 @@ begin
end;
{$IfDef ValInternCompiled}
Function ValSignedInt(DestSize: longint; Const S: ShortString; var Code: ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_SHORTSTR'];
var
u: ValSInt;
@ -465,6 +412,7 @@ begin
End;
end;
Function ValUnsignedInt(Const S: ShortString; var Code: ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_SHORTSTR'];
var
u: ValUInt;
@ -506,6 +454,7 @@ begin
code := 0;
end;
Function ValFloat(const s : shortstring; var code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_SHORTSTR'];
var
hd,
@ -599,6 +548,7 @@ begin
code:=0;
end;
{$ifdef SUPPORT_FIXED}
Function ValFixed(const s : shortstring;var code : ValSInt): Fixed; [public, alias:'FPC_VAL_FIXED_SHORTSTR'];
begin
@ -607,592 +557,7 @@ end;
{$endif SUPPORT_FIXED}
{$Else ValInternCompiled}
procedure val(const s : shortstring;var l : longint;var code : word);
var
base,u : byte;
negativ : boolean;
begin
l:=0;
Code:=InitVal(s,negativ,base);
if Code>length(s) then
exit;
if negativ and (s='-2147483648') then
begin
Code:=0;
l:=$80000000;
exit;
end;
while Code<=Length(s) do
begin
u:=ord(s[code]);
case u of
48..57 : u:=u-48;
65..70 : u:=u-55;
97..104 : u:=u-87;
else
u:=16;
end;
l:=l*longint(base);
if (u>=base) or ((base=10) and (2147483647-l<longint(u))) then
begin
l:=0;
exit;
end;
l:=l+u;
inc(code);
end;
code := 0;
if negativ then
l:=0-l;
end;
procedure val(const s : shortstring;var l : longint;var code : integer);
begin
val(s,l,word(code));
end;
procedure val(const s : shortstring;var l : longint;var code : longint);
var
cw : word;
begin
val (s,l,cw);
code:=cw;
end;
procedure val(const s : shortstring;var l : longint);
var
code : word;
begin
val (s,l,code);
end;
procedure val(const s : shortstring;var b : byte);
var
l : longint;
begin
val(s,l);
b:=l;
end;
procedure val(const s : shortstring;var b : byte;var code : word);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : byte;var code : Integer);
begin
val(s,b,word(code));
end;
procedure val(const s : shortstring;var b : byte;var code : longint);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : shortint);
var
l : longint;
begin
val(s,l);
b:=l;
end;
procedure val(const s : shortstring;var b : shortint;var code : word);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : shortint;var code : Integer);
begin
val(s,b,word(code));
end;
procedure val(const s : shortstring;var b : shortint;var code : longint);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : word);
var
l : longint;
begin
val(s,l);
b:=l;
end;
procedure val(const s : shortstring;var b : word;var code : word);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : word;var code : Integer);
begin
val(s,b,word(code));
end;
procedure val(const s : shortstring;var b : word;var code : longint);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : integer);
var
l : longint;
begin
val(s,l);
b:=l;
end;
procedure val(const s : shortstring;var b : integer;var code : word);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var b : integer;var code : Integer);
begin
val(s,b,word(code));
end;
procedure val(const s : shortstring;var b : integer;var code : longint);
var
l : longint;
begin
val(s,l,code);
b:=l;
end;
procedure val(const s : shortstring;var v : cardinal;var code : word);
var
negativ : boolean;
base,u : byte;
begin
v:=0;
code:=InitVal(s,negativ,base);
if (Code>length(s)) or negativ then
exit;
while Code<=Length(s) do
begin
u:=ord(s[code]);
case u of
48..57 : u:=u-48;
65..70 : u:=u-55;
97..104 : u:=u-87;
else
u:=16;
end;
cardinal(v):=cardinal(v)*cardinal(longint(base));
if (u>base) or (cardinal($ffffffff)-cardinal(v)>cardinal(longint(u))) then
begin
v:=0;
exit;
end;
v:=v+u;
inc(code);
end;
code:=0;
end;
procedure val(const s : shortstring;var v : cardinal);
var
code : word;
begin
val(s,v,code);
end;
procedure val(const s : shortstring;var v : cardinal;var code : integer);
begin
val(s,v,word(code));
end;
procedure val(const s : shortstring;var v : cardinal;var code : longint);
var
cw : word;
begin
val(s,v,cw);
code:=cw;
end;
procedure val(const s : shortstring;var d : valreal;var code : word);
var
hd,
esign,sign : valreal;
exponent,i : longint;
flags : byte;
const
i10 = 10;
begin
d:=0;
code:=1;
exponent:=0;
esign:=1;
flags:=0;
sign:=1;
while (code<=length(s)) and (s[code] in [' ',#9]) do
inc(code);
case s[code] of
'+' : inc(code);
'-' : begin
sign:=-1;
inc(code);
end;
end;
while (Code<=Length(s)) and (s[code] in ['0'..'9']) do
begin
{ Read integer part }
flags:=flags or 1;
d:=d*i10;
d:=d+(ord(s[code])-ord('0'));
inc(code);
end;
{ Decimal ? }
if (s[code]='.') and (length(s)>=code) then
begin
hd:=extended(i1)/extended(i10);
inc(code);
while (s[code] in ['0'..'9']) and (length(s)>=code) do
begin
{ Read fractional part. }
flags:=flags or 2;
d:=d+hd*(ord(s[code])-ord('0'));
hd:=hd/i10;
inc(code);
end;
end;
{ Again, read integer and fractional part}
if flags=0 then
begin
d:=0;
exit;
end;
{ Exponent ? }
if (upcase(s[code])='E') and (length(s)>=code) then
begin
inc(code);
if s[code]='+' then
inc(code)
else
if s[code]='-' then
begin
esign:=-1;
inc(code);
end;
if not(s[code] in ['0'..'9']) or (length(s)<code) then
begin
d:=0;
exit;
end;
while (s[code] in ['0'..'9']) and (length(s)>=code) do
begin
exponent:=exponent*i10;
exponent:=exponent+ord(s[code])-ord('0');
inc(code);
end;
end;
{ Calculate Exponent }
if esign>0 then
for i:=1 to exponent do
d:=d*i10
else
for i:=1 to exponent do
d:=d/i10;
{ Not all characters are read ? }
if length(s)>=code then
begin
d:=0.0;
exit;
end;
{ evalute sign }
d:=d*sign;
{ success ! }
code:=0;
end;
procedure val(const s : shortstring;var d : valreal;var code : integer);
begin
val(s,d,word(code));
end;
procedure val(const s : shortstring;var d : valreal;var code : longint);
var
cw : word;
begin
val(s,d,cw);
code:=cw;
end;
procedure val(const s : shortstring;var d : valreal);
var
code : word;
begin
val(s,d,code);
end;
{$ifdef SUPPORT_SINGLE}
procedure val(const s : shortstring;var d : single;var code : word);
var
e : valreal;
begin
val(s,e,code);
d:=e;
end;
procedure val(const s : shortstring;var d : single;var code : integer);
var
e : valreal;
begin
val(s,e,word(code));
d:=e;
end;
procedure val(const s : shortstring;var d : single;var code : longint);
var
cw : word;
e : valreal;
begin
val(s,e,cw);
d:=e;
code:=cw;
end;
procedure val(const s : shortstring;var d : single);
var
code : word;
e : valreal;
begin
val(s,e,code);
d:=e;
end;
{$endif SUPPORT_SINGLE}
{$ifdef DEFAULT_EXTENDED}
{ with extended as default the valreal is extended so for real there need
to be a new val }
procedure val(const s : shortstring;var d : real;var code : word);
var
e : valreal;
begin
val(s,e,code);
d:=e;
end;
procedure val(const s : shortstring;var d : real;var code : integer);
var
e : valreal;
begin
val(s,e,word(code));
d:=e;
end;
procedure val(const s : shortstring;var d : real;var code : longint);
var
cw : word;
e : valreal;
begin
val(s,e,cw);
d:=e;
code:=cw;
end;
procedure val(const s : shortstring;var d : real);
var
code : word;
e : valreal;
begin
val(s,e,code);
d:=e;
end;
{$else DEFAULT_EXTENDED}
{ when extended is not the default it could still be supported }
{$ifdef SUPPORT_EXTENDED}
procedure val(const s : shortstring;var d : extended;var code : word);
var
e : valreal;
begin
val(s,e,code);
d:=e;
end;
procedure val(const s : shortstring;var d : extended;var code : integer);
var
e : valreal;
begin
val(s,e,word(code));
d:=e;
end;
procedure val(const s : shortstring;var d : extended;var code : longint);
var
cw : word;
e : valreal;
begin
val(s,e,cw);
d:=e;
code:=cw;
end;
procedure val(const s : shortstring;var d : extended);
var
code : word;
e : valreal;
begin
val(s,e,code);
d:=e;
end;
{$endif SUPPORT_EXTENDED}
{$endif DEFAULT_EXTENDED}
{$ifdef SUPPORT_COMP}
procedure val(const s : shortstring;var d : comp;var code : word);
var
e : valreal;
begin
val(s,e,code);
d:=comp(e);
end;
procedure val(const s : shortstring;var d : comp;var code : integer);
var
e : valreal;
begin
val(s,e,word(code));
d:=comp(e);
end;
procedure val(const s : shortstring;var d : comp;var code : longint);
var
cw : word;
e : valreal;
begin
val(s,e,cw);
d:=comp(e);
code:=cw;
end;
procedure val(const s : shortstring;var d : comp);
var
code : word;
e : valreal;
begin
val(s,e,code);
d:=comp(e);
end;
{$endif SUPPORT_COMP}
{$ifdef SUPPORT_FIXED}
procedure val(const s : shortstring;var d : fixed;var code : word);
var
e : valreal;
begin
val(s,e,code);
d:=fixed(e);
end;
procedure val(const s : shortstring;var d : fixed;var code : integer);
var
e : valreal;
begin
val(s,e,word(code));
d:=fixed(e);
end;
procedure val(const s : shortstring;var d : fixed;var code : longint);
var
cw : word;
e : valreal;
begin
val(s,e,cw);
d:=fixed(e);
code:=cw;
end;
procedure val(const s : shortstring;var d : fixed);
var
code : word;
e : valreal;
begin
val(s,e,code);
d:=fixed(e);
end;
{$endif SUPPORT_FIXED}
{$EndIf ValInternCompiled}
Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
begin
Move (Buf[0],S[1],Len);
S[0]:=chr(len);
@ -1200,7 +565,10 @@ end;
{
$Log$
Revision 1.28 1999-05-06 09:05:13 peter
Revision 1.29 1999-07-05 20:04:26 peter
* removed temp defines
Revision 1.28 1999/05/06 09:05:13 peter
* generic write_float str_float
Revision 1.27 1999/04/08 15:57:54 peter

37
rtl/inc/system.inc
View File

@ -32,6 +32,9 @@ Procedure HandleErrorFrame (Errno : longint;frame : longint); forward;
type
FileFunc = Procedure(var t : TextRec);
PLongint = ^Longint;
PByte = ^Byte;
const
{ Random / Randomize constants }
OldRandSeed : Cardinal = 0;
@ -56,11 +59,11 @@ var
Function lo(i : Integer) : byte; [INTERNPROC: In_lo_Word];
Function lo(w : Word) : byte; [INTERNPROC: In_lo_Word];
Function lo(l : Longint) : Word; [INTERNPROC: In_lo_long];
Function lo(l : DWord) : Word; [INTERNPROC: In_lo_long];
Function lo(l : DWord) : 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];
Function hi(l : DWord) : Word; [INTERNPROC: In_hi_long];
Function hi(l : DWord) : Word; [INTERNPROC: In_hi_long];
{$ifdef INT64}
Function lo(q : QWord) : DWord; [INTERNPROC: In_lo_qword];
@ -76,6 +79,7 @@ Function Length(c : char) : byte; [INTERNPROC: In_Length_string];
Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{****************************************************************************
Include processor specific routines
****************************************************************************}
@ -93,6 +97,7 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{$ENDIF}
{$ENDIF}
{****************************************************************************
Set Handling
****************************************************************************}
@ -100,6 +105,7 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{ Include set support which is processor specific}
{$I set.inc}
{****************************************************************************
Subroutines for String handling
****************************************************************************}
@ -108,10 +114,6 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
{$i sstrings.inc}
Type
PLongint = ^Longint;
PByte = ^Byte;
{$i astrings.inc}
@ -266,13 +268,6 @@ Begin
ptr:=pointer(off);
End;
{$ifndef INTERNALADDR}
Function Addr(var x):pointer;
begin
Addr:=@x;
end;
{$endif}
Function CSeg : Word;
Begin
Cseg:=0;
@ -336,11 +331,9 @@ end;
{*****************************************************************************
Init / Exit / ExitProc
Initialization / Finalization
*****************************************************************************}
{$ifdef HASFINALIZE}
const
maxunits=1024; { See also files.pas of the compiler source }
type
@ -386,8 +379,10 @@ begin
end;
end;
{$endif}
{*****************************************************************************
Error / Exit / ExitProc
*****************************************************************************}
Procedure HandleErrorFrame (Errno : longint;frame : longint);
{
@ -472,10 +467,8 @@ Begin
exitProc:=nil;
current_exit();
End;
{$ifdef HASFINALIZE}
{ Finalize units }
FinalizeUnits;
{$endif}
{ Show runtime error }
If erroraddr<>nil Then
Begin
@ -565,6 +558,7 @@ end;
{$i setjump.inc}
{*****************************************************************************
Object Pascal support
*****************************************************************************}
@ -573,7 +567,10 @@ end;
{
$Log$
Revision 1.63 1999-07-03 01:24:19 peter
Revision 1.64 1999-07-05 20:04:27 peter
* removed temp defines
Revision 1.63 1999/07/03 01:24:19 peter
* $ifdef int64
Revision 1.62 1999/07/02 18:06:42 florian

136
rtl/inc/systemh.inc
View File

@ -50,10 +50,6 @@ Type
{$ifdef i386}
StrLenInt = LongInt;
{$ifndef INTERNDOUBLE}
Double = real;
{$endif}
{$define DEFAULT_EXTENDED}
{$define SUPPORT_SINGLE}
@ -90,12 +86,9 @@ Type
TProcedure = Procedure;
const
{$IfDef ValInternCompiled}
{ Maximum value of the biggest signed and unsigned integer type available}
MaxSIntValue = High(ValSInt);
MaxUIntValue = High(ValUInt);
{$EndIf ValInternCompiled}
{ max. values for longint and int}
maxLongint = $7fffffff;
@ -117,6 +110,7 @@ const
{ max level in dumping on error }
Max_Frame_Dump : Word = 8;
{ Exit Procedure handling consts and types }
ExitProc : pointer = nil;
Erroraddr: pointer = nil;
@ -206,9 +200,6 @@ Function odd(l:Longint):Boolean;
{$ifndef RTLLITE}
Function ptr(sel,off:Longint):pointer;
{$ifndef INTERNALADDR}
Function Addr(var x):pointer;
{$endif}
Function Cseg:Word;
Function Dseg:Word;
Function Sseg:Word;
@ -231,89 +222,31 @@ Function Pos(C:Char;const s:shortstring):StrLenInt;
Procedure SetLength(var s:shortstring;len:StrLenInt);
Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
Function Length(s:string):byte;
Function upCase(const s:shortstring):shortstring;
{$ifndef RTLLITE}
Function lowerCase(const s:shortstring):shortstring;
{$endif}
Function Space(b:byte):shortstring;
{$ifndef RTLLITE}
Function hexStr(Val:Longint;cnt:byte):shortstring;
Function binStr(Val:Longint;cnt:byte):shortstring;
{$endif RTLLITE}
{ Char functions to overcome overloading problem with ansistrings }
{ Char functions }
Function Chr(b:byte):Char;
Function upCase(c:Char):Char;
{$ifndef RTLLITE}
Function lowerCase(c:Char):Char;
{$endif RTLLITE}
function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
function pos(const substr : shortstring;c:char): StrLenInt;
function length(c:char):byte;
Function Chr(b:byte):Char;
Function upCase(const s:shortstring):shortstring;
Function upCase(c:Char):Char;
{$ifndef RTLLITE}
Function lowerCase(c:Char):Char;
Function lowerCase(const s:shortstring):shortstring;
Function hexStr(Val:Longint;cnt:byte):shortstring;
Function binStr(Val:Longint;cnt:byte):shortstring;
{$endif RTLLITE}
Function Space(b:byte):shortstring;
{$IfNDef ValInternCompiled}
Procedure Val(const s:shortstring;Var l:Longint;Var code:Word);
Procedure Val(const s:shortstring;Var l:Longint;Var code:Integer);
Procedure Val(const s:shortstring;Var l:Longint;Var code:Longint);
Procedure Val(const s:shortstring;Var l:Longint);
Procedure Val(const s:shortstring;Var b:byte;Var code:Word);
Procedure Val(const s:shortstring;Var b:byte;Var code:Integer);
Procedure Val(const s:shortstring;Var b:byte;Var code:Longint);
Procedure Val(const s:shortstring;Var b:byte);
Procedure Val(const s:shortstring;Var b:shortint;Var code:Word);
Procedure Val(const s:shortstring;Var b:shortint;Var code:Integer);
Procedure Val(const s:shortstring;Var b:shortint;Var code:Longint);
Procedure Val(const s:shortstring;Var b:shortint);
Procedure Val(const s:shortstring;Var b:Word;Var code:Word);
Procedure Val(const s:shortstring;Var b:Word;Var code:Integer);
Procedure Val(const s:shortstring;Var b:Word;Var code:Longint);
Procedure Val(const s:shortstring;Var b:Word);
Procedure Val(const s:shortstring;Var b:Integer;Var code:Word);
Procedure Val(const s:shortstring;Var b:Integer;Var code:Integer);
Procedure Val(const s:shortstring;Var b:Integer;Var code:Longint);
Procedure Val(const s:shortstring;Var b:Integer);
Procedure Val(const s:shortstring;Var v:cardinal;Var code:Word);
Procedure Val(const s:shortstring;Var v:cardinal;Var code:Integer);
Procedure Val(const s:shortstring;Var v:cardinal;Var code:Longint);
Procedure Val(const s:shortstring;Var v:cardinal);
Procedure Val(const s:shortstring;Var d:ValReal;Var code:Word);
Procedure Val(const s:shortstring;Var d:ValReal;Var code:Integer);
Procedure Val(const s:shortstring;Var d:ValReal;Var code:Longint);
Procedure Val(const s:shortstring;Var d:ValReal);
{$ifdef SUPPORT_SINGLE}
Procedure Val(const s:shortstring;Var d:single;Var code:Word);
Procedure Val(const s:shortstring;Var d:single;Var code:Integer);
Procedure Val(const s:shortstring;Var d:single;Var code:Longint);
Procedure Val(const s:shortstring;Var d:single);
{$endif SUPPORT_SINGLE}
{$ifdef SUPPORT_COMP}
Procedure Val(const s:shortstring;Var d:comp;Var code:Word);
Procedure Val(const s:shortstring;Var d:comp;Var code:Integer);
Procedure Val(const s:shortstring;Var d:comp;Var code:Longint);
Procedure Val(const s:shortstring;Var d:comp);
{$endif SUPPORT_COMP}
{$ifdef SUPPORT_FIXED}
Procedure Val(const s:shortstring;Var d:fixed;Var code:Word);
Procedure Val(const s:shortstring;Var d:fixed;Var code:Integer);
Procedure Val(const s:shortstring;Var d:fixed;Var code:Longint);
Procedure Val(const s:shortstring;Var d:fixed);
{$endif SUPPORT_FIXED}
{$ifdef DEFAULT_EXTENDED}
Procedure Val(const s:shortstring;Var d:Real;Var code:Word);
Procedure Val(const s:shortstring;Var d:Real;Var code:Integer);
Procedure Val(const s:shortstring;Var d:Real;Var code:Longint);
Procedure Val(const s:shortstring;Var d:Real);
{$else DEFAULT_EXTENDED}
{$ifdef SUPPORT_EXTENDED}
Procedure Val(const s:shortstring;Var d:Extended;Var code:Word);
Procedure Val(const s:shortstring;Var d:Extended;Var code:Integer);
Procedure Val(const s:shortstring;Var d:Extended;Var code:Longint);
Procedure Val(const s:shortstring;Var d:Extended);
{$endif}
{$endif DEFAULT_EXTENDED}
{$EndIf ValInternCompiled}
{****************************************************************************
AnsiString Handling
****************************************************************************}
Procedure SetLength (Var S : AnsiString; l : Longint);
Procedure UniqueAnsiString (Var S : AnsiString);
Function Length (Const S : AnsiString) : Longint;
@ -321,30 +254,6 @@ Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString;
Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint;
Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint);
Procedure Delete (Var S : AnsiString; Index,Size: Longint);
{$IfNDef ValInternCompiled}
Procedure Val (Const S : AnsiString; var R : real; Var Code : Integer);
{
Procedure Val (Const S : AnsiString; var D : Double; Var Code : Integer);
}
Procedure Val (Const S : AnsiString; var E : Extended; Code : Integer);
Procedure Val (Const S : AnsiString; var C : Cardinal; Code : Integer);
Procedure Val (Const S : AnsiString; var L : Longint; Var Code : Integer);
Procedure Val (Const S : AnsiString; var W : Word; Var Code : Integer);
Procedure Val (Const S : AnsiString; var I : Integer; Var Code : Integer);
Procedure Val (Const S : AnsiString; var B : Byte; Var Code : Integer);
Procedure Val (Const S : AnsiString; var SI : ShortInt; Var Code : Integer);
{$EndIf ValInternCompiled}
{
Procedure Str (Const R : Real;Len, fr : longint; Var S : AnsiString);
Procedure Str (Const D : Double;Len,fr : longint; Var S : AnsiString);
Procedure Str (Const E : Extended;Len,fr : longint; Var S : AnsiString);
Procedure Str (Const C : Cardinal;len : Longint; Var S : AnsiString);
Procedure Str (Const L : LongInt;len : longint; Var S : AnsiString);
Procedure Str (Const W : Word;len : longint; Var S : AnsiString);
Procedure Str (Const I : Integer;len : Longint; Var S : AnsiString);
Procedure Str (Const B : Byte; Len : longint; Var S : AnsiString);
Procedure Str (Const SI : ShortInt; Len : longint; Var S : AnsiString);
}
{****************************************************************************
@ -377,6 +286,7 @@ Procedure Rename(Var f:File;p:pchar);
Procedure Rename(Var f:File;c:char);
Procedure Truncate (Var F:File);
{****************************************************************************
Typed File Management
****************************************************************************}
@ -387,6 +297,7 @@ Procedure Assign(Var f:TypedFile;c:char);
Procedure Rewrite(Var f:TypedFile);
Procedure Reset(Var f:TypedFile);
{****************************************************************************
Text File Management
****************************************************************************}
@ -414,6 +325,7 @@ Function SeekEOF:Boolean;
Procedure SetTextBuf(Var f:Text; Var Buf);
Procedure SetTextBuf(Var f:Text; Var Buf; Size:Word);
{****************************************************************************
Directory Management
****************************************************************************}
@ -424,6 +336,7 @@ Procedure rmdir(const s:string);
Procedure getdir(drivenr:byte;Var dir:shortstring);
Procedure getdir(drivenr:byte;Var dir:ansistring);
{*****************************************************************************
Miscelleaous
*****************************************************************************}
@ -436,6 +349,7 @@ function get_caller_frame(framebp:longint):longint;
Function IOResult:Word;
Function Sptr:Longint;
{*****************************************************************************
Init / Exit / ExitProc
*****************************************************************************}
@ -453,6 +367,7 @@ Procedure AddExitProc(Proc:TProcedure);
{$endif RTLLITE}
Procedure halt;
{*****************************************************************************
Abstract/Assert
*****************************************************************************}
@ -471,14 +386,19 @@ const
{$i setjumph.inc}
{*****************************************************************************
Object Pascal support
*****************************************************************************}
{$i objpash.inc}
{
$Log$
Revision 1.60 1999-07-03 01:24:21 peter
Revision 1.61 1999-07-05 20:04:28 peter
* removed temp defines
Revision 1.60 1999/07/03 01:24:21 peter
* $ifdef int64
Revision 1.59 1999/07/02 18:06:43 florian

386
rtl/inc/text.inc
View File

@ -433,7 +433,7 @@ begin
end;
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'SHORTSTR'{$else}'STRING'{$endif}];
Procedure Write_Str(Len : Longint;var f : TextRec;const s : String);[Public,Alias:'FPC_WRITE_TEXT_SHORTSTR'];
Begin
If (InOutRes<>0) then
exit;
@ -448,11 +448,7 @@ Begin
End;
{$ifndef NEWWRITEARRAY}
type
array00=array[0..0] of char;
{$endif}
Procedure Write_Array(Len : Longint;var f : TextRec;const s : {$ifdef NEWWRITEARRAY} array of char{$else}array00{$endif});[Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_ARRAY'];
Procedure Write_Array(Len : Longint;var f : TextRec;const s : array of char);[Public,Alias:'FPC_WRITE_TEXT_PCHAR_AS_ARRAY'];
var
ArrayLen : longint;
p : pchar;
@ -492,7 +488,7 @@ Begin
End;
Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; S : Pointer);[Public,alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'ANSISTR'{$else}'ANSISTRING'{$endif}];
Procedure Write_Text_AnsiString (Len : Longint; Var T : TextRec; S : Pointer);[Public,alias:'FPC_WRITE_TEXT_ANSISTR'];
{
Writes a AnsiString to the Text file T
}
@ -503,7 +499,7 @@ begin
end;
Procedure Write_SInt(Len : Longint;var t : TextRec;l : ValSInt);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'SINT'{$else}'LONGINT'{$endif}];
Procedure Write_SInt(Len : Longint;var t : TextRec;l : ValSInt);[Public,Alias:'FPC_WRITE_TEXT_SINT'];
var
s : String;
Begin
@ -514,7 +510,7 @@ Begin
End;
Procedure Write_UInt(Len : Longint;var t : TextRec;l : ValUInt);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef NEWREADINT}'UINT'{$else}'CARDINAL'{$endif}];
Procedure Write_UInt(Len : Longint;var t : TextRec;l : ValUInt);[Public,Alias:'FPC_WRITE_TEXT_UINT'];
var
s : String;
Begin
@ -524,21 +520,19 @@ Begin
Write_Str(Len,t,s);
End;
{$ifdef INT64}
procedure write_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_WRITE_TEXT_QWORD'];
var
s : string;
begin
if (InOutRes<>0) then
exit;
int_str(q,s);
write_str(len,t,s);
end;
procedure write_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_WRITE_TEXT_QWORD'];
var
s : string;
begin
if (InOutRes<>0) then
exit;
int_str(q,s);
write_str(len,t,s);
end;
{$endif INT64}
{$ifdef INTERNDOUBLE}
Procedure Write_Float(rt,fixkomma,Len : Longint;var t : TextRec;r : ValReal);[Public,Alias:'FPC_WRITE_TEXT_FLOAT'];
var
@ -550,75 +544,6 @@ Begin
Write_Str(Len,t,s);
End;
{$else INTERNDOUBLE}
{$ifdef SUPPORT_SINGLE}
Procedure Write_S32Real(fixkomma,Len : Longint;var t : TextRec;r : single);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'S32REAL'{$else}'SINGLE'{$endif}];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str_real(Len,fixkomma,r,rt_s32real,s);
Write_Str(Len,t,s);
End;
{$endif SUPPORT_S32REAL}
{$ifdef SUPPORT_DOUBLE}
Procedure Write_s64Real(fixkomma,Len : Longint;var t : TextRec;r : double);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'S64'{$endif}+'REAL'];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str_real(Len,fixkomma,r,rt_s64real,s);
Write_Str(Len,t,s);
End;
{$endif SUPPORT_S64REAL}
{$ifdef SUPPORT_EXTENDED}
Procedure Write_S80Real(fixkomma,Len : Longint;var t : TextRec;r : extended);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'S80REAL'{$else}'EXTENDED'{$endif}];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str_real(Len,fixkomma,r,rt_s80real,s);
Write_Str(Len,t,s);
End;
{$endif SUPPORT_S80REAL}
{$ifdef SUPPORT_COMP}
Procedure Write_C64Bit(fixkomma,Len : Longint;var t : TextRec;r : comp);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'C64BIT'{$else}'COMP'{$endif}];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str_real(Len,fixkomma,r,rt_c64bit,s);
Write_Str(Len,t,s);
End;
{$endif SUPPORT_C64BIT}
{$ifdef SUPPORT_FIXED}
Procedure Write_Fixed(fixkomma,Len : Longint;var t : TextRec;r : fixed16);[Public,Alias:'FPC_WRITE_TEXT_'+{$ifdef INTERNDOUBLE}'F16BIT'{$else}'FIXED'{$endif}];
var
s : String;
Begin
If (InOutRes<>0) then
exit;
Str_real(Len,fixkomma,r,rt_f32bit,s);
Write_Str(Len,t,s);
End;
{$endif SUPPORT_F16BIT}
{$endif INTERNDOUBLE}
Procedure Write_Boolean(Len : Longint;var t : TextRec;b : Boolean);[Public,Alias:'FPC_WRITE_TEXT_BOOLEAN'];
Begin
@ -669,7 +594,6 @@ begin
end;
Function IgnoreSpaces(var f:TextRec):Boolean;
{
Removes all leading spaces,tab,eols from the input buffer, returns true if
@ -818,7 +742,7 @@ Begin
End;
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias:'FPC_READ_TEXT_'+{$ifdef NEWREADINT}'SHORTSTR'{$else}'STRING'{$endif}];
Procedure Read_String(var f : TextRec;var s : String);[Public,Alias:'FPC_READ_TEXT_SHORTSTR'];
Begin
s[0]:=chr(ReadPCharLen(f,pchar(@s[1]),high(s)));
End;
@ -830,13 +754,13 @@ Begin
End;
Procedure Read_Array(var f : TextRec;var s : {$ifdef NEWWRITEARRAY}array of char{$else}array00{$endif});[Public,Alias:'FPC_READ_TEXT_PCHAR_AS_ARRAY'];
Procedure Read_Array(var f : TextRec;var s : array of char);[Public,Alias:'FPC_READ_TEXT_PCHAR_AS_ARRAY'];
Begin
pchar(pchar(@s)+ReadPCharLen(f,pchar(@s),{$ifdef NEWWRITEARRAY}high(s){$else}$7fffffff{$endif}))^:=#0;
pchar(pchar(@s)+ReadPCharLen(f,pchar(@s),high(s)))^:=#0;
End;
Procedure Read_AnsiString(var f : TextRec;var s : AnsiString);[Public,Alias:'FPC_READ_TEXT_'+{$ifdef NEWREADINT}'ANSISTR'{$else}'ANSISTRING'{$endif}];
Procedure Read_AnsiString(var f : TextRec;var s : AnsiString);[Public,Alias:'FPC_READ_TEXT_ANSISTR'];
var
len : longint;
Begin
@ -850,8 +774,6 @@ Begin
End;
{$ifdef NEWREADINT}
Function Read_Char(var f : TextRec):char;[Public,Alias:'FPC_READ_TEXT_CHAR'];
Begin
Read_Char:=#0;
@ -971,260 +893,13 @@ begin
InOutRes:=106;
end;
{$ifdef INT64}
procedure read_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_READ_TEXT_QWORD'];
begin
{!!!!!!!!!!!!!}
end;
{$endif INT64}
{$else}
Procedure Read_Char(var f : TextRec;var c : Char);[Public,Alias:'FPC_READ_TEXT_CHAR'];
Begin
c:=#0;
{ Check error and if file is open }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
{ Read next char or EOF }
If f.BufPos>=f.BufEnd Then
begin
FileFunc(f.InOutFunc)(f);
If f.BufPos>=f.BufEnd Then
begin
c:=#26;
exit;
end;
end;
c:=f.Bufptr^[f.BufPos];
inc(f.BufPos);
end;
Procedure Read_Longint(var f : TextRec;var l : Longint);[Public,Alias:'FPC_READ_TEXT_LONGINT'];
var
hs : String;
code : Longint;
base : longint;
Begin
l:=0;
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
hs:='';
if IgnoreSpaces(f) and ReadSign(f,hs) and ReadBase(f,hs,Base) then
ReadNumeric(f,hs,Base);
Val(hs,l,code);
If code<>0 Then
InOutRes:=106;
End;
Procedure Read_Integer(var f : TextRec;var l : Integer);[Public,Alias:'FPC_READ_TEXT_INTEGER'];
var
ll : Longint;
Begin
l:=0;
If InOutRes <> 0 then
exit;
Read_Longint(f,ll);
If (ll<-32768) or (ll>32767) Then
InOutRes:=201
else
l:=ll;
End;
Procedure Read_Word(var f : TextRec;var l : Word);[Public,Alias:'FPC_READ_TEXT_WORD'];
var
ll : Longint;
Begin
l:=0;
If InOutRes <> 0 then
exit;
Read_Longint(f,ll);
If (ll<0) or (ll>$ffff) Then
InOutRes:=201
else
l:=ll;
End;
Procedure Read_Byte(var f : TextRec;var l : byte);[Public,Alias:'FPC_READ_TEXT_BYTE'];
var
ll : Longint;
Begin
l:=0;
If InOutRes <> 0 then
exit;
Read_Longint(f,ll);
If (ll<0) or (ll>255) Then
InOutRes:=201
else
l:=ll;
End;
Procedure Read_Shortint(var f : TextRec;var l : shortint);[Public,Alias:'FPC_READ_TEXT_SHORTINT'];
var
ll : Longint;
Begin
l:=0;
If InOutRes <> 0 then
exit;
Read_Longint(f,ll);
If (ll<-128) or (ll>127) Then
InOutRes:=201
else
l:=ll;
End;
Procedure Read_Cardinal(var f : TextRec;var l : cardinal);[Public,Alias:'FPC_READ_TEXT_CARDINAL'];
var
hs : String;
code : longint;
base : longint;
Begin
l:=0;
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
hs:='';
if IgnoreSpaces(f) and ReadSign(f,hs) and ReadBase(f,hs,Base) then
ReadNumeric(f,hs,Base);
val(hs,l,code);
If code<>0 Then
InOutRes:=106;
End;
{$ifdef INT64}
procedure read_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_READ_TEXT_QWORD'];
begin
{!!!!!!!!!!!!!}
end;
{$endif INT64}
function ReadRealStr(var f:TextRec):string;
var
hs : string;
procedure read_qword(len : longint;var t : textrec;q : qword);[public,alias:'FPC_READ_TEXT_QWORD'];
begin
ReadRealStr:='';
{ Leave if error or not open file, else check for empty buf }
If (InOutRes<>0) then
exit;
if (f.mode<>fmInput) Then
begin
InOutRes:=104;
exit;
end;
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
hs:='';
if IgnoreSpaces(f) and ReadSign(f,hs) and ReadNumeric(f,hs,10) then
begin
{ First check for a . }
if (f.Bufptr^[f.BufPos]='.') and (f.BufPos<f.BufEnd) Then
begin
hs:=hs+'.';
Inc(f.BufPos);
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
ReadNumeric(f,hs,10);
end;
{ Also when a point is found check for a E }
if (f.Bufptr^[f.BufPos] in ['e','E']) and (f.BufPos<f.BufEnd) Then
begin
hs:=hs+'E';
Inc(f.BufPos);
If f.BufPos>=f.BufEnd Then
FileFunc(f.InOutFunc)(f);
if ReadSign(f,hs) then
ReadNumeric(f,hs,10);
end;
end;
ReadRealStr:=hs;
{ !!!!!!!!!!!!! }
end;
Procedure Read_Real(var f : TextRec;var d : Real);[Public,Alias:'FPC_READ_TEXT_REAL'];
var
code : Word;
Begin
val(ReadRealStr(f),d,code);
If code<>0 Then
InOutRes:=106;
End;
{$ifdef SUPPORT_SINGLE}
Procedure Read_Single(var f : TextRec;var d : single);[Public,Alias:'FPC_READ_TEXT_SINGLE'];
var
code : Word;
Begin
val(ReadRealStr(f),d,code);
If code<>0 Then
InOutRes:=106;
End;
{$endif SUPPORT_SINGLE}
{$ifdef SUPPORT_EXTENDED}
Procedure Read_Extended(var f : TextRec;var d : extended);[Public,Alias:'FPC_READ_TEXT_EXTENDED'];
var
code : Word;
Begin
val(ReadRealStr(f),d,code);
If code<>0 Then
InOutRes:=106;
End;
{$endif SUPPORT_EXTENDED}
{$ifdef SUPPORT_COMP}
Procedure Read_Comp(var f : TextRec;var d : comp);[Public,Alias:'FPC_READ_TEXT_COMP'];
var
code : Word;
Begin
val(ReadRealStr(f),d,code);
If code<>0 Then
InOutRes:=106;
End;
{$endif SUPPORT_COMP}
{$ifdef SUPPORT_FIXED}
Procedure Read_Fixed(var f : TextRec;var d : fixed);[Public,Alias:'FPC_READ_TEXT_FIXED'];
var
code : Word;
Begin
val(ReadRealStr(f),d,code);
If code<>0 Then
InOutRes:=106;
End;
{$endif SUPPORT_FIXED}
{$endif}
{$endif INT64}
{*****************************************************************************
@ -1238,11 +913,13 @@ begin
TextRec(f).Mode:=mode;
TextRec(f).Closefunc:=@FileCloseFunc;
case mode of
fmInput : TextRec(f).InOutFunc:=@FileReadFunc;
fmOutput : begin
TextRec(f).InOutFunc:=@FileWriteFunc;
TextRec(f).FlushFunc:=@FileWriteFunc;
end;
fmInput :
TextRec(f).InOutFunc:=@FileReadFunc;
fmOutput :
begin
TextRec(f).InOutFunc:=@FileWriteFunc;
TextRec(f).FlushFunc:=@FileWriteFunc;
end;
else
HandleError(102);
end;
@ -1251,7 +928,10 @@ end;
{
$Log$
Revision 1.48 1999-07-01 15:39:52 florian
Revision 1.49 1999-07-05 20:04:29 peter
* removed temp defines
Revision 1.48 1999/07/01 15:39:52 florian
+ qword/int64 type released
Revision 1.47 1999/06/30 22:17:24 florian

48
rtl/win32/syswin32.pp
View File

@ -219,7 +219,7 @@ end;
function paramstr(l : longint) : string;
begin
if (l>0) and (l+1<=argc) then
paramstr:=strpas(argv[l])
else
@ -250,12 +250,9 @@ end;
external 'kernel32' name 'GlobalSize';
{$endif}
{$ifdef NEWATT}
var heap : longint;external name 'HEAP';
var intern_heapsize : longint;external name 'HEAPSIZE';
{$else NEWATT}
{$asmmode direct}
{$endif def NEWATT}
var
heap : longint;external name 'HEAP';
intern_heapsize : longint;external name 'HEAPSIZE';
function getheapstart:pointer;assembler;
asm
@ -265,11 +262,7 @@ end ['EAX'];
function getheapsize:longint;assembler;
asm
{$ifdef NEWATT}
movl intern_HEAPSIZE,%eax
{$else}
movl HEAPSIZE,%eax
{$endif}
end ['EAX'];
@ -290,6 +283,7 @@ end;
{ include standard heap management }
{$I heap.inc}
{*****************************************************************************
Low Level File Routines
*****************************************************************************}
@ -373,14 +367,14 @@ end;
function do_read(h,addr,len : longint) : longint;
var
result:longint;
_result:longint;
begin
if readfile(h,pointer(addr),len,result,nil)=0 then
if readfile(h,pointer(addr),len,_result,nil)=0 then
Begin
errno:=GetLastError;
Errno2InoutRes;
end;
do_read:=result;
do_read:=_result;
end;
@ -757,16 +751,13 @@ end;
{$endif}
procedure install_exception_handlers;forward;
{$ifdef NEWATT}
procedure PascalMain;external name 'PASCALMAIN';
procedure fpc_do_exit;external name 'FPC_DO_EXIT';
{$endif def NEWATT}
var
{ value of the stack segment
to check if the call stack can be written on exceptions }
_SS : longint;
{ value of the stack segment
to check if the call stack can be written on exceptions }
_SS : longint;
procedure Exe_entry;[public, alias : '_FPC_EXE_Entry'];
begin
@ -782,11 +773,6 @@ procedure Exe_entry;[public, alias : '_FPC_EXE_Entry'];
movw %ss,%bp
movl %ebp,_SS
xorl %ebp,%ebp
end;
{$ifndef NEWATT}
{$ASMMODE DIRECT}
{$endif ndef NEWATT}
asm
call PASCALMAIN
popl %ebp
end;
@ -794,7 +780,6 @@ procedure Exe_entry;[public, alias : '_FPC_EXE_Entry'];
ExitProcess(0);
end;
{$ASMMODE ATT}
procedure Dll_entry;[public, alias : '_FPC_DLL_Entry'];
begin
@ -805,11 +790,6 @@ procedure Dll_entry;[public, alias : '_FPC_DLL_Entry'];
asm
xorl %edi,%edi
movw %ss,%di
end;
{$ifndef NEWATT}
{$ASMMODE DIRECT}
{$endif ndef NEWATT}
asm
movl %edi,_SS
call PASCALMAIN
end;
@ -823,7 +803,6 @@ procedure Dll_entry;[public, alias : '_FPC_DLL_Entry'];
end;
end;
{$ASMMODE ATT}
{$ifdef Set_i386_Exception_handler}
@ -1022,7 +1001,10 @@ end.
{
$Log$
Revision 1.40 1999-06-11 16:26:40 michael
Revision 1.41 1999-07-05 20:04:30 peter
* removed temp defines
Revision 1.40 1999/06/11 16:26:40 michael
+ Fixed paramstr(0)
Revision 1.39 1999/05/17 21:52:47 florian