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

Implemented rtti, inserted ansistrings again

Browse Source
This commit is contained in:
michael 1998-06-08 12:38:21 +00:00
parent 3e7af43b99
commit 05b01ddb00
4 changed files with 299 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
rtl/inc/astrings.pp
View File

@ -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. 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; Function NewAnsiString (Len : Longint) : AnsiString; forward;
ShortString = string; Procedure DisposeAnsiString (Var S : AnsiString); forward;
Procedure Decr_Ansi_Ref (Var S : AnsiString); forward;
{$i textrec.inc} Procedure Incr_Ansi_Ref (Var S : AnsiString); forward;
{ 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);
Procedure AssignAnsiString (Var S1 : AnsiString; S2 : AnsiString); Procedure AssignAnsiString (Var S1 : AnsiString; S2 : AnsiString);
Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString); Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString); forward;
Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Const S2 : ShortString); Procedure Ansi_ShortString_Concat (Var S1: AnsiString; Const S2 : ShortString); forward;
Procedure Ansi_To_ShortString (Var S1 : ShortString; Const S2 : AnsiString; maxlen : longint); Procedure Ansi_To_ShortString (Var S1 : ShortString; Const S2 : AnsiString; maxlen : longint); forward;
Procedure Short_To_AnsiString (Var S1 : AnsiString; Const S2 : ShortString); Procedure Short_To_AnsiString (Var S1 : AnsiString; Const S2 : ShortString); forward;
Function AnsiCompare (Const S1,S2 : AnsiString): Longint; Function AnsiCompare (Const S1,S2 : AnsiString): Longint; forward;
Function AnsiCompare (Const S1 : AnsiString; Const S2 : ShortString): Longint; Function AnsiCompare (Const S1 : AnsiString; Const S2 : ShortString): Longint; forward;
Procedure SetCharAtIndex (Var S : AnsiString; Index : Longint; C : CHar); Procedure SetCharAtIndex (Var S : AnsiString; Index : Longint; C : CHar); forward;
{ Public functions, Will end up in systemh.inc } { 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} {$PACKRECORDS 1}
Type TAnsiRec = Record Type TAnsiRec = Record
Maxlen, len, ref : Longint; Maxlen, len, ref : Longint;
@ -146,9 +106,21 @@ begin
PAnsiRec(P)^.First:=#0; { Terminating #0 } PAnsiRec(P)^.First:=#0; { Terminating #0 }
P:=P+FirstOff; { Points to string now } P:=P+FirstOff; { Points to string now }
end; end;
NewAnsiString:=P; //!! NewAnsiString:=P;
end; 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); Procedure Decr_Ansi_Ref (Var S : AnsiString);
{ {
Decreases the ReferenceCount of a non constant ansistring; Decreases the ReferenceCount of a non constant ansistring;
@ -194,16 +166,6 @@ begin
end; 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); Procedure AssignAnsiString (Var S1 : AnsiString; S2 : AnsiString);
{ {
@ -221,7 +183,7 @@ begin
Temp:=Pointer(NewAnsiString(PansiRec(Pointer(S2)-FirstOff)^.Len)); Temp:=Pointer(NewAnsiString(PansiRec(Pointer(S2)-FirstOff)^.Len));
Move (Pointer(S2)^,Temp^,PAnsiRec(Pointer(S2)-FirstOff)^.len+1); Move (Pointer(S2)^,Temp^,PAnsiRec(Pointer(S2)-FirstOff)^.len+1);
PAnsiRec(Temp-FirstOff)^.Len:=PAnsiRec(Pointer(S2)-FirstOff)^.len; PAnsiRec(Temp-FirstOff)^.Len:=PAnsiRec(Pointer(S2)-FirstOff)^.len;
S2:=Temp; //!! S2:=Temp;
end end
else else
Inc(PAnsiRec(Pointer(S2)-FirstOff)^.ref) Inc(PAnsiRec(Pointer(S2)-FirstOff)^.ref)
@ -229,7 +191,7 @@ begin
{ Decrease the reference count on the old S1 } { Decrease the reference count on the old S1 }
Decr_Ansi_Ref (S1); Decr_Ansi_Ref (S1);
{ And finally, have S1 pointing to S2 (or its copy) } { And finally, have S1 pointing to S2 (or its copy) }
Pointer(S1):=Pointer(S2); //!! Pointer(S1):=Pointer(S2);
end; end;
Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString); Procedure Ansi_String_Concat (Var S1 : AnsiString; Const S2 : AnsiString);
@ -250,7 +212,7 @@ begin
{ Setlength takes case of uniqueness { Setlength takes case of uniqueness
and alllocated memory. We need to use length, and alllocated memory. We need to use length,
to take into account possibility of S1=Nil } 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); Move (Pointer(S2)^,Pointer(Pointer(S1)+location)^,Size+1);
end; end;
end; end;
@ -707,13 +669,13 @@ begin
Decr_ansi_ref (AnsiString(S4)); Decr_ansi_ref (AnsiString(S4));
end; end;
{$ifdef astrings_unit}
end.
{$endif}
{ {
$Log$ $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 * moved getopts to inc/, all supported OS's need argc,argv exported
+ strpas, strlen are now exported in the systemunit + strpas, strlen are now exported in the systemunit
* removed logs * removed logs

179
rtl/inc/rtti.inc Normal file
View File

@ -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;

59
rtl/inc/system.inc
View File

@ -85,6 +85,47 @@ Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile]; Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_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 Math Routines
****************************************************************************} ****************************************************************************}
@ -216,13 +257,6 @@ End;
{ Include processor specific routines } { Include processor specific routines }
{$I math.inc} {$I math.inc}
{****************************************************************************
Set Handling
****************************************************************************}
{ Include set support which is processor specific}
{$I set.inc}
{**************************************************************************** {****************************************************************************
Memory Management Memory Management
****************************************************************************} ****************************************************************************}
@ -253,12 +287,6 @@ Begin
Sseg:=0; Sseg:=0;
End; End;
{****************************************************************************
Subroutines for short strings are in sstrings.inc
****************************************************************************}
{$i sstrings.inc}
{***************************************************************************** {*****************************************************************************
Miscellaneous Miscellaneous
*****************************************************************************} *****************************************************************************}
@ -388,7 +416,10 @@ End;
{ {
$Log$ $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 * comp,extended are only i386 added support_comp,support_extended
Revision 1.6 1998/05/20 11:23:09 cvs Revision 1.6 1998/05/20 11:23:09 cvs

46
rtl/inc/systemh.inc
View File

@ -186,9 +186,6 @@ Function Sseg:Word;
function strpas(p:pchar):string; function strpas(p:pchar):string;
function strlen(p:pchar):longint; function strlen(p:pchar):longint;
{****************************************************************************
String Handling
****************************************************************************}
Function copy(const s:string;index:Integer;count:Integer):string; Function copy(const s:string;index:Integer;count:Integer):string;
Procedure Delete(Var s:string;index:Integer;count:Integer); 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;Var code:Integer);
Procedure Val(const s:string;Var v:cardinal); 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 Untyped File Management
****************************************************************************} ****************************************************************************}
@ -336,7 +371,10 @@ Procedure AddExitProc(Proc:TProcedure);
{ {
$Log$ $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 * comp,extended are only i386 added support_comp,support_extended
Revision 1.9 1998/06/04 08:26:03 pierre Revision 1.9 1998/06/04 08:26:03 pierre