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

compiler: allow const, type, var and class var sections for objects + test

Browse Source 
git-svn-id: trunk@15092 -
This commit is contained in:
paul 2010-03-30 04:22:19 +00:00
parent 2a7636580e
commit 973d947d6c
7 changed files with 56 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitattributes vendored
View File

@ -9182,6 +9182,7 @@ tests/test/tobject2.pp svneol=native#text/plain
tests/test/tobject3.pp svneol=native#text/plain
tests/test/tobject4.pp svneol=native#text/plain
tests/test/tobject5.pp svneol=native#text/pascal
tests/test/tobject6.pp svneol=native#text/plain
tests/test/toperator1.pp svneol=native#text/plain
tests/test/toperator2.pp svneol=native#text/plain
tests/test/toperator3.pp svneol=native#text/plain

6
compiler/pdecobj.pas
View File

@ -552,7 +552,7 @@ implementation
_TYPE :
begin
if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
(current_objectdef.objecttype<>odt_class) then
not(current_objectdef.objecttype in [odt_class,odt_object]) then
Message(parser_e_type_var_const_only_in_generics_and_classes);
consume(_TYPE);
object_member_blocktype:=bt_type;
@ -560,7 +560,7 @@ implementation
_VAR :
begin
if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
(current_objectdef.objecttype<>odt_class) then
not(current_objectdef.objecttype in [odt_class,odt_object]) then
Message(parser_e_type_var_const_only_in_generics_and_classes);
consume(_VAR);
fields_allowed:=true;
@ -571,7 +571,7 @@ implementation
_CONST:
begin
if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
(current_objectdef.objecttype<>odt_class) then
not(current_objectdef.objecttype in [odt_class,odt_object]) then
Message(parser_e_type_var_const_only_in_generics_and_classes);
consume(_CONST);
object_member_blocktype:=bt_const;

5
compiler/pdecvar.pas
View File

@ -1413,12 +1413,11 @@ implementation
{ Don't search in the recordsymtable for types (can be nested!) }
recstlist.count:=0;
if ([df_generic,df_specialization]*tdef(recst.defowner).defoptions=[]) and
not is_class(tdef(recst.defowner)) then
not is_class_or_object(tdef(recst.defowner)) then
begin
recstlist.add(recst);
symtablestack.pop(recst);
while (is_object(tdef(symtablestack.top.defowner)) or
(symtablestack.top.symtabletype=recordsymtable)) and
while (symtablestack.top.symtabletype=recordsymtable) and
([df_generic,df_specialization]*tdef(symtablestack.top.defowner).defoptions=[]) do
begin
recst:=tabstractrecordsymtable(symtablestack.top);

3
compiler/pexpr.pas
View File

@ -1530,7 +1530,8 @@ implementation
if assigned(srsym) then
begin
check_hints(srsym,srsym.symoptions,srsym.deprecatedmsg);
if not(getaddr) and not(sp_static in srsym.symoptions) then
if not(getaddr) and
not((sp_static in srsym.symoptions) or (srsym.typ=constsym)) then
Message(sym_e_only_static_in_static)
else
begin

9
compiler/symdef.pas
View File

@ -758,6 +758,7 @@ interface
function is_class_or_interface_or_object(def: tdef): boolean;
function is_class_or_interface_or_dispinterface(def: tdef): boolean;
function is_class_or_interface_or_dispinterface_or_objc(def: tdef): boolean;
function is_class_or_object(def: tdef): boolean;
procedure loadobjctypes;
@ -4786,7 +4787,6 @@ implementation
var
def: tdef absolute data;
pd: tprocdef absolute data;
founderrordef: tdef;
i,
paracount: longint;
begin
@ -5351,6 +5351,13 @@ implementation
(tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol]);
end;
function is_class_or_object(def: tdef): boolean;
begin
result:=
assigned(def) and
(def.typ=objectdef) and
(tobjectdef(def).objecttype in [odt_class,odt_object]);
end;
procedure loadobjctypes;
begin

4
compiler/symtable.pas
View File

@ -1828,7 +1828,7 @@ implementation
records
objects
parameters
Exception are classes, generic definitions and specializations
Exception are classes, objects, generic definitions and specializations
that have the parameterized types inserted in the symtable.
}
srsymtable:=stackitem^.symtable;
@ -1837,7 +1837,7 @@ implementation
(
(df_generic in tdef(srsymtable.defowner).defoptions) or
(df_specialization in tdef(srsymtable.defowner).defoptions) or
is_class(tdef(srsymtable.defowner)))
is_class_or_object(tdef(srsymtable.defowner)))
) then
begin
srsym:=tsym(srsymtable.FindWithHash(hashedid));

38
tests/test/tobject6.pp Normal file
View File

@ -0,0 +1,38 @@
program tobject6;
{$APPTYPE console}
{$ifdef fpc}
{$mode delphi}{$H+}
{$endif}
type
TR = object
private
type
tsometype = integer;
class var
ffield1: tsometype;
var
ffield2: string;
const
somevalue = 1;
class procedure SetField1(const Value: tsometype); static;
public
class property field1: tsometype read ffield1 write SetField1;
end;
{ TR }
class procedure TR.SetField1(const Value: tsometype);
begin
ffield1 := Value;
end;
begin
TR.field1 := 10;
if TR.field1 <> 10 then
halt(1);
WriteLn(TR.somevalue);
if TR.somevalue <> 1 then
halt(2);
WriteLn('ok');
end.