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

* changed ver1_0 defines to temporary defs

Browse Source
This commit is contained in:
peter 2000-11-06 20:34:24 +00:00
parent 8df98007d6
commit 94c1f86d79
6 changed files with 98 additions and 77 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
rtl/inc/astrings.inc
View File

@ -344,11 +344,11 @@ begin
HandleErrorFrame(201,get_frame);
end;
{$ifdef ver1_0}
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : AnsiString; l : Longint);
{$else ver1_0}
{$else INTERNSETLENGTH}
Procedure AnsiStr_SetLength (Var S : AnsiString; l : Longint);[Public,Alias : 'FPC_ANSISTR_SETLENGTH'];
{$endif ver1_0}
{$endif INTERNSETLENGTH}
{
Sets The length of string S to L.
Makes sure S is unique, and contains enough room.
@ -668,7 +668,10 @@ end;
{
$Log$
Revision 1.6 2000-10-21 18:20:17 florian
Revision 1.7 2000-11-06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.6 2000/10/21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended

109
rtl/inc/objpas.inc
View File

@ -32,7 +32,7 @@
handleerror(219);
end;
{$ifdef ver1_0}
{$ifndef HASINTF}
{ dummies for make cycle with 1.0.x }
procedure int_do_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
begin
@ -50,7 +50,7 @@
begin
end;
{$else ver1_0}
{$else HASINTF}
{ interface helpers }
procedure int_do_intf_decr_ref(var i: pointer);[public,alias: 'FPC_INTF_DECR_REF'];
begin
@ -67,8 +67,10 @@
procedure int_do_intf_assign(var D: pointer; const S: pointer);[public,alias: 'FPC_INTF_ASSIGN'];
begin
if assigned(S) then IUnknown(S)._AddRef;
if assigned(D) then IUnknown(D)._Release;
if assigned(S) then
IUnknown(S)._AddRef;
if assigned(D) then
IUnknown(D)._Release;
D:=S;
end;
@ -88,7 +90,7 @@
else
int_do_intf_decr_ref(D);
end;
{$endif ver1_0}
{$endif HASINTF}
{****************************************************************************
TOBJECT
@ -187,13 +189,13 @@
class function TObject.MethodAddress(const name : shortstring) : pointer;
var
UName : ShortString;
UName : ShortString;
methodtable : pmethodnametable;
i : dword;
c : tclass;
begin
UName := UpCase(name);
UName := UpCase(name);
c:=self;
while assigned(c) do
begin
@ -243,53 +245,53 @@
function TObject.FieldAddress(const name : shortstring) : pointer;
type
PFieldInfo = ^TFieldInfo;
TFieldInfo = packed record
FieldOffset: LongWord;
ClassTypeIndex: Word;
Name: ShortString;
end;
type
PFieldInfo = ^TFieldInfo;
TFieldInfo = packed record
FieldOffset: LongWord;
ClassTypeIndex: Word;
Name: ShortString;
end;
PFieldTable = ^TFieldTable;
TFieldTable = packed record
FieldCount: Word;
ClassTable: Pointer;
{ Fields: array[Word] of TFieldInfo; Elements have variant size! }
end;
PFieldTable = ^TFieldTable;
TFieldTable = packed record
FieldCount: Word;
ClassTable: Pointer;
{ Fields: array[Word] of TFieldInfo; Elements have variant size! }
end;
var
UName: ShortString;
CurClassType: TClass;
FieldTable: PFieldTable;
FieldInfo: PFieldInfo;
i: Integer;
UName: ShortString;
CurClassType: TClass;
FieldTable: PFieldTable;
FieldInfo: PFieldInfo;
i: Integer;
begin
if Length(name) > 0 then
begin
UName := UpCase(name);
CurClassType := ClassType;
while CurClassType <> nil do
begin
FieldTable := PFieldTable((Pointer(CurClassType) + vmtFieldTable)^);
if FieldTable <> nil then
begin
FieldInfo := PFieldInfo(Pointer(FieldTable) + 6);
for i := 0 to FieldTable^.FieldCount - 1 do
begin
if UpCase(FieldInfo^.Name) = UName then
begin
fieldaddress := Pointer(Self) + FieldInfo^.FieldOffset;
exit;
end;
Inc(Pointer(FieldInfo), 7 + Length(FieldInfo^.Name));
end;
end;
{ Try again with the parent class type }
CurClassType := CurClassType.ClassParent;
end;
end;
if Length(name) > 0 then
begin
UName := UpCase(name);
CurClassType := ClassType;
while CurClassType <> nil do
begin
FieldTable := PFieldTable((Pointer(CurClassType) + vmtFieldTable)^);
if FieldTable <> nil then
begin
FieldInfo := PFieldInfo(Pointer(FieldTable) + 6);
for i := 0 to FieldTable^.FieldCount - 1 do
begin
if UpCase(FieldInfo^.Name) = UName then
begin
fieldaddress := Pointer(Self) + FieldInfo^.FieldOffset;
exit;
end;
Inc(Pointer(FieldInfo), 7 + Length(FieldInfo^.Name));
end;
end;
{ Try again with the parent class type }
CurClassType := CurClassType.ClassParent;
end;
end;
fieldaddress:=nil;
end;
@ -502,7 +504,7 @@
begin
end;
{$ifndef ver1_0}
{$ifdef HASINTF}
function IsGUIDEqual(const guid1, guid2: tguid): boolean;
begin
IsGUIDEqual:=
@ -590,7 +592,7 @@
begin
getinterfacetable:=pinterfacetable((pointer(Self)+vmtIntfTable)^);
end;
{$endif ver1_0}
{$endif HASINTF}
{****************************************************************************
Exception Support
@ -604,7 +606,10 @@
{
$Log$
Revision 1.5 2000-11-04 17:52:46 florian
Revision 1.6 2000-11-06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.5 2000/11/04 17:52:46 florian
* fixed linker errors
Revision 1.4 2000/11/04 16:29:54 florian

15
rtl/inc/objpash.inc
View File

@ -138,17 +138,17 @@
{ new for gtk, default handler for text based messages }
procedure DefaultHandlerStr(var message);virtual;
{$ifndef ver1_0}
{$ifdef HASINTF}
{ interface functions }
function getinterface(const iid : tguid; out obj) : boolean;
function getinterfacebystr(const iidstr : string; out obj) : boolean;
class function getinterfaceentry(const iid : tguid) : pinterfaceentry;
class function getinterfaceentrybystr(const iidstr : string) : pinterfaceentry;
class function getinterfacetable : pinterfacetable;
{$endif ver1_0}
{$endif HASINTF}
end;
{$ifndef ver1_0}
{$ifdef HASINTF}
IUnknown = interface
['{00000000-0000-0000-C000-000000000046}']
function QueryInterface(const iid: tguid; out obj): LongInt; stdcall;
@ -168,7 +168,7 @@
LocaleID: LongInt; Flags: Word; var params;
VarResult, ExcepInfo, ArgErr: Pointer): Integer; stdcall;
end;
{$endif ver1_0}
{$endif HASINTF}
TExceptProc = Procedure (Obj : TObject; Addr,Frame: Pointer);
@ -183,7 +183,7 @@
Const
ExceptProc : TExceptProc = Nil;
RaiseProc : TExceptProc = Nil;
RaiseProc : TExceptProc = Nil;
Function RaiseList : PExceptObject;
@ -258,7 +258,10 @@
end;
{
$Log$
Revision 1.6 2000-11-04 17:31:50 florian
Revision 1.7 2000-11-06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.6 2000/11/04 17:31:50 florian
* fixed some out declarations
Revision 1.5 2000/11/04 16:28:55 florian

12
rtl/inc/sstrings.inc
View File

@ -17,11 +17,12 @@
****************************************************************************}
{$I real2str.inc}
{$ifdef ver1_0}
{$ifndef INTERNSETLENGTH}
procedure SetLength(var s:shortstring;len:StrLenInt);
{$else ver1_0}
{$else INTERNSETLENGTH}
procedure Shortstr_SetLength(var s:shortstring;len:StrLenInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH'];
{$endif ver1_0}
{$endif INTERNSETLENGTH}
begin
if Len>255 then
Len:=255;
@ -559,7 +560,10 @@ end;
{
$Log$
Revision 1.4 2000-10-21 18:20:17 florian
Revision 1.5 2000-11-06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.4 2000/10/21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended

17
rtl/inc/systemh.inc
View File

@ -267,9 +267,9 @@ function strpas(p:pchar):shortstring;
function strlen(p:pchar):longint;
{ Shortstring functions }
{$ifdef ver1_0}
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : ShortString; l : longint);
{$endif ver1_0}
{$endif INTERNSETLENGTH}
Function Copy(const s:shortstring;index:StrLenInt;count:StrLenInt):shortstring;
Procedure Delete(Var s:shortstring;index:StrLenInt;count:StrLenInt);
Procedure Insert(const source:shortstring;Var s:shortstring;index:StrLenInt);
@ -304,9 +304,9 @@ function length(c:char):byte;
AnsiString Handling
****************************************************************************}
{$ifdef ver1_0}
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : AnsiString; l : Longint);
{$endif ver1_0}
{$endif INTERNSETLENGTH}
Procedure UniqueString (Var S : AnsiString);
Function Length (Const S : AnsiString) : Longint;
Function Copy (Const S : AnsiString; Index,Size : Longint) : AnsiString;
@ -321,9 +321,9 @@ Function StringOfChar(c : char;l : longint) : AnsiString;
****************************************************************************}
{$ifdef haswidechar}
{$ifdef ver1_0}
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : WideString; l : Longint);
{$endif ver1_0}
{$endif INTERNSETLENGTH}
Procedure UniqueString (Var S : WideString);
Function Length (Const S : WideString) : Longint;
Function Copy (Const S : WideString; Index,Size : Longint) : WideString;
@ -484,7 +484,10 @@ const
{
$Log$
Revision 1.8 2000-10-23 16:15:40 jonas
Revision 1.9 2000-11-06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.8 2000/10/23 16:15:40 jonas
* renamed strlenint to longint since 1.0 doesn't know that type
Revision 1.7 2000/10/23 14:00:59 florian

11
rtl/inc/wstrings.inc
View File

@ -294,11 +294,11 @@ begin
HandleErrorFrame(201,get_frame);
end;
{$ifdef ver1_0}
{$ifndef INTERNSETLENGTH}
Procedure SetLength (Var S : WideString; l : Longint);
{$else ver1_0}
{$else INTERNSETLENGTH}
Procedure WideStr_SetLength (Var S : WideString; l : Longint);[Public,Alias : 'FPC_WIDESTR_SETLENGTH'];
{$endif ver1_0}
{$endif INTERNSETLENGTH}
{
Sets The length of string S to L.
Makes sure S is unique, and contains enough room.
@ -500,7 +500,10 @@ end;}
{
$Log$
Revision 1.4 2000-10-21 18:20:17 florian
Revision 1.5 2000-11-06 20:34:24 peter
* changed ver1_0 defines to temporary defs
Revision 1.4 2000/10/21 18:20:17 florian
* a lot of small changes:
- setlength is internal
- win32 graph unit extended