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

+ Initial implementation of varutils

Browse Source
This commit is contained in:
michael 2000-08-29 08:23:13 +00:00
parent 558f3cd963
commit 82f4c2d9a3
8 changed files with 1154 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
rtl/linux/Makefile
View File

@ -1,5 +1,5 @@
#
# Makefile generated by fpcmake v1.00 [2000/08/14]
# Makefile generated by fpcmake v1.00 [2000/07/11]
#
defaultrule: all
@ -202,7 +202,7 @@ endif
# Targets
override LOADEROBJECTS+=prt0 cprt0 gprt0 cprt21 gprt21
override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux ports initc dos crt objects printer graph ggigraph sysutils typinfo math cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc serial dl dynlibs
override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings linux ports initc dos crt objects printer graph ggigraph sysutils typinfo math cpu mmx getopts heaptrc lineinfo errors sockets gpm ipc serial dl dynlibs varutils
override RSTOBJECTS+=math
# Clean
@ -230,7 +230,7 @@ endif
LIBNAME=libfprtl.so
LIBVERSION=1.0
SHAREDLIBUNITOBJECTS=$(SYSTEMUNIT) objpas strings linux ports dos crt objects printer sysutils typinfo math cpu mmx getopts heaptrc errors sockets ipc dl dynlibs
SHAREDLIBUNITOBJECTS=$(SYSTEMUNIT) objpas strings linux ports dos crt objects printer sysutils typinfo math cpu mmx getopts heaptrc errors sockets ipc dl dynlibs varutils
# Info
@ -928,7 +928,7 @@ ifdef INSTALLPPUFILES
ifdef PPUFILES
INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
else
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))))
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
endif
endif
@ -1093,7 +1093,7 @@ ifdef CLEANPPUFILES
ifdef PPUFILES
CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
else
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))))
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
endif
endif
@ -1298,6 +1298,9 @@ math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
gettext$(PPUEXT): $(OBJPASDIR)/gettext.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/gettext.pp $(REDIR)
varutils$(PPUEXT) : $(OBJPASDIR)/varutils.pp $(OBJPASDIR)/varutils.inc
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/varutils.pp $(REDIR)
#
# Other system-independent RTL Units
#

7
rtl/linux/Makefile.fpc
View File

@ -9,7 +9,7 @@ units=$(SYSTEMUNIT) objpas strings \
dos crt objects printer graph ggigraph \
sysutils typinfo math \
cpu mmx getopts heaptrc lineinfo \
errors sockets gpm ipc serial dl dynlibs
errors sockets gpm ipc serial dl dynlibs varutils
rst=math
@ -36,7 +36,7 @@ libunits=$(SYSTEMUNIT) objpas strings \
dos crt objects printer \
sysutils typinfo math \
cpu mmx getopts heaptrc \
errors sockets ipc dl dynlibs
errors sockets ipc dl dynlibs varutils
[presettings]
@ -179,6 +179,9 @@ math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
gettext$(PPUEXT): $(OBJPASDIR)/gettext.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/gettext.pp $(REDIR)
varutils$(PPUEXT) : $(OBJPASDIR)/varutils.pp $(OBJPASDIR)/varutils.inc
$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/varutils.pp $(REDIR)
#
# Other system-independent RTL Units
#

1
rtl/objpas/makefile.op
View File

@ -11,4 +11,3 @@ typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp $(REDIR)

724
rtl/objpas/varutils.inc Normal file
View File

@ -0,0 +1,724 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
Variant routines for non-windows oses.
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.
**********************************************************************}
{ ---------------------------------------------------------------------
Some general stuff: Error handling and so on.
---------------------------------------------------------------------}
Resourcestring
SNoWidestrings = 'No widestrings supported';
SNoInterfaces = 'No interfaces supported';
Procedure NoWidestrings;
begin
Raise Exception.Create(SNoWideStrings);
end;
Procedure NoInterfaces;
begin
Raise Exception.Create(SNoInterfaces);
end;
Constructor EVariantError.CreateCode (Code : longint);
begin
ErrCode:=Code;
end;
Procedure VariantTypeMismatch;
begin
Raise EVariantError.CreateCode(VAR_TYPEMISMATCH);
end;
Function ExceptionToVariantError (E : Exception): HResult;
begin
If E is EoutOfMemory then
Result:=VAR_OUTOFMEMORY
else
Result:=VAR_EXCEPTION;
end;
Procedure SetUnlockResult (P : PVarArray; Res : HResult);
begin
If Res=VAR_OK then
Res:=SafeArrayUnlock(P)
else
SafeArrayUnlock(P);
end;
{ ---------------------------------------------------------------------
Basic variant handling.
---------------------------------------------------------------------}
function VariantInit(var Varg: TVarData): HRESULT;stdcall;
begin
With Varg do
begin
VType:=varEmpty;
FillChar(VBytes, SizeOf(VBytes), 0);
end;
Result:=VAR_OK;
end;
function VariantClear(var Varg: TVarData): HRESULT;stdcall;
begin
With Varg do
if (VType and varArray) <> 0 then
Exit(SafeArrayDestroy(VArray))
else
begin
if (VType and varByRef) = 0 then
case VType of
varEmpty, varNull, varSmallint, varInteger, varSingle, varDouble,
varCurrency, varDate, varError, varBoolean, varByte:;
varOleStr:
NoWideStrings;
varDispatch,
varUnknown:
NoInterfaces;
else
exit(VAR_BADVARTYPE)
end;
end;
Result:=VariantInit(Varg);
end;
function VariantCopy(var VargDest: TVarData; const VargSrc: TVarData): HRESULT;stdcall;
begin
if @VargSrc = @VargDest then
Exit(VAR_OK);
Result:=VariantClear(VargDest);
if Result<>VAR_OK then
exit;
With VargSrc do
begin
if (VType and varArray) <> 0 then
Result:=SafeArrayCopy(VArray,VargDest.VArray)
else
begin
if (VType and varByRef) <> 0 then
VArgDest.VPointer:=VPointer
else
case (VType and varTypeMask) of
varEmpty, varNull:;
varSmallint, varInteger, varSingle, varDouble, varCurrency,
varDate, varError, varBoolean, varByte:
Move(VBytes, VargDest.VBytes, SizeOf(VargDest.VBytes));
varOleStr:
NoWideStrings; // We should copy here...
varDispatch,
varUnknown:
NoInterfaces; // We should bump up reference count here (Addref)
else
Exit(VAR_BADVARTYPE);
end;
end;
VargDest.VType:=VType;
end;
end;
function VariantCopyInd(var VargDest: TVarData; const VargSrc: TVarData): HRESULT;stdcall;
begin
if (VargSrc.VType and varByRef) = 0 then
Exit(VariantCopy(VargDest, VargSrc));
With VargSrc do
begin
if (VType and varArray) <> 0 then
Exit(VAR_INVALIDARG);
case (VType and varTypeMask) of
varEmpty, varNull:;
varSmallint : VargDest.VSmallInt:=PSmallInt(VPointer)^;
varInteger : VargDest.VInteger:=PLongint(VPointer)^;
varSingle : VargDest.VSingle:=PSingle(VPointer)^;
varDouble : VargDest.VDouble:=PDouble(VPointer)^;
varCurrency : VargDest.VCurrency:=PCurrency(VPointer)^;
varDate : VargDest.VDate:=PDate(VPointer)^;
varBoolean : VargDest.VBoolean:=PWordBool(VPointer)^;
varError : VargDest.VError:=PError(VPointer)^;
varByte : VargDest.VByte:=PByte(VPointer)^;
varVariant : // Variant(VargDest):=PVariant(VPointer)^
;
varOleStr : NoWideStrings;
varDispatch,
varUnknown : NoInterfaces;
else
Exit(VAR_BADVARTYPE);
end;
VargDest.VType:=VType and VarTypeMask;
end;
Result:=VAR_OK;
end;
Function VariantChangeTypeEx(var VargDest: TVarData; const VargSrc: TVarData;
LCID: Integer; Flags: Word; VarType: Word): HRESULT; stdcall;
var
Tmp : TVarData;
begin
if ((VarType and varArray) <> 0) or
((VargSrc.VType and varArray) <> 0) or
((VarType and varByRef) <> 0) then
Exit(VAR_INVALIDARG);
Result:=VariantCopyInd(Tmp, VargSrc);
if Result = VAR_OK then
try
Result:=VariantClear(VargDest);
{$RANGECHECKS ON}
if Result = VAR_OK then
try
case Vartype of
varSmallInt : VargDest.VSmallInt:=VariantToSmallInt(Tmp);
varInteger : VargDest.VInteger:=VariantToLongint(Tmp);
varSingle : VargDest.VSingle:=VariantToSingle(Tmp);
varDouble : VargDest.VDouble:=VariantToDouble(Tmp);
varCurrency : VargDest.VCurrency:=VariantToCurrency(Tmp);
varDate : VargDest.VDate:=VariantToDate(tmp);
varOleStr : NoWidestrings;
varDispatch : Result:=VAR_TYPEMISMATCH;
varUnknown : Result:=VAR_TYPEMISMATCH;
varBoolean : VargDest.VBoolean:=VariantToBoolean(Tmp);
varByte : VargDest.VByte:=VariantToByte(Tmp);
else
Result:=VAR_BADVARTYPE;
end;
If Result = VAR_OK then
VargDest.VType:=VarType;
except
On E : EVariantError do
Result:=E.ErrCode;
else
Result:=VAR_INVALIDARG;
end;
finally
VariantClear(Tmp);
end;
end;
{ ---------------------------------------------------------------------
Variant array support
---------------------------------------------------------------------}
Function CheckArrayUnlocked (psa : PVarArray) : HResult;
begin
If psa^.LockCount = 0 Then
Result:=VAR_OK
else
Result:=VAR_ARRAYISLOCKED;
end;
Function CheckVarArray(psa: PVarArray ): HRESULT;
begin
If psa=nil then
Result:=VAR_INVALIDARG
else
Result:=VAR_OK;
end;
Function SafeArrayCalculateElementAddress(psa: PVarArray; aElement: Integer): Pointer;
begin
Result:=Pointer(Integer(psa^.Data)+(aElement*psa^.ElementSize));
end;
Function CheckVarArrayAndCalculateAddress(psa: PVarArray;
Indices: PVarArrayCoorArray; var Address: Pointer; Lockit: Boolean): HRESULT;
Function CountElements(D: Longint): Longint;
begin
if (D<psa^.DimCount) then
Result:=CountElements(D+1)+psa^.Bounds[D-1].ElementCount
else
Result:=1;
end;
var
LB,HB,I,Count : LongInt;
begin
Result:=CheckVarArray(psa);
Address:=nil;
Count:=0;
If Result<>VAR_OK then
exit;
for I:=1 to psa^.DimCount do
begin
LB:=psa^.Bounds[I-1].LowBound;
HB:=LB+psa^.Bounds[I-1].ElementCount;
if (LB=HB) or ((Indices^[I-1]< LB) or(Indices^[I-1]>HB)) then
Exit(VAR_BADINDEX);
Count:=Count+(Indices^[I-1]-LB)*CountElements(I+1);
end;
Address:=SafeArrayCalculateElementAddress(psa, Count);
if LockIt then
Result:=SafeArrayLock(psa);
end;
Function SafeArrayElementTotal(psa: PVarArray): Integer;
var
I: Integer;
begin
Result:=1;
With psa^ do
for I:=0 to DimCount - 1 do
Result:=Result*Bounds[I].ElementCount;
end;
type
TVariantArrayType = (vatNormal, varInterface, varWideString);
Function VariantArrayType(psa: PVarArray): TVariantArrayType;
begin
if ((psa^.Flags and ARR_DISPATCH) <> 0) or
((psa^.Flags and ARR_UNKNOWN) <> 0) then
Result:=varInterface
else if (psa^.Flags AND ARR_OLESTR) <> 0 then
Result:=varWideString
else
Result:=vatNormal;
end;
Function SafeArrayClearDataSpace(psa: PVarArray; WipeBytes: Boolean {= True}): HRESULT;
var
I : Integer;
vat: TVariantArrayType;
begin
try
vat:=VariantArrayType(psa);
case vat of
vatNormal : FillChar(psa^.Data^,
SafeArrayElementTotal(psa)*psa^.ElementSize,
0);
varInterface : NoInterfaces;
varWideString : NoWidestrings;
end;
Result:=VAR_OK;
except
On E : Exception do
Result:=ExceptionToVariantError (E);
end;
end;
Function SafeArrayCopyDataSpace(psa, psaOut: PVarArray): HRESULT;
var
I : Integer;
vVargSrc, vTarget: Pointer;
vat: TVariantArrayType;
begin
try
vat:=VariantArrayType(psa);
case vat of
vatNormal: Move(psa^.Data^,
psaOut^.Data^,
SafeArrayElementTotal(psa)*psa^.ElementSize);
varInterface : NoInterfaces; // Copy element per element...
varWideString: NoWideStrings; // here also...
end;
Result:=VAR_OK;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
end;
Type
TVartypes = varEmpty..varByte;
Const
Supportedpsas : set of TVarTypes =
[varSmallint,varInteger,varSingle,varDouble,varCurrency,varDate,varOleStr,
varDispatch,varError,varBoolean,varVariant,varUnknown,varByte];
psaElementSizes : Array [varEmpty..varByte] of Byte =
(0,0,2,4,4,8,8,8,4,4,4,2,16,4,0,0,0,1);
psaElementFlags : Array [varEmpty..varByte] of Longint =
(ARR_NONE,ARR_NONE,ARR_NONE,ARR_NONE,ARR_NONE,ARR_NONE,ARR_NONE,ARR_NONE,
ARR_OLESTR,ARR_DISPATCH,ARR_NONE,ARR_NONE,ARR_NONE,ARR_UNKNOWN,
ARR_NONE,ARR_NONE,ARR_NONE,ARR_NONE);
Function SafeArrayCreate(VarType, Dims: Integer; const Bounds: TVarArrayBoundArray): PVarArray;stdcall;
var
res : HRESULT;
I : Longint;
begin
Result:=nil;
if Not (VarType in Supportedpsas) Then
exit;
Res:=SafeArrayAllocDescriptor(Dims, Result);
if Res<>VAR_OK then
exit;
With Result^ do
begin
DimCount:=Dims;
Flags:=psaElementFlags[VarType];
ElementSize:=psaElementSizes[VarType];
for i:=0 to Dims-1 do
begin
Bounds[i].LowBound:=Bounds[Dims-I-1].LowBound;
Bounds[I].ElementCount:=Bounds[Dims-I-1].ElementCount;
end;
end;
res:=SafeArrayAllocData(Result);
if res<>VAR_OK then
begin
SafeArrayDestroyDescriptor(Result);
Result:=nil;
end;
end;
Function SafeArrayAllocDescriptor(DimCount: Integer; var psa: PVarArray): HRESULT;stdcall;
begin
try
psa:=GetMem(SizeOf(TVarArray) + SizeOf(TVarArrayBound) * (DimCount - 1));
Result:=VAR_OK;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
end;
Function SafeArrayAllocData(psa: PVarArray): HRESULT;stdcall;
begin
try
With psa^ do
Data:=GetMem(SafeArrayElementTotal(psa)*ElementSize);
Result:=VAR_OK;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
end;
Function SafeArrayDestroy(psa: PVarArray): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if Result<> VAR_OK then
exit;
Result:=CheckArrayUnlocked(psa);
if Result<> VAR_OK then
exit;
Result:=SafeArrayDestroyData(psa);
if Result<>VAR_OK then
exit;
Result:=SafeArrayDestroyDescriptor(psa);
end;
Function SafeArrayDestroyDescriptor(psa: PVarArray): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
Result:=CheckArrayUnlocked(psa);
if Result<> VAR_OK then
exit;
try
FreeMem(psa);
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
end;
Function SafeArrayDestroyData(psa: PVarArray): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
Result:=CheckArrayUnlocked(psa);
if Result<> VAR_OK then
exit;
try
Result:=SafeArrayClearDataSpace(psa, False);
if (Result=VAR_OK) and ((psa^.Flags and ARR_FIXEDSIZE)=0) then
begin
FreeMem(psa^.Data);
psa^.Data:=nil;
end;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
end;
Function SafeArrayRedim(psa: PVarArray; const NewBound: TVarArrayBound): HRESULT;stdcall;
var
vat: TVariantArrayType;
i, D,j,count : Integer;
P : Pointer;
begin
Result:=CheckVarArray(psa);
if Result <> VAR_OK then
exit;
if (psa^.Flags and ARR_FIXEDSIZE) <> 0 then
Exit(VAR_INVALIDARG);
Result:=SafeArrayLock(psa);
if Result<>VAR_OK then
exit;
try
D:=NewBound.ElementCount - psa^.Bounds[0].ElementCount;
for i:=1 to psa^.DimCount - 1 do
D:=D*psa^.Bounds[i].ElementCount;
if D<>0 then
begin
Count:=SafeArrayElementTotal(psa);
if D<0 then
begin
vat:=VariantArrayType(psa);
for j:=Count-1 downto Count+D do
begin
P:=SafeArrayCalculateElementAddress(psa,j);
if vat = varInterface then
NoInterfaces // Set to nil
else
NoWideStrings; // Set to empty...
end;
end;
ReAllocMem(psa^.Data,Count+D);
end;
psa^.Bounds[0].ElementCount:=NewBound.ElementCount;
psa^.Bounds[0].LowBound:=NewBound.LowBound;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
SetUnlockResult(psa,Result);
end;
Function SafeArrayCopy(psa: PVarArray; var psaOut: PVarArray): HRESULT;stdcall;
var
i : Integer;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
Result:=SafeArrayLock(psa);
if Result<>VAR_OK then
exit;
try
Result:=SafeArrayAllocDescriptor(psa^.DimCount,psaOut);
if Result<>VAR_OK then
Exit;
try
With psaOut^ do
begin
Flags:=psa^.Flags;
ElementSize:=psa^.ElementSize;
DimCount:=psa^.DimCount;
for i:=0 to DimCount-1 do
begin
Bounds[i].ElementCount:=psa^.Bounds[i].ElementCount;
Bounds[i].LowBound:=psa^.Bounds[i].LowBound;
end;
end;
Result:=SafeArrayAllocData(psaOut);
if Result<>VAR_OK then
exit;
Result:=SafeArrayCopyDataSpace(psa, psaOut);
finally
if Result<>VAR_OK then
begin
SafeArrayDestroyDescriptor(psaOut);
psaOut:=nil;
end;
end;
except
On E : Exception do
Result:=ExceptionToVariantError(E)
end;
SetUnlockResult(psa,Result);
end;
Function SafeArrayCopyData(psa, psaOut: PVarArray): HRESULT;stdcall;
var
i : Integer;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
Result:=CheckVarArray(psaOut);
if Result<>VAR_OK then
exit;
Result:=SafeArrayLock(psaOut);
if Result<>VAR_OK then
exit;
try
Result:=SafeArrayLock(psa);
if Result<>VAR_OK then
exit;
try
With psaOut^ do
begin
if (psa^.Flags<>Flags) or
(psa^.ElementSize<>ElementSize) or
(psa^.DimCount<>DimCount) then
Exit(VAR_INVALIDARG);
for i:=0 to psa^.DimCount - 1 do
if (psa^.Bounds[i].LowBound<>Bounds[i].LowBound) or
(psa^.Bounds[i].ElementCount<>Bounds[i].ElementCount) then
exit(VAR_INVALIDARG);
end;
Result:=SafeArrayClearDataSpace(psaOut,True);
if Result<> VAR_OK then
exit;
Result:=SafeArrayCopyDataSpace(psa, psaOut);
finally
SetUnlockResult(psa,Result);
end;
finally
SetUnlockResult(psaOut,Result);
end;
end;
Function SafeArrayGetLBound(psa: PVarArray; Dim: Integer; var LBound: Integer): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
if (Dim>0) and (Dim<=psa^.DimCount) then
LBound:=psa^.Bounds[Dim-1].LowBound
else
Result:=VAR_BADINDEX;
end;
Function SafeArrayGetUBound(psa: PVarArray; Dim: Integer; var UBound: Integer): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
if (Dim>0) and (Dim<=psa^.DimCount) then
UBound:=psa^.Bounds[Dim-1].LowBound +
psa^.Bounds[Dim-1].ElementCount-1
else
Result:=VAR_BADINDEX
end;
Function SafeArrayGetDim(psa: PVarArray): Integer;stdcall;
begin
if CheckVarArray(psa)<>VAR_OK then
Result:=0
else
Result:=psa^.DimCount;
end;
Function SafeArrayAccessData(psa: PVarArray; var ppvData: Pointer): HRESULT;stdcall;
begin
Result:=SafeArrayLock(psa);
if Result<>VAR_OK then
ppvData:=nil
else
ppvData:=psa^.Data;
end;
Function SafeArrayUnaccessData(psa: PVarArray): HRESULT;stdcall;
begin
Result:=SafeArrayUnlock(psa);
end;
Function SafeArrayLock(psa: PVarArray): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if Result<>VAR_OK then
exit;
Inc(psa^.LockCount);
end;
Function SafeArrayUnlock(psa: PVarArray): HRESULT;stdcall;
begin
Result:=CheckVarArray(psa);
if (Result<>VAR_OK) then
exit;
If (psa^.LockCount>0) then
Dec(psa^.LockCount);
end;
Function SafeArrayGetElement(psa: PVarArray; Indices: PVarArrayCoorArray;
Data: Pointer): HRESULT;stdcall;
var
P: Pointer;
begin
Result:=CheckVarArrayAndCalculateAddress(psa, Indices, P, True);
if Result<>VAR_OK then
exit;
try
case VariantArrayType(psa) of
vatNormal:
Move(P^, Data^, psa^.ElementSize);
varInterface:
NoInterfaces; // Just assign...
varWideString:
NoWideStrings; // Just assign...
end;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
SetUnlockResult(psa,Result);
end;
Function SafeArrayPutElement(psa: PVarArray; Indices: PVarArrayCoorArray;
const Data: Pointer): HRESULT;stdcall;
var
P: Pointer;
begin
Result:=CheckVarArrayAndCalculateAddress(psa,Indices,P,True);
if Result<>VAR_OK then
exit;
try
case VariantArrayType(psa) of
vatNormal: Move(Data^,P^,psa^.ElementSize);
varInterface: NoInterfaces;
varWideString: NoWideStrings;
end;
except
On E : Exception do
Result:=ExceptionToVariantError(E);
end;
SetUnlockResult(psa,Result);
end;
Function SafeArrayPtrOfIndex(psa: PVarArray; Indices: PVarArrayCoorArray;
var Address: Pointer): HRESULT;stdcall;
begin
Result:=CheckVarArrayAndCalculateAddress(psa,Indices,Address,False);
end;
Function SafeArrayGetElemSize(psa: PVarArray): LongWord;stdcall;
begin
if CheckVarArray(psa)<>VAR_OK then
Result:=0
else
Result:=psa^.ElementSize;
end;

347
rtl/objpas/varutils.pp Normal file
View File

@ -0,0 +1,347 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
Interface and OS-independent part of variant support
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.
**********************************************************************}
{$MODE ObjFPC}
Unit varutils;
Interface
Uses sysutils;
Type
// 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;
EVarianterror = Class(Exception)
ErrCode : longint;
Constructor CreateCode(Code : Longint);
end;
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;
{ Variant functions }
function VariantChangeTypeEx(var VargDest: TVarData; const VargSrc: TVarData; LCID: Integer; Flags: Word; VarType: Word): HRESULT; stdcall;
function VariantClear(var Varg: TVarData): HRESULT; stdcall;
function VariantCopy(var VargDest: TVarData; const VargSrc: TVarData): HRESULT; stdcall;
function VariantCopyInd(var VargDest: TVarData; const VargSrc: TVarData): HRESULT; stdcall;
function VariantInit(var Varg: TVarData): HRESULT; stdcall;
{ Variant array functions }
function SafeArrayAccessData(psa: PVarArray; var ppvdata: Pointer): HRESULT; stdcall;
function SafeArrayAllocData(psa: PVarArray): HRESULT; stdcall;
function SafeArrayAllocDescriptor(DimCount: Integer; var psa: PVarArray): HRESULT; stdcall;
function SafeArrayCopy(psa: PVarArray; var psaout: PVarArray): HRESULT; stdcall;
function SafeArrayCopyData(psa, psaOut: PVarArray): HRESULT; stdcall;
function SafeArrayCreate(VarType, Dim: Integer; const Bounds: TVarArrayBoundArray): PVarArray; stdcall;
function SafeArrayDestroy(psa: PVarArray): HRESULT; stdcall;
function SafeArrayDestroyData(psa: PVarArray): HRESULT; stdcall;
function SafeArrayDestroyDescriptor(psa: PVarArray): HRESULT; stdcall;
function SafeArrayGetDim(psa: PVarArray): Integer; stdcall;
function SafeArrayGetElemSize(psa: PVarArray): LongWord; stdcall;
function SafeArrayGetElement(psa: PVarArray; Indices: PVarArrayCoorArray; Data: Pointer): HRESULT; stdcall;
function SafeArrayGetLBound(psa: PVarArray; Dim: Integer; var LBound: Integer): HRESULT; stdcall;
function SafeArrayGetUBound(psa: PVarArray; Dim: Integer; var UBound: Integer): HRESULT; stdcall;
function SafeArrayLock(psa: PVarArray): HRESULT; stdcall;
function SafeArrayPtrOfIndex(psa: PVarArray; Indices: PVarArrayCoorArray; var Address: Pointer): HRESULT; stdcall;
function SafeArrayPutElement(psa: PVarArray; Indices: PVarArrayCoorArray; const Data: Pointer): HRESULT; stdcall;
function SafeArrayRedim(psa: PVarArray; const NewBound: TVarArrayBound): HRESULT; stdcall;
function SafeArrayUnaccessData(psa: PVarArray): HRESULT; stdcall;
function SafeArrayUnlock(psa: PVarArray): HRESULT; stdcall;
{ Conversion routines NOT in windows oleaut }
Function VariantToSmallInt(Const VargSrc : TVarData) : SmallInt;
Function VariantToLongint(Const VargSrc : TVarData) : Longint;
Function VariantToSingle(Const VargSrc : TVarData) : Single;
Function VariantToDouble(Const VargSrc : TVarData) : Double;
Function VariantToCurrency(Const VargSrc : TVarData) : Currency;
Function VariantToDate(Const VargSrc : TVarData) : TDateTime;
Function VariantToBoolean(Const VargSrc : TVarData) : Boolean;
Function VariantToByte(Const VargSrc : TVarData) : Byte;
// Names match the ones in Borland varutils unit.
const
VAR_OK = HRESULT($00000000);
VAR_TYPEMISMATCH = HRESULT($80020005);
VAR_BADVARTYPE = HRESULT($80020008);
VAR_EXCEPTION = HRESULT($80020009);
VAR_OVERFLOW = HRESULT($8002000A);
VAR_BADINDEX = HRESULT($8002000B);
VAR_ARRAYISLOCKED = HRESULT($8002000D);
VAR_NOTIMPL = HRESULT($80004001);
VAR_OUTOFMEMORY = HRESULT($8007000E);
VAR_INVALIDARG = HRESULT($80070057);
VAR_UNEXPECTED = HRESULT($8000FFFF);
ARR_NONE = $0000;
ARR_FIXEDSIZE = $0010;
ARR_OLESTR = $0100;
ARR_UNKNOWN = $0200;
ARR_DISPATCH = $0400;
ARR_VARIANT = $0800;
Implementation
{$i varutils.inc}
{ ---------------------------------------------------------------------
OS-independent functions not present in Windows
---------------------------------------------------------------------}
Function VariantToSmallInt(Const VargSrc : TVarData) : SmallInt;
begin
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt;
VarInteger : Result:=VInteger;
VarSingle : Result:=Round(VSingle);
VarDouble : Result:=Round(VDouble);
VarCurrency: Result:=Round(VCurrency);
VarDate : Result:=Round(VDate);
VarOleStr : NoWideStrings;
VarBoolean : Result:=SmallInt(VBoolean);
VarByte : Result:=VByte;
else
VariantTypeMismatch;
end;
end;
Function VariantToLongint(Const VargSrc : TVarData) : Longint;
begin
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt;
VarInteger : Result:=VInteger;
VarSingle : Result:=Round(VSingle);
VarDouble : Result:=Round(VDouble);
VarCurrency: Result:=Round(VCurrency);
VarDate : Result:=Round(VDate);
VarOleStr : NoWideStrings;
VarBoolean : Result:=Longint(VBoolean);
VarByte : Result:=VByte;
else
VariantTypeMismatch;
end;
end;
Function VariantToSingle(Const VargSrc : TVarData) : Single;
begin
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt;
VarInteger : Result:=VInteger;
VarSingle : Result:=VSingle;
VarDouble : Result:=VDouble;
VarCurrency: Result:=VCurrency;
VarDate : Result:=VDate;
VarOleStr : NoWideStrings;
VarBoolean : Result:=Longint(VBoolean);
VarByte : Result:=VByte;
else
VariantTypeMismatch;
end;
end;
Function VariantToDouble(Const VargSrc : TVarData) : Double;
begin
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt;
VarInteger : Result:=VInteger;
VarSingle : Result:=VSingle;
VarDouble : Result:=VDouble;
VarCurrency: Result:=VCurrency;
VarDate : Result:=VDate;
VarOleStr : NoWideStrings;
VarBoolean : Result:=Longint(VBoolean);
VarByte : Result:=VByte;
else
VariantTypeMismatch;
end;
end;
Function VariantToCurrency(Const VargSrc : TVarData) : Currency;
begin
Try
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt;
VarInteger : Result:=VInteger;
VarSingle : Result:=FloatToCurr(VSingle);
VarDouble : Result:=FloatToCurr(VDouble);
VarCurrency: Result:=VCurrency;
VarDate : Result:=FloatToCurr(VDate);
VarOleStr : NoWideStrings;
VarBoolean : Result:=Longint(VBoolean);
VarByte : Result:=VByte;
else
VariantTypeMismatch;
end;
except
On EConvertError do
VariantTypeMismatch;
else
Raise;
end;
end;
Function VariantToDate(Const VargSrc : TVarData) : TDateTime;
begin
Try
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=FloatToDateTime(VSmallInt);
VarInteger : Result:=FloatToDateTime(VInteger);
VarSingle : Result:=FloatToDateTime(VSingle);
VarDouble : Result:=FloatToDateTime(VDouble);
VarCurrency: Result:=FloatToDateTime(VCurrency);
VarDate : Result:=VDate;
VarOleStr : NoWideStrings;
VarBoolean : Result:=FloatToDateTime(Longint(VBoolean));
VarByte : Result:=FloatToDateTime(VByte);
else
VariantTypeMismatch;
end;
except
On EConvertError do
VariantTypeMismatch;
else
Raise;
end;
end;
Function VariantToBoolean(Const VargSrc : TVarData) : Boolean;
begin
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt<>0;
VarInteger : Result:=VInteger<>0;
VarSingle : Result:=VSingle<>0;
VarDouble : Result:=VDouble<>0;
VarCurrency: Result:=VCurrency<>0;
VarDate : Result:=VDate<>0;
VarOleStr : NoWideStrings;
VarBoolean : Result:=VBoolean;
VarByte : Result:=VByte<>0;
else
VariantTypeMismatch;
end;
end;
Function VariantToByte(Const VargSrc : TVarData) : Byte;
begin
Try
With VargSrc do
Case (VType and VarTypeMask) of
VarSmallInt: Result:=VSmallInt;
VarInteger : Result:=VInteger;
VarSingle : Result:=Round(VSingle);
VarDouble : Result:=Round(VDouble);
VarCurrency: Result:=Round(VCurrency);
VarDate : Result:=Round(VDate);
VarOleStr : NoWideStrings;
VarBoolean : Result:=Longint(VBoolean);
VarByte : Result:=VByte;
else
VariantTypeMismatch;
end;
except
On EConvertError do
VariantTypeMismatch;
else
Raise;
end;
end;
end.

11
rtl/win32/Makefile
View File

@ -1,5 +1,5 @@
#
# Makefile generated by fpcmake v1.00 [2000/08/14]
# Makefile generated by fpcmake v1.00 [2000/07/11]
#
defaultrule: all
@ -198,7 +198,7 @@ endif
# Targets
override LOADEROBJECTS+=wprt0 wdllprt0
override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings windows ole2 opengl32 os_types winsock initc dos crt objects graph sysutils typinfo math cpu mmx getopts heaptrc lineinfo wincrt winmouse sockets printer dynlibs
override UNITOBJECTS+=$(SYSTEMUNIT) objpas strings windows ole2 opengl32 os_types winsock initc dos crt objects graph sysutils typinfo math cpu mmx getopts heaptrc lineinfo wincrt winmouse sockets printer dynlibs varutils
override RSTOBJECTS+=math
# Clean
@ -921,7 +921,7 @@ ifdef INSTALLPPUFILES
ifdef PPUFILES
INSTALLPPULINKFILES:=$(shell $(PPUFILES) -S -O $(INSTALLPPUFILES))
else
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(INSTALLPPUFILES))))
INSTALLPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(INSTALLPPUFILES)))
endif
endif
@ -1086,7 +1086,7 @@ ifdef CLEANPPUFILES
ifdef PPUFILES
CLEANPPULINKFILES:=$(shell $(PPUFILES) $(CLEANPPUFILES))
else
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)) $(addprefix $(LIBPREFIX),$(subst $(PPUEXT),$(STATICLIBEXT),$(CLEANPPUFILES))))
CLEANPPULINKFILES:=$(wildcard $(subst $(PPUEXT),$(OEXT),$(CLEANPPUFILES)))
endif
endif
@ -1286,6 +1286,9 @@ typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp $(REDIR)
varutils$(PPUEXT) : $(OBJPASDIR)/varutils.pp varutils.inc
$(COMPILER) -I. -I$(OBJPASDIR) $(OBJPASDIR)/varutils.pp $(REDIR)
#
# Other system-independent RTL Units
#

5
rtl/win32/Makefile.fpc
View File

@ -9,7 +9,7 @@ units=$(SYSTEMUNIT) objpas strings \
dos crt objects graph \
sysutils typinfo math \
cpu mmx getopts heaptrc lineinfo \
wincrt winmouse sockets printer dynlibs
wincrt winmouse sockets printer dynlibs varutils
rst=math
@ -160,6 +160,9 @@ typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
$(COMPILER) $(OBJPASDIR)/math.pp $(REDIR)
varutils$(PPUEXT) : $(OBJPASDIR)/varutils.pp varutils.inc
$(COMPILER) -I. -I$(OBJPASDIR) $(OBJPASDIR)/varutils.pp $(REDIR)
#
# Other system-independent RTL Units
#

59
rtl/win32/varutils.inc Normal file
View File

@ -0,0 +1,59 @@
{
$Id$
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team
Windows import statements for variant support.
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.
**********************************************************************}
{ ---------------------------------------------------------------------
Windows external definitions.
---------------------------------------------------------------------}
const
oleaut = 'oleaut32.dll';
{ Variant functions }
function VariantChangeTypeEx(var VargDest: TVarData; const VargSrc: TVarData; LCID: Integer; Flags: Word; VarType: Word): HRESULT; stdcall;external oleaut;
function VariantClear(var Varg: TVarData): HRESULT; stdcall;external oleaut;
function VariantCopy(var VargDest: TVarData; const VargSrc: TVarData): HRESULT; stdcall;external oleaut;
function VariantCopyInd(var VargDest: TVarData; const VargSrc: TVarData): HRESULT; stdcall;external oleaut;
function VariantInit(var Varg: TVarData): HRESULT; stdcall;external oleaut;
{ Variant array functions }
function SafeArrayAccessData(psa: PVarArray; var Data: Pointer): HRESULT; stdcall;external oleaut;
function SafeArrayAllocData(psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayAllocDescriptor(DimCount: Integer; var psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayCopy(psa: PVarArray; var psaOut: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayCopyData(psa, psaOut: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayCreate(VarType, Dim: Integer; const Bounds: TVarArrayBoundArray): PVarArray; stdcall;external oleaut;
function SafeArrayDestroy(psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayDestroyData(psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayDestroyDescriptor(psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayGetDim(psa: PVarArray): Integer; stdcall;external oleaut;
function SafeArrayGetElemSize(psa: PVarArray): LongWord; stdcall;external oleaut;
function SafeArrayGetElement(psa: PVarArray; Indices: PVarArrayCoorArray; Data: Pointer): HRESULT; stdcall;external oleaut;
function SafeArrayGetLBound(psa: PVarArray; Dim: Integer; var LBound: Integer): HRESULT; stdcall;external oleaut;
function SafeArrayGetUBound(psa: PVarArray; Dim: Integer; var UBound: Integer): HRESULT; stdcall;external oleaut;
function SafeArrayLock(psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayPtrOfIndex(psa: PVarArray; Indices: PVarArrayCoorArray; var Address: Pointer): HRESULT; stdcall;external oleaut;
function SafeArrayPutElement(psa: PVarArray; Indices: PVarArrayCoorArray; const Data: Pointer): HRESULT; stdcall;external oleaut;
function SafeArrayRedim(psa: PVarArray; const NewBound: TVarArrayBound): HRESULT; stdcall;external oleaut;
function SafeArrayUnaccessData(psa: PVarArray): HRESULT; stdcall;external oleaut;
function SafeArrayUnlock(psa: PVarArray): HRESULT; stdcall;external oleaut;
{
$Log$
Revision 1.1 2000-08-29 08:23:14 michael
+ Initial implementation of varutils
}