diff --git a/rtl/inc/astrings.pp b/rtl/inc/astrings.pp index ea55cfaf83..798fb00484 100644 --- a/rtl/inc/astrings.pp +++ b/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 diff --git a/rtl/inc/rtti.inc b/rtl/inc/rtti.inc new file mode 100644 index 0000000000..f2173e772f --- /dev/null +++ b/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; diff --git a/rtl/inc/system.inc b/rtl/inc/system.inc index c5540a0dbc..5418d3afce 100644 --- a/rtl/inc/system.inc +++ b/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 diff --git a/rtl/inc/systemh.inc b/rtl/inc/systemh.inc index ad61b2d12c..7d2acc19a5 100644 --- a/rtl/inc/systemh.inc +++ b/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