mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-08-14 02:59:33 +02:00
* Implicitly use Variants unit when (ole)Variant type appears as a function/operator result and nowhere else. Mantis #24863.
git-svn-id: trunk@25261 -
This commit is contained in:
parent
92811d09c1
commit
c558991d8f
1
.gitattributes
vendored
1
.gitattributes
vendored
@ -13476,6 +13476,7 @@ tests/webtbs/tw2480.pp svneol=native#text/plain
|
|||||||
tests/webtbs/tw2481.pp svneol=native#text/plain
|
tests/webtbs/tw2481.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2483.pp svneol=native#text/plain
|
tests/webtbs/tw2483.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw24848.pp svneol=native#text/pascal
|
tests/webtbs/tw24848.pp svneol=native#text/pascal
|
||||||
|
tests/webtbs/tw24863.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2492.pp svneol=native#text/plain
|
tests/webtbs/tw2492.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2494.pp svneol=native#text/plain
|
tests/webtbs/tw2494.pp svneol=native#text/plain
|
||||||
tests/webtbs/tw2503.pp svneol=native#text/plain
|
tests/webtbs/tw2503.pp svneol=native#text/plain
|
||||||
|
@ -103,7 +103,7 @@ implementation
|
|||||||
{ parameter handling }
|
{ parameter handling }
|
||||||
paramgr,cpupara,
|
paramgr,cpupara,
|
||||||
{ pass 1 }
|
{ pass 1 }
|
||||||
fmodule,node,htypechk,ncon,
|
fmodule,node,htypechk,ncon,ppu,
|
||||||
objcutil,
|
objcutil,
|
||||||
{ parser }
|
{ parser }
|
||||||
scanner,
|
scanner,
|
||||||
@ -1078,6 +1078,10 @@ implementation
|
|||||||
end;
|
end;
|
||||||
single_type(pd.returndef,[stoAllowSpecialization]);
|
single_type(pd.returndef,[stoAllowSpecialization]);
|
||||||
|
|
||||||
|
if ((pd.returndef=cvarianttype) or (pd.returndef=colevarianttype)) and
|
||||||
|
not(cs_compilesystem in current_settings.moduleswitches) then
|
||||||
|
current_module.flags:=current_module.flags or uf_uses_variants;
|
||||||
|
|
||||||
if is_dispinterface(pd.struct) and not is_automatable(pd.returndef) then
|
if is_dispinterface(pd.struct) and not is_automatable(pd.returndef) then
|
||||||
Message1(type_e_not_automatable,pd.returndef.typename);
|
Message1(type_e_not_automatable,pd.returndef.typename);
|
||||||
|
|
||||||
|
60
tests/webtbs/tw24863.pp
Normal file
60
tests/webtbs/tw24863.pp
Normal file
@ -0,0 +1,60 @@
|
|||||||
|
program test2;
|
||||||
|
|
||||||
|
{$mode objfpc}{$H+}
|
||||||
|
|
||||||
|
// This demo program abuses FPC's custom operator facility to simulate
|
||||||
|
// Vector Pascal's \+ (reduce-add) operator, which is derived from APL's
|
||||||
|
// +/ function/operator.
|
||||||
|
//
|
||||||
|
// If the dummy record type (TReduce) is empty, there will be a runtime error
|
||||||
|
// when the operator result is assigned. This can be fixed either by
|
||||||
|
// explicitly importing the Variants unit, or by changing the operator
|
||||||
|
// function to return an integer.
|
||||||
|
|
||||||
|
type t1= array of integer;
|
||||||
|
TReduce= record
|
||||||
|
// x: variant
|
||||||
|
end;
|
||||||
|
|
||||||
|
var a1: t1;
|
||||||
|
reduce: TReduce = ();
|
||||||
|
|
||||||
|
|
||||||
|
procedure print(const a: t1);
|
||||||
|
|
||||||
|
var i: integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
for i := Low(a) to High(a) do
|
||||||
|
Write(a[i], ' ');
|
||||||
|
WriteLn
|
||||||
|
end { print } ;
|
||||||
|
|
||||||
|
|
||||||
|
operator + (const r: TReduce; const a: t1): variant;
|
||||||
|
|
||||||
|
var i: integer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
result := 0;
|
||||||
|
for i := Low(a) to High(a) do
|
||||||
|
result += a[i]
|
||||||
|
end { + } ;
|
||||||
|
|
||||||
|
|
||||||
|
begin
|
||||||
|
// a1 := t1.create(1,2,3,4,5); Requires trunk
|
||||||
|
// a1 := t1([1,2,3,4,5]); Doesn't work without tuple support
|
||||||
|
SetLength(a1, 5);
|
||||||
|
a1[0] := 1;
|
||||||
|
a1[1] := 2;
|
||||||
|
a1[2] := 3;
|
||||||
|
a1[3] := 4;
|
||||||
|
a1[4] := 5;
|
||||||
|
WriteLn('a1:');
|
||||||
|
print(a1);
|
||||||
|
WriteLn('+/ a1:');
|
||||||
|
WriteLn(reduce + a1);
|
||||||
|
WriteLn
|
||||||
|
end.
|
||||||
|
|
Loading…
Reference in New Issue
Block a user