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

* Length made internal

Browse Source 
* Add array support for Length
This commit is contained in:
peter 2001-07-09 21:15:40 +00:00
parent 7321b8436e
commit db87f86f00
11 changed files with 162 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
compiler/compinnr.inc
View File

@ -21,7 +21,7 @@ const
in_lo_long = 3;
in_hi_long = 4;
in_ord_x = 5;
in_length_string = 6;
in_length_x = 6;
in_chr_byte = 7;
in_write_x = 14;
in_writeln_x = 15;
@ -102,7 +102,11 @@ const
{
$Log$
Revision 1.2 2000-11-09 17:46:54 florian
Revision 1.3 2001-07-09 21:15:40 peter
* Length made internal
* Add array support for Length
Revision 1.2 2000/11/09 17:46:54 florian
* System.TypeInfo fixed
+ System.Finalize implemented
+ some new keywords for interface support added

8
compiler/ncal.pas
View File

@ -494,7 +494,7 @@ implementation
end
else
begin
hightree:=caddnode.create(subn,geninlinenode(in_length_string,false,left.getcopy),
hightree:=caddnode.create(subn,geninlinenode(in_length_x,false,left.getcopy),
cordconstnode.create(1,s32bittype));
firstpass(hightree);
hightree:=ctypeconvnode.create(hightree,s32bittype);
@ -1655,7 +1655,11 @@ begin
end.
{
$Log$
Revision 1.36 2001-07-01 20:16:15 peter
Revision 1.37 2001-07-09 21:15:40 peter
* Length made internal
* Add array support for Length
Revision 1.36 2001/07/01 20:16:15 peter
* alignmentinfo record added
* -Oa argument supports more alignment settings that can be specified
per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

118
compiler/ninl.pas
View File

@ -538,46 +538,79 @@ implementation
result:=hp;
end;
in_length_string:
in_length_x:
begin
set_varstate(left,true);
{ we don't need string convertions here }
if (left.nodetype=typeconvn) and
(ttypeconvnode(left).left.resulttype.def.deftype=stringdef) then
begin
hp:=ttypeconvnode(left).left;
ttypeconvnode(left).left:=nil;
left.free;
left:=hp;
end;
case left.resulttype.def.deftype of
stringdef :
begin
{ we don't need string convertions here }
if (left.nodetype=typeconvn) and
(ttypeconvnode(left).left.resulttype.def.deftype=stringdef) then
begin
hp:=ttypeconvnode(left).left;
ttypeconvnode(left).left:=nil;
left.free;
left:=hp;
end;
{ evaluates length of constant strings direct }
if (left.nodetype=stringconstn) then
begin
hp:=cordconstnode.create(tstringconstnode(left).len,s32bittype);
resulttypepass(hp);
result:=hp;
goto myexit;
end
{ length of char is one allways }
else if is_constcharnode(left) then
begin
hp:=cordconstnode.create(1,s32bittype);
resulttypepass(hp);
result:=hp;
goto myexit;
end;
{ evaluates length of constant strings direct }
if (left.nodetype=stringconstn) then
begin
hp:=cordconstnode.create(tstringconstnode(left).len,s32bittype);
resulttypepass(hp);
result:=hp;
goto myexit;
end;
end;
orddef :
begin
{ length of char is one allways }
if is_char(left.resulttype.def) or
is_widechar(left.resulttype.def) then
begin
hp:=cordconstnode.create(1,s32bittype);
resulttypepass(hp);
result:=hp;
goto myexit;
end
else
CGMessage(type_e_mismatch);
end;
arraydef :
begin
if is_open_array(left.resulttype.def) or
is_array_of_const(left.resulttype.def) then
begin
srsym:=searchsymonlyin(tloadnode(left).symtable,'high'+tvarsym(tloadnode(left).symtableentry).name);
hp:=caddnode.create(addn,cloadnode.create(tvarsym(srsym),tloadnode(left).symtable),
cordconstnode.create(1,s32bittype));
resulttypepass(hp);
result:=hp;
goto myexit;
end
else
if not is_dynamic_array(left.resulttype.def) then
begin
hp:=cordconstnode.create(tarraydef(left.resulttype.def).highrange-
tarraydef(left.resulttype.def).lowrange+1,
s32bittype);
resulttypepass(hp);
result:=hp;
goto myexit;
end;
end;
else
CGMessage(type_e_mismatch);
end;
{ shortstring return an 8 bit value as the length
is the first byte of the string }
if is_shortstring(left.resulttype.def) then
resulttype:=u8bittype
else
resulttype:=s32bittype;
{ check the type, must be string or char }
if (left.resulttype.def.deftype<>stringdef) and
(not is_char(left.resulttype.def)) then
CGMessage(type_e_mismatch);
resulttype:=u8bittype
else
resulttype:=s32bittype;
end;
in_typeinfo_x:
@ -1415,8 +1448,17 @@ implementation
end;
in_length_string:
in_length_x:
begin
if is_shortstring(left.resulttype.def) then
location.loc:=LOC_REFERENCE
else
begin
{ ansi/wide string }
if registers32<1 then
registers32:=1;
location.loc:=LOC_REGISTER;
end;
end;
in_typeinfo_x:
@ -1748,7 +1790,11 @@ begin
end.
{
$Log$
Revision 1.43 2001-07-08 21:00:15 peter
Revision 1.44 2001-07-09 21:15:40 peter
* Length made internal
* Add array support for Length
Revision 1.43 2001/07/08 21:00:15 peter
* various widestring updates, it works now mostly without charset
mapping supported

7
compiler/options.pas
View File

@ -1275,6 +1275,7 @@ begin
def_symbol('HASINTF');
def_symbol('HASVARIANT');
def_symbol('INTERNSETLENGTH');
def_symbol('INTERNLENGTH');
def_symbol('INT64FUNCRESOK');
def_symbol('PACKENUMFIXED');
def_symbol('HAS_ADDR_STACK_ON_STACK');
@ -1562,7 +1563,11 @@ finalization
end.
{
$Log$
Revision 1.48 2001-07-08 21:00:15 peter
Revision 1.49 2001-07-09 21:15:40 peter
* Length made internal
* Add array support for Length
Revision 1.48 2001/07/08 21:00:15 peter
* various widestring updates, it works now mostly without charset
mapping supported

16
compiler/pexpr.pas
View File

@ -475,6 +475,16 @@ implementation
statement_syssym := p1;
end;
in_length_x:
begin
consume(_LKLAMMER);
in_args:=true;
p1:=comp_expr(true);
p2:=geninlinenode(l,false,p1);
consume(_RKLAMMER);
statement_syssym:=p2;
end;
in_write_x,
in_writeln_x :
begin
@ -2314,7 +2324,11 @@ implementation
end.
{
$Log$
Revision 1.37 2001-06-29 14:16:57 jonas
Revision 1.38 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.37 2001/06/29 14:16:57 jonas
* fixed inconsistent handling of procvars in FPC mode (sometimes @ was
required to assign the address of a procedure to a procvar, sometimes
not. Now it is always required) (merged)

7
compiler/psystem.pas
View File

@ -75,6 +75,7 @@ begin
p.insert(tsyssym.create('TypeInfo',in_typeinfo_x));
p.insert(tsyssym.create('SetLength',in_setlength_x));
p.insert(tsyssym.create('Finalize',in_finalize_x));
p.insert(tsyssym.create('Length',in_length_x));
end;
@ -265,7 +266,11 @@ end;
end.
{
$Log$
Revision 1.16 2001-05-09 19:58:45 peter
Revision 1.17 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.16 2001/05/09 19:58:45 peter
* m68k doesn't support double (merged)
Revision 1.15 2001/04/13 01:22:13 peter

9
compiler/ptype.pas
View File

@ -474,7 +474,8 @@ implementation
Message2(type_e_incompatible_types,p.resulttype.def.typename,s32bittype.def.typename);
end
else
Message(cg_e_illegal_expression)
Message(cg_e_illegal_expression);
p.free;
end
else
inc(l);
@ -599,7 +600,11 @@ implementation
end.
{
$Log$
Revision 1.27 2001-07-01 20:16:16 peter
Revision 1.28 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.27 2001/07/01 20:16:16 peter
* alignmentinfo record added
* -Oa argument supports more alignment settings that can be specified
per type: PROC,LOOP,VARMIN,VARMAX,CONSTMIN,CONSTMAX,RECORDMIN

8
rtl/inc/astrings.inc
View File

@ -414,6 +414,7 @@ end;
Public functions, In interface.
*****************************************************************************}
{$ifndef INTERNLENGTH}
Function Length (Const S : AnsiString) : Longint;
{
Returns the length of an AnsiString.
@ -425,6 +426,7 @@ begin
else
Length:=PAnsiRec(Pointer(S)-FirstOff)^.Len;
end;
{$endif INTERNLENGTH}
Procedure UniqueString(Var S : AnsiString); [Public,Alias : 'FPC_ANSISTR_UNIQUE'];
@ -705,7 +707,11 @@ end;
{
$Log$
Revision 1.14 2001-07-09 11:41:57 florian
Revision 1.15 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.14 2001/07/09 11:41:57 florian
* another MT fix
Revision 1.13 2001/07/08 21:00:18 peter

8
rtl/inc/system.inc
View File

@ -69,8 +69,10 @@ Function hi(q : QWord) : DWord; [INTERNPROC: In_hi_qword];
Function hi(i : Int64) : DWord; [INTERNPROC: In_hi_qword];
Function chr(b : byte) : Char; [INTERNPROC: In_chr_byte];
{$ifndef INTERNLENGTH}
Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
Function Length(c : char) : byte; [INTERNPROC: In_Length_string];
{$endif INTERNLENGTH}
Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
@ -656,7 +658,11 @@ end;
{
$Log$
Revision 1.16 2001-07-08 21:00:18 peter
Revision 1.17 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.16 2001/07/08 21:00:18 peter
* various widestring updates, it works now mostly without charset
mapping supported

14
rtl/inc/systemh.inc
View File

@ -299,7 +299,9 @@ Function Pos(const substr:shortstring;const s:shortstring):StrLenInt;
Function Pos(C:Char;const s:shortstring):StrLenInt;
Procedure SetString (Var S : Shortstring; Buf : PChar; Len : Longint);
Procedure SetString (Var S : AnsiString; Buf : PChar; Len : Longint);
{$ifndef INTERNLENGTH}
Function Length(s:string):byte;
{$endif INTERNLENGTH}
Function upCase(const s:shortstring):shortstring;
Function lowerCase(const s:shortstring):shortstring;
Function Space(b:byte):shortstring;
@ -314,7 +316,9 @@ Function upCase(c:Char):Char;
Function lowerCase(c:Char):Char;
function copy(c:char;index : StrLenInt;count : StrLenInt): shortstring;
function pos(const substr : shortstring;c:char): StrLenInt;
{$ifndef INTERNLENGTH}
function length(c:char):byte;
{$endif INTERNLENGTH}
{****************************************************************************
@ -325,7 +329,9 @@ function length(c:char):byte;
Procedure SetLength (Var S : AnsiString; l : Longint);
{$endif INTERNSETLENGTH}
Procedure UniqueString (Var S : AnsiString);
{$ifndef INTERNLENGTH}
Function Length (Const S : AnsiString) : Longint;
{$endif INTERNLENGTH}
Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString;
Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : Longint;
Function Pos (c : Char; Const s : AnsiString) : Longint;
@ -345,7 +351,9 @@ function lowercase(const s : ansistring) : ansistring;
Procedure SetLength (Var S : WideString; l : Longint);
{$endif INTERNSETLENGTH}
Procedure UniqueString (Var S : WideString);
{$ifndef INTERNLENGTH}
Function Length (Const S : WideString) : Longint;
{$endif INTERNLENGTH}
Function Copy (Const S : WideString; Index,Size : Longint) : WideString;
Function Pos (Const Substr : WideString; Const Source : WideString) : Longint;
Function Pos (c : Char; Const s : WideString) : Longint;
@ -504,7 +512,11 @@ const
{
$Log$
Revision 1.25 2001-07-08 21:00:18 peter
Revision 1.26 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.25 2001/07/08 21:00:18 peter
* various widestring updates, it works now mostly without charset
mapping supported

8
rtl/inc/wstrings.inc
View File

@ -459,6 +459,7 @@ end;
Public functions, In interface.
*****************************************************************************}
{$ifndef INTERNLENGTH}
Function Length (Const S : WideString) : Longint;
{
Returns the length of an WideString.
@ -470,6 +471,7 @@ begin
else
Length:=PWideRec(Pointer(S)-WideFirstOff)^.Len;
end;
{$endif INTERNLENGTH}
Procedure UniqueString(Var S : WideString); [Public,Alias : 'FPC_WIDESTR_UNIQUE'];
@ -748,7 +750,11 @@ end;
{
$Log$
Revision 1.8 2001-07-08 21:00:18 peter
Revision 1.9 2001-07-09 21:15:41 peter
* Length made internal
* Add array support for Length
Revision 1.8 2001/07/08 21:00:18 peter
* various widestring updates, it works now mostly without charset
mapping supported