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

* ansistring fixes

Browse Source
This commit is contained in:
peter 1998-11-04 10:20:48 +00:00
parent 7469443729
commit 5727090134
5 changed files with 221 additions and 175 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
rtl/inc/astrings.pp
View File

@ -172,16 +172,15 @@ Procedure AssignAnsiString (Var S1 : Pointer;S2 : Pointer);
{ {
Assigns S2 to S1 (S1:=S2), taking in account reference counts. Assigns S2 to S1 (S1:=S2), taking in account reference counts.
} }
begin begin
If S2<>nil then If S2<>nil then
If PAnsiRec(S2-FirstOff)^.Ref>0 then If PAnsiRec(S2-FirstOff)^.Ref>0 then
Inc(PAnsiRec(S2-FirstOff)^.ref); Inc(PAnsiRec(S2-FirstOff)^.ref);
Temp:=S2; { Temp:=S2;
end; end;
end end
else else
temp:=S2; temp:=S2; }
{ Decrease the reference count on the old S1 } { Decrease the reference count on the old S1 }
Decr_Ansi_Ref (S1); Decr_Ansi_Ref (S1);
{ And finally, have S1 pointing to S2 (or its copy) } { And finally, have S1 pointing to S2 (or its copy) }
@ -391,7 +390,7 @@ Procedure SetLength (Var S : AnsiString; l : Longint);
Makes sure S is unique, and contains enough room. Makes sure S is unique, and contains enough room.
} }
Var Temp : Pointer; Var Temp : Pointer;
begin begin
If (Pointer(S)=Nil) and (l>0) then If (Pointer(S)=Nil) and (l>0) then
begin begin
@ -406,7 +405,7 @@ begin
If (PAnsiRec(Pointer(S)-FirstOff)^.Maxlen < L) or If (PAnsiRec(Pointer(S)-FirstOff)^.Maxlen < L) or
(PAnsiRec(Pointer(S)-FirstOff)^.Ref <> 1) then (PAnsiRec(Pointer(S)-FirstOff)^.Ref <> 1) then
begin begin
{ Reallocation is needed... } { Reallocation is needed... }
Temp:=Pointer(NewAnsiString(L)); Temp:=Pointer(NewAnsiString(L));
if Length(S)>0 then if Length(S)>0 then
Move (Pointer(S)^,Temp^,Length(S)+1); Move (Pointer(S)^,Temp^,Length(S)+1);
@ -681,7 +680,7 @@ end;
Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint); Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : Longint);
var s3,s4,s5 : Pointer; var s3,s4,s5 : Pointer;
begin begin
If Length(Source)=0 then exit; If Length(Source)=0 then exit;
if index <= 0 then index := 1; if index <= 0 then index := 1;
@ -702,7 +701,10 @@ end;
{ {
$Log$ $Log$
Revision 1.26 1998-11-02 09:46:12 michael Revision 1.27 1998-11-04 10:20:48 peter
* ansistring fixes
Revision 1.26 1998/11/02 09:46:12 michael
+ Fix for assign of null string + Fix for assign of null string
Revision 1.25 1998/10/30 21:42:48 michael Revision 1.25 1998/10/30 21:42:48 michael
@ -787,4 +789,4 @@ end;
* removed logs * removed logs
* removed $ifdef ver_above * removed $ifdef ver_above
} }

177
rtl/inc/sstrings.inc
View File

@ -18,7 +18,7 @@
{$I real2str.inc} {$I real2str.inc}
function copy(const s : string;index : StrLenInt;count : StrLenInt): string; function copy(const s : shortstring;index : StrLenInt;count : StrLenInt): shortstring;
begin begin
if count<0 then if count<0 then
count:=0; count:=0;
@ -36,7 +36,7 @@ begin
end; end;
procedure delete(var s : string;index : StrLenInt;count : StrLenInt); procedure delete(var s : shortstring;index : StrLenInt;count : StrLenInt);
begin begin
if index<=0 then if index<=0 then
begin begin
@ -54,7 +54,7 @@ begin
end; end;
procedure insert(const source : string;var s : string;index : StrLenInt); procedure insert(const source : shortstring;var s : shortstring;index : StrLenInt);
begin begin
if index>1 then if index>1 then
dec(index) dec(index)
@ -64,9 +64,9 @@ begin
end; end;
function pos(const substr : string;const s : string): byte; function pos(const substr : shortstring;const s : shortstring):StrLenInt;
var var
i,j : longint; i,j : StrLenInt;
e : boolean; e : boolean;
begin begin
i := 0; i := 0;
@ -86,9 +86,9 @@ end;
{Faster when looking for a single char...} {Faster when looking for a single char...}
function pos(c:char;const s:string):byte; function pos(c:char;const s:shortstring):StrLenInt;
var var
i : longint; i : StrLenInt;
begin begin
for i:=1 to length(s) do for i:=1 to length(s) do
if s[i]=c then if s[i]=c then
@ -100,10 +100,42 @@ begin
end; end;
procedure SetLength(var s:shortstring;len:StrLenInt);
begin
if Len>255 then
Len:=255;
s[0]:=chr(len);
end;
function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
begin
if (index=1) and (Count>0) then
Copy:=c
else
Copy:='';
end;
function pos(const substr : shortstring;c:char): StrLenInt;
begin
if (length(substr)=1) and (substr[1]=c) then
Pos:=1
else
Pos:=0;
end;
function length(c:char):StrLenInt;
begin
Length:=1;
end;
{$ifdef IBM_CHAR_SET} {$ifdef IBM_CHAR_SET}
const const
UpCaseTbl : string[7]=#154#142#153#144#128#143#165; UpCaseTbl : shortstring[7]=#154#142#153#144#128#143#165;
LoCaseTbl : string[7]=#129#132#148#130#135#134#164; LoCaseTbl : shortstring[7]=#129#132#148#130#135#134#164;
{$endif} {$endif}
function upcase(c : char) : char; function upcase(c : char) : char;
@ -129,7 +161,7 @@ begin
end; end;
function upcase(const s : string) : string; function upcase(const s : shortstring) : shortstring;
var var
i : longint; i : longint;
begin begin
@ -164,7 +196,7 @@ begin
end; end;
function lowercase(const s : string) : string; function lowercase(const s : shortstring) : shortstring;
var var
i : longint; i : longint;
begin begin
@ -174,7 +206,7 @@ begin
end; end;
function hexstr(val : longint;cnt : byte) : string; function hexstr(val : longint;cnt : byte) : shortstring;
const const
HexTbl : array[0..15] of char='0123456789ABCDEF'; HexTbl : array[0..15] of char='0123456789ABCDEF';
var var
@ -189,7 +221,7 @@ begin
end; end;
function binstr(val : longint;cnt : byte) : string; function binstr(val : longint;cnt : byte) : shortstring;
var var
i : longint; i : longint;
begin begin
@ -204,7 +236,7 @@ end;
{$endif RTLLITE} {$endif RTLLITE}
function space (b : byte): string; function space (b : byte): shortstring;
begin begin
space[0] := chr(b); space[0] := chr(b);
FillChar (Space[1],b,' '); FillChar (Space[1],b,' ');
@ -215,7 +247,7 @@ end;
Str() Helpers Str() Helpers
*****************************************************************************} *****************************************************************************}
procedure int_str_real(d : real;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_REAL'{$else}'STR_REAL'{$endif}]; procedure int_str_real(d : real;len,fr : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_REAL'{$else}'STR_REAL'{$endif}];
begin begin
{$ifdef i386} {$ifdef i386}
str_real(len,fr,d,rt_s64real,s); str_real(len,fr,d,rt_s64real,s);
@ -226,7 +258,7 @@ end;
{$ifdef SUPPORT_SINGLE} {$ifdef SUPPORT_SINGLE}
procedure int_str_single(d : single;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_SINGLE'{$else}'STR_SINGLE'{$endif}]; procedure int_str_single(d : single;len,fr : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_SINGLE'{$else}'STR_SINGLE'{$endif}];
begin begin
str_real(len,fr,d,rt_s32real,s); str_real(len,fr,d,rt_s32real,s);
end; end;
@ -234,7 +266,7 @@ end;
{$ifdef SUPPORT_EXTENDED} {$ifdef SUPPORT_EXTENDED}
procedure int_str_extended(d : extended;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_EXTENDED'{$else}'STR_EXTENDED'{$endif}]; procedure int_str_extended(d : extended;len,fr : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_EXTENDED'{$else}'STR_EXTENDED'{$endif}];
begin begin
str_real(len,fr,d,rt_s80real,s); str_real(len,fr,d,rt_s80real,s);
end; end;
@ -242,7 +274,7 @@ end;
{$ifdef SUPPORT_COMP} {$ifdef SUPPORT_COMP}
procedure int_str_comp(d : comp;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_COMP'{$else}'STR_COMP'{$endif}]; procedure int_str_comp(d : comp;len,fr : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_COMP'{$else}'STR_COMP'{$endif}];
begin begin
str_real(len,fr,d,rt_s64bit,s); str_real(len,fr,d,rt_s64bit,s);
end; end;
@ -250,14 +282,14 @@ end;
{$ifdef SUPPORT_FIXED} {$ifdef SUPPORT_FIXED}
procedure int_str_fixed(d : fixed;len,fr : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_FIXED'{$else}'STR_FIXED'{$endif}]; procedure int_str_fixed(d : fixed;len,fr : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_FIXED'{$else}'STR_FIXED'{$endif}];
begin begin
str_real(len,fr,d,rt_f32bit,s); str_real(len,fr,d,rt_f32bit,s);
end; end;
{$endif SUPPORT_FIXED} {$endif SUPPORT_FIXED}
procedure int_str_longint(v : longint;len : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_LONGINT'{$else}'STR_LONGINT'{$endif}]; procedure int_str_longint(v : longint;len : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_LONGINT'{$else}'STR_LONGINT'{$endif}];
begin begin
int_str(v,s); int_str(v,s);
if length(s)<len then if length(s)<len then
@ -265,7 +297,7 @@ begin
end; end;
procedure int_str_cardinal(v : cardinal;len : longint;var s : string);[public, alias : {$ifdef FPCNAMES}'FPC_STR_CARDINAL'{$else}'STR_CARDINAL'{$endif}]; procedure int_str_cardinal(v : cardinal;len : longint;var s : shortstring);[public, alias : {$ifdef FPCNAMES}'FPC_STR_CARDINAL'{$else}'STR_CARDINAL'{$endif}];
begin begin
int_str(v,s); int_str(v,s);
if length(s)<len then if length(s)<len then
@ -277,7 +309,7 @@ end;
Val() Functions Val() Functions
*****************************************************************************} *****************************************************************************}
Function InitVal(const s:string;var negativ:boolean;var base:byte):Word; Function InitVal(const s:shortstring;var negativ:boolean;var base:byte):Word;
var var
Code : Longint; Code : Longint;
begin begin
@ -317,7 +349,7 @@ begin
end; end;
procedure val(const s : string;var l : longint;var code : word); procedure val(const s : shortstring;var l : longint;var code : word);
var var
base,u : byte; base,u : byte;
negativ : boolean; negativ : boolean;
@ -357,13 +389,13 @@ begin
end; end;
procedure val(const s : string;var l : longint;var code : integer); procedure val(const s : shortstring;var l : longint;var code : integer);
begin begin
val(s,l,word(code)); val(s,l,word(code));
end; end;
procedure val(const s : string;var l : longint;var code : longint); procedure val(const s : shortstring;var l : longint;var code : longint);
var var
cw : word; cw : word;
begin begin
@ -372,7 +404,7 @@ begin
end; end;
procedure val(const s : string;var l : longint); procedure val(const s : shortstring;var l : longint);
var var
code : word; code : word;
begin begin
@ -380,7 +412,7 @@ begin
end; end;
procedure val(const s : string;var b : byte); procedure val(const s : shortstring;var b : byte);
var var
l : longint; l : longint;
begin begin
@ -389,7 +421,7 @@ begin
end; end;
procedure val(const s : string;var b : byte;var code : word); procedure val(const s : shortstring;var b : byte;var code : word);
var var
l : longint; l : longint;
begin begin
@ -398,13 +430,13 @@ begin
end; end;
procedure val(const s : string;var b : byte;var code : Integer); procedure val(const s : shortstring;var b : byte;var code : Integer);
begin begin
val(s,b,word(code)); val(s,b,word(code));
end; end;
procedure val(const s : string;var b : byte;var code : longint); procedure val(const s : shortstring;var b : byte;var code : longint);
var var
l : longint; l : longint;
begin begin
@ -413,7 +445,7 @@ begin
end; end;
procedure val(const s : string;var b : shortint); procedure val(const s : shortstring;var b : shortint);
var var
l : longint; l : longint;
begin begin
@ -422,7 +454,7 @@ begin
end; end;
procedure val(const s : string;var b : shortint;var code : word); procedure val(const s : shortstring;var b : shortint;var code : word);
var var
l : longint; l : longint;
begin begin
@ -431,13 +463,13 @@ begin
end; end;
procedure val(const s : string;var b : shortint;var code : Integer); procedure val(const s : shortstring;var b : shortint;var code : Integer);
begin begin
val(s,b,word(code)); val(s,b,word(code));
end; end;
procedure val(const s : string;var b : shortint;var code : longint); procedure val(const s : shortstring;var b : shortint;var code : longint);
var var
l : longint; l : longint;
begin begin
@ -446,7 +478,7 @@ begin
end; end;
procedure val(const s : string;var b : word); procedure val(const s : shortstring;var b : word);
var var
l : longint; l : longint;
begin begin
@ -455,7 +487,7 @@ begin
end; end;
procedure val(const s : string;var b : word;var code : word); procedure val(const s : shortstring;var b : word;var code : word);
var var
l : longint; l : longint;
begin begin
@ -464,13 +496,13 @@ begin
end; end;
procedure val(const s : string;var b : word;var code : Integer); procedure val(const s : shortstring;var b : word;var code : Integer);
begin begin
val(s,b,word(code)); val(s,b,word(code));
end; end;
procedure val(const s : string;var b : word;var code : longint); procedure val(const s : shortstring;var b : word;var code : longint);
var var
l : longint; l : longint;
begin begin
@ -479,7 +511,7 @@ begin
end; end;
procedure val(const s : string;var b : integer); procedure val(const s : shortstring;var b : integer);
var var
l : longint; l : longint;
begin begin
@ -488,7 +520,7 @@ begin
end; end;
procedure val(const s : string;var b : integer;var code : word); procedure val(const s : shortstring;var b : integer;var code : word);
var var
l : longint; l : longint;
begin begin
@ -497,13 +529,13 @@ begin
end; end;
procedure val(const s : string;var b : integer;var code : Integer); procedure val(const s : shortstring;var b : integer;var code : Integer);
begin begin
val(s,b,word(code)); val(s,b,word(code));
end; end;
procedure val(const s : string;var b : integer;var code : longint); procedure val(const s : shortstring;var b : integer;var code : longint);
var var
l : longint; l : longint;
begin begin
@ -512,7 +544,7 @@ begin
end; end;
procedure val(const s : string;var v : cardinal;var code : word); procedure val(const s : shortstring;var v : cardinal;var code : word);
var var
negativ : boolean; negativ : boolean;
base,u : byte; base,u : byte;
@ -544,7 +576,7 @@ begin
end; end;
procedure val(const s : string;var v : cardinal); procedure val(const s : shortstring;var v : cardinal);
var var
code : word; code : word;
begin begin
@ -552,13 +584,13 @@ begin
end; end;
procedure val(const s : string;var v : cardinal;var code : integer); procedure val(const s : shortstring;var v : cardinal;var code : integer);
begin begin
val(s,v,word(code)); val(s,v,word(code));
end; end;
procedure val(const s : string;var v : cardinal;var code : longint); procedure val(const s : shortstring;var v : cardinal;var code : longint);
var var
cw : word; cw : word;
begin begin
@ -567,7 +599,7 @@ begin
end; end;
procedure val(const s : string;var d : valreal;var code : word); procedure val(const s : shortstring;var d : valreal;var code : word);
var var
hd, hd,
esign,sign : valreal; esign,sign : valreal;
@ -667,13 +699,13 @@ begin
end; end;
procedure val(const s : string;var d : valreal;var code : integer); procedure val(const s : shortstring;var d : valreal;var code : integer);
begin begin
val(s,d,word(code)); val(s,d,word(code));
end; end;
procedure val(const s : string;var d : valreal;var code : longint); procedure val(const s : shortstring;var d : valreal;var code : longint);
var var
cw : word; cw : word;
begin begin
@ -682,7 +714,7 @@ begin
end; end;
procedure val(const s : string;var d : valreal); procedure val(const s : shortstring;var d : valreal);
var var
code : word; code : word;
begin begin
@ -691,7 +723,7 @@ end;
{$ifdef SUPPORT_SINGLE} {$ifdef SUPPORT_SINGLE}
procedure val(const s : string;var d : single;var code : word); procedure val(const s : shortstring;var d : single;var code : word);
var var
e : valreal; e : valreal;
begin begin
@ -700,7 +732,7 @@ begin
end; end;
procedure val(const s : string;var d : single;var code : integer); procedure val(const s : shortstring;var d : single;var code : integer);
var var
e : valreal; e : valreal;
begin begin
@ -709,7 +741,7 @@ begin
end; end;
procedure val(const s : string;var d : single;var code : longint); procedure val(const s : shortstring;var d : single;var code : longint);
var var
cw : word; cw : word;
e : valreal; e : valreal;
@ -720,7 +752,7 @@ begin
end; end;
procedure val(const s : string;var d : single); procedure val(const s : shortstring;var d : single);
var var
code : word; code : word;
e : valreal; e : valreal;
@ -736,7 +768,7 @@ end;
{ with extended as default the valreal is extended so for real there need { with extended as default the valreal is extended so for real there need
to be a new val } to be a new val }
procedure val(const s : string;var d : real;var code : word); procedure val(const s : shortstring;var d : real;var code : word);
var var
e : valreal; e : valreal;
begin begin
@ -745,7 +777,7 @@ end;
end; end;
procedure val(const s : string;var d : real;var code : integer); procedure val(const s : shortstring;var d : real;var code : integer);
var var
e : valreal; e : valreal;
begin begin
@ -754,7 +786,7 @@ end;
end; end;
procedure val(const s : string;var d : real;var code : longint); procedure val(const s : shortstring;var d : real;var code : longint);
var var
cw : word; cw : word;
e : valreal; e : valreal;
@ -765,7 +797,7 @@ end;
end; end;
procedure val(const s : string;var d : real); procedure val(const s : shortstring;var d : real);
var var
code : word; code : word;
e : valreal; e : valreal;
@ -780,7 +812,7 @@ end;
{$ifdef SUPPORT_EXTENDED} {$ifdef SUPPORT_EXTENDED}
procedure val(const s : string;var d : extended;var code : word); procedure val(const s : shortstring;var d : extended;var code : word);
var var
e : valreal; e : valreal;
begin begin
@ -788,7 +820,7 @@ end;
d:=e; d:=e;
end; end;
procedure val(const s : string;var d : extended;var code : integer); procedure val(const s : shortstring;var d : extended;var code : integer);
var var
e : valreal; e : valreal;
begin begin
@ -796,7 +828,7 @@ end;
d:=e; d:=e;
end; end;
procedure val(const s : string;var d : extended;var code : longint); procedure val(const s : shortstring;var d : extended;var code : longint);
var var
cw : word; cw : word;
e : valreal; e : valreal;
@ -806,7 +838,7 @@ end;
code:=cw; code:=cw;
end; end;
procedure val(const s : string;var d : extended); procedure val(const s : shortstring;var d : extended);
var var
code : word; code : word;
e : valreal; e : valreal;
@ -821,7 +853,7 @@ end;
{$ifdef SUPPORT_COMP} {$ifdef SUPPORT_COMP}
procedure val(const s : string;var d : comp;var code : word); procedure val(const s : shortstring;var d : comp;var code : word);
var var
e : valreal; e : valreal;
begin begin
@ -830,7 +862,7 @@ begin
end; end;
procedure val(const s : string;var d : comp;var code : integer); procedure val(const s : shortstring;var d : comp;var code : integer);
var var
e : valreal; e : valreal;
begin begin
@ -839,7 +871,7 @@ begin
end; end;
procedure val(const s : string;var d : comp;var code : longint); procedure val(const s : shortstring;var d : comp;var code : longint);
var var
cw : word; cw : word;
e : valreal; e : valreal;
@ -850,7 +882,7 @@ begin
end; end;
procedure val(const s : string;var d : comp); procedure val(const s : shortstring;var d : comp);
var var
code : word; code : word;
e : valreal; e : valreal;
@ -862,7 +894,7 @@ end;
{$ifdef SUPPORT_FIXED} {$ifdef SUPPORT_FIXED}
procedure val(const s : string;var d : fixed;var code : word); procedure val(const s : shortstring;var d : fixed;var code : word);
var var
e : valreal; e : valreal;
begin begin
@ -871,7 +903,7 @@ begin
end; end;
procedure val(const s : string;var d : fixed;var code : integer); procedure val(const s : shortstring;var d : fixed;var code : integer);
var var
e : valreal; e : valreal;
begin begin
@ -880,7 +912,7 @@ begin
end; end;
procedure val(const s : string;var d : fixed;var code : longint); procedure val(const s : shortstring;var d : fixed;var code : longint);
var var
cw : word; cw : word;
e : valreal; e : valreal;
@ -891,7 +923,7 @@ begin
end; end;
procedure val(const s : string;var d : fixed); procedure val(const s : shortstring;var d : fixed);
var var
code : word; code : word;
e : valreal; e : valreal;
@ -904,7 +936,10 @@ end;
{ {
$Log$ $Log$
Revision 1.14 1998-10-11 14:30:19 peter Revision 1.15 1998-11-04 10:20:50 peter
* ansistring fixes
Revision 1.14 1998/10/11 14:30:19 peter
* small typo :( * small typo :(
Revision 1.13 1998/10/10 15:28:46 peter Revision 1.13 1998/10/10 15:28:46 peter

135
rtl/inc/systemh.inc
View File

@ -67,7 +67,9 @@ Type
{ some type aliases } { some type aliases }
dword = cardinal; dword = cardinal;
longword = cardinal; longword = cardinal;
ShortString = String[255]; {$ifndef useansistrings}
shortstring = string;
{$endif}
{ Zero - terminated strings } { Zero - terminated strings }
PChar = ^Char; PChar = ^Char;
@ -182,80 +184,88 @@ Function Sseg:Word;
PChar and String Handling PChar and String Handling
****************************************************************************} ****************************************************************************}
function strpas(p:pchar):string; function strpas(p:pchar):shortstring;
function strlen(p:pchar):longint; function strlen(p:pchar):longint;
Function Copy(const s:string;index:StrLenInt;count:StrLenInt):string; { Shortstring functions }
Procedure Delete(Var s:string;index:StrLenInt;count:StrLenInt); Function Copy(const s:shortstring;index:StrLenInt;count:StrLenInt):shortstring;
Procedure Insert(const source:string;Var s:string;index:StrLenInt); Procedure Delete(Var s:shortstring;index:StrLenInt;count:StrLenInt);
Function Pos(const substr:string;const s:string):byte; Procedure Insert(const source:shortstring;Var s:shortstring;index:StrLenInt);
Function Pos(C:Char;const s:string):byte; Function Pos(const substr:shortstring;const s:shortstring):StrLenInt;
Function Pos(C:Char;const s:shortstring):StrLenInt;
Procedure SetLength(var s:shortstring;len:StrLenInt);
{ Char functions to overcome overloading problem with ansistrings }
function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
function pos(const substr : shortstring;c:char): StrLenInt;
function length(c:char):StrLenInt;
Function upCase(const s:shortstring):shortstring;
Function upCase(c:Char):Char; Function upCase(c:Char):Char;
Function upCase(const s:string):string;
{$ifndef RTLLITE} {$ifndef RTLLITE}
Function lowerCase(c:Char):Char; Function lowerCase(c:Char):Char;
Function lowerCase(const s:string):string; Function lowerCase(const s:shortstring):shortstring;
Function hexStr(Val:Longint;cnt:byte):string; Function hexStr(Val:Longint;cnt:byte):shortstring;
Function binStr(Val:Longint;cnt:byte):string; Function binStr(Val:Longint;cnt:byte):shortstring;
{$endif RTLLITE} {$endif RTLLITE}
Function Space(b:byte):string; Function Space(b:byte):shortstring;
Procedure Val(const s:string;Var l:Longint;Var code:Word); Procedure Val(const s:shortstring;Var l:Longint;Var code:Word);
Procedure Val(const s:string;Var l:Longint;Var code:Integer); Procedure Val(const s:shortstring;Var l:Longint;Var code:Integer);
Procedure Val(const s:string;Var l:Longint;Var code:Longint); Procedure Val(const s:shortstring;Var l:Longint;Var code:Longint);
Procedure Val(const s:string;Var l:Longint); Procedure Val(const s:shortstring;Var l:Longint);
Procedure Val(const s:string;Var b:byte;Var code:Word); Procedure Val(const s:shortstring;Var b:byte;Var code:Word);
Procedure Val(const s:string;Var b:byte;Var code:Integer); Procedure Val(const s:shortstring;Var b:byte;Var code:Integer);
Procedure Val(const s:string;Var b:byte;Var code:Longint); Procedure Val(const s:shortstring;Var b:byte;Var code:Longint);
Procedure Val(const s:string;Var b:byte); Procedure Val(const s:shortstring;Var b:byte);
Procedure Val(const s:string;Var b:shortint;Var code:Word); Procedure Val(const s:shortstring;Var b:shortint;Var code:Word);
Procedure Val(const s:string;Var b:shortint;Var code:Integer); Procedure Val(const s:shortstring;Var b:shortint;Var code:Integer);
Procedure Val(const s:string;Var b:shortint;Var code:Longint); Procedure Val(const s:shortstring;Var b:shortint;Var code:Longint);
Procedure Val(const s:string;Var b:shortint); Procedure Val(const s:shortstring;Var b:shortint);
Procedure Val(const s:string;Var b:Word;Var code:Word); Procedure Val(const s:shortstring;Var b:Word;Var code:Word);
Procedure Val(const s:string;Var b:Word;Var code:Integer); Procedure Val(const s:shortstring;Var b:Word;Var code:Integer);
Procedure Val(const s:string;Var b:Word;Var code:Longint); Procedure Val(const s:shortstring;Var b:Word;Var code:Longint);
Procedure Val(const s:string;Var b:Word); Procedure Val(const s:shortstring;Var b:Word);
Procedure Val(const s:string;Var b:Integer;Var code:Word); Procedure Val(const s:shortstring;Var b:Integer;Var code:Word);
Procedure Val(const s:string;Var b:Integer;Var code:Integer); Procedure Val(const s:shortstring;Var b:Integer;Var code:Integer);
Procedure Val(const s:string;Var b:Integer;Var code:Longint); Procedure Val(const s:shortstring;Var b:Integer;Var code:Longint);
Procedure Val(const s:string;Var b:Integer); Procedure Val(const s:shortstring;Var b:Integer);
Procedure Val(const s:string;Var v:cardinal;Var code:Word); Procedure Val(const s:shortstring;Var v:cardinal;Var code:Word);
Procedure Val(const s:string;Var v:cardinal;Var code:Integer); Procedure Val(const s:shortstring;Var v:cardinal;Var code:Integer);
Procedure Val(const s:string;Var v:cardinal;Var code:Longint); Procedure Val(const s:shortstring;Var v:cardinal;Var code:Longint);
Procedure Val(const s:string;Var v:cardinal); Procedure Val(const s:shortstring;Var v:cardinal);
Procedure Val(const s:string;Var d:ValReal;Var code:Word); Procedure Val(const s:shortstring;Var d:ValReal;Var code:Word);
Procedure Val(const s:string;Var d:ValReal;Var code:Integer); Procedure Val(const s:shortstring;Var d:ValReal;Var code:Integer);
Procedure Val(const s:string;Var d:ValReal;Var code:Longint); Procedure Val(const s:shortstring;Var d:ValReal;Var code:Longint);
Procedure Val(const s:string;Var d:ValReal); Procedure Val(const s:shortstring;Var d:ValReal);
{$ifdef SUPPORT_SINGLE} {$ifdef SUPPORT_SINGLE}
Procedure Val(const s:string;Var d:single;Var code:Word); Procedure Val(const s:shortstring;Var d:single;Var code:Word);
Procedure Val(const s:string;Var d:single;Var code:Integer); Procedure Val(const s:shortstring;Var d:single;Var code:Integer);
Procedure Val(const s:string;Var d:single;Var code:Longint); Procedure Val(const s:shortstring;Var d:single;Var code:Longint);
Procedure Val(const s:string;Var d:single); Procedure Val(const s:shortstring;Var d:single);
{$endif SUPPORT_SINGLE} {$endif SUPPORT_SINGLE}
{$ifdef SUPPORT_COMP} {$ifdef SUPPORT_COMP}
Procedure Val(const s:string;Var d:comp;Var code:Word); Procedure Val(const s:shortstring;Var d:comp;Var code:Word);
Procedure Val(const s:string;Var d:comp;Var code:Integer); Procedure Val(const s:shortstring;Var d:comp;Var code:Integer);
Procedure Val(const s:string;Var d:comp;Var code:Longint); Procedure Val(const s:shortstring;Var d:comp;Var code:Longint);
Procedure Val(const s:string;Var d:comp); Procedure Val(const s:shortstring;Var d:comp);
{$endif SUPPORT_COMP} {$endif SUPPORT_COMP}
{$ifdef SUPPORT_FIXED} {$ifdef SUPPORT_FIXED}
Procedure Val(const s:string;Var d:fixed;Var code:Word); Procedure Val(const s:shortstring;Var d:fixed;Var code:Word);
Procedure Val(const s:string;Var d:fixed;Var code:Integer); Procedure Val(const s:shortstring;Var d:fixed;Var code:Integer);
Procedure Val(const s:string;Var d:fixed;Var code:Longint); Procedure Val(const s:shortstring;Var d:fixed;Var code:Longint);
Procedure Val(const s:string;Var d:fixed); Procedure Val(const s:shortstring;Var d:fixed);
{$endif SUPPORT_FIXED} {$endif SUPPORT_FIXED}
{$ifdef DEFAULT_EXTENDED} {$ifdef DEFAULT_EXTENDED}
Procedure Val(const s:string;Var d:Real;Var code:Word); Procedure Val(const s:shortstring;Var d:Real;Var code:Word);
Procedure Val(const s:string;Var d:Real;Var code:Integer); Procedure Val(const s:shortstring;Var d:Real;Var code:Integer);
Procedure Val(const s:string;Var d:Real;Var code:Longint); Procedure Val(const s:shortstring;Var d:Real;Var code:Longint);
Procedure Val(const s:string;Var d:Real); Procedure Val(const s:shortstring;Var d:Real);
{$else DEFAULT_EXTENDED} {$else DEFAULT_EXTENDED}
{$ifdef SUPPORT_EXTENDED} {$ifdef SUPPORT_EXTENDED}
Procedure Val(const s:string;Var d:Extended;Var code:Word); Procedure Val(const s:shortstring;Var d:Extended;Var code:Word);
Procedure Val(const s:string;Var d:Extended;Var code:Integer); Procedure Val(const s:shortstring;Var d:Extended;Var code:Integer);
Procedure Val(const s:string;Var d:Extended;Var code:Longint); Procedure Val(const s:shortstring;Var d:Extended;Var code:Longint);
Procedure Val(const s:string;Var d:Extended); Procedure Val(const s:shortstring;Var d:Extended);
{$endif} {$endif}
{$endif DEFAULT_EXTENDED} {$endif DEFAULT_EXTENDED}
@ -422,7 +432,10 @@ const
{ {
$Log$ $Log$
Revision 1.37 1998-10-10 15:28:47 peter Revision 1.38 1998-11-04 10:20:51 peter
* ansistring fixes
Revision 1.37 1998/10/10 15:28:47 peter
+ read single,fixed + read single,fixed
+ val with code:longint + val with code:longint
+ val for fixed + val for fixed

60
rtl/objpas/sysstr.inc
View File

@ -453,7 +453,7 @@ begin
Writeln (S); Writeln (S);
{$endif} {$endif}
end; end;
Procedure DoFormatError (ErrCode : Longint); Procedure DoFormatError (ErrCode : Longint);
Var S : String; Var S : String;
@ -484,28 +484,28 @@ Var ChPos,OldPos,ArgPos,DoArg,Len : Longint;
{ {
ReadFormat reads the format string. It returns the type character in ReadFormat reads the format string. It returns the type character in
uppercase, and sets index, Width, Prec to their correct values, uppercase, and sets index, Width, Prec to their correct values,
or -1 if not set. It sets Left to true if left alignment was requested. or -1 if not set. It sets Left to true if left alignment was requested.
In case of an error, DoFormatError is called. In case of an error, DoFormatError is called.
} }
Function ReadFormat : Char; Function ReadFormat : Char;
Var Value : longint; Var Value : longint;
Procedure ReadInteger; Procedure ReadInteger;
Var Code : Word; Var Code : Word;
begin begin
If Value<>-1 then exit; // Was already read. If Value<>-1 then exit; // Was already read.
OldPos:=chPos; OldPos:=chPos;
While (Chpos<Len) and While (Chpos<Len) and
(Pos(Fmt[chpos],'1234567890')<>0) do inc(chpos); (Pos(Fmt[chpos],'1234567890')<>0) do inc(chpos);
If Chpos=len then DoFormatError(feInvalidFormat); If Chpos=len then DoFormatError(feInvalidFormat);
If Fmt[Chpos]='*' then If Fmt[Chpos]='*' then
begin begin
If (Chpos>OldPos) or (ArgPos>High(Args)) If (Chpos>OldPos) or (ArgPos>High(Args))
or (Args[ArgPos].Vtype<>vtInteger) then or (Args[ArgPos].Vtype<>vtInteger) then
DoFormatError(feInvalidFormat); DoFormatError(feInvalidFormat);
Value:=Args[ArgPos].VInteger; Value:=Args[ArgPos].VInteger;
@ -542,7 +542,7 @@ Var ChPos,OldPos,ArgPos,DoArg,Len : Longint;
Procedure ReadLeft; Procedure ReadLeft;
begin begin
If Fmt[chpos]='-' then If Fmt[chpos]='-' then
begin begin
left:=True; left:=True;
Inc(chpos); Inc(chpos);
@ -559,7 +559,7 @@ Var ChPos,OldPos,ArgPos,DoArg,Len : Longint;
If Value<>-1 then If Value<>-1 then
begin begin
Width:=Value; Width:=Value;
Value:=-1; Value:=-1;
end; end;
Log ('Read width'); Log ('Read width');
end; end;
@ -611,7 +611,7 @@ Procedure Checkarg (AT : Longint);
DoArg is set to the argument that must be used. DoArg is set to the argument that must be used.
} }
begin begin
If Index=-1 then If Index=-1 then
begin begin
DoArg:=Argpos; DoArg:=Argpos;
inc(ArgPos); inc(ArgPos);
@ -623,7 +623,7 @@ begin
end; end;
Const Zero = '000000000000000000000000000000000000000000000000000000000000000'; Const Zero = '000000000000000000000000000000000000000000000000000000000000000';
begin begin
Result:=''; Result:='';
Len:=Length(Fmt)+1; Len:=Length(Fmt)+1;
@ -634,7 +634,7 @@ begin
begin begin
// uses shortcut evaluation !! // uses shortcut evaluation !!
While (ChPos<=Len) and (Fmt[chpos]<>'%') do inc(chpos); While (ChPos<=Len) and (Fmt[chpos]<>'%') do inc(chpos);
If ChPos>OldPos Then If ChPos>OldPos Then
Result:=Result+Copy(Fmt,OldPos,Chpos-Oldpos); Result:=Result+Copy(Fmt,OldPos,Chpos-Oldpos);
If ChPos<Len then If ChPos<Len then
begin begin
@ -661,7 +661,7 @@ begin
Prec:=Prec+5; // correct dot, eXXX Prec:=Prec+5; // correct dot, eXXX
If ExtVal<0 then Inc(Prec); // Corect for minus sign If ExtVal<0 then Inc(Prec); // Corect for minus sign
If Abs(Extval)<1 then Inc(Prec); // correct for - in E If Abs(Extval)<1 then Inc(Prec); // correct for - in E
Writeln('STRING ',prec); Writeln('STRING ',prec);
Str(Args[doarg].VExtended^:prec,ToAdd); Str(Args[doarg].VExtended^:prec,ToAdd);
WRITELN('DID'); WRITELN('DID');
end; end;
@ -682,15 +682,15 @@ begin
end; end;
'X' : begin 'X' : begin
Checkarg(vtinteger); Checkarg(vtinteger);
If Prec>32 then If Prec>32 then
ToAdd:=HexStr(Args[Doarg].VInteger,Prec) ToAdd:=HexStr(Args[Doarg].VInteger,Prec)
else else
begin begin
// determine minimum needed number of hex digits. // determine minimum needed number of hex digits.
Index:=1; Index:=1;
While (1 shl (Index*4))<Args[DoArg].VInteger do While (1 shl (Index*4))<Args[DoArg].VInteger do
inc(Index); inc(Index);
If Index>Prec then If Index>Prec then
Prec:=Index; Prec:=Index;
ToAdd:=HexStr(Args[DoArg].VInteger,Prec); ToAdd:=HexStr(Args[DoArg].VInteger,Prec);
end; end;
@ -700,11 +700,11 @@ begin
end; end;
If Width<>-1 then If Width<>-1 then
If Length(ToAdd)<Width then If Length(ToAdd)<Width then
If not Left then If not Left then
ToAdd:=Space(Width-Length(ToAdd))+ToAdd ToAdd:=Space(Width-Length(ToAdd))+ToAdd
else else
ToAdd:=ToAdd+space(Width-Length(ToAdd)); ToAdd:=ToAdd+space(Width-Length(ToAdd));
Result:=Result+ToAdd; Result:=Result+ToAdd;
end; end;
inc(chpos); inc(chpos);
Oldpos:=chpos; Oldpos:=chpos;
@ -716,18 +716,6 @@ end;
{ extra functions } { extra functions }
{==============================================================================} {==============================================================================}
{ SetLength sets the length of S to NewLength }
// SetLength should be in the system unit
// which lacks the ShortString version of SetLength
function SetLength(var S: string; NewLength: integer): integer;
begin
if (NewLength > 255) then
NewLength := 255;
S[0] := char(NewLength);
Result := Ord(S[0]);
end ;
{ LeftStr returns Count left-most characters from S } { LeftStr returns Count left-most characters from S }
function LeftStr(const S: string; Count: integer): string; function LeftStr(const S: string; Count: integer): string;
@ -906,7 +894,10 @@ end ;
{ {
$Log$ $Log$
Revision 1.8 1998-10-02 13:57:38 michael Revision 1.9 1998-11-04 10:20:52 peter
* ansistring fixes
Revision 1.8 1998/10/02 13:57:38 michael
Format error now causes exception Format error now causes exception
Revision 1.7 1998/10/02 12:17:17 michael Revision 1.7 1998/10/02 12:17:17 michael
@ -929,7 +920,10 @@ end ;
Update from gertjan Schouten, plus small fix for linux Update from gertjan Schouten, plus small fix for linux
$Log$ $Log$
Revision 1.8 1998-10-02 13:57:38 michael Revision 1.9 1998-11-04 10:20:52 peter
* ansistring fixes
Revision 1.8 1998/10/02 13:57:38 michael
Format error now causes exception Format error now causes exception
Revision 1.7 1998/10/02 12:17:17 michael Revision 1.7 1998/10/02 12:17:17 michael

6
rtl/objpas/sysstrh.inc
View File

@ -77,14 +77,16 @@ Function Format (Const Fmt : String; const Args : Array of const) : String;
{ extra functions } { extra functions }
{==============================================================================} {==============================================================================}
function SetLength(var S: string; NewLength: integer): integer; // should be in the system unit
function LeftStr(const S: string; Count: integer): string; function LeftStr(const S: string; Count: integer): string;
function RightStr(const S: string; Count: integer): string; function RightStr(const S: string; Count: integer): string;
function BCDToInt(Value: integer): integer; function BCDToInt(Value: integer): integer;
{ {
$Log$ $Log$
Revision 1.3 1998-11-02 12:53:53 michael Revision 1.4 1998-11-04 10:20:53 peter
* ansistring fixes
Revision 1.3 1998/11/02 12:53:53 michael
+ Added format function + Added format function
Revision 1.2 1998/09/16 08:28:43 michael Revision 1.2 1998/09/16 08:28:43 michael