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

* make cycle for win32 fixed

Browse Source
This commit is contained in:
florian 2001-11-17 10:29:48 +00:00
parent 1b89398cec
commit 92b842342c
4 changed files with 134 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
rtl/inc/genrtti.inc
View File

@ -55,8 +55,10 @@ begin
With PRecRec(Temp)^.elements[I] do With PRecRec(Temp)^.elements[I] do
int_Initialize (Data+Offset,Info); int_Initialize (Data+Offset,Info);
end; end;
{$ifdef HASVARIANTS}
tkVariant: tkVariant:
variant_init(Variant(PVarData(Data)^)) variant_init(Variant(PVarData(Data)^))
{$endif HASVARIANTS}
end; end;
end; end;
{$endif} {$endif}
@ -100,8 +102,10 @@ begin
With PRecRec(Temp)^.elements[I] do With PRecRec(Temp)^.elements[I] do
int_Finalize (Data+Offset,Info); int_Finalize (Data+Offset,Info);
end; end;
{$ifdef HASVARIANTS}
tkVariant: tkVariant:
variant_clear(Variant(PVarData(Data)^)) variant_clear(Variant(PVarData(Data)^))
{$endif HASVARIANTS}
end; end;
end; end;
{$endif} {$endif}
@ -212,8 +216,11 @@ procedure fpc_FinalizeArray(data,typeinfo : pointer;count,size : longint); [Publ
{ {
$Log$ $Log$
Revision 1.6 2001-11-14 22:59:11 michael Revision 1.7 2001-11-17 10:29:48 florian
+ Initial variant support * make cycle for win32 fixed
Revision 1.6 2001/11/14 22:59:11 michael
+ Initial variant support
Revision 1.5 2001/08/01 15:00:10 jonas Revision 1.5 2001/08/01 15:00:10 jonas
+ "compproc" helpers + "compproc" helpers

116
rtl/objpas/cvarutil.inc
View File

@ -425,10 +425,124 @@ Function VariantToShortString(Const VargSrc : TVarData) : ShortString;
begin begin
end; end;
{ ---------------------------------------------------------------------
Some debug routines
---------------------------------------------------------------------}
Procedure DumpVariant(Const VArgSrc : TVarData);
begin
DumpVariant(Output,VArgSrc);
end;
(*
tvardata = packed record
vtype : tvartype;
case integer of
0:(res1 : word;
case integer of
0:
(res2,res3 : word;
case word of
varsmallint : (vsmallint : smallint);
varinteger : (vinteger : longint);
varsingle : (vsingle : single);
vardouble : (vdouble : double);
varcurrency : (vcurrency : currency);
vardate : (vdate : tdatetime);
varolestr : (volestr : pwidechar);
vardispatch : (vdispatch : pointer);
varerror : (verror : dword);
varboolean : (vboolean : wordbool);
varunknown : (vunknown : pointer);
// vardecimal : ( : );
varshortint : (vshortint : shortint);
varbyte : (vbyte : byte);
varword : (vword : word);
varlongword : (vlongword : dword);
varint64 : (vint64 : int64);
varqword : (vqword : qword);
varword64 : (vword64 : qword);
varstring : (vstring : pointer);
varany : (vany : pointer);
vararray : (varray : pvararray);
varbyref : (vpointer : pointer);
);
1:
(vlongs : array[0..2] of longint);
);
1:(vwords : array[0..6] of word);
2:(vbytes : array[0..13] of byte);
end;
*)
Const
VarTypeStrings : Array [varEmpty..varqword] of string = (
'empty', 'null', 'smallint', 'integer', 'single', 'double',
'currency', 'date', 'olestr', 'dispatch', 'error', 'boolean',
'variant', 'unknown', 'unknown','decimal', 'shortint', 'byte', 'word',
'longword', 'int64', 'qword');
Procedure DumpVariant(Var F : Text; Const VArgSrc : TVarData);
begin
If VArgSrc.vType in [varEmpty..varqword] then
Writeln(F,'Variant has type : ',VarTypeStrings[VArgSrc.vType])
else if (VArgSrc.vType=VarArray) Then
begin
Write(F,'Variant is array.');
exit;
end
else if (VargSrc.vType=VarByRef) then
begin
Writeln(F,'Variant is by reference.');
exit;
end
else
begin
Writeln(F,'Variant has unknown type: ', VargSrc.vType);
Exit;
end;
If VArgSrc.vType<>varEmpty then
With VArgSrc do
begin
Write(F,'Value is: ') ;
Case vtype of
varnull : Write(F,'Null');
varsmallint : Write(F,vsmallint);
varinteger : Write(F,vinteger);
varsingle : Write(F,vsingle);
vardouble : Write(F,vdouble);
varcurrency : Write(F,vcurrency) ;
vardate : Write(F,vdate) ;
varolestr : Write(F,'Not supported') ;
vardispatch : Write(F,'Not suppordted') ;
varerror : Write(F,'Error') ;
varboolean : Write(F,vboolean) ;
varvariant : Write(F,'Unsupported') ;
varunknown : Write(F,'Unsupported') ;
vardecimal : Write(F,'Unsupported') ;
varshortint : Write(F,vshortint) ;
varbyte : Write(F,vbyte) ;
varword : Write(F,vword) ;
varlongword : Write(F,vlongword) ;
varint64 : Write(F,vint64) ;
varqword : Write(F,vqword) ;
end;
Writeln(f);
end;
end;
{$endif HASVARIANT} {$endif HASVARIANT}
{ {
$Log$ $Log$
Revision 1.4 2001-11-15 22:33:14 michael Revision 1.5 2001-11-17 10:29:48 florian
* make cycle for win32 fixed
Revision 1.4 2001/11/15 22:33:14 michael
+ Real/Boolean support added, Start of string support + Real/Boolean support added, Start of string support
Revision 1.3 2001/11/14 23:00:17 michael Revision 1.3 2001/11/14 23:00:17 michael

86
rtl/objpas/varutilh.inc
View File

@ -17,90 +17,14 @@
**********************************************************************} **********************************************************************}
{$ifdef HASVARIANT}
Type Type
EVarianterror = Class(Exception) EVarianterror = Class(Exception)
ErrCode : longint; ErrCode : longint;
Constructor CreateCode(Code : Longint); Constructor CreateCode(Code : Longint);
end; end;
{$ifndef HASVARIANT}
// Types needed to make this work. These should be moved to the system unit.
currency = int64;
HRESULT = Longint;
PSmallInt = ^Smallint;
PLongint = ^Longint;
PSingle = ^Single;
PDouble = ^Double;
PCurrency = ^Currency;
TDateTime = Double;
PDate = ^TDateTime;
PPWideChar = ^PWideChar;
Error = Longint;
PError = ^Error;
PWordBool = ^WordBool;
PByte = ^Byte;
TVarArrayBound = packed record
ElementCount: Longint;
LowBound: Longint;
end;
TVarArrayBoundArray = Array [0..0] of TVarArrayBound;
PVarArrayBoundArray = ^TVarArrayBoundArray;
TVarArrayCoorArray = Array [0..0] of Longint;
PVarArrayCoorArray = ^TVarArrayCoorArray;
PVarArray = ^TVarArray;
TVarArray = packed record
DimCount: Word;
Flags: Word;
ElementSize: Longint;
LockCount: Integer;
Data: Pointer;
Bounds: TVarArrayBoundArray;
end;
TVarType = Word;
PVarData = ^TVarData;
TVarData = packed record
VType: TVarType;
case Integer of
0: (Reserved1: Word;
case Integer of
0: (Reserved2, Reserved3: Word;
case Integer of
varSmallInt: (VSmallInt: SmallInt);
varInteger: (VInteger: Longint);
varSingle: (VSingle: Single);
varDouble: (VDouble: Double);
varCurrency: (VCurrency: Currency);
varDate: (VDate: Double);
varOleStr: (VOleStr: PWideChar);
varDispatch: (VDispatch: Pointer);
varError: (VError: LongWord);
varBoolean: (VBoolean: WordBool);
varUnknown: (VUnknown: Pointer);
varByte: (VByte: Byte);
varString: (VString: Pointer);
varAny: (VAny: Pointer);
varArray: (VArray: PVarArray);
varByRef: (VPointer: Pointer);
);
1: (VLongs: array[0..2] of LongInt);
);
2: (VWords: array [0..6] of Word);
3: (VBytes: array [0..13] of Byte);
end;
Variant = TVarData;
PVariant = ^Variant;
{$endif}
{$ifdef hasvariant}
{ Variant functions } { Variant functions }
function VariantChangeTypeEx(var VargDest: TVarData; const VargSrc: TVarData; LCID: Integer; Flags: Word; VarType: Word): HRESULT; stdcall; function VariantChangeTypeEx(var VargDest: TVarData; const VargSrc: TVarData; LCID: Integer; Flags: Word; VarType: Word): HRESULT; stdcall;
function VariantClear(var Varg: TVarData): HRESULT; stdcall; function VariantClear(var Varg: TVarData): HRESULT; stdcall;
function VariantCopy(var VargDest: TVarData; const VargSrc: TVarData): HRESULT; stdcall; function VariantCopy(var VargDest: TVarData; const VargSrc: TVarData): HRESULT; stdcall;
@ -179,14 +103,16 @@ const
{ {
$Log$ $Log$
Revision 1.4 2001-11-15 22:33:14 michael Revision 1.5 2001-11-17 10:29:48 florian
* make cycle for win32 fixed
Revision 1.4 2001/11/15 22:33:14 michael
+ Real/Boolean support added, Start of string support + Real/Boolean support added, Start of string support
Revision 1.3 2001/11/14 23:00:17 michael Revision 1.3 2001/11/14 23:00:17 michael
+ First working variant support + First working variant support
Revision 1.2 2001/08/19 21:02:02 florian Revision 1.2 2001/08/19 21:02:02 florian
* fixed and added a lot of stuff to get the Jedi DX( headers * fixed and added a lot of stuff to get the Jedi DX8 headers
compiled compiled
} }

118
rtl/objpas/varutils.inc
View File

@ -708,122 +708,13 @@ begin
Result:=psa^.ElementSize; Result:=psa^.ElementSize;
end; end;
{ ---------------------------------------------------------------------
Some debug routines
---------------------------------------------------------------------}
Procedure DumpVariant(Const VArgSrc : TVarData);
begin
DumpVariant(Output,VArgSrc);
end;
(*
tvardata = packed record
vtype : tvartype;
case integer of
0:(res1 : word;
case integer of
0:
(res2,res3 : word;
case word of
varsmallint : (vsmallint : smallint);
varinteger : (vinteger : longint);
varsingle : (vsingle : single);
vardouble : (vdouble : double);
varcurrency : (vcurrency : currency);
vardate : (vdate : tdatetime);
varolestr : (volestr : pwidechar);
vardispatch : (vdispatch : pointer);
varerror : (verror : dword);
varboolean : (vboolean : wordbool);
varunknown : (vunknown : pointer);
// vardecimal : ( : );
varshortint : (vshortint : shortint);
varbyte : (vbyte : byte);
varword : (vword : word);
varlongword : (vlongword : dword);
varint64 : (vint64 : int64);
varqword : (vqword : qword);
varword64 : (vword64 : qword);
varstring : (vstring : pointer);
varany : (vany : pointer);
vararray : (varray : pvararray);
varbyref : (vpointer : pointer);
);
1:
(vlongs : array[0..2] of longint);
);
1:(vwords : array[0..6] of word);
2:(vbytes : array[0..13] of byte);
end;
*)
Const
VarTypeStrings : Array [varEmpty..varqword] of string = (
'empty', 'null', 'smallint', 'integer', 'single', 'double',
'currency', 'date', 'olestr', 'dispatch', 'error', 'boolean',
'variant', 'unknown', 'unknown','decimal', 'shortint', 'byte', 'word',
'longword', 'int64', 'qword');
Procedure DumpVariant(Var F : Text; Const VArgSrc : TVarData);
begin
If VArgSrc.vType in [varEmpty..varqword] then
Writeln(F,'Variant has type : ',VarTypeStrings[VArgSrc.vType])
else if (VArgSrc.vType=VarArray) Then
begin
Write(F,'Variant is array.');
exit;
end
else if (VargSrc.vType=VarByRef) then
begin
Writeln(F,'Variant is by reference.');
exit;
end
else
begin
Writeln(F,'Variant has unknown type: ', VargSrc.vType);
Exit;
end;
If VArgSrc.vType<>varEmpty then
With VArgSrc do
begin
Write(F,'Value is: ') ;
Case vtype of
varnull : Write(F,'Null');
varsmallint : Write(F,vsmallint);
varinteger : Write(F,vinteger);
varsingle : Write(F,vsingle);
vardouble : Write(F,vdouble);
varcurrency : Write(F,vcurrency) ;
vardate : Write(F,vdate) ;
varolestr : Write(F,'Not supported') ;
vardispatch : Write(F,'Not suppordted') ;
varerror : Write(F,'Error') ;
varboolean : Write(F,vboolean) ;
varvariant : Write(F,'Unsupported') ;
varunknown : Write(F,'Unsupported') ;
vardecimal : Write(F,'Unsupported') ;
varshortint : Write(F,vshortint) ;
varbyte : Write(F,vbyte) ;
varword : Write(F,vword) ;
varlongword : Write(F,vlongword) ;
varint64 : Write(F,vint64) ;
varqword : Write(F,vqword) ;
end;
Writeln(f);
end;
end;
{$endif HASVARIANT} {$endif HASVARIANT}
{ {
$Log$ $Log$
Revision 1.6 2001-11-15 22:33:14 michael Revision 1.7 2001-11-17 10:29:48 florian
* make cycle for win32 fixed
Revision 1.6 2001/11/15 22:33:14 michael
+ Real/Boolean support added, Start of string support + Real/Boolean support added, Start of string support
Revision 1.5 2001/11/14 23:00:17 michael Revision 1.5 2001/11/14 23:00:17 michael
@ -832,5 +723,4 @@ end;
Revision 1.4 2001/08/19 21:02:02 florian Revision 1.4 2001/08/19 21:02:02 florian
* fixed and added a lot of stuff to get the Jedi DX( headers * fixed and added a lot of stuff to get the Jedi DX( headers
compiled compiled
} }