Implemented rtti, inserted ansistrings again

rtl/inc/astrings.pp

@@ -13,7 +13,7 @@
 
  **********************************************************************}
 { ---------------------------------------------------------------------
-   This units implements AnsiStrings for FPC
+   This file implements AnsiStrings for FPC
   ---------------------------------------------------------------------}
 
 
@@ -34,64 +34,24 @@
   Meaning that they can't be disposed of.
   
 }
-{$ifdef astrings_unit} 
-{ Compile as a separate unit - development only}
-unit astrings;
 
-Interface 
+Type shortstring=string;
 
-Type AnsiString = Pointer;
-     ShortString = string;
-
-{$i textrec.inc}
-
-{ Internal functions, will not appear in systemh.inc }
-
-Function  NewAnsiString (Len : Longint) : AnsiString;
-Procedure DisposeAnsiString (Var S : AnsiString);
-Procedure Decr_Ansi_Ref (Var S : AnsiString);
-Procedure Incr_Ansi_Ref (Var S : AnsiString);
+Function  NewAnsiString (Len : Longint) : AnsiString; forward;
+Procedure DisposeAnsiString (Var S : AnsiString); forward;
+Procedure Decr_Ansi_Ref (Var S : AnsiString); forward;
+Procedure Incr_Ansi_Ref (Var S : AnsiString); forward;
 Procedure AssignAnsiString (Var S1 : AnsiString; S2 : AnsiString); 
-Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString);
-Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Const S2 : ShortString);
-Procedure Ansi_To_ShortString (Var S1 : ShortString; Const S2 : AnsiString; maxlen : longint);
-Procedure Short_To_AnsiString (Var S1 : AnsiString; Const S2 : ShortString);
-Function  AnsiCompare (Const S1,S2 : AnsiString): Longint;
-Function  AnsiCompare (Const S1 : AnsiString; Const S2 : ShortString): Longint;
-Procedure SetCharAtIndex (Var S : AnsiString; Index : Longint; C : CHar);
+Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString); forward;
+Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Const S2 : ShortString); forward;
+Procedure Ansi_To_ShortString (Var S1 : ShortString; Const S2 : AnsiString; maxlen : longint); forward;
+Procedure Short_To_AnsiString (Var S1 : AnsiString; Const S2 : ShortString); forward;
+Function  AnsiCompare (Const S1,S2 : AnsiString): Longint; forward;
+Function  AnsiCompare (Const S1 : AnsiString; Const S2 : ShortString): Longint; forward;
+Procedure SetCharAtIndex (Var S : AnsiString; Index : Longint; C : CHar); forward;
 
 { Public functions, Will end up in systemh.inc }
 
-Procedure SetLength (Var S : AnsiString; l : Longint);
-Procedure UniqueAnsiString (Var S : AnsiString);
-Procedure Write_Text_AnsiString (Len : Longint; T : Textrec; Var S : AnsiString);
-Function  Length (Const S : AnsiString) : Longint;
-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);
-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);
-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);
-
-Implementation
-
-{$endif}
 {$PACKRECORDS 1}
 Type TAnsiRec = Record
       Maxlen, len, ref :  Longint;
@@ -146,9 +106,21 @@ begin
      PAnsiRec(P)^.First:=#0;      { Terminating #0 }
      P:=P+FirstOff;               { Points to string now }
      end;
-  NewAnsiString:=P;
+//!!  NewAnsiString:=P;
+end;
+
+Procedure DisposeAnsiString (Var S : AnsiString);
+{
+  Deallocates a AnsiString From the heap.
+}
+begin
+  If Pointer(S)=Nil then exit;
+  Dec (Longint(S),FirstOff);
+//!!  FreeMem (S,PAnsiRec(Pointer(S))^.Maxlen+AnsiRecLen);
+//!!  Pointer(S):=Nil;
 end;
 
+
 Procedure Decr_Ansi_Ref (Var S : AnsiString);
 {
  Decreases the ReferenceCount of a non constant ansistring; 
@@ -194,16 +166,6 @@ begin
 end;
 
 
-Procedure DisposeAnsiString (Var S : AnsiString);
-{
-  Deallocates a AnsiString From the heap.
-}
-begin
-  If Pointer(S)=Nil then exit;
-  Dec (Longint(S),FirstOff);
-  FreeMem (S,PAnsiRec(Pointer(S))^.Maxlen+AnsiRecLen);
-  Pointer(S):=Nil;
-end;
 
 Procedure AssignAnsiString (Var S1 : AnsiString; S2 : AnsiString); 
 {
@@ -221,7 +183,7 @@ begin
       Temp:=Pointer(NewAnsiString(PansiRec(Pointer(S2)-FirstOff)^.Len));
       Move (Pointer(S2)^,Temp^,PAnsiRec(Pointer(S2)-FirstOff)^.len+1);
       PAnsiRec(Temp-FirstOff)^.Len:=PAnsiRec(Pointer(S2)-FirstOff)^.len;
-      S2:=Temp;
+//!!      S2:=Temp;
       end
     else
       Inc(PAnsiRec(Pointer(S2)-FirstOff)^.ref)
@@ -229,7 +191,7 @@ begin
   { Decrease the reference count on the old S1 }
   Decr_Ansi_Ref (S1);
   { And finally, have S1 pointing to S2 (or its copy) }
-  Pointer(S1):=Pointer(S2);
+//!!  Pointer(S1):=Pointer(S2);
 end;
 
 Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString);
@@ -250,7 +212,7 @@ begin
     { Setlength takes case of uniqueness 
       and alllocated memory. We need to use length, 
       to take into account possibility of S1=Nil }
-    SetLength (S1,Size+Location); 
+//!!    SetLength (S1,Size+Location); 
     Move (Pointer(S2)^,Pointer(Pointer(S1)+location)^,Size+1);
     end;
 end;
@@ -707,13 +669,13 @@ begin
   Decr_ansi_ref (AnsiString(S4));
 end;
 
-{$ifdef astrings_unit}
-end.
-{$endif}
 
 {
   $Log$
-  Revision 1.2  1998-05-12 10:42:44  peter
+  Revision 1.3  1998-06-08 12:38:22  michael
+  Implemented rtti, inserted ansistrings again
+
+  Revision 1.2  1998/05/12 10:42:44  peter
     * moved getopts to inc/, all supported OS's need argc,argv exported
     + strpas, strlen are now exported in the systemunit
     * removed logs

rtl/inc/rtti.inc

@@ -0,0 +1,179 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1993,97 by xxxx
+    member of the Free Pascal development team
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{ Run-Time type information routines }
+
+{ The RTTI is implemented through a series of constants : }
+
+Const 
+  tkLString  = 10;
+  tkWString = 11;
+  tkVariant  = 12;
+  tkArray    = 13;
+  tkRecord   = 14;
+ 
+{ Some useful types }
+Type
+
+  PByte = ^Byte;
+
+
+{ A record is designed as follows : 
+    1    : tkrecord
+    2    : Length of name string (n);
+    3    : name string;
+    3+n  : record size;
+    7+n  : number of elements (N)
+    11+n : N times : Pointer to type info
+                     Offset in record
+} 
+
+TRecElem = Record
+  Info : Pointer;
+  Offset : Longint;
+  end;
+
+TRecElemArray = Array[1..Maxint] of TRecElem;
+
+PRecRec = ^TRecRec;
+TRecRec = record
+  Size,Count : Longint;
+  Elements : TRecElemArray;
+  end;
+
+
+{ An array is designed as follows :
+   1    : tkArray;
+   2    : length of name string (n);
+   3    : NAme string
+   3+n  : Element Size
+   7+n  : Number of elements
+   11+n : Pointer to type of elements
+}
+
+PArrayRec = ^TArrayRec;
+TArrayRec = record
+  Size,Count : Longint;
+  Info : Pointer;
+  end;
+  
+
+Procedure Initialize (Data,TypeInfo : pointer);[Alias : 'INITIALIZE'];
+
+Var Temp       : PByte;
+    I          : longint;
+    Size,Count : longint;
+    TInfo : Pointer;
+     
+begin
+  Temp:=PByte(TypeInfo);
+  case temp^ of 
+    tkLstring,tkWstring : PPchar(Data)^:=Nil;
+    tkArray :
+      begin
+      temp:=Temp+1;
+      I:=temp^; 
+      temp:=temp+(I+1);               // skip name string;
+      Size:=PArrayRec(Temp)^.Size;     // get element size
+      Count:=PArrayRec(Temp)^.Count;  // get element Count
+      TInfo:=PArrayRec(Temp)^.Info;   // Get element info 
+      For I:=0 to Count-1 do
+        Initialize (Data+(I*size),TInfo);   
+      end; 
+    tkrecord :
+      begin
+      Temp:=Temp+1;
+      I:=Temp^;
+      temp:=temp+(I+1);             // skip name string;
+      Size:=PRecRec(Temp)^.Size;    // get record size; not needed.
+      Count:=PRecRec(Temp)^.Count;  // get element Count
+      For I:=1 to count Do 
+        With PRecRec(Temp)^.elements[I] do
+          Initialize (Data+Offset,Info);
+      end;
+  end;
+end;
+
+Procedure Finalize (Data,TypeInfo: Pointer);[Alias : 'FINALIZE'];
+
+Var Temp       : PByte;
+    I          : longint;
+    Size,Count : longint;
+    TInfo : Pointer;
+
+begin
+  Temp:=PByte(TypeInfo);
+  case temp^ of 
+    tkLstring,tkWstring : Decr_Ansi_ref(Data);
+    tkArray :
+      begin
+      Temp:=Temp+1;
+      I:=temp^; 
+      temp:=temp+(I+1);               // skip name string;
+      Size:=PArrayRec(Temp)^.Size;     // get element size
+      Count:=PArrayRec(Temp)^.Count;  // get element Count
+      TInfo:=PArrayRec(Temp)^.Info;   // Get element info 
+      For I:=0 to Count-1 do
+        Finalize (Data+(I*size),TInfo);   
+      end; 
+    tkrecord :
+      begin
+      Temp:=Temp+1;
+      I:=Temp^;
+      temp:=temp+(I+1);             // skip name string;
+      Size:=PRecRec(Temp)^.Size;    // get record size; not needed.
+      Count:=PRecRec(Temp)^.Count;  // get element Count
+      For I:=1 to count do 
+        With PRecRec(Temp)^.elements[I] do
+          Finalize (Data+Offset,Info);
+      end;
+  end;
+end;
+
+Procedure Addref (Data,TypeInfo : Pointer); [alias : 'ADDREF'];
+
+Var Temp       : PByte;
+    I          : longint;
+    Size,Count : longint;
+    TInfo : Pointer;
+
+begin
+  Temp:=PByte(TypeInfo);
+  case temp^ of 
+    tkLstring,tkWstring : Incr_Ansi_ref(Data);
+    tkArray :
+      begin
+      Temp:=Temp+1;
+      I:=temp^; 
+      temp:=temp+(I+1);               // skip name string;
+      Size:=PArrayRec(Temp)^.Size;     // get element size
+      Count:=PArrayRec(Temp)^.Count;  // get element Count
+      TInfo:=PArrayRec(Temp)^.Info;   // Get element info 
+      For I:=0 to Count-1 do
+        Finalize (Data+(I*size),TInfo);   
+      end; 
+    tkrecord :
+      begin
+      Temp:=Temp+1;
+      I:=Temp^;
+      temp:=temp+(I+1);             // skip name string;
+      Size:=PRecRec(Temp)^.Size;    // get record size; not needed.
+      Count:=PRecRec(Temp)^.Count;  // get element Count
+      For I:=1 to count do 
+        With PRecRec(Temp)^.elements[I] do
+          Finalize (Data+Offset,Info);
+      end;
+  end;
+end;

rtl/inc/system.inc

@@ -85,6 +85,47 @@ Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
 Procedure Reset(var f : TypedFile);   [INTERNPROC: In_Reset_TypedFile];
 Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
 
+
+{****************************************************************************
+                                Set Handling
+****************************************************************************}
+
+{ Include set support which is processor specific}
+{$I set.inc}
+
+{****************************************************************************
+                  Subroutines for String handling
+****************************************************************************}
+
+{ Needs to be before RTTI handling }
+
+{$i sstrings.inc}
+
+{$ifdef UseAnsiStrings}
+
+{$i astrings.pp}
+
+{$else}
+
+{ Provide dummy procedures needed for rtti}
+Procedure decr_ansi_ref (P : pointer);
+  begin
+  end; 
+
+Procedure incr_ansi_ref (P : pointer);
+  begin
+  end; 
+
+{$endif}
+
+
+{****************************************************************************
+                         Run-Time Type Information (RTTI)
+****************************************************************************}
+
+
+{$i rtti.inc}
+
 {****************************************************************************
                                Math Routines
 ****************************************************************************}
@@ -216,13 +257,6 @@ End;
 { Include processor specific routines }
 {$I math.inc}
 
-{****************************************************************************
-                                Set Handling
-****************************************************************************}
-
-{ Include set support which is processor specific}
-{$I set.inc}
-
 {****************************************************************************
                              Memory Management
 ****************************************************************************}
@@ -253,12 +287,6 @@ Begin
   Sseg:=0;
 End;
 
-{****************************************************************************
-                Subroutines for short strings are in sstrings.inc
-****************************************************************************}
-
-{$i sstrings.inc}
-
 {*****************************************************************************
                              Miscellaneous
 *****************************************************************************}
@@ -388,7 +416,10 @@ End;
 
 {
   $Log$
-  Revision 1.7  1998-06-04 23:46:01  peter
+  Revision 1.8  1998-06-08 12:38:24  michael
+  Implemented rtti, inserted ansistrings again
+
+  Revision 1.7  1998/06/04 23:46:01  peter
     * comp,extended are only i386 added support_comp,support_extended
 
   Revision 1.6  1998/05/20 11:23:09  cvs

rtl/inc/systemh.inc

@@ -186,9 +186,6 @@ Function  Sseg:Word;
 function strpas(p:pchar):string;
 function strlen(p:pchar):longint;
 
-{****************************************************************************
-                              String Handling
-****************************************************************************}
 
 Function  copy(const s:string;index:Integer;count:Integer):string;
 Procedure Delete(Var s:string;index:Integer;count:Integer);
@@ -237,6 +234,44 @@ Procedure Val(const s:string;Var v:cardinal;Var code:Word);
 Procedure Val(const s:string;Var v:cardinal;Var code:Integer);
 Procedure Val(const s:string;Var v:cardinal);
 
+{****************************************************************************
+                             AnsiString Handling
+****************************************************************************}
+
+{$ifdef UseAnsiStrings }
+
+Procedure SetLength (Var S : AnsiString; l : Longint); 
+Procedure UniqueAnsiString (Var S : AnsiString); 
+Function  Length (Const S : AnsiString) : Longint; 
+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); 
+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); 
+{
+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); 
+}
+{$endif}
+
+
 {****************************************************************************
                           Untyped File Management
 ****************************************************************************}
@@ -336,7 +371,10 @@ Procedure AddExitProc(Proc:TProcedure);
 
 {
   $Log$
-  Revision 1.10  1998-06-04 23:46:02  peter
+  Revision 1.11  1998-06-08 12:38:23  michael
+  Implemented rtti, inserted ansistrings again
+
+  Revision 1.10  1998/06/04 23:46:02  peter
     * comp,extended are only i386 added support_comp,support_extended
 
   Revision 1.9  1998/06/04 08:26:03  pierre