mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-08 01:08:07 +02:00
Implemented rtti, inserted ansistrings again
This commit is contained in:
michael
parent
3e7af43b99
commit
05b01ddb00
@ -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
|
||||
|
||||
179
rtl/inc/rtti.inc
Normal file
179
rtl/inc/rtti.inc
Normal 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;
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user