/compiler/ptype.pas
Pascal | 1805 lines | 1466 code | 84 blank | 255 comment | 195 complexity | 8429cbce16bababc1f1d8aceedbfeb21 MD5 | raw file
Possible License(s): LGPL-2.0, LGPL-2.1, LGPL-3.0
- {
- Copyright (c) 1998-2002 by Florian Klaempfl
- Does parsing types for Free Pascal
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
- 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. See the
- GNU General Public License for more details.
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- ****************************************************************************
- }
- unit ptype;
- {$i fpcdefs.inc}
- interface
- uses
- globtype,cclasses,
- symtype,symdef,symbase;
- type
- TSingleTypeOption=(
- stoIsForwardDef, { foward declaration }
- stoAllowTypeDef, { allow type definitions }
- stoAllowSpecialization, { allow type specialization }
- stoParseClassParent { parse of parent class type }
- );
- TSingleTypeOptions=set of TSingleTypeOption;
- procedure resolve_forward_types;
- { reads a string, file type or a type identifier }
- procedure single_type(var def:tdef;options:TSingleTypeOptions);
- { reads any type declaration, where the resulting type will get name as type identifier }
- procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean);
- { reads any type declaration }
- procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
- { generate persistent type information like VMT, RTTI and inittables }
- procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
- { add a definition for a method to a record/objectdef that will contain
- all code for initialising typed constants (only for targets in
- systems.systems_typed_constants_node_init) }
- procedure add_typedconst_init_routine(def: tabstractrecorddef);
- { parse hint directives (platform, deprecated, ...) for a procdef }
- procedure maybe_parse_hint_directives(pd:tprocdef);
- implementation
- uses
- { common }
- cutils,
- { global }
- globals,tokens,verbose,constexp,
- systems,
- { target }
- paramgr,procinfo,
- { symtable }
- symconst,symsym,symtable,symcreat,
- defutil,defcmp,
- {$ifdef jvm}
- jvmdef,
- {$endif}
- { modules }
- fmodule,
- { pass 1 }
- node,ncgrtti,nobj,
- nmat,nadd,ncal,nset,ncnv,ninl,ncon,nld,nflw,
- { parser }
- scanner,
- pbase,pexpr,pdecsub,pdecvar,pdecobj,pdecl,pgenutil
- {$ifdef jvm}
- ,pjvm
- {$endif}
- ;
- procedure maybe_parse_hint_directives(pd:tprocdef);
- var
- dummysymoptions : tsymoptions;
- deprecatedmsg : pshortstring;
- begin
- dummysymoptions:=[];
- deprecatedmsg:=nil;
- while try_consume_hintdirective(dummysymoptions,deprecatedmsg) do
- Consume(_SEMICOLON);
- if assigned(pd) then
- begin
- pd.symoptions:=pd.symoptions+dummysymoptions;
- pd.deprecatedmsg:=deprecatedmsg;
- end
- else
- stringdispose(deprecatedmsg);
- end;
- procedure resolve_forward_types;
- var
- i: longint;
- hpd,
- def : tdef;
- srsym : tsym;
- srsymtable : TSymtable;
- hs : string;
- begin
- for i:=0 to current_module.checkforwarddefs.Count-1 do
- begin
- def:=tdef(current_module.checkforwarddefs[i]);
- case def.typ of
- pointerdef,
- classrefdef :
- begin
- { classrefdef inherits from pointerdef }
- hpd:=tabstractpointerdef(def).pointeddef;
- { still a forward def ? }
- if hpd.typ=forwarddef then
- begin
- { try to resolve the forward }
- if not assigned(tforwarddef(hpd).tosymname) then
- internalerror(200211201);
- hs:=tforwarddef(hpd).tosymname^;
- searchsym(upper(hs),srsym,srsymtable);
- { we don't need the forwarddef anymore, dispose it }
- hpd.free;
- tabstractpointerdef(def).pointeddef:=nil; { if error occurs }
- { was a type sym found ? }
- if assigned(srsym) and
- (srsym.typ=typesym) then
- begin
- tabstractpointerdef(def).pointeddef:=ttypesym(srsym).typedef;
- { avoid wrong unused warnings web bug 801 PM }
- inc(ttypesym(srsym).refs);
- { we need a class type for classrefdef }
- if (def.typ=classrefdef) and
- not(is_class(ttypesym(srsym).typedef)) and
- not(is_objcclass(ttypesym(srsym).typedef)) and
- not(is_javaclass(ttypesym(srsym).typedef)) then
- MessagePos1(def.typesym.fileinfo,type_e_class_type_expected,ttypesym(srsym).typedef.typename);
- { this could also be a generic dummy that was not
- overridden with a specific type }
- if (sp_generic_dummy in srsym.symoptions) and
- (
- (ttypesym(srsym).typedef.typ=undefineddef) or
- (
- { or an unspecialized generic symbol, which is
- the case for generics defined in non-Delphi
- modes }
- (df_generic in ttypesym(srsym).typedef.defoptions) and
- not parse_generic
- )
- ) then
- MessagePos(def.typesym.fileinfo,parser_e_no_generics_as_types);
- end
- else
- begin
- Message1(sym_e_forward_type_not_resolved,hs);
- { try to recover }
- tabstractpointerdef(def).pointeddef:=generrordef;
- end;
- end;
- end;
- objectdef :
- begin
- { give an error as the implementation may follow in an
- other type block which is allowed by FPC modes }
- if not(m_fpc in current_settings.modeswitches) and
- (oo_is_forward in tobjectdef(def).objectoptions) then
- MessagePos1(def.typesym.fileinfo,type_e_type_is_not_completly_defined,def.typename);
- end;
- else
- internalerror(200811071);
- end;
- end;
- current_module.checkforwarddefs.clear;
- end;
- procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable); forward;
- { def is the outermost type in which other types have to be searched
- isforward indicates whether the current definition can be a forward definition
- if assigned, currentstructstack is a list of tabstractrecorddefs that, from
- last to first, are child types of def that are not yet visible via the
- normal symtable searching routines because they are types that are currently
- being parsed (so using id_type on them after pushing def on the
- symtablestack would result in errors because they'd come back as errordef)
- }
- procedure parse_nested_types(var def: tdef; isforwarddef: boolean; currentstructstack: tfpobjectlist);
- var
- t2: tdef;
- structstackindex: longint;
- srsym: tsym;
- srsymtable: tsymtable;
- oldsymtablestack: TSymtablestack;
- begin
- if assigned(currentstructstack) then
- structstackindex:=currentstructstack.count-1
- else
- structstackindex:=-1;
- { handle types inside classes, e.g. TNode.TLongint }
- while (token=_POINT) do
- begin
- if is_class_or_object(def) or is_record(def) or is_java_class_or_interface(def) then
- begin
- if (def.typ=objectdef) then
- def:=find_real_class_definition(tobjectdef(def),false);
- consume(_POINT);
- if (structstackindex>=0) and
- (tabstractrecorddef(currentstructstack[structstackindex]).objname^=pattern) then
- begin
- def:=tdef(currentstructstack[structstackindex]);
- dec(structstackindex);
- consume(_ID);
- end
- else
- begin
- structstackindex:=-1;
- oldsymtablestack:=symtablestack;
- symtablestack:=TSymtablestack.create;
- symtablestack.push(tabstractrecorddef(def).symtable);
- t2:=generrordef;
- id_type(t2,isforwarddef,false,false,srsym,srsymtable);
- symtablestack.pop(tabstractrecorddef(def).symtable);
- symtablestack.free;
- symtablestack:=oldsymtablestack;
- def:=t2;
- end;
- end
- else
- break;
- end;
- end;
- function try_parse_structdef_nested_type(out def: tdef; basedef: tabstractrecorddef; isfowarddef: boolean): boolean;
- var
- structdef : tdef;
- structdefstack : tfpobjectlist;
- begin
- def:=nil;
- { use of current parsed object:
- classes, objects, records can be used also in themself }
- structdef:=basedef;
- structdefstack:=nil;
- while assigned(structdef) and (structdef.typ in [objectdef,recorddef]) do
- begin
- if (tabstractrecorddef(structdef).objname^=pattern) then
- begin
- consume(_ID);
- def:=structdef;
- { we found the top-most match, now check how far down we can
- follow }
- structdefstack:=tfpobjectlist.create(false);
- structdef:=basedef;
- while (structdef<>def) do
- begin
- structdefstack.add(structdef);
- structdef:=tabstractrecorddef(structdef.owner.defowner);
- end;
- parse_nested_types(def,isfowarddef,structdefstack);
- structdefstack.free;
- result:=true;
- exit;
- end;
- structdef:=tdef(tabstractrecorddef(structdef).owner.defowner);
- end;
- result:=false;
- end;
- procedure id_type(var def : tdef;isforwarddef,checkcurrentrecdef,allowgenericsyms:boolean;out srsym:tsym;out srsymtable:tsymtable);
- { reads a type definition }
- { to a appropriating tdef, s gets the name of }
- { the type to allow name mangling }
- var
- is_unit_specific : boolean;
- pos : tfileposinfo;
- s,sorg : TIDString;
- t : ttoken;
- begin
- srsym:=nil;
- srsymtable:=nil;
- s:=pattern;
- sorg:=orgpattern;
- pos:=current_tokenpos;
- { use of current parsed object:
- classes, objects, records can be used also in themself }
- if checkcurrentrecdef and
- try_parse_structdef_nested_type(def,current_structdef,isforwarddef) then
- exit;
- { Use the special searchsym_type that search only types }
- searchsym_type(s,srsym,srsymtable);
- { handle unit specification like System.Writeln }
- is_unit_specific:=try_consume_unitsym(srsym,srsymtable,t,true);
- consume(t);
- { Types are first defined with an error def before assigning
- the real type so check if it's an errordef. if so then
- give an error. Only check for typesyms in the current symbol
- table as forwarddef are not resolved directly }
- if assigned(srsym) and
- (srsym.typ=typesym) and
- ((ttypesym(srsym).typedef.typ=errordef) or
- (not allowgenericsyms and
- (ttypesym(srsym).typedef.typ=undefineddef) and
- not (sp_generic_para in srsym.symoptions))) then
- begin
- Message1(type_e_type_is_not_completly_defined,ttypesym(srsym).realname);
- def:=generrordef;
- exit;
- end;
- { are we parsing a possible forward def ? }
- if isforwarddef and
- not(is_unit_specific) then
- begin
- def:=tforwarddef.create(sorg,pos);
- exit;
- end;
- { unknown sym ? }
- if not assigned(srsym) then
- begin
- Message1(sym_e_id_not_found,sorg);
- def:=generrordef;
- exit;
- end;
- { type sym ? }
- if (srsym.typ<>typesym) then
- begin
- Message(type_e_type_id_expected);
- def:=generrordef;
- exit;
- end;
- { Give an error when referring to an errordef }
- if (ttypesym(srsym).typedef.typ=errordef) then
- begin
- Message(sym_e_error_in_type_def);
- def:=generrordef;
- exit;
- end;
- { In non-Delphi modes the class/record name of a generic might be used
- in the declaration of sub types without type parameters; in that case
- we need to check by name as the link from the dummy symbol to the
- current type is not yet established }
- if (sp_generic_dummy in srsym.symoptions) and
- assigned(current_structdef) and
- (df_generic in current_structdef.defoptions) and
- (ttypesym(srsym).typedef.typ=undefineddef) and
- not (m_delphi in current_settings.modeswitches) then
- begin
- def:=get_generic_in_hierarchy_by_name(srsym,current_structdef);
- if assigned(def) then
- exit;
- end;
- def:=ttypesym(srsym).typedef;
- end;
- procedure single_type(var def:tdef;options:TSingleTypeOptions);
- var
- t2 : tdef;
- dospecialize,
- again : boolean;
- srsym : tsym;
- srsymtable : tsymtable;
- begin
- dospecialize:=false;
- repeat
- again:=false;
- case token of
- _STRING:
- string_dec(def,stoAllowTypeDef in options);
- _FILE:
- begin
- consume(_FILE);
- if (token=_OF) then
- begin
- if not(stoAllowTypeDef in options) then
- Message(parser_e_no_local_para_def);
- consume(_OF);
- single_type(t2,[stoAllowTypeDef]);
- if is_managed_type(t2) then
- Message(parser_e_no_refcounted_typed_file);
- def:=tfiledef.createtyped(t2);
- end
- else
- def:=cfiletype;
- end;
- _ID:
- begin
- if try_to_consume(_SPECIALIZE) then
- begin
- if ([stoAllowSpecialization,stoAllowTypeDef] * options = []) then
- begin
- Message(parser_e_no_local_para_def);
- { try to recover }
- while token<>_SEMICOLON do
- consume(token);
- def:=generrordef;
- end
- else
- begin
- dospecialize:=true;
- again:=true;
- end;
- end
- else
- begin
- id_type(def,stoIsForwardDef in options,true,true,srsym,srsymtable);
- parse_nested_types(def,stoIsForwardDef in options,nil);
- end;
- end;
- else
- begin
- message(type_e_type_id_expected);
- def:=generrordef;
- end;
- end;
- until not again;
- if ([stoAllowSpecialization,stoAllowTypeDef] * options <> []) and
- (m_delphi in current_settings.modeswitches) then
- dospecialize:=token in [_LSHARPBRACKET,_LT];
- if dospecialize and
- (def.typ=forwarddef) then
- begin
- if not assigned(srsym) or not (srsym.typ=typesym) then
- begin
- Message1(type_e_type_is_not_completly_defined,def.typename);
- def:=generrordef;
- dospecialize:=false;
- end;
- end;
- if dospecialize then
- begin
- if def.typ=forwarddef then
- def:=ttypesym(srsym).typedef;
- generate_specialization(def,stoParseClassParent in options,'');
- end
- else
- begin
- if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
- begin
- def:=current_specializedef
- end
- else if (def=current_genericdef) then
- begin
- def:=current_genericdef
- end
- { when parsing a nested specialization in non-Delphi mode it might
- use the name of the topmost generic without type paramaters, thus
- def will contain the generic definition, but we need a reference
- to the specialization of that generic }
- { TODO : only in non-Delphi modes? }
- else if assigned(current_structdef) and
- (df_specialization in current_structdef.defoptions) and
- return_specialization_of_generic(current_structdef,def,t2) then
- begin
- def:=t2
- end
- else if (df_generic in def.defoptions) and
- not
- (
- parse_generic and
- (current_genericdef.typ in [recorddef,objectdef]) and
- (
- { if both defs belong to the same generic (e.g. both are
- subtypes) then we must allow the usage }
- defs_belong_to_same_generic(def,current_genericdef) or
- { this is needed to correctly resolve "type Foo=SomeGeneric<T>"
- declarations inside a generic }
- sym_is_owned_by(srsym,tabstractrecorddef(current_genericdef).symtable)
- )
- )
- then
- begin
- Message(parser_e_no_generics_as_types);
- def:=generrordef;
- end
- else if (def.typ=undefineddef) and
- (sp_generic_dummy in srsym.symoptions) and
- parse_generic and
- (current_genericdef.typ in [recorddef,objectdef]) and
- (Pos(upper(srsym.realname),tabstractrecorddef(current_genericdef).objname^)=1) then
- begin
- if m_delphi in current_settings.modeswitches then
- begin
- Message(parser_e_no_generics_as_types);
- def:=generrordef;
- end
- else
- def:=current_genericdef;
- end
- else if is_classhelper(def) and
- not (stoParseClassParent in options) then
- begin
- Message(parser_e_no_category_as_types);
- def:=generrordef
- end
- end;
- end;
- procedure parse_record_members;
- function IsAnonOrLocal: Boolean;
- begin
- result:=(current_structdef.objname^='') or
- not(symtablestack.stack^.next^.symtable.symtabletype in [globalsymtable,staticsymtable,objectsymtable,recordsymtable]);
- end;
- var
- pd : tprocdef;
- oldparse_only: boolean;
- member_blocktype : tblock_type;
- fields_allowed, is_classdef, classfields: boolean;
- vdoptions: tvar_dec_options;
- begin
- { empty record declaration ? }
- if (token=_SEMICOLON) then
- Exit;
- current_structdef.symtable.currentvisibility:=vis_public;
- fields_allowed:=true;
- is_classdef:=false;
- classfields:=false;
- member_blocktype:=bt_general;
- repeat
- case token of
- _TYPE :
- begin
- consume(_TYPE);
- member_blocktype:=bt_type;
- { local and anonymous records can not have inner types. skip top record symtable }
- if IsAnonOrLocal then
- Message(parser_e_no_types_in_local_anonymous_records);
- end;
- _VAR :
- begin
- consume(_VAR);
- fields_allowed:=true;
- member_blocktype:=bt_general;
- classfields:=is_classdef;
- is_classdef:=false;
- end;
- _CONST:
- begin
- consume(_CONST);
- member_blocktype:=bt_const;
- { local and anonymous records can not have constants. skip top record symtable }
- if IsAnonOrLocal then
- Message(parser_e_no_consts_in_local_anonymous_records);
- end;
- _ID, _CASE, _OPERATOR :
- begin
- case idtoken of
- _PRIVATE :
- begin
- consume(_PRIVATE);
- current_structdef.symtable.currentvisibility:=vis_private;
- include(current_structdef.objectoptions,oo_has_private);
- fields_allowed:=true;
- is_classdef:=false;
- classfields:=false;
- member_blocktype:=bt_general;
- end;
- _PROTECTED :
- begin
- consume(_PROTECTED);
- current_structdef.symtable.currentvisibility:=vis_protected;
- include(current_structdef.objectoptions,oo_has_protected);
- fields_allowed:=true;
- is_classdef:=false;
- classfields:=false;
- member_blocktype:=bt_general;
- end;
- _PUBLIC :
- begin
- consume(_PUBLIC);
- current_structdef.symtable.currentvisibility:=vis_public;
- fields_allowed:=true;
- is_classdef:=false;
- classfields:=false;
- member_blocktype:=bt_general;
- end;
- _PUBLISHED :
- begin
- Message(parser_e_no_record_published);
- consume(_PUBLISHED);
- current_structdef.symtable.currentvisibility:=vis_published;
- fields_allowed:=true;
- is_classdef:=false;
- classfields:=false;
- member_blocktype:=bt_general;
- end;
- _STRICT :
- begin
- consume(_STRICT);
- if token=_ID then
- begin
- case idtoken of
- _PRIVATE:
- begin
- consume(_PRIVATE);
- current_structdef.symtable.currentvisibility:=vis_strictprivate;
- include(current_structdef.objectoptions,oo_has_strictprivate);
- end;
- _PROTECTED:
- begin
- consume(_PROTECTED);
- current_structdef.symtable.currentvisibility:=vis_strictprotected;
- include(current_structdef.objectoptions,oo_has_strictprotected);
- end;
- else
- message(parser_e_protected_or_private_expected);
- end;
- end
- else
- message(parser_e_protected_or_private_expected);
- fields_allowed:=true;
- is_classdef:=false;
- classfields:=false;
- member_blocktype:=bt_general;
- end
- else
- if is_classdef and (idtoken=_OPERATOR) then
- begin
- pd:=parse_record_method_dec(current_structdef,is_classdef);
- fields_allowed:=false;
- is_classdef:=false;
- end
- else
- begin
- if member_blocktype=bt_general then
- begin
- if (not fields_allowed)and(idtoken<>_CASE) then
- Message(parser_e_field_not_allowed_here);
- vdoptions:=[vd_record];
- if classfields then
- include(vdoptions,vd_class);
- read_record_fields(vdoptions,nil);
- end
- else if member_blocktype=bt_type then
- types_dec(true)
- else if member_blocktype=bt_const then
- consts_dec(true,true)
- else
- internalerror(201001110);
- end;
- end;
- end;
- _PROPERTY :
- begin
- if IsAnonOrLocal then
- Message(parser_e_no_properties_in_local_anonymous_records);
- struct_property_dec(is_classdef);
- fields_allowed:=false;
- is_classdef:=false;
- end;
- _CLASS:
- begin
- is_classdef:=false;
- { read class method/field/property }
- consume(_CLASS);
- { class modifier is only allowed for procedures, functions, }
- { constructors, destructors, fields and properties }
- if not(token in [_FUNCTION,_PROCEDURE,_PROPERTY,_VAR,_CONSTRUCTOR,_DESTRUCTOR,_OPERATOR]) and
- not((token=_ID) and (idtoken=_OPERATOR)) then
- Message(parser_e_procedure_or_function_expected);
- if IsAnonOrLocal then
- Message(parser_e_no_class_in_local_anonymous_records);
- is_classdef:=true;
- end;
- _PROCEDURE,
- _FUNCTION:
- begin
- if IsAnonOrLocal then
- Message(parser_e_no_methods_in_local_anonymous_records);
- pd:=parse_record_method_dec(current_structdef,is_classdef);
- fields_allowed:=false;
- is_classdef:=false;
- end;
- _CONSTRUCTOR :
- begin
- if IsAnonOrLocal then
- Message(parser_e_no_methods_in_local_anonymous_records);
- if not is_classdef and (current_structdef.symtable.currentvisibility <> vis_public) then
- Message(parser_w_constructor_should_be_public);
- { only 1 class constructor is allowed }
- if is_classdef and (oo_has_class_constructor in current_structdef.objectoptions) then
- Message1(parser_e_only_one_class_constructor_allowed, current_structdef.objrealname^);
- oldparse_only:=parse_only;
- parse_only:=true;
- if is_classdef then
- pd:=class_constructor_head(current_structdef)
- else
- begin
- pd:=constructor_head;
- if pd.minparacount = 0 then
- MessagePos(pd.procsym.fileinfo,parser_e_no_parameterless_constructor_in_records);
- end;
- parse_only:=oldparse_only;
- fields_allowed:=false;
- is_classdef:=false;
- end;
- _DESTRUCTOR :
- begin
- if IsAnonOrLocal then
- Message(parser_e_no_methods_in_local_anonymous_records);
- if not is_classdef then
- Message(parser_e_no_destructor_in_records);
- { only 1 class destructor is allowed }
- if is_classdef and (oo_has_class_destructor in current_structdef.objectoptions) then
- Message1(parser_e_only_one_class_destructor_allowed, current_structdef.objrealname^);
- oldparse_only:=parse_only;
- parse_only:=true;
- if is_classdef then
- pd:=class_destructor_head(current_structdef)
- else
- pd:=destructor_head;
- parse_only:=oldparse_only;
- fields_allowed:=false;
- is_classdef:=false;
- end;
- _END :
- begin
- {$ifdef jvm}
- add_java_default_record_methods_intf(trecorddef(current_structdef));
- {$endif}
- if target_info.system in systems_typed_constants_node_init then
- add_typedconst_init_routine(current_structdef);
- consume(_END);
- break;
- end;
- else
- consume(_ID); { Give a ident expected message, like tp7 }
- end;
- until false;
- end;
- { reads a record declaration }
- function record_dec(const n:tidstring;genericdef:tstoreddef;genericlist:TFPObjectList):tdef;
- var
- old_current_structdef: tabstractrecorddef;
- old_current_genericdef,
- old_current_specializedef: tstoreddef;
- old_parse_generic: boolean;
- recst: trecordsymtable;
- begin
- old_current_structdef:=current_structdef;
- old_current_genericdef:=current_genericdef;
- old_current_specializedef:=current_specializedef;
- old_parse_generic:=parse_generic;
- current_genericdef:=nil;
- current_specializedef:=nil;
- { create recdef }
- if (n<>'') or
- not(target_info.system in systems_jvm) then
- begin
- recst:=trecordsymtable.create(n,current_settings.packrecords);
- { can't use recst.realname^ instead of n, because recst.realname is
- nil in case of an empty name }
- current_structdef:=trecorddef.create(n,recst);
- end
- else
- begin
- { for the JVM target records always need a name, because they are
- represented by a class }
- recst:=trecordsymtable.create(current_module.realmodulename^+'__fpc_intern_recname_'+tostr(current_module.deflist.count),current_settings.packrecords);
- current_structdef:=trecorddef.create(recst.name^,recst);
- end;
- result:=current_structdef;
- { insert in symtablestack }
- symtablestack.push(recst);
- { usage of specialized type inside its generic template }
- if assigned(genericdef) then
- current_specializedef:=current_structdef
- { reject declaration of generic class inside generic class }
- else if assigned(genericlist) then
- current_genericdef:=current_structdef;
- { nested types of specializations are specializations as well }
- if assigned(old_current_structdef) and
- (df_specialization in old_current_structdef.defoptions) then
- include(current_structdef.defoptions,df_specialization);
- if assigned(old_current_structdef) and
- (df_generic in old_current_structdef.defoptions) then
- begin
- include(current_structdef.defoptions,df_generic);
- current_genericdef:=current_structdef;
- end;
- insert_generic_parameter_types(current_structdef,genericdef,genericlist);
- { when we are parsing a generic already then this is a generic as
- well }
- if old_parse_generic then
- include(current_structdef.defoptions, df_generic);
- parse_generic:=(df_generic in current_structdef.defoptions);
- { in non-Delphi modes we need a strict private symbol without type
- count and type parameters in the name to simply resolving }
- maybe_insert_generic_rename_symbol(n,genericlist);
- if m_advanced_records in current_settings.modeswitches then
- begin
- parse_record_members;
- end
- else
- begin
- read_record_fields([vd_record],nil);
- {$ifdef jvm}
- { we need a constructor to create temps, a deep copy helper, ... }
- add_java_default_record_methods_intf(trecorddef(current_structdef));
- {$endif}
- if target_info.system in systems_typed_constants_node_init then
- add_typedconst_init_routine(current_structdef);
- consume(_END);
- end;
- { make the record size aligned (has to be done before inserting the
- parameters, because that may depend on the record's size) }
- recst.addalignmentpadding;
- { don't keep track of procdefs in a separate list, because the
- compiler may add additional procdefs (e.g. property wrappers for
- the jvm backend) }
- insert_record_hidden_paras(trecorddef(current_structdef));
- { restore symtable stack }
- symtablestack.pop(recst);
- if trecorddef(current_structdef).is_packed and is_managed_type(current_structdef) then
- Message(type_e_no_packed_inittable);
- { restore old state }
- parse_generic:=old_parse_generic;
- current_structdef:=old_current_structdef;
- current_genericdef:=old_current_genericdef;
- current_specializedef:=old_current_specializedef;
- end;
- { reads a type definition and returns a pointer to it }
- procedure read_named_type(var def:tdef;const newsym:tsym;genericdef:tstoreddef;genericlist:TFPObjectList;parseprocvardir:boolean;hadtypetoken:boolean);
- var
- pt : tnode;
- tt2 : tdef;
- aktenumdef : tenumdef;
- s : TIDString;
- l,v : TConstExprInt;
- oldpackrecords : longint;
- defpos,storepos : tfileposinfo;
- name: TIDString;
- procedure expr_type;
- var
- pt1,pt2 : tnode;
- lv,hv : TConstExprInt;
- old_block_type : tblock_type;
- dospecialize : boolean;
- newdef : tdef;
- begin
- old_block_type:=block_type;
- dospecialize:=false;
- { use of current parsed object:
- classes, objects, records can be used also in themself }
- if (token=_ID) then
- if try_parse_structdef_nested_type(def,current_structdef,false) then
- exit;
- { Generate a specialization in FPC mode? }
- dospecialize:=not(m_delphi in current_settings.modeswitches) and try_to_consume(_SPECIALIZE);
- { we can't accept a equal in type }
- pt1:=comp_expr(false,true);
- if not dospecialize and
- try_to_consume(_POINTPOINT) then
- begin
- { get high value of range }
- pt2:=comp_expr(false,false);
- { make both the same type or give an error. This is not
- done when both are integer values, because typecasting
- between -3200..3200 will result in a signed-unsigned
- conflict and give a range check error (PFV) }
- if not(is_integer(pt1.resultdef) and is_integer(pt2.resultdef)) then
- inserttypeconv(pt1,pt2.resultdef);
- { both must be evaluated to constants now }
- if (pt1.nodetype=ordconstn) and
- (pt2.nodetype=ordconstn) then
- begin
- lv:=tordconstnode(pt1).value;
- hv:=tordconstnode(pt2).value;
- { Check bounds }
- if hv<lv then
- message(parser_e_upper_lower_than_lower)
- else if (lv.signed and (lv.svalue<0)) and (not hv.signed and (hv.uvalue>qword(high(int64)))) then
- message(type_e_cant_eval_constant_expr)
- else
- begin
- { All checks passed, create the new def }
- case pt1.resultdef.typ of
- enumdef :
- def:=tenumdef.create_subrange(tenumdef(pt1.resultdef),lv.svalue,hv.svalue);
- orddef :
- begin
- if is_char(pt1.resultdef) then
- def:=torddef.create(uchar,lv,hv)
- else
- if is_boolean(pt1.resultdef) then
- def:=torddef.create(pasbool8,lv,hv)
- else if is_signed(pt1.resultdef) then
- def:=torddef.create(range_to_basetype(lv,hv),lv,hv)
- else
- def:=torddef.create(range_to_basetype(lv,hv),lv,hv);
- end;
- end;
- end;
- end
- else
- Message(sym_e_error_in_type_def);
- pt2.free;
- end
- else
- begin
- { a simple type renaming or generic specialization }
- if (pt1.nodetype=typen) then
- begin
- def:=ttypenode(pt1).resultdef;
- { Delphi mode specialization? }
- if (m_delphi in current_settings.modeswitches) then
- dospecialize:=token=_LSHARPBRACKET
- else
- { in non-Delphi modes we might get a inline specialization
- without "specialize" or "<T>" of the same type we're
- currently parsing, so we need to handle that special }
- newdef:=nil;
- if not dospecialize and
- assigned(ttypenode(pt1).typesym) and
- (ttypenode(pt1).typesym.typ=typesym) and
- (sp_generic_dummy in ttypenode(pt1).typesym.symoptions) and
- assigned(current_structdef) and
- (
- (
- not (m_delphi in current_settings.modeswitches) and
- (ttypesym(ttypenode(pt1).typesym).typedef.typ=undefineddef) and
- (df_generic in current_structdef.defoptions) and
- (ttypesym(ttypenode(pt1).typesym).typedef.owner=current_structdef.owner) and
- (upper(ttypenode(pt1).typesym.realname)=copy(current_structdef.objname^,1,pos('$',current_structdef.objname^)-1))
- ) or (
- { this could be a nested specialization which uses
- the type name of a surrounding generic to
- reference the specialization of said surrounding
- class }
- (df_specialization in current_structdef.defoptions) and
- return_specialization_of_generic(current_structdef,ttypesym(ttypenode(pt1).typesym).typedef,newdef)
- )
- )
- then
- begin
- if assigned(newdef) then
- def:=newdef
- else
- def:=current_structdef;
- if assigned(def) then
- { handle nested types }
- post_comp_expr_gendef(def)
- else
- def:=generrordef;
- end;
- if dospecialize then
- begin
- generate_specialization(def,false,name);
- { handle nested types }
- if assigned(def) then
- post_comp_expr_gendef(def);
- end
- else
- begin
- if assigned(current_specializedef) and (def=current_specializedef.genericdef) then
- begin
- def:=current_specializedef
- end
- else if (def=current_genericdef) then
- begin
- def:=current_genericdef
- end
- else if (df_generic in def.defoptions) and
- { TODO : check once nested generics are allowed }
- not
- (
- parse_generic and
- (current_genericdef.typ in [recorddef,objectdef]) and
- (def.typ in [recorddef,objectdef]) and
- (
- { if both defs belong to the same generic (e.g. both are
- subtypes) then we must allow the usage }
- defs_belong_to_same_generic(def,current_genericdef) or
- { this is needed to correctly resolve "type Foo=SomeGeneric<T>"
- declarations inside a generic }
- (
- (ttypenode(pt1).typesym<>nil) and
- sym_is_owned_by(ttypenode(pt1).typesym,tabstractrecorddef(current_genericdef).symtable)
- )
- )
- )
- then
- begin
- Message(parser_e_no_generics_as_types);
- def:=generrordef;
- end
- else if is_classhelper(def) then
- begin
- Message(parser_e_no_category_as_types);
- def:=generrordef
- end
- end;
- end
- else
- Message(sym_e_error_in_type_def);
- end;
- pt1.free;
- block_type:=old_block_type;
- end;
- procedure set_dec;
- begin
- consume(_SET);
- consume(_OF);
- read_anon_type(tt2,true);
- if assigned(tt2) then
- begin
- case tt2.typ of
- { don't forget that min can be negativ PM }
- enumdef :
- if (tenumdef(tt2).min>=0) and
- (tenumdef(tt2).max<=255) then
- // !! def:=tsetdef.create(tt2,tenumdef(tt2.def).min,tenumdef(tt2.def).max))
- def:=tsetdef.create(tt2,tenumdef(tt2).min,tenumdef(tt2).max)
- else
- Message(sym_e_ill_type_decl_set);
- orddef :
- begin
- if (torddef(tt2).ordtype<>uvoid) and
- (torddef(tt2).ordtype<>uwidechar) and
- (torddef(tt2).low>=0) then
- // !! def:=tsetdef.create(tt2,torddef(tt2.def).low,torddef(tt2.def).high))
- if Torddef(tt2).high>int64(high(byte)) then
- message(sym_e_ill_type_decl_set)
- else
- def:=tsetdef.create(tt2,torddef(tt2).low.svalue,torddef(tt2).high.svalue)
- else
- Message(sym_e_ill_type_decl_set);
- end;
- else
- Message(sym_e_ill_type_decl_set);
- end;
- end
- else
- def:=generrordef;
- end;
- procedure array_dec(is_packed:boolean;genericdef:tstoreddef;genericlist:TFPObjectList);
- var
- lowval,
- highval : TConstExprInt;
- indexdef : tdef;
- hdef : tdef;
- arrdef : tarraydef;
- procedure setdefdecl(def:tdef);
- begin
- case def.typ of
- enumdef :
- begin
- lowval:=tenumdef(def).min;
- highval:=tenumdef(def).max;
- if (m_fpc in current_settings.modeswitches) and
- (tenumdef(def).has_jumps) then
- Message(type_e_array_index_enums_with_assign_not_possible);
- indexdef:=def;
- end;
- orddef :
- begin
- if torddef(def).ordtype in [uchar,
- u8bit,u16bit,
- s8bit,s16bit,s32bit,
- {$ifdef cpu64bitaddr}
- u32bit,s64bit,
- {$endif cpu64bitaddr}
- pasbool8,pasbool16,pasbool32,pasbool64,
- bool8bit,bool16bit,bool32bit,bool64bit,
- uwidechar] then
- begin
- lowval:=torddef(def).low;
- highval:=torddef(def).high;
- indexdef:=def;
- end
- else
- Message1(parser_e_type_cant_be_used_in_array_index,def.typename);
- end;
- else
- Message(sym_e_error_in_type_def);
- end;
- end;
- var
- old_current_genericdef,
- old_current_specializedef: tstoreddef;
- first,
- old_parse_generic: boolean;
- begin
- old_current_genericdef:=current_genericdef;
- old_current_specializedef:=current_specializedef;
- old_parse_generic:=parse_generic;
- current_genericdef:=nil;
- current_specializedef:=nil;
- first:=true;
- arrdef:=tarraydef.create(0,0,s32inttype);
- consume(_ARRAY);
- { usage of specialized type inside its generic template }
- if assigned(genericdef) then
- current_specializedef:=arrdef
- { reject declaration of generic class inside generic class }
- else if assigned(genericlist) then
- current_genericdef:=arrdef;
- symtablestack.push(arrdef.symtable);
- insert_generic_parameter_types(arrdef,genericdef,genericlist);
- { there are two possibilties for the following to be true:
- * the array declaration itself is generic
- * the array is declared inside a generic
- in both cases we need "parse_generic" and "current_genericdef"
- so that e.g. specializations of another generic inside the
- current generic can be used (either inline ones or "type" ones) }
- parse_generic:=(df_generic in arrdef.defoptions) or old_parse_generic;
- if parse_generic and not assigned(current_genericdef) then
- current_genericdef:=old_current_genericdef;
- { open array? }
- if try_to_consume(_LECKKLAMMER) then
- begin
- { defaults }
- indexdef:=generrordef;
- { use defaults which don't overflow the compiler }
- lowval:=0;
- highval:=0;
- repeat
- { read the expression and check it, check apart if the
- declaration is an enum declaration because that needs to
- be parsed by readtype (PFV) }
- if token=_LKLAMMER then
- begin
- read_anon_type(hdef,true);
- setdefdecl(hdef);
- end
- else
- begin
- pt:=expr(true);
- if pt.nodetype=typen then
- setdefdecl(pt.resultdef)
- else
- begin
- if pt.nodetype=rangen then
- begin
- { pure ordconstn expressions can be checked for
- generics as well, but don't give an error in case
- of parsing a generic if that isn't yet the case }
- if (trangenode(pt).left.nodetype=ordconstn) and
- (trangenode(pt).right.nodetype=ordconstn) then
- begin
- { make both the same type or give an error. This is not
- done when both are integer values, because typecasting
- between -3200..3200 will result in a signed-unsigned
- conflict and give a range check error (PFV) }
- if not(is_integer(trangenode(pt).left.resultdef) and is_integer(trangenode(pt).left.resultdef)) then
- inserttypeconv(trangenode(pt).left,trangenode(pt).right.resultdef);
- lowval:=tordconstnode(trangenode(pt).left).value;
- highval:=tordconstnode(trangenode(pt).right).value;
- if highval<lowval then
- begin
- Message(parser_e_array_lower_less_than_upper_bound);
- highval:=lowval;
- end
- else if (lowval<int64(low(asizeint))) or
- (highval>high(asizeint)) then
- begin
- Message(parser_e_array_range_out_of_bounds);
- lowval :=0;
- highval:=0;
- end;
- if is_integer(trangenode(pt).left.resultdef) then
- range_to_type(lowval,highval,indexdef)
- else
- indexdef:=trangenode(pt).left.resultdef;
- end
- else
- if not parse_generic then
- Message(type_e_cant_eval_constant_expr);
- end
- else
- Message(sym_e_error_in_type_def)
- end;
- pt.free;
- end;
- { if we are not at the first dimension, add the new arrray
- as element of the existing array, otherwise modify the existing array }
- if not(first) then
- begin
- arrdef.elementdef:=tarraydef.create(lowval.svalue,highval.svalue,indexdef);
- { push new symtable }
- symtablestack.pop(arrdef.symtable);
- arrdef:=tarraydef(arrdef.elementdef);
- symtablestack.push(arrdef.symtable);
- end
- else
- begin
- arrdef.lowrange:=lowval.svalue;
- arrdef.highrange:=highval.svalue;
- arrdef.rangedef:=indexdef;
- def:=arrdef;
- first:=false;
- end;
- if is_packed then
- include(arrdef.arrayoptions,ado_IsBitPacked);
- if token=_COMMA then
- consume(_COMMA)
- else
- break;
- until false;
- consume(_RECKKLAMMER);
- end
- else
- begin
- if is_packed then
- Message(parser_e_packed_dynamic_open_array);
- arrdef.lowrange:=0;
- arrdef.highrange:=-1;
- arrdef.rangedef:=s32inttype;
- include(arrdef.arrayoptions,ado_IsDynamicArray);
- def:=arrdef;
- end;
- consume(_OF);
- read_anon_type(tt2,true);
- { set element type of the last array definition }
- if assigned(arrdef) then
- begin
- symtablestack.pop(arrdef.symtable);
- arrdef.elementdef:=tt2;
- if is_packed and
- is_managed_type(tt2) then
- Message(type_e_no_packed_inittable);
- end;
- { restore old state }
- parse_generic:=old_parse_generic;
- current_genericdef:=old_current_genericdef;
- current_specializedef:=old_current_specializedef;
- end;
- function procvar_dec(genericdef:tstoreddef;genericlist:TFPObjectList):tdef;
- var
- is_func:boolean;
- pd:tabstractprocdef;
- newtype:ttypesym;
- old_current_genericdef,
- old_current_specializedef: tstoreddef;
- old_parse_generic: boolean;
- begin
- old_current_genericdef:=current_genericdef;
- old_current_specializedef:=current_specializedef;
- old_parse_generic:=parse_generic;
- current_genericdef:=nil;
- current_specializedef:=nil;
- is_func:=(token=_FUNCTION);
- consume(token);
- pd:=tprocvardef.create(normal_function_level);
- { usage of specialized type inside its generic template }
- if assigned(genericdef) then
- current_specializedef:=pd
- { reject declaration of generic class inside generic class }
- else if assigned(genericlist) then
- current_genericdef:=pd;
- symtablestack.push(pd.parast);
- insert_generic_parameter_types(pd,genericdef,genericlist);
- { there are two possibilties for the following to be true:
- * the procvar declaration itself is generic
- * the procvar is declared inside a generic
- in both cases we need "parse_generic" and "current_genericdef"
- so that e.g. specializations of another generic inside the
- current generic can be used (either inline ones or "type" ones) }
- parse_generic:=(df_generic in pd.defoptions) or old_parse_generic;
- if parse_generic and not assigned(current_genericdef) then
- current_genericdef:=old_current_genericdef;
- { don't allow to add defs to the symtable - use it for type param search only }
- tparasymtable(pd.parast).readonly:=true;
- if token=_LKLAMMER then
- parse_parameter_dec(pd);
- if is_func then
- begin
- consume(_COLON);
- single_type(pd.returndef,[]);
- end;
- if try_to_consume(_OF) then
- begin
- consume(_OBJECT);
- include(pd.procoptions,po_methodpointer);
- end
- else if (m_nested_procvars in current_settings.modeswitches) and
- try_to_consume(_IS) then
- begin
- consume(_NESTED);
- pd.parast.symtablelevel:=normal_function_level+1;
- pd.check_mark_as_nested;
- end;
- symtablestack.pop(pd.parast);
- tparasymtable(pd.parast).readonly:=false;
- result:=pd;
- { possible proc directives }
- if parseprocvardir then
- begin
- if check_proc_directive(true) then
- begin
- newtype:=ttypesym.create('unnamed',result);
- parse_var_proc_directives(tsym(newtype));
- newtype.typedef:=nil;
- result.typesym:=nil;
- newtype.free;
- end;
- { Add implicit hidden parameters and function result }
- handle_calling_convention(pd);
- end;
- { restore old state }
- parse_generic:=old_parse_generic;
- current_genericdef:=old_current_genericdef;
- current_specializedef:=old_current_specializedef;
- end;
- const
- SingleTypeOptionsInTypeBlock:array[Boolean] of TSingleTypeOptions = ([],[stoIsForwardDef]);
- SingleTypeOptionsIsDelphi:array[Boolean] of TSingleTypeOptions = ([],[stoAllowSpecialization]);
- var
- p : tnode;
- hdef : tdef;
- enumdupmsg, first, is_specialize : boolean;
- oldlocalswitches : tlocalswitches;
- bitpacking: boolean;
- stitem: psymtablestackitem;
- sym: tsym;
- st: tsymtable;
- begin
- def:=nil;
- if assigned(newsym) then
- name:=newsym.RealName
- else
- name:='';
- case token of
- _STRING,_FILE:
- begin
- single_type(def,[stoAllowTypeDef]);
- end;
- _LKLAMMER:
- begin
- consume(_LKLAMMER);
- first:=true;
- { allow negativ value_str }
- l:=int64(-1);
- enumdupmsg:=false;
- { check that we are not adding an enum from specialization
- we can't just use current_specializedef because of inner types
- like specialize array of record }
- is_specialize:=false;
- stitem:=symtablestack.stack;
- while assigned(stitem) do
- begin
- { check records, classes and arrays because they can be specialized }
- if stitem^.symtable.symtabletype in [recordsymtable,ObjectSymtable,arraysymtable] then
- begin
- is_specialize:=is_specialize or (df_specialization in tstoreddef(stitem^.symtable.defowner).defoptions);
- stitem:=stitem^.next;
- end
- else
- break;
- end;
- if not is_specialize then
- aktenumdef:=tenumdef.create
- else
- aktenumdef:=nil;
- repeat
- { if it is a specialization then search the first enum member
- and get the member owner instead of just created enumdef }
- if not assigned(aktenumdef) then
- begin
- searchsym(pattern,sym,st);
- if sym.typ=enumsym then
- aktenumdef:=tenumsym(sym).definition
- else
- internalerror(201101021);
- end;
- s:=orgpattern;
- defpos:=current_tokenpos;
- consume(_ID);
- { only allow assigning of specific numbers under fpc mode }
- if not(m_tp7 in current_settings.modeswitches) and
- (
- { in fpc mode also allow := to be compatible
- with previous 1.0.x versions }
- ((m_fpc in current_settings.modeswitches) and
- try_to_consume(_ASSIGNMENT)) or
- try_to_consume(_EQ)
- ) then
- begin
- oldlocalswitches:=current_settings.localswitches;
- include(current_settings.localswitches,cs_allow_enum_calc);
- p:=comp_expr(true,false);
- current_settings.localswitches:=oldlocalswitches;
- if (p.nodetype=ordconstn) then
- begin
- { we expect an integer or an enum of the
- same type }
- if is_integer(p.resultdef) or
- is_char(p.resultdef) or
- equal_defs(p.resultdef,aktenumdef) then
- v:=tordconstnode(p).value
- else
- IncompatibleTypes(p.resultdef,s32inttype);
- end
- else
- Message(parser_e_illegal_expression);
- p.free;
- { please leave that a note, allows type save }
- { declarations in the win32 units ! }
- if (not first) and (v<=l) and (not enumdupmsg) then
- begin
- Message(parser_n_duplicate_enum);
- enumdupmsg:=true;
- end;
- l:=v;
- end
- else
- inc(l.svalue);
- first:=false;
- { don't generate enum members is this is a specialization because aktenumdef is copied from the generic type }
- if not is_specialize then
- begin
- storepos:=current_tokenpos;
- current_tokenpos:=defpos;
- tenumsymtable(aktenumdef.symtable).insert(tenumsym.create(s,aktenumdef,longint(l.svalue)));
- if not (cs_scopedenums in current_settings.localswitches) then
- tstoredsymtable(aktenumdef.owner).insert(tenumsym.create(s,aktenumdef,longint(l.svalue)));
- current_tokenpos:=storepos;
- end;
- until not try_to_consume(_COMMA);
- def:=aktenumdef;
- consume(_RKLAMMER);
- {$ifdef jvm}
- jvm_maybe_create_enum_class(name,def);
- {$endif}
- end;
- _ARRAY:
- begin
- array_dec(false,genericdef,genericlist);
- end;
- _SET:
- begin
- set_dec;
- end;
- _CARET:
- begin
- consume(_CARET);
- single_type(tt2,
- SingleTypeOptionsInTypeBlock[block_type=bt_type]+
- SingleTypeOptionsIsDelphi[m_delphi in current_settings.modeswitches]
- );
- { in case of e.g. var or const sections we need to especially
- check that we don't use a generic dummy symbol }
- if (block_type<>bt_type) and
- (tt2.typ=undefineddef) and
- assigned(tt2.typesym) and
- (sp_generic_dummy in tt2.typesym.symoptions) then
- Message(parser_e_no_generics_as_types);
- { don't use getpointerdef() here, since this is a type
- declaration (-> must create new typedef) }
- def:=tpointerdef.create(tt2);
- if tt2.typ=forwarddef then
- current_module.checkforwarddefs.add(def);
- end;
- _RECORD:
- begin
- consume(token);
- if (idtoken=_HELPER) and (m_advanced_records in current_settings.modeswitches) then
- begin
- consume(_HELPER);
- def:=object_dec(odt_helper,name,newsym,genericdef,genericlist,nil,ht_record);
- end
- else
- def:=record_dec(name,genericdef,genericlist);
- end;
- _PACKED,
- _BITPACKED:
- begin
- bitpacking :=
- (cs_bitpacking in current_settings.localswitches) or
- (token = _BITPACKED);
- consume(token);
- if token=_ARRAY then
- array_dec(bitpacking,genericdef,genericlist)
- else if token=_SET then
- set_dec
- else if token=_FILE then
- single_type(def,[stoAllowTypeDef])
- else
- begin
- oldpackrecords:=current_settings.packrecords;
- if (not bitpacking) or
- (token in [_CLASS,_OBJECT]) then
- current_settings.packrecords:=1
- else
- current_settings.packrecords:=bit_alignment;
- case token of
- _CLASS :
- begin
- consume(_CLASS);
- def:=object_dec(odt_class,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _OBJECT :
- begin
- consume(_OBJECT);
- def:=object_dec(odt_object,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- else begin
- consume(_RECORD);
- def:=record_dec(name,genericdef,genericlist);
- end;
- end;
- current_settings.packrecords:=oldpackrecords;
- end;
- end;
- _DISPINTERFACE :
- begin
- { need extra check here since interface is a keyword
- in all pascal modes }
- if not(m_class in current_settings.modeswitches) then
- Message(parser_f_need_objfpc_or_delphi_mode);
- consume(token);
- def:=object_dec(odt_dispinterface,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _CLASS :
- begin
- consume(token);
- { Delphi only allows class of in type blocks }
- if (token=_OF) and
- (
- not(m_delphi in current_settings.modeswitches) or
- (block_type=bt_type)
- ) then
- begin
- consume(_OF);
- single_type(hdef,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
- if is_class(hdef) or
- is_objcclass(hdef) or
- is_javaclass(hdef) then
- def:=tclassrefdef.create(hdef)
- else
- if hdef.typ=forwarddef then
- begin
- def:=tclassrefdef.create(hdef);
- current_module.checkforwarddefs.add(def);
- end
- else
- Message1(type_e_class_or_objcclass_type_expected,hdef.typename);
- end
- else
- if (idtoken=_HELPER) then
- begin
- consume(_HELPER);
- def:=object_dec(odt_helper,name,newsym,genericdef,genericlist,nil,ht_class);
- end
- else
- def:=object_dec(default_class_type,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _CPPCLASS :
- begin
- consume(token);
- def:=object_dec(odt_cppclass,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _OBJCCLASS :
- begin
- if not(m_objectivec1 in current_settings.modeswitches) then
- Message(parser_f_need_objc);
- consume(token);
- def:=object_dec(odt_objcclass,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _INTERFACE :
- begin
- { need extra check here since interface is a keyword
- in all pascal modes }
- if not(m_class in current_settings.modeswitches) then
- Message(parser_f_need_objfpc_or_delphi_mode);
- consume(token);
- case current_settings.interfacetype of
- it_interfacecom:
- def:=object_dec(odt_interfacecom,name,newsym,genericdef,genericlist,nil,ht_none);
- it_interfacecorba:
- def:=object_dec(odt_interfacecorba,name,newsym,genericdef,genericlist,nil,ht_none);
- it_interfacejava:
- def:=object_dec(odt_interfacejava,name,newsym,genericdef,genericlist,nil,ht_none);
- else
- internalerror(2010122612);
- end;
- end;
- _OBJCPROTOCOL :
- begin
- if not(m_objectivec1 in current_settings.modeswitches) then
- Message(parser_f_need_objc);
- consume(token);
- def:=object_dec(odt_objcprotocol,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _OBJCCATEGORY :
- begin
- if not(m_objectivec1 in current_settings.modeswitches) then
- Message(parser_f_need_objc);
- consume(token);
- def:=object_dec(odt_objccategory,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _OBJECT :
- begin
- consume(token);
- def:=object_dec(odt_object,name,newsym,genericdef,genericlist,nil,ht_none);
- end;
- _PROCEDURE,
- _FUNCTION:
- begin
- def:=procvar_dec(genericdef,genericlist);
- {$ifdef jvm}
- jvm_create_procvar_class(name,def);
- {$endif}
- end;
- else
- if (token=_KLAMMERAFFE) and (m_iso in current_settings.modeswitches) then
- begin
- consume(_KLAMMERAFFE);
- single_type(tt2,SingleTypeOptionsInTypeBlock[block_type=bt_type]);
- def:=tpointerdef.create(tt2);
- if tt2.typ=forwarddef then
- current_module.checkforwarddefs.add(def);
- end
- else
- if hadtypetoken and
- { don't allow "type helper" in mode delphi and require modeswitch class }
- ([m_delphi,m_class]*current_settings.modeswitches=[m_class]) and
- (token=_ID) and (idtoken=_HELPER) then
- begin
- consume(_HELPER);
- def:=object_dec(odt_helper,name,newsym,genericdef,genericlist,nil,ht_type);
- end
- else
- expr_type;
- end;
- if def=nil then
- def:=generrordef;
- end;
- procedure read_anon_type(var def : tdef;parseprocvardir:boolean);
- begin
- read_named_type(def,nil,nil,nil,parseprocvardir,false);
- end;
- procedure write_persistent_type_info(st:tsymtable;is_global:boolean);
- var
- i : longint;
- def : tdef;
- vmtwriter : TVMTWriter;
- begin
- {$ifdef jvm}
- { no Delphi-style RTTI }
- exit;
- {$endif jvm}
- for i:=0 to st.DefList.Count-1 do
- begin
- def:=tdef(st.DefList[i]);
- case def.typ of
- recorddef :
- write_persistent_type_info(trecorddef(def).symtable,is_global);
- objectdef :
- begin
- { Skip generics and forward defs }
- if ([df_generic,df_genconstraint]*def.defoptions<>[]) or
- (oo_is_forward in tobjectdef(def).objectoptions) then
- continue;
- write_persistent_type_info(tobjectdef(def).symtable,is_global);
- { Write also VMT if not done yet }
- if not(ds_vmt_written in def.defstates) then
- begin
- vmtwriter:=TVMTWriter.create(tobjectdef(def));
- if is_interface(tobjectdef(def)) then
- vmtwriter.writeinterfaceids;
- if (oo_has_vmt in tobjectdef(def).objectoptions) then
- vmtwriter.writevmt;
- vmtwriter.free;
- include(def.defstates,ds_vmt_written);
- end;
- end;
- procdef :
- begin
- if assigned(tprocdef(def).localst) and
- (tprocdef(def).localst.symtabletype=localsymtable) then
- write_persistent_type_info(tprocdef(def).localst,false);
- if assigned(tprocdef(def).parast) then
- write_persistent_type_info(tprocdef(def).parast,false);
- end;
- end;
- { generate always persistent tables for types in the interface so it can
- be reused in other units and give always the same pointer location. }
- { Init }
- if (
- assigned(def.typesym) and
- is_global and
- not is_objc_class_or_protocol(def)
- ) or
- is_managed_type(def) or
- (ds_init_table_used in def.defstates) then
- RTTIWriter.write_rtti(def,initrtti);
- { RTTI }
- if (
- assigned(def.typesym) and
- is_global and
- not is_objc_class_or_protocol(def)
- ) or
- (ds_rtti_table_used in def.defstates) then
- RTTIWriter.write_rtti(def,fullrtti);
- end;
- end;
- procedure add_typedconst_init_routine(def: tabstractrecorddef);
- var
- sstate: tscannerstate;
- pd: tprocdef;
- begin
- replace_scanner('tcinit_routine',sstate);
- { the typed constant initialization code is called from the class
- constructor by tnodeutils.wrap_proc_body; at this point, we don't
- know yet whether that will be necessary, because there may be
- typed constants inside method bodies -> always force the addition
- of a class constructor.
- We cannot directly add the typed constant initialisations to the
- class constructor, because when it's parsed not all method bodies
- are necessarily already parsed }
- pd:=def.find_procdef_bytype(potype_class_constructor);
- { the class constructor }
- if not assigned(pd) then
- begin
- if str_parse_method_dec('constructor fpc_init_typed_consts_class_constructor;',potype_class_constructor,true,def,pd) then
- pd.synthetickind:=tsk_empty
- else
- internalerror(2011040206);
- end;
- { the initialisation helper }
- if str_parse_method_dec('procedure fpc_init_typed_consts_helper; static;',potype_procedure,true,def,pd) then
- pd.synthetickind:=tsk_tcinit
- else
- internalerror(2011040207);
- restore_scanner(sstate);
- end;
- end.