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

compiler: implement class constants + tests

Browse Source 
git-svn-id: trunk@14609 -
This commit is contained in:
paul 2010-01-11 08:43:10 +00:00
parent c9987c296e
commit 166f8a63a2
10 changed files with 309 additions and 253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -8892,6 +8892,8 @@ tests/test/tclass1.pp svneol=native#text/plain
tests/test/tclass10.pp svneol=native#text/pascal
tests/test/tclass11a.pp svneol=native#text/pascal
tests/test/tclass11b.pp svneol=native#text/pascal
tests/test/tclass12a.pp svneol=native#text/pascal
tests/test/tclass12b.pp svneol=native#text/pascal
tests/test/tclass2.pp svneol=native#text/plain
tests/test/tclass3.pp svneol=native#text/plain
tests/test/tclass4.pp svneol=native#text/plain

4
compiler/msg/errore.msg
View File

@ -1104,8 +1104,8 @@ parser_e_packed_element_no_loop=03223_E_Bit packed array elements and record fie
% (or as \var{packed} in any mode with \var{\{\$bitpacking on\}}), it will
% be packed at the bit level. For performance reasons, they cannot be
% used as loop variables.
parser_e_type_and_var_only_in_generics_and_classes=03224_E_VAR and TYPE are allowed only in generics and classes
% The usage of VAR and TYPE to declare new types inside an object is allowed only inside
parser_e_type_var_const_only_in_generics_and_classes=03224_E_VAR, TYPE and CONST are allowed only in generics and classes
% The usage of VAR, TYPE and CONST to declare new types inside an object is allowed only inside
% generics and classes.
parser_e_cant_create_generics_of_this_type=03225_E_This type can't be a generic
% Only Classes, Objects, Interfaces and Records are allowed to be used as generic.

4
compiler/msgidx.inc
View File

@ -312,7 +312,7 @@ const
parser_e_packed_element_no_var_addr=03221;
parser_e_packed_dynamic_open_array=03222;
parser_e_packed_element_no_loop=03223;
parser_e_type_and_var_only_in_generics_and_classes=03224;
parser_e_type_var_const_only_in_generics_and_classes=03224;
parser_e_cant_create_generics_of_this_type=03225;
parser_w_no_lineinfo_use_switch=03226;
parser_e_no_funcret_specified=03227;
@ -840,7 +840,7 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 55239;
MsgTxtSize = 55246;
MsgIdxMax : array[1..20] of longint=(
24,87,285,95,71,51,110,22,202,63,

404
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

12
compiler/ncon.pas
View File

@ -291,15 +291,23 @@ implementation
p1:=nil;
case p.consttyp of
constord :
p1:=cordconstnode.create(p.value.valueord,p.constdef,true);
begin
if p.constdef=nil then
internalerror(200403232);
p1:=cordconstnode.create(p.value.valueord,p.constdef,true);
end;
conststring :
begin
len:=p.value.len;
if not(cs_ansistrings in current_settings.localswitches) and (len>255) then
len:=255;
getmem(pc,len+1);
move(pchar(p.value.valueptr)^,pc^,len);
pc[len]:=#0;
p1:=cstringconstnode.createpchar(pc,len);
end;
constwstring :
p1:=cstringconstnode.createwstr(pcompilerwidestring(p.value.valueptr));
constreal :
p1:=crealconstnode.create(pbestreal(p.value.valueptr)^,pbestrealtype^);
constset :
@ -308,6 +316,8 @@ implementation
p1:=cpointerconstnode.create(p.value.valueordptr,p.constdef);
constnil :
p1:=cnilnode.create;
constguid :
p1:=cguidconstnode.create(pguid(p.value.valueptr)^);
else
internalerror(200205103);
end;

13
compiler/pdecl.pas
View File

@ -36,6 +36,7 @@ interface
function readconstant(const orgname:string;const filepos:tfileposinfo):tconstsym;
procedure const_dec;
procedure consts_dec(in_class: boolean);
procedure label_dec;
procedure type_dec;
procedure types_dec(in_class: boolean);
@ -154,8 +155,13 @@ implementation
readconstant:=hp;
end;
procedure const_dec;
begin
consume(_CONST);
consts_dec(false);
end;
procedure consts_dec(in_class: boolean);
var
orgname : TIDString;
hdef : tdef;
@ -168,7 +174,6 @@ implementation
tclist : tasmlist;
varspez : tvarspez;
begin
consume(_CONST);
old_block_type:=block_type;
block_type:=bt_const;
repeat
@ -189,6 +194,7 @@ implementation
begin
sym.symoptions:=sym.symoptions+dummysymoptions;
sym.deprecatedmsg:=deprecatedmsg;
sym.visibility:=symtablestack.top.currentvisibility;
symtablestack.top.insert(sym);
end
else
@ -213,6 +219,7 @@ implementation
else
varspez:=vs_value;
sym:=tstaticvarsym.create(orgname,varspez,hdef,[]);
sym.visibility:=symtablestack.top.currentvisibility;
current_tokenpos:=storetokenpos;
symtablestack.top.insert(sym);
{ procvar can have proc directives, but not type references }
@ -255,7 +262,7 @@ implementation
{ generate an error }
consume(_EQUAL);
end;
until token<>_ID;
until (token<>_ID)or(in_class and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
block_type:=old_block_type;
end;

20
compiler/pdecobj.pas
View File

@ -553,7 +553,7 @@ implementation
begin
if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
(current_objectdef.objecttype<>odt_class) then
Message(parser_e_type_and_var_only_in_generics_and_classes);
Message(parser_e_type_var_const_only_in_generics_and_classes);
consume(_TYPE);
object_member_blocktype:=bt_type;
end;
@ -561,13 +561,21 @@ implementation
begin
if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
(current_objectdef.objecttype<>odt_class) then
Message(parser_e_type_and_var_only_in_generics_and_classes);
Message(parser_e_type_var_const_only_in_generics_and_classes);
consume(_VAR);
fields_allowed:=true;
object_member_blocktype:=bt_general;
classfields:=is_classdef;
is_classdef:=false;
end;
_CONST:
begin
if (([df_generic,df_specialization]*current_objectdef.defoptions)=[]) and
(current_objectdef.objecttype<>odt_class) then
Message(parser_e_type_var_const_only_in_generics_and_classes);
consume(_CONST);
object_member_blocktype:=bt_const;
end;
_ID :
begin
if is_objcprotocol(current_objectdef) and
@ -671,7 +679,13 @@ implementation
read_record_fields([vd_object])
end
else
types_dec(true);
if object_member_blocktype=bt_type then
types_dec(true)
else
if object_member_blocktype=bt_const then
consts_dec(true)
else
internalerror(201001110);
end;
end;
end;

53
compiler/pexpr.pas
View File

@ -1252,7 +1252,12 @@ implementation
begin
p1:=ctypenode.create(ttypesym(sym).typedef);
end;
else internalerror(16);
constsym:
begin
p1:=genconstsymtree(tconstsym(sym));
end
else
internalerror(16);
end;
end;
end;
@ -1559,44 +1564,14 @@ implementation
constsym :
begin
case tconstsym(srsym).consttyp of
constord :
begin
if tconstsym(srsym).constdef=nil then
internalerror(200403232);
p1:=cordconstnode.create(tconstsym(srsym).value.valueord,tconstsym(srsym).constdef,true);
end;
conststring :
begin
len:=tconstsym(srsym).value.len;
if not(cs_ansistrings in current_settings.localswitches) and (len>255) then
len:=255;
getmem(pc,len+1);
move(pchar(tconstsym(srsym).value.valueptr)^,pc^,len);
pc[len]:=#0;
p1:=cstringconstnode.createpchar(pc,len);
end;
constwstring :
p1:=cstringconstnode.createwstr(pcompilerwidestring(tconstsym(srsym).value.valueptr));
constreal :
p1:=crealconstnode.create(pbestreal(tconstsym(srsym).value.valueptr)^,pbestrealtype^);
constset :
p1:=csetconstnode.create(pconstset(tconstsym(srsym).value.valueptr),tconstsym(srsym).constdef);
constpointer :
p1:=cpointerconstnode.create(tconstsym(srsym).value.valueordptr,tconstsym(srsym).constdef);
constnil :
p1:=cnilnode.create;
constresourcestring:
begin
p1:=cloadnode.create(srsym,srsymtable);
do_typecheckpass(p1);
p1.resultdef:=cansistringtype;
end;
constguid :
p1:=cguidconstnode.create(pguid(tconstsym(srsym).value.valueptr)^);
else
internalerror(200507181);
end;
if tconstsym(srsym).consttyp=constresourcestring then
begin
p1:=cloadnode.create(srsym,srsymtable);
do_typecheckpass(p1);
p1.resultdef:=cansistringtype;
end
else
p1:=genconstsymtree(tconstsym(srsym));
end;
procsym :

23
tests/test/tclass12a.pp Normal file
View File

@ -0,0 +1,23 @@
program tclass12a;
{$ifdef fpc}
{$mode delphi}
{$endif}
{$apptype console}
type
TSomeClass = class
strict private
const
PrivateConst = 3.14;
public
class procedure WritePrivateConst; static;
end;
class procedure TSomeClass.WritePrivateConst;
begin
WriteLn(PrivateConst);
end;
begin
TSomeClass.WritePrivateConst;
end.

27
tests/test/tclass12b.pp Normal file
View File

@ -0,0 +1,27 @@
{ %FAIL}
program tclass12b;
{$ifdef fpc}
{$mode delphi}
{$endif}
{$apptype console}
type
TSomeClass = class
strict private
const
PrivateConst = 3.14;
end;
TAnotherClass = class(TSomeClass)
public
class procedure WritePrivateConst; static;
end;
class procedure TAnotherClass.WritePrivateConst;
begin
WriteLn(PrivateConst)
end;
begin
TAnotherClass.WritePrivateConst
end.