* Length made internal

  * Add array support for Length

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

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

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
 

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
 

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)

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

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

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

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
 

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
 

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