From db87f86f0081a36ddb80de14ced1121cc1e56d6b Mon Sep 17 00:00:00 2001 From: peter Date: Mon, 9 Jul 2001 21:15:40 +0000 Subject: [PATCH] * Length made internal * Add array support for Length --- compiler/compinnr.inc | 8 ++- compiler/ncal.pas | 8 ++- compiler/ninl.pas | 118 +++++++++++++++++++++++++++++------------- compiler/options.pas | 7 ++- compiler/pexpr.pas | 16 +++++- compiler/psystem.pas | 7 ++- compiler/ptype.pas | 9 +++- rtl/inc/astrings.inc | 8 ++- rtl/inc/system.inc | 8 ++- rtl/inc/systemh.inc | 14 ++++- rtl/inc/wstrings.inc | 8 ++- 11 files changed, 162 insertions(+), 49 deletions(-) diff --git a/compiler/compinnr.inc b/compiler/compinnr.inc index bd3b3445d4..3a503ee7d1 100644 --- a/compiler/compinnr.inc +++ b/compiler/compinnr.inc @@ -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 diff --git a/compiler/ncal.pas b/compiler/ncal.pas index ef5da4f177..acf7bf8697 100644 --- a/compiler/ncal.pas +++ b/compiler/ncal.pas @@ -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 diff --git a/compiler/ninl.pas b/compiler/ninl.pas index 2a63b60018..93775c3eeb 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -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 diff --git a/compiler/options.pas b/compiler/options.pas index 65f26b12a5..a2ef6d1006 100644 --- a/compiler/options.pas +++ b/compiler/options.pas @@ -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 diff --git a/compiler/pexpr.pas b/compiler/pexpr.pas index ccad5908bc..7ba3da3390 100644 --- a/compiler/pexpr.pas +++ b/compiler/pexpr.pas @@ -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) diff --git a/compiler/psystem.pas b/compiler/psystem.pas index 3d3325b3f7..0a468cd3d6 100644 --- a/compiler/psystem.pas +++ b/compiler/psystem.pas @@ -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 diff --git a/compiler/ptype.pas b/compiler/ptype.pas index 131610be9f..b2b83d2546 100644 --- a/compiler/ptype.pas +++ b/compiler/ptype.pas @@ -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 diff --git a/rtl/inc/astrings.inc b/rtl/inc/astrings.inc index 10282677a2..aee9540428 100644 --- a/rtl/inc/astrings.inc +++ b/rtl/inc/astrings.inc @@ -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 diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index 4d6de93517..82a88f7ac0 100644 --- a/rtl/inc/system.inc +++ b/rtl/inc/system.inc @@ -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 diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index 5a9235ccd2..d135745cb8 100644 --- a/rtl/inc/systemh.inc +++ b/rtl/inc/systemh.inc @@ -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 diff --git a/rtl/inc/wstrings.inc b/rtl/inc/wstrings.inc index b9d3775900..d252fa20dc 100644 --- a/rtl/inc/wstrings.inc +++ b/rtl/inc/wstrings.inc @@ -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