diff options
Diffstat (limited to 'closures/compiler/symdef.pas')
| -rw-r--r-- | closures/compiler/symdef.pas | 5947 |
1 files changed, 5947 insertions, 0 deletions
diff --git a/closures/compiler/symdef.pas b/closures/compiler/symdef.pas new file mode 100644 index 0000000000..6b9852fc52 --- /dev/null +++ b/closures/compiler/symdef.pas @@ -0,0 +1,5947 @@ +{ + Symbol table implementation for the definitions + + Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller + + 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 symdef; + +{$i fpcdefs.inc} + +interface + + uses + { common } + cclasses, + { global } + globtype,globals,tokens,constexp, + { symtable } + symconst,symbase,symtype, + { ppu } + ppu, + { node } + node, + { aasm } + aasmbase,aasmtai,aasmdata, + cpubase,cpuinfo, + cgbase,cgutils, + parabase + ; + + + type +{************************************************ + TDef +************************************************} + + { tstoreddef } + + tstoreddef = class(tdef) + protected + typesymderef : tderef; + public +{$ifdef EXTDEBUG} + fileinfo : tfileposinfo; +{$endif} + { generic support } + genericdef : tstoreddef; + genericdefderef : tderef; + generictokenbuf : tdynamicarray; + { Set if PPU was generated with another + endianess as current compiler or ppudump utils } + change_endian : boolean; + constructor create(dt:tdeftyp); + constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + destructor destroy;override; + function getcopy : tstoreddef;virtual; + procedure ppuwrite(ppufile:tcompilerppufile);virtual; + procedure buildderef;override; + procedure buildderefimpl;override; + procedure deref;override; + procedure derefimpl;override; + function size:asizeint;override; + function getvardef:longint;override; + function alignment:shortint;override; + function is_publishable : boolean;override; + function needs_inittable : boolean;override; + function rtti_mangledname(rt:trttitype):string;override; + function OwnerHierarchyName: string; override; + function in_currentunit: boolean; + { regvars } + function is_intregable : boolean; + function is_fpuregable : boolean; + { generics } + procedure initgeneric; + private + savesize : asizeuint; + end; + + tfiletyp = (ft_text,ft_typed,ft_untyped); + + tfiledef = class(tstoreddef) + filetyp : tfiletyp; + typedfiledef : tdef; + typedfiledefderef : tderef; + constructor createtext; + constructor createuntyped; + constructor createtyped(def : tdef); + constructor ppuload(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure deref;override; + function GetTypeName:string;override; + function getmangledparaname:string;override; + procedure setsize; + end; + + tvariantdef = class(tstoreddef) + varianttype : tvarianttype; + constructor create(v : tvarianttype); + constructor ppuload(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + function GetTypeName:string;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function getvardef:longint;override; + procedure setsize; + function is_publishable : boolean;override; + function needs_inittable : boolean;override; + end; + + tformaldef = class(tstoreddef) + typed:boolean; + constructor create(Atyped:boolean); + constructor ppuload(ppufile:tcompilerppufile); + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + end; + + tforwarddef = class(tstoreddef) + tosymname : pshortstring; + forwardpos : tfileposinfo; + constructor create(const s:string;const pos:tfileposinfo); + destructor destroy;override; + function getcopy:tstoreddef;override; + function GetTypeName:string;override; + end; + + tundefineddef = class(tstoreddef) + constructor create; + constructor ppuload(ppufile:tcompilerppufile); + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + end; + + terrordef = class(tstoreddef) + constructor create; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + function getmangledparaname : string;override; + end; + + tabstractpointerdef = class(tstoreddef) + pointeddef : tdef; + pointeddefderef : tderef; + constructor create(dt:tdeftyp;def:tdef); + constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure deref;override; + end; + + tpointerdef = class(tabstractpointerdef) + is_far : boolean; + has_pointer_math : boolean; + constructor create(def:tdef); + constructor createfar(def:tdef); + function getcopy:tstoreddef;override; + constructor ppuload(ppufile:tcompilerppufile); + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + end; + + tprocdef = class; + { tabstractrecorddef } + + tabstractrecorddef= class(tstoreddef) + objname, + objrealname : PShortString; + symtable : TSymtable; + cloneddef : tabstractrecorddef; + cloneddefderef : tderef; + objectoptions : tobjectoptions; + constructor create(const n:string; dt:tdeftyp); + constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + procedure ppuwrite(ppufile:tcompilerppufile);override; + destructor destroy; override; + procedure check_forwards; virtual; + function find_procdef_bytype(pt:tproctypeoption): tprocdef; + function GetSymtable(t:tGetSymtable):TSymtable;override; + function is_packed:boolean; + function RttiName: string; + { enumerator support } + function search_enumerator_get: tprocdef; virtual; + function search_enumerator_move: tprocdef; virtual; + function search_enumerator_current: tsym; virtual; + end; + + trecorddef = class(tabstractrecorddef) + public + isunion : boolean; + constructor create(const n:string; p:TSymtable); + constructor ppuload(ppufile:tcompilerppufile); + destructor destroy;override; + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure deref;override; + function size:asizeint;override; + function alignment : shortint;override; + function padalignment: shortint; + function GetTypeName:string;override; + { debug } + function needs_inittable : boolean;override; + end; + + tobjectdef = class; + + { TImplementedInterface } + + TImplementedInterface = class + IntfDef : tobjectdef; + IntfDefDeref : tderef; + IType : tinterfaceentrytype; + IOffset : longint; + VtblImplIntf : TImplementedInterface; + NameMappings : TFPHashList; + ProcDefs : TFPObjectList; + ImplementsGetter : tsym; + constructor create(aintf: tobjectdef); + constructor create_deref(d:tderef); + destructor destroy; override; + function getcopy:TImplementedInterface; + procedure buildderef; + procedure deref; + procedure AddMapping(const origname, newname: string); + function GetMapping(const origname: string):string; + procedure AddImplProc(pd:tprocdef); + function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean; + end; + + { tvmtentry } + tvmtentry = record + procdef : tprocdef; + procdefderef : tderef; + visibility : tvisibility; + end; + pvmtentry = ^tvmtentry; + + { tobjectdef } + + tvmcallstatic = (vmcs_default, vmcs_yes, vmcs_no, vmcs_unreachable); + pmvcallstaticinfo = ^tmvcallstaticinfo; + tmvcallstaticinfo = array[0..1024*1024-1] of tvmcallstatic; + tobjectdef = class(tabstractrecorddef) + private + fcurrent_dispid: longint; + public + dwarf_struct_lab : tasmsymbol; + childof : tobjectdef; + childofderef : tderef; + + { for Object Pascal helpers } + extendeddef : tdef; + extendeddefderef: tderef; + { for C++ classes: name of the library this class is imported from } + import_lib, + { for Objective-C: protocols and classes can have the same name there } + objextname : pshortstring; + { to be able to have a variable vmt position } + { and no vmt field for objects without virtuals } + vmtentries : TFPList; + vmcallstaticinfo : pmvcallstaticinfo; + vmt_offset : longint; + iidguid : pguid; + iidstr : pshortstring; + { store implemented interfaces defs and name mappings } + ImplementedInterfaces : TFPObjectList; + writing_class_record_dbginfo, + { a class of this type has been created in this module } + created_in_current_module, + { a loadvmtnode for this class has been created in this + module, so if a classrefdef variable of this or a parent + class is used somewhere to instantiate a class, then this + class may be instantiated + } + maybe_created_in_current_module, + { a "class of" this particular class has been created in + this module + } + classref_created_in_current_module : boolean; + objecttype : tobjecttyp; + constructor create(ot:tobjecttyp;const n:string;c:tobjectdef); + constructor ppuload(ppufile:tcompilerppufile); + destructor destroy;override; + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + procedure buildderef;override; + procedure deref;override; + procedure buildderefimpl;override; + procedure derefimpl;override; + procedure resetvmtentries; + procedure copyvmtentries(objdef:tobjectdef); + function getparentdef:tdef;override; + function size : asizeint;override; + function alignment:shortint;override; + function vmtmethodoffset(index:longint):longint; + function members_need_inittable : boolean; + function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface; + { this should be called when this class implements an interface } + procedure prepareguid; + function is_publishable : boolean;override; + function is_related(d : tdef) : boolean;override; + function needs_inittable : boolean;override; + function rtti_mangledname(rt:trttitype):string;override; + function vmt_mangledname : string; + procedure check_forwards; override; + procedure insertvmt; + procedure set_parent(c : tobjectdef); + function find_destructor: tprocdef; + function implements_any_interfaces: boolean; + { dispinterface support } + function get_next_dispid: longint; + { enumerator support } + function search_enumerator_get: tprocdef; override; + function search_enumerator_move: tprocdef; override; + function search_enumerator_current: tsym; override; + { WPO } + procedure register_created_object_type;override; + procedure register_maybe_created_object_type; + procedure register_created_classref_type; + procedure register_vmt_call(index:longint); + { ObjC } + procedure finish_objc_data; + function check_objc_types: boolean; + { C++ } + procedure finish_cpp_data; + end; + + tclassrefdef = class(tabstractpointerdef) + constructor create(def:tdef); + constructor ppuload(ppufile:tcompilerppufile); + procedure ppuwrite(ppufile:tcompilerppufile);override; + function getcopy:tstoreddef;override; + function GetTypeName:string;override; + function is_publishable : boolean;override; + function rtti_mangledname(rt:trttitype):string;override; + procedure register_created_object_type;override; + end; + + tarraydef = class(tstoreddef) + lowrange, + highrange : asizeint; + rangedef : tdef; + rangedefderef : tderef; + arrayoptions : tarraydefoptions; + symtable : TSymtable; + protected + _elementdef : tdef; + _elementdefderef : tderef; + procedure setelementdef(def:tdef); + public + function elesize : asizeint; + function elepackedbitsize : asizeint; + function elecount : asizeuint; + constructor create_from_pointer(def:tdef); + constructor create(l,h:asizeint;def:tdef); + constructor ppuload(ppufile:tcompilerppufile); + destructor destroy; override; + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + function getmangledparaname : string;override; + procedure buildderef;override; + procedure deref;override; + function size : asizeint;override; + function alignment : shortint;override; + { returns the label of the range check string } + function needs_inittable : boolean;override; + property elementdef : tdef read _elementdef write setelementdef; + function is_publishable : boolean;override; + end; + + torddef = class(tstoreddef) + low,high : TConstExprInt; + ordtype : tordtype; + constructor create(t : tordtype;v,b : TConstExprInt); + constructor ppuload(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function is_publishable : boolean;override; + function GetTypeName:string;override; + function alignment:shortint;override; + procedure setsize; + function packedbitsize: asizeint; override; + function getvardef : longint;override; + end; + + tfloatdef = class(tstoreddef) + floattype : tfloattype; + constructor create(t : tfloattype); + constructor ppuload(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + function is_publishable : boolean;override; + function alignment:shortint;override; + procedure setsize; + function getvardef:longint;override; + end; + + { tabstractprocdef } + + tabstractprocdef = class(tstoreddef) + { saves a definition to the return type } + returndef : tdef; + returndefderef : tderef; + parast : TSymtable; + paras : tparalist; + proctypeoption : tproctypeoption; + proccalloption : tproccalloption; + procoptions : tprocoptions; + callerargareasize, + calleeargareasize: pint; +{$ifdef m68k} + exp_funcretloc : tregister; { explicit funcretloc for AmigaOS } +{$endif} + funcretloc : array[tcallercallee] of TCGPara; + has_paraloc_info : tcallercallee; { paraloc info is available } + { number of user visible parameters } + maxparacount, + minparacount : byte; + constructor create(dt:tdeftyp;level:byte); + constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + destructor destroy;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure deref;override; + procedure calcparas; + function typename_paras(showhidden:boolean): string; + function is_methodpointer:boolean;virtual; + function is_addressonly:boolean;virtual; + function no_self_node:boolean; + procedure check_mark_as_nested; + procedure init_paraloc_info(side: tcallercallee); + function stack_tainting_parameter(side: tcallercallee): boolean; + private + procedure count_para(p:TObject;arg:pointer); + procedure insert_para(p:TObject;arg:pointer); + end; + + tprocvardef = class(tabstractprocdef) + constructor create(level:byte); + constructor ppuload(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetSymtable(t:tGetSymtable):TSymtable;override; + function size : asizeint;override; + function GetTypeName:string;override; + function is_publishable : boolean;override; + function is_methodpointer:boolean;override; + function is_addressonly:boolean;override; + function getmangledparaname:string;override; + end; + + tmessageinf = record + case integer of + 0 : (str : pshortstring); + 1 : (i : longint); + end; + + tinlininginfo = record + { node tree } + code : tnode; + flags : tprocinfoflags; + end; + pinlininginfo = ^tinlininginfo; + + +{$ifdef oldregvars} + { register variables } + pregvarinfo = ^tregvarinfo; + tregvarinfo = record + regvars : array[1..maxvarregs] of tsym; + regvars_para : array[1..maxvarregs] of boolean; + regvars_refs : array[1..maxvarregs] of longint; + + fpuregvars : array[1..maxfpuvarregs] of tsym; + fpuregvars_para : array[1..maxfpuvarregs] of boolean; + fpuregvars_refs : array[1..maxfpuvarregs] of longint; + end; +{$endif oldregvars} + + { tprocdef } + + tprocdef = class(tabstractprocdef) + private + _mangledname : pshortstring; + public + messageinf : tmessageinf; + dispid : longint; +{$ifndef EXTDEBUG} + { where is this function defined and what were the symbol + flags, needed here because there + is only one symbol for all overloaded functions + EXTDEBUG has fileinfo in tdef (PFV) } + fileinfo : tfileposinfo; +{$endif} + symoptions : tsymoptions; + deprecatedmsg : pshortstring; + { symbol owning this definition } + procsym : tsym; + procsymderef : tderef; + { alias names } + aliasnames : TCmdStrList; + { symtables } + localst : TSymtable; + funcretsym : tsym; + funcretsymderef : tderef; + struct : tabstractrecorddef; + structderef : tderef; +{$if defined(powerpc) or defined(m68k)} + { library symbol for AmigaOS/MorphOS } + libsym : tsym; + libsymderef : tderef; +{$endif powerpc or m68k} + { name of the result variable to insert in the localsymtable } + resultname : pshortstring; + { import info } + import_dll, + import_name : pshortstring; + { info for inlining the subroutine, if this pointer is nil, + the procedure can't be inlined } + inlininginfo : pinlininginfo; +{$ifdef oldregvars} + regvarinfo: pregvarinfo; +{$endif oldregvars} + { interrupt vector } + interruptvector : longint; + { First/last assembler symbol/instruction in aasmoutput list. + Note: initialised after compiling the code for the procdef, but + not saved to/restored from ppu. Used when inserting debug info } + procstarttai, + procendtai : tai; + import_nr : word; + extnumber : word; +{$ifdef i386} + fpu_used : byte; +{$endif i386} + visibility : tvisibility; + { true, if the procedure is only declared + (forward procedure) } + forwarddef, + { true if the procedure is declared in the interface } + interfacedef : boolean; + { true if the procedure has a forward declaration } + hasforward : boolean; + constructor create(level:byte); + constructor ppuload(ppufile:tcompilerppufile); + destructor destroy;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure buildderefimpl;override; + procedure deref;override; + procedure derefimpl;override; + function GetSymtable(t:tGetSymtable):TSymtable;override; + function GetTypeName : string;override; + function mangledname : string; + procedure setmangledname(const s : string); + function fullprocname(showhidden:boolean):string; + function cplusplusmangledname : string; + function objcmangledname : string; + function is_methodpointer:boolean;override; + function is_addressonly:boolean;override; + procedure make_external; + end; + + { single linked list of overloaded procs } + pprocdeflist = ^tprocdeflist; + tprocdeflist = record + def : tprocdef; + defderef : tderef; + next : pprocdeflist; + end; + + tstringdef = class(tstoreddef) + encoding : tstringencoding; + stringtype : tstringtype; + len : asizeint; + constructor createshort(l : byte); + constructor loadshort(ppufile:tcompilerppufile); + constructor createlong(l : asizeint); + constructor loadlong(ppufile:tcompilerppufile); + constructor createansi(aencoding:tstringencoding); + constructor loadansi(ppufile:tcompilerppufile); + constructor createwide; + constructor loadwide(ppufile:tcompilerppufile); + constructor createunicode; + constructor loadunicode(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + function stringtypname:string; + procedure ppuwrite(ppufile:tcompilerppufile);override; + function GetTypeName:string;override; + function getmangledparaname:string;override; + function is_publishable : boolean;override; + function alignment : shortint;override; + function needs_inittable : boolean;override; + function getvardef:longint;override; + end; + + { tenumdef } + + tenumdef = class(tstoreddef) + minval, + maxval : asizeint; + basedef : tenumdef; + basedefderef : tderef; + symtable : TSymtable; + has_jumps : boolean; + constructor create; + constructor create_subrange(_basedef:tenumdef;_min,_max:asizeint); + constructor ppuload(ppufile:tcompilerppufile); + destructor destroy;override; + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure deref;override; + function GetTypeName:string;override; + function is_publishable : boolean;override; + procedure calcsavesize; + function packedbitsize: asizeint; override; + procedure setmax(_max:asizeint); + procedure setmin(_min:asizeint); + function min:asizeint; + function max:asizeint; + function getfirstsym:tsym; + end; + + tsetdef = class(tstoreddef) + elementdef : tdef; + elementdefderef : tderef; + setbase, + setmax : aword; + constructor create(def:tdef;low, high : asizeint); + constructor ppuload(ppufile:tcompilerppufile); + function getcopy : tstoreddef;override; + procedure ppuwrite(ppufile:tcompilerppufile);override; + procedure buildderef;override; + procedure deref;override; + function GetTypeName:string;override; + function is_publishable : boolean;override; + end; + + tdefawaresymtablestack = class(TSymtablestack) + private + procedure addhelpers(st: TSymtable); + procedure removehelpers(st: TSymtable); + public + procedure push(st: TSymtable); override; + procedure pop(st: TSymtable); override; + end; + + var + current_structdef: tabstractrecorddef; { used for private functions check !! } + current_genericdef: tstoreddef; { used to reject declaration of generic class inside generic class } + current_specializedef: tstoreddef; { used to implement usage of generic class in itself } + + { default types } + generrordef, { error in definition } + voidpointertype, { pointer for Void-pointeddef } + charpointertype, { pointer for Char-pointeddef } + widecharpointertype, { pointer for WideChar-pointeddef } + voidfarpointertype, + cundefinedtype, + cformaltype, { unique formal definition } + ctypedformaltype, { unique typed formal definition } + voidtype, { Void (procedure) } + cchartype, { Char } + cwidechartype, { WideChar } + pasbool8type, { boolean type } + pasbool16type, + pasbool32type, + pasbool64type, + bool8type, + bool16type, + bool32type, + bool64type, { implement me } + u8inttype, { 8-Bit unsigned integer } + s8inttype, { 8-Bit signed integer } + u16inttype, { 16-Bit unsigned integer } + s16inttype, { 16-Bit signed integer } + u32inttype, { 32-Bit unsigned integer } + s32inttype, { 32-Bit signed integer } + u64inttype, { 64-bit unsigned integer } + s64inttype, { 64-bit signed integer } + s32floattype, { 32 bit floating point number } + s64floattype, { 64 bit floating point number } + s80floattype, { 80 bit floating point number } + sc80floattype, { 80 bit floating point number but stored like in C } + s64currencytype, { pointer to a currency type } + cshortstringtype, { pointer to type of short string const } + clongstringtype, { pointer to type of long string const } + cansistringtype, { pointer to type of ansi string const } + cwidestringtype, { pointer to type of wide string const } + cunicodestringtype, + openshortstringtype, { pointer to type of an open shortstring, + needed for readln() } + openchararraytype, { pointer to type of an open array of char, + needed for readln() } + cfiletype, { get the same definition for all file } + { used for stabs } + methodpointertype, { typecasting of methodpointers to extract self } + hresultdef, + { we use only one variant def for every variant class } + cvarianttype, + colevarianttype, + { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems } + sinttype, + uinttype, + { unsigned and signed ord type with the same size as a pointer } + ptruinttype, + ptrsinttype, + { several types to simulate more or less C++ objects for GDB } + vmttype, + vmtarraytype, + pvmttype : tdef; { type of classrefs, used for stabs } + + { pointer to the anchestor of all classes } + class_tobject : tobjectdef; + { pointer to the ancestor of all COM interfaces } + interface_iunknown : tobjectdef; + { pointer to the ancestor of all dispinterfaces } + interface_idispatch : tobjectdef; + { pointer to the TGUID type + of all interfaces } + rec_tguid : trecorddef; + + { pointer to jump buffer } + rec_jmp_buf : trecorddef; + + { Objective-C base types } + objc_metaclasstype, + objc_superclasstype, + objc_idtype, + objc_seltype : tpointerdef; + objc_objecttype : trecorddef; + { base type of @protocol(protocolname) Objective-C statements } + objc_protocoltype : tobjectdef; + { helper types for for-in "fast enumeration" support in Objective-C 2.0 } + objc_fastenumeration : tobjectdef; + objc_fastenumerationstate : trecorddef; + + const +{$ifdef i386} + pbestrealtype : ^tdef = @s80floattype; +{$endif} +{$ifdef x86_64} + pbestrealtype : ^tdef = @s80floattype; +{$endif} +{$ifdef m68k} + pbestrealtype : ^tdef = @s64floattype; +{$endif} +{$ifdef alpha} + pbestrealtype : ^tdef = @s64floattype; +{$endif} +{$ifdef powerpc} + pbestrealtype : ^tdef = @s64floattype; +{$endif} +{$ifdef POWERPC64} + pbestrealtype : ^tdef = @s64floattype; +{$endif} +{$ifdef ia64} + pbestrealtype : ^tdef = @s64floattype; +{$endif} +{$ifdef SPARC} + pbestrealtype : ^tdef = @s64floattype; +{$endif SPARC} +{$ifdef vis} + pbestrealtype : ^tdef = @s64floattype; +{$endif vis} +{$ifdef ARM} + pbestrealtype : ^tdef = @s64floattype; +{$endif ARM} +{$ifdef MIPS} + pbestrealtype : ^tdef = @s64floattype; +{$endif MIPS} +{$ifdef AVR} + pbestrealtype : ^tdef = @s64floattype; +{$endif AVR} + + function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string; + function make_dllmangledname(const dllname,importname:string; + import_nr : word; pco : tproccalloption):string; + + { should be in the types unit, but the types unit uses the node stuff :( } + function is_interfacecom(def: tdef): boolean; + function is_interfacecom_or_dispinterface(def: tdef): boolean; + function is_interfacecorba(def: tdef): boolean; + function is_interface(def: tdef): boolean; + function is_dispinterface(def: tdef): boolean; + function is_object(def: tdef): boolean; + function is_class(def: tdef): boolean; + function is_cppclass(def: tdef): boolean; + function is_objectpascal_helper(def: tdef): boolean; + function is_objcclass(def: tdef): boolean; + function is_objcclassref(def: tdef): boolean; + function is_objcprotocol(def: tdef): boolean; + function is_objccategory(def: tdef): boolean; + function is_objc_class_or_protocol(def: tdef): boolean; + function is_objc_protocol_or_category(def: tdef): boolean; + function is_classhelper(def: tdef): boolean; + function is_class_or_interface(def: tdef): boolean; + function is_class_or_interface_or_objc(def: tdef): boolean; + function is_class_or_interface_or_object(def: tdef): boolean; + function is_class_or_interface_or_dispinterface(def: tdef): boolean; + function is_implicit_pointer_object_type(def: tdef): boolean; + function is_class_or_object(def: tdef): boolean; + function is_record(def: tdef): boolean; + + procedure loadobjctypes; + procedure maybeloadcocoatypes; + + function use_vectorfpu(def : tdef) : boolean; + + function getansistringcodepage:tstringencoding; inline; + function getansistringdef:tstringdef; inline; + function getparaencoding(def:tdef):tstringencoding; inline; + +implementation + + uses + SysUtils, + cutils, + { global } + verbose, + { target } + systems,aasmcpu,paramgr, + { symtable } + symsym,symtable,symutil,defutil,objcdef, + { module } + fmodule, + { other } + gendef, + fpccrc + ; + +{**************************************************************************** + Helpers +****************************************************************************} + + function getansistringcodepage:tstringencoding; inline; + begin + if cs_explicit_codepage in current_settings.moduleswitches then + result:=current_settings.sourcecodepage + else + result:=0; + end; + + function getansistringdef:tstringdef; inline; + var + symtable:tsymtable; + begin + { if codepage is explicitly defined in this mudule we need to return + a replacement for ansistring def } + if cs_explicit_codepage in current_settings.moduleswitches then + begin + if not assigned(current_module) then + internalerror(2011101301); + { codepage can be redeclared only once per unit so we don't need a list of + redefined ansistring but only one pointer } + if not assigned(current_module.ansistrdef) then + begin + { if we did not create it yet we need to do this now } + if current_module.is_unit then + symtable:=current_module.globalsymtable + else + symtable:=current_module.localsymtable; + symtablestack.push(symtable); + current_module.ansistrdef:=tstringdef.createansi(current_settings.sourcecodepage); + symtablestack.pop(symtable); + end; + result:=tstringdef(current_module.ansistrdef); + end + else + result:=tstringdef(cansistringtype); + end; + + function getparaencoding(def:tdef):tstringencoding; inline; + begin + { don't pass CP_NONE encoding to internal functions + they expect 0 encoding instead } + result:=tstringdef(def).encoding; + if result=CP_NONE then + result:=0 + end; + + function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string; + var + s,hs, + prefix : string; + oldlen, + newlen, + i : longint; + crc : dword; + hp : tparavarsym; + begin + prefix:=''; + if not assigned(st) then + internalerror(200204212); + { sub procedures } + while (st.symtabletype=localsymtable) do + begin + if st.defowner.typ<>procdef then + internalerror(200204173); + { Add the full mangledname of procedure to prevent + conflicts with 2 overloads having both a nested procedure + with the same name, see tb0314 (PFV) } + s:=tprocdef(st.defowner).procsym.name; + oldlen:=length(s); + for i:=0 to tprocdef(st.defowner).paras.count-1 do + begin + hp:=tparavarsym(tprocdef(st.defowner).paras[i]); + if not(vo_is_hidden_para in hp.varoptions) then + s:=s+'$'+hp.vardef.mangledparaname; + end; + if not is_void(tprocdef(st.defowner).returndef) then + s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname; + newlen:=length(s); + { Replace with CRC if the parameter line is very long } + if (newlen-oldlen>12) and + ((newlen+length(prefix)>100) or (newlen-oldlen>32)) then + begin + crc:=0; + for i:=0 to tprocdef(st.defowner).paras.count-1 do + begin + hp:=tparavarsym(tprocdef(st.defowner).paras[i]); + if not(vo_is_hidden_para in hp.varoptions) then + begin + hs:=hp.vardef.mangledparaname; + crc:=UpdateCrc32(crc,hs[1],length(hs)); + end; + end; + hs:=hp.vardef.mangledparaname; + crc:=UpdateCrc32(crc,hs[1],length(hs)); + s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8); + end; + if prefix<>'' then + prefix:=s+'_'+prefix + else + prefix:=s; + if length(prefix)>100 then + begin + crc:=0; + crc:=UpdateCrc32(crc,prefix[1],length(prefix)); + prefix:='$CRC'+hexstr(crc,8); + end; + st:=st.defowner.owner; + end; + { object/classes symtable, nested type definitions in classes require the while loop } + while st.symtabletype in [ObjectSymtable,recordsymtable] do + begin + if not (st.defowner.typ in [objectdef,recorddef]) then + internalerror(200204174); + prefix:=tabstractrecorddef(st.defowner).objname^+'_$_'+prefix; + st:=st.defowner.owner; + end; + { symtable must now be static or global } + if not(st.symtabletype in [staticsymtable,globalsymtable]) then + internalerror(200204175); + + { The mangled name is made out of at most 4 parts: + 1) Optional typeprefix given as first parameter + with '_$' appended if not empty + 2) Unit name or 'P$'+program name (never empty) + 3) optional prefix variable that contains a unique + name for the local symbol table (prepended with '$_$' + if not empty) + 4) suffix as given as third parameter, + also optional (i.e. can be empty) + prepended by '_$$_' if not empty } + result:=''; + if typeprefix<>'' then + result:=result+typeprefix+'_$'; + { Add P$ for program, which can have the same name as + a unit } + if (TSymtable(main_module.localsymtable)=st) and + (not main_module.is_unit) then + result:=result+'P$'+st.name^ + else + result:=result+st.name^; + if prefix<>'' then + result:=result+'$_$'+prefix; + if suffix<>'' then + result:=result+'_$$_'+suffix; + { the Darwin assembler assumes that all symbols starting with 'L' are local } + { Further, the Mac OS X 10.5 linker does not consider symbols which do not } + { start with '_' as regular symbols (it does not generate N_GSYM entries } + { those in the debug map, leading to troubles with dsymutil). So always } + { add an underscore on darwin. } + if (target_info.system in systems_darwin) then + result := '_' + result; + end; + + function make_dllmangledname(const dllname,importname:string;import_nr : word; pco : tproccalloption):string; + var + crc : cardinal; + i : longint; + use_crc : boolean; + dllprefix : string; + begin + if (target_info.system in (systems_all_windows + systems_nativent + + [system_i386_emx, system_i386_os2])) + and (dllname <> '') then + begin + dllprefix:=lower(ExtractFileName(dllname)); + { Remove .dll suffix if present } + if copy(dllprefix,length(dllprefix)-3,length(dllprefix))='.dll' then + dllprefix:=copy(dllprefix,1,length(dllprefix)-4); + use_crc:=false; + for i:=1 to length(dllprefix) do + if not (dllprefix[i] in ['a'..'z','A'..'Z','_','0'..'9']) then + begin + use_crc:=true; + break; + end; + if use_crc then + begin + crc:=0; + crc:=UpdateCrc32(crc,dllprefix[1],length(dllprefix)); + dllprefix:='_$dll$crc$'+hexstr(crc,8)+'$'; + end + else + dllprefix:='_$dll$'+dllprefix+'$'; + + if importname<>'' then + result:=dllprefix+importname + else + result:=dllprefix+'_index_'+tostr(import_nr); + { Replace ? and @ in import name, since GNU AS does not allow these characters in symbol names. } + { This allows to import VC++ mangled names from DLLs. } + { Do not perform replacement, if external symbol is not imported from DLL. } + if (dllname<>'') then + begin + Replace(result,'?','__q$$'); + {$ifdef arm} + { @ symbol is not allowed in ARM assembler only } + Replace(result,'@','__a$$'); + {$endif arm} + end; + end + else + begin + if importname<>'' then + begin + if not(pco in [pocall_cdecl,pocall_cppdecl]) then + result:=importname + else + result:=target_info.Cprefix+importname; + end + else + result:='_index_'+tostr(import_nr); + end; + + end; + +{**************************************************************************** + TDEFAWARESYMTABLESTACK + (symtablestack descendant that does some special actions on + the pushed/popped symtables) +****************************************************************************} + + procedure tdefawaresymtablestack.addhelpers(st: TSymtable); + var + i: integer; + s: string; + list: TFPObjectList; + def: tdef; + begin + { search the symtable from first to last; the helper to use will be the + last one in the list } + for i:=0 to st.symlist.count-1 do + begin + if not (st.symlist[i] is ttypesym) then + continue; + def:=ttypesym(st.SymList[i]).typedef; + if is_objectpascal_helper(def) and + (tobjectdef(def).extendeddef.typ in [recorddef,objectdef]) then + begin + s:=make_mangledname('',tabstractrecorddef(tobjectdef(def).extendeddef).symtable,''); + list:=TFPObjectList(current_module.extendeddefs.Find(s)); + if not assigned(list) then + begin + list:=TFPObjectList.Create(false); + current_module.extendeddefs.Add(s,list); + end; + list.Add(def); + end + else + { add nested helpers as well } + if def.typ in [recorddef,objectdef] then + addhelpers(tabstractrecorddef(def).symtable); + end; + end; + + procedure tdefawaresymtablestack.removehelpers(st: TSymtable); + var + i, j: integer; + tmpst: TSymtable; + list: TFPObjectList; + begin + for i:=current_module.extendeddefs.count-1 downto 0 do + begin + list:=TFPObjectList(current_module.extendeddefs[i]); + for j:=list.count-1 downto 0 do + begin + if not (list[j] is tobjectdef) then + Internalerror(2011031501); + tmpst:=tobjectdef(list[j]).owner; + repeat + if tmpst=st then + begin + list.delete(j); + break; + end + else + begin + if assigned(tmpst.defowner) then + tmpst:=tmpst.defowner.owner + else + tmpst:=nil; + end; + until not assigned(tmpst) or (tmpst.symtabletype in [globalsymtable,staticsymtable]); + end; + if list.count=0 then + current_module.extendeddefs.delete(i); + end; + end; + + procedure tdefawaresymtablestack.push(st: TSymtable); + begin + { nested helpers will be added as well } + if (st.symtabletype in [globalsymtable,staticsymtable]) and + (sto_has_helper in st.tableoptions) then + addhelpers(st); + inherited push(st); + end; + + procedure tdefawaresymtablestack.pop(st: TSymtable); + begin + inherited pop(st); + { nested helpers will be removed as well } + if (st.symtabletype in [globalsymtable,staticsymtable]) and + (sto_has_helper in st.tableoptions) then + removehelpers(st); + end; + + +{**************************************************************************** + TDEF (base class for definitions) +****************************************************************************} + + constructor tstoreddef.create(dt:tdeftyp); + var + insertstack : psymtablestackitem; + begin + inherited create(dt); + savesize := 0; +{$ifdef EXTDEBUG} + fileinfo := current_filepos; +{$endif} + generictokenbuf:=nil; + genericdef:=nil; + change_endian:=false; + + { Don't register forwarddefs, they are disposed at the + end of an type block } + if (dt=forwarddef) then + exit; + { Register in current_module } + if assigned(current_module) then + begin + current_module.deflist.Add(self); + DefId:=current_module.deflist.Count-1; + end; + { Register in symtable stack } + if assigned(symtablestack) then + begin + insertstack:=symtablestack.stack; + while assigned(insertstack) and + (insertstack^.symtable.symtabletype=withsymtable) do + insertstack:=insertstack^.next; + if not assigned(insertstack) then + internalerror(200602044); + insertstack^.symtable.insertdef(self); + end; + end; + + + destructor tstoreddef.destroy; + begin + { Direct calls are not allowed, use symtable.deletedef() } + if assigned(owner) then + internalerror(200612311); + if assigned(generictokenbuf) then + begin + generictokenbuf.free; + generictokenbuf:=nil; + end; + inherited destroy; + end; + + + constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + var + sizeleft,i : longint; + buf : array[0..255] of byte; + begin + inherited create(dt); + DefId:=ppufile.getlongint; + current_module.deflist[DefId]:=self; +{$ifdef EXTDEBUG} + fillchar(fileinfo,sizeof(fileinfo),0); +{$endif} + { load } + ppufile.getderef(typesymderef); + ppufile.getsmallset(defoptions); + ppufile.getsmallset(defstates); + if df_generic in defoptions then + begin + sizeleft:=ppufile.getlongint; + change_endian:=ppufile.change_endian; + initgeneric; + while sizeleft>0 do + begin + if sizeleft>sizeof(buf) then + i:=sizeof(buf) + else + i:=sizeleft; + ppufile.getdata(buf,i); + generictokenbuf.write(buf,i); + dec(sizeleft,i); + end; + end; + if df_specialization in defoptions then + ppufile.getderef(genericdefderef); + end; + + + function Tstoreddef.rtti_mangledname(rt:trttitype):string; + var + prefix : string[4]; + begin + if rt=fullrtti then + begin + prefix:='RTTI'; + include(defstates,ds_rtti_table_used); + end + else + begin + prefix:='INIT'; + include(defstates,ds_init_table_used); + end; + if assigned(typesym) and + (owner.symtabletype in [staticsymtable,globalsymtable]) then + result:=make_mangledname(prefix,owner,typesym.name) + else + result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId)) + end; + + + function tstoreddef.OwnerHierarchyName: string; + var + tmp: tdef; + begin + tmp:=self; + result:=''; + repeat + if tmp.owner.symtabletype in [ObjectSymtable,recordsymtable] then + tmp:=tdef(tmp.owner.defowner) + else + break; + result:=tabstractrecorddef(tmp).objrealname^+'.'+result; + until tmp=nil; + end; + + + function tstoreddef.in_currentunit: boolean; + var + st: tsymtable; + begin + st:=owner; + while not(st.symtabletype in [globalsymtable,staticsymtable]) do + st:=st.defowner.owner; + result:=st.iscurrentunit; + end; + + + function tstoreddef.getcopy : tstoreddef; + begin + Message(sym_e_cant_create_unique_type); + getcopy:=terrordef.create; + end; + + + procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile); + var + sizeleft,i : longint; + buf : array[0..255] of byte; + oldintfcrc : boolean; + begin + ppufile.putlongint(DefId); + ppufile.putderef(typesymderef); + ppufile.putsmallset(defoptions); + oldintfcrc:=ppufile.do_crc; + ppufile.do_crc:=false; + ppufile.putsmallset(defstates); + if df_generic in defoptions then + begin + if assigned(generictokenbuf) then + begin + sizeleft:=generictokenbuf.size; + generictokenbuf.seek(0); + end + else + sizeleft:=0; + ppufile.putlongint(sizeleft); + while sizeleft>0 do + begin + if sizeleft>sizeof(buf) then + i:=sizeof(buf) + else + i:=sizeleft; + generictokenbuf.read(buf,i); + ppufile.putdata(buf,i); + dec(sizeleft,i); + end; + end; + ppufile.do_crc:=oldintfcrc; + if df_specialization in defoptions then + ppufile.putderef(genericdefderef); + end; + + + procedure tstoreddef.buildderef; + begin + typesymderef.build(typesym); + genericdefderef.build(genericdef); + end; + + + procedure tstoreddef.buildderefimpl; + begin + end; + + + procedure tstoreddef.deref; + begin + typesym:=ttypesym(typesymderef.resolve); + if df_specialization in defoptions then + genericdef:=tstoreddef(genericdefderef.resolve); + end; + + + procedure tstoreddef.derefimpl; + begin + end; + + + function tstoreddef.size : asizeint; + begin + size:=savesize; + end; + + + function tstoreddef.getvardef:longint; + begin + result:=varUndefined; + end; + + + function tstoreddef.alignment : shortint; + begin + { natural alignment by default } + alignment:=size_2_align(savesize); + { can happen if savesize = 0, e.g. for voiddef or + an empty record + } + if (alignment=0) then + alignment:=1; + end; + + + { returns true, if the definition can be published } + function tstoreddef.is_publishable : boolean; + begin + is_publishable:=false; + end; + + + { needs an init table } + function tstoreddef.needs_inittable : boolean; + begin + needs_inittable:=false; + end; + + + function tstoreddef.is_intregable : boolean; + var + recsize,temp: longint; + begin + is_intregable:=false; + case typ of + orddef, + pointerdef, + enumdef, + classrefdef: + is_intregable:=true; + procvardef : + is_intregable:=tprocvardef(self).is_addressonly; + objectdef: + is_intregable:=(is_implicit_pointer_object_type(self)) and not needs_inittable; + setdef: + is_intregable:=is_smallset(self); + recorddef: + begin + recsize:=size; + is_intregable:= + ispowerof2(recsize,temp) and + (recsize <= sizeof(asizeint)); + end; + end; + end; + + + function tstoreddef.is_fpuregable : boolean; + begin +{$ifdef x86} + result:=use_vectorfpu(self); +{$else x86} + result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches); +{$endif x86} + end; + + + procedure tstoreddef.initgeneric; + begin + if assigned(generictokenbuf) then + internalerror(200512131); + generictokenbuf:=tdynamicarray.create(256); + end; + + +{**************************************************************************** + Tstringdef +****************************************************************************} + + constructor tstringdef.createshort(l : byte); + begin + inherited create(stringdef); + stringtype:=st_shortstring; + encoding:=0; + len:=l; + savesize:=len+1; + end; + + + constructor tstringdef.loadshort(ppufile:tcompilerppufile); + begin + inherited ppuload(stringdef,ppufile); + stringtype:=st_shortstring; + encoding:=0; + len:=ppufile.getbyte; + savesize:=len+1; + end; + + + constructor tstringdef.createlong(l : asizeint); + begin + inherited create(stringdef); + stringtype:=st_longstring; + encoding:=0; + len:=l; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.loadlong(ppufile:tcompilerppufile); + begin + inherited ppuload(stringdef,ppufile); + stringtype:=st_longstring; + encoding:=0; + len:=ppufile.getasizeint; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.createansi(aencoding:tstringencoding); + begin + inherited create(stringdef); + stringtype:=st_ansistring; + encoding:=aencoding; + len:=-1; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.loadansi(ppufile:tcompilerppufile); + begin + inherited ppuload(stringdef,ppufile); + stringtype:=st_ansistring; + len:=ppufile.getaint; + encoding:=ppufile.getword; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.createwide; + begin + inherited create(stringdef); + stringtype:=st_widestring; + encoding:=CP_UTF16; + len:=-1; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.loadwide(ppufile:tcompilerppufile); + begin + inherited ppuload(stringdef,ppufile); + stringtype:=st_widestring; + encoding:=CP_UTF16; + len:=ppufile.getaint; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.createunicode; + begin + inherited create(stringdef); + stringtype:=st_unicodestring; + encoding:=CP_UTF16; + len:=-1; + savesize:=sizeof(pint); + end; + + + constructor tstringdef.loadunicode(ppufile:tcompilerppufile); + begin + inherited ppuload(stringdef,ppufile); + stringtype:=st_unicodestring; + len:=ppufile.getaint; + encoding:=ppufile.getword; + savesize:=sizeof(pint); + end; + + + function tstringdef.getcopy : tstoreddef; + begin + result:=tstringdef.create(typ); + result.typ:=stringdef; + tstringdef(result).stringtype:=stringtype; + tstringdef(result).encoding:=encoding; + tstringdef(result).len:=len; + tstringdef(result).savesize:=savesize; + end; + + + function tstringdef.stringtypname:string; + const + typname:array[tstringtype] of string[10]=( + 'shortstr','longstr','ansistr','widestr','unicodestr' + ); + begin + stringtypname:=typname[stringtype]; + end; + + + procedure tstringdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + if stringtype=st_shortstring then + begin +{$ifdef extdebug} + if len > 255 then internalerror(12122002); +{$endif} + ppufile.putbyte(byte(len)) + end + else + ppufile.putaint(len); + if stringtype in [st_ansistring,st_unicodestring] then + ppufile.putword(encoding); + case stringtype of + st_shortstring : ppufile.writeentry(ibshortstringdef); + st_longstring : ppufile.writeentry(iblongstringdef); + st_ansistring : ppufile.writeentry(ibansistringdef); + st_widestring : ppufile.writeentry(ibwidestringdef); + st_unicodestring : ppufile.writeentry(ibunicodestringdef); + end; + end; + + + function tstringdef.needs_inittable : boolean; + begin + needs_inittable:=stringtype in [st_ansistring,st_widestring,st_unicodestring]; + end; + + + function tstringdef.GetTypeName : string; + const + names : array[tstringtype] of string[15] = ( + 'ShortString','LongString','AnsiString','WideString','UnicodeString'); + begin + GetTypeName:=names[stringtype]; + end; + + + function tstringdef.getvardef : longint; + const + vardef : array[tstringtype] of longint = ( + varUndefined,varUndefined,varString,varOleStr,varUString); + begin + result:=vardef[stringtype]; + end; + + + function tstringdef.alignment : shortint; + begin + case stringtype of + st_unicodestring, + st_widestring, + st_ansistring: + alignment:=size_2_align(savesize); + st_longstring, + st_shortstring: + { char to string accesses byte 0 and 1 with one word access } + if (tf_requires_proper_alignment in target_info.flags) or + { macpas needs an alignment of 2 (MetroWerks compatible) } + (m_mac in current_settings.modeswitches) then + alignment:=size_2_align(2) + else + alignment:=size_2_align(1); + else + internalerror(200412301); + end; + end; + + + function tstringdef.getmangledparaname : string; + begin + getmangledparaname:='STRING'; + end; + + + function tstringdef.is_publishable : boolean; + begin + is_publishable:=true; + end; + + +{**************************************************************************** + TENUMDEF +****************************************************************************} + + constructor tenumdef.create; + begin + inherited create(enumdef); + minval:=0; + maxval:=0; + calcsavesize; + has_jumps:=false; + basedef:=nil; + symtable:=tenumsymtable.create(self); + end; + + + constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:asizeint); + begin + inherited create(enumdef); + minval:=_min; + maxval:=_max; + basedef:=_basedef; + calcsavesize; + has_jumps:=false; + symtable:=basedef.symtable.getcopy; + include(defoptions, df_copied_def); + end; + + + constructor tenumdef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(enumdef,ppufile); + minval:=ppufile.getaint; + maxval:=ppufile.getaint; + savesize:=ppufile.getaint; + has_jumps:=false; + if df_copied_def in defoptions then + begin + symtable:=nil; + ppufile.getderef(basedefderef); + end + else + begin + // create with nil defowner first to prevent values changes on insert + symtable:=tenumsymtable.create(nil); + tenumsymtable(symtable).ppuload(ppufile); + symtable.defowner:=self; + end; + end; + + destructor tenumdef.destroy; + begin + symtable.free; + symtable:=nil; + inherited destroy; + end; + + + function tenumdef.getcopy : tstoreddef; + begin + if assigned(basedef) then + result:=tenumdef.create_subrange(basedef,minval,maxval) + else + begin + result:=tenumdef.create; + tenumdef(result).minval:=minval; + tenumdef(result).maxval:=maxval; + tenumdef(result).symtable.free; + tenumdef(result).symtable:=symtable.getcopy; + tenumdef(result).basedef:=self; + end; + tenumdef(result).has_jumps:=has_jumps; + tenumdef(result).basedefderef:=basedefderef; + include(tenumdef(result).defoptions,df_copied_def); + end; + + + procedure tenumdef.calcsavesize; + begin +{$IFNDEF cpu64bitaddr} {$push}{$warnings off} {$ENDIF} //comparison always false warning + if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then + savesize:=8 +{$IFDEF not cpu64bitaddr} {$pop} {$ENDIF} + else + if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then + savesize:=4 + else + if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then + savesize:=2 + else + savesize:=1; + end; + + + function tenumdef.packedbitsize: asizeint; + var + sizeval: tconstexprint; + power: longint; + begin + result := 0; + if (minval >= 0) and + (maxval <= 1) then + result := 1 + else + begin + if (minval>=0) then + sizeval:=maxval + else + { don't count 0 twice } + sizeval:=(cutils.max(-minval,maxval)*2)-1; + { 256 must become 512 etc. } + nextpowerof2(sizeval+1,power); + result := power; + end; + end; + + + procedure tenumdef.setmax(_max:asizeint); + begin + maxval:=_max; + calcsavesize; + end; + + + procedure tenumdef.setmin(_min:asizeint); + begin + minval:=_min; + calcsavesize; + end; + + + function tenumdef.min:asizeint; + begin + min:=minval; + end; + + + function tenumdef.max:asizeint; + begin + max:=maxval; + end; + + function tenumdef.getfirstsym: tsym; + var + i:integer; + begin + for i := 0 to symtable.SymList.Count - 1 do + begin + result:=tsym(symtable.SymList[i]); + if tenumsym(result).value=minval then + exit; + end; + result:=nil; + end; + + + procedure tenumdef.buildderef; + begin + inherited buildderef; + if df_copied_def in defoptions then + basedefderef.build(basedef) + else + tenumsymtable(symtable).buildderef; + end; + + + procedure tenumdef.deref; + begin + inherited deref; + if df_copied_def in defoptions then + begin + basedef:=tenumdef(basedefderef.resolve); + symtable:=basedef.symtable.getcopy; + end + else + tenumsymtable(symtable).deref; + end; + + + procedure tenumdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putaint(min); + ppufile.putaint(max); + ppufile.putaint(savesize); + if df_copied_def in defoptions then + ppufile.putderef(basedefderef); + ppufile.writeentry(ibenumdef); + if not (df_copied_def in defoptions) then + tenumsymtable(symtable).ppuwrite(ppufile); + end; + + + function tenumdef.is_publishable : boolean; + begin + is_publishable:=true; + end; + + + function tenumdef.GetTypeName : string; + begin + GetTypeName:='<enumeration type>'; + end; + + +{**************************************************************************** + TORDDEF +****************************************************************************} + + constructor torddef.create(t : tordtype;v,b : TConstExprInt); + begin + inherited create(orddef); + low:=v; + high:=b; + ordtype:=t; + setsize; + end; + + + constructor torddef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(orddef,ppufile); + ordtype:=tordtype(ppufile.getbyte); + low:=ppufile.getexprint; + high:=ppufile.getexprint; + setsize; + end; + + + function torddef.getcopy : tstoreddef; + begin + result:=torddef.create(ordtype,low,high); + result.typ:=orddef; + torddef(result).low:=low; + torddef(result).high:=high; + torddef(result).ordtype:=ordtype; + torddef(result).savesize:=savesize; + end; + + + function torddef.alignment:shortint; + begin + if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) and + (ordtype in [s64bit,u64bit]) then + result := 4 + else + result := inherited alignment; + end; + + + procedure torddef.setsize; + const + sizetbl : array[tordtype] of longint = ( + 0, + 1,2,4,8, + 1,2,4,8, + 1,2,4,8, + 1,2,4,8, + 1,2,8 + ); + begin + savesize:=sizetbl[ordtype]; + end; + + + function torddef.packedbitsize: asizeint; + var + sizeval: tconstexprint; + power: longint; + begin + result := 0; + if ordtype = uvoid then + exit; + +{$ifndef cpu64bitalu} + if (ordtype in [s64bit,u64bit]) then +{$else not cpu64bitalu} + if (ordtype = u64bit) or + ((ordtype = s64bit) and + ((low <= (system.low(int64) div 2)) or + (high > (system.high(int64) div 2)))) then +{$endif cpu64bitalu} + result := 64 + else if (low >= 0) and + (high <= 1) then + result := 1 + else + begin + if (low>=0) then + sizeval:=high + else + { don't count 0 twice } + sizeval:=(cutils.max(-low,high)*2)-1; + { 256 must become 512 etc. } + nextpowerof2(sizeval+1,power); + result := power; + end; + end; + + + function torddef.getvardef : longint; + const + basetype2vardef : array[tordtype] of longint = ( + varUndefined, + varbyte,varword,varlongword,varqword, + varshortint,varsmallint,varinteger,varint64, + varboolean,varboolean,varboolean,varboolean, + varboolean,varboolean,varUndefined,varUndefined, + varUndefined,varUndefined,varCurrency); + begin + result:=basetype2vardef[ordtype]; + end; + + + procedure torddef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(ordtype)); + ppufile.putexprint(low); + ppufile.putexprint(high); + ppufile.writeentry(iborddef); + end; + + + function torddef.is_publishable : boolean; + begin + is_publishable:=(ordtype<>uvoid); + end; + + + function torddef.GetTypeName : string; + const + names : array[tordtype] of string[20] = ( + 'untyped', + 'Byte','Word','DWord','QWord', + 'ShortInt','SmallInt','LongInt','Int64', + 'Boolean','Boolean16','Boolean32','Boolean64', + 'ByteBool','WordBool','LongBool','QWordBool', + 'Char','WideChar','Currency'); + + begin + GetTypeName:=names[ordtype]; + end; + + +{**************************************************************************** + TFLOATDEF +****************************************************************************} + + constructor tfloatdef.create(t : tfloattype); + begin + inherited create(floatdef); + floattype:=t; + setsize; + end; + + + constructor tfloatdef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(floatdef,ppufile); + floattype:=tfloattype(ppufile.getbyte); + setsize; + end; + + + function tfloatdef.getcopy : tstoreddef; + begin + result:=tfloatdef.create(floattype); + result.typ:=floatdef; + tfloatdef(result).savesize:=savesize; + end; + + + function tfloatdef.alignment:shortint; + begin + if (target_info.system in [system_i386_darwin,system_i386_iphonesim,system_arm_darwin]) then + case floattype of + sc80real, + s80real: result:=16; + s64real, + s64currency, + s64comp : result:=4; + else + result := inherited alignment; + end + else + result := inherited alignment; + end; + + + procedure tfloatdef.setsize; + begin + case floattype of + s32real : savesize:=4; + s80real : savesize:=10; + sc80real: + if target_info.system in [system_i386_darwin,system_i386_iphonesim,system_x86_64_darwin, + system_x86_64_linux,system_x86_64_freebsd, + system_x86_64_solaris,system_x86_64_embedded] then + savesize:=16 + else + savesize:=12; + s64real, + s64currency, + s64comp : savesize:=8; + else + savesize:=0; + end; + end; + + + function tfloatdef.getvardef : longint; + const + floattype2vardef : array[tfloattype] of longint = ( + varSingle,varDouble,varUndefined,varUndefined, + varUndefined,varCurrency,varUndefined); + begin + if (upper(typename)='TDATETIME') and + assigned(owner) and + assigned(owner.name) and + (owner.name^='SYSTEM') then + result:=varDate + else + result:=floattype2vardef[floattype]; + end; + + + procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(floattype)); + ppufile.writeentry(ibfloatdef); + end; + + + function tfloatdef.is_publishable : boolean; + begin + is_publishable:=true; + end; + + + function tfloatdef.GetTypeName : string; + const + names : array[tfloattype] of string[20] = ( + 'Single','Double','Extended','CExtended','Comp','Currency','Float128'); + begin + GetTypeName:=names[floattype]; + end; + + +{**************************************************************************** + TFILEDEF +****************************************************************************} + + constructor tfiledef.createtext; + begin + inherited create(filedef); + filetyp:=ft_text; + typedfiledef:=nil; + setsize; + end; + + + constructor tfiledef.createuntyped; + begin + inherited create(filedef); + filetyp:=ft_untyped; + typedfiledef:=nil; + setsize; + end; + + + constructor tfiledef.createtyped(def:tdef); + begin + inherited create(filedef); + filetyp:=ft_typed; + typedfiledef:=def; + setsize; + end; + + + constructor tfiledef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(filedef,ppufile); + filetyp:=tfiletyp(ppufile.getbyte); + if filetyp=ft_typed then + ppufile.getderef(typedfiledefderef) + else + typedfiledef:=nil; + setsize; + end; + + + function tfiledef.getcopy : tstoreddef; + begin + case filetyp of + ft_typed: + result:=tfiledef.createtyped(typedfiledef); + ft_untyped: + result:=tfiledef.createuntyped; + ft_text: + result:=tfiledef.createtext; + else + internalerror(2004121201); + end; + end; + + + procedure tfiledef.buildderef; + begin + inherited buildderef; + if filetyp=ft_typed then + typedfiledefderef.build(typedfiledef); + end; + + + procedure tfiledef.deref; + begin + inherited deref; + if filetyp=ft_typed then + typedfiledef:=tdef(typedfiledefderef.resolve); + end; + + + procedure tfiledef.setsize; + begin +{$ifdef cpu64bitaddr} + case filetyp of + ft_text : + if target_info.system in [system_x86_64_win64,system_ia64_win64] then + savesize:=634{+8} + else + savesize:=630{+8}; + ft_typed, + ft_untyped : + if target_info.system in [system_x86_64_win64,system_ia64_win64] then + savesize:=372 + else + savesize:=368; + end; +{$endif cpu64bitaddr} +{$ifdef cpu32bitaddr} + case filetyp of + ft_text : + savesize:=594{+4}; + ft_typed, + ft_untyped : + savesize:=332; + end; +{$endif cpu32bitaddr} +{$ifdef cpu8bitaddr} + case filetyp of + ft_text : + savesize:=127; + ft_typed, + ft_untyped : + savesize:=127; + end; +{$endif cpu8bitaddr} + end; + + + procedure tfiledef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(filetyp)); + if filetyp=ft_typed then + ppufile.putderef(typedfiledefderef); + ppufile.writeentry(ibfiledef); + end; + + + function tfiledef.GetTypeName : string; + begin + case filetyp of + ft_untyped: + GetTypeName:='File'; + ft_typed: + GetTypeName:='File Of '+typedfiledef.typename; + ft_text: + GetTypeName:='Text' + end; + end; + + + function tfiledef.getmangledparaname : string; + begin + case filetyp of + ft_untyped: + getmangledparaname:='FILE'; + ft_typed: + getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname; + ft_text: + getmangledparaname:='TEXT' + end; + end; + + +{**************************************************************************** + TVARIANTDEF +****************************************************************************} + + constructor tvariantdef.create(v : tvarianttype); + begin + inherited create(variantdef); + varianttype:=v; + setsize; + end; + + + constructor tvariantdef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(variantdef,ppufile); + varianttype:=tvarianttype(ppufile.getbyte); + setsize; + end; + + + function tvariantdef.getcopy : tstoreddef; + begin + result:=tvariantdef.create(varianttype); + end; + + + procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(varianttype)); + ppufile.writeentry(ibvariantdef); + end; + + + function tvariantdef.getvardef : longint; + begin + Result:=varVariant; + end; + + + procedure tvariantdef.setsize; + begin +{$ifdef cpu64bitaddr} + savesize:=24; +{$else cpu64bitaddr} + savesize:=16; +{$endif cpu64bitaddr} + end; + + + function tvariantdef.GetTypeName : string; + begin + case varianttype of + vt_normalvariant: + GetTypeName:='Variant'; + vt_olevariant: + GetTypeName:='OleVariant'; + end; + end; + + + function tvariantdef.needs_inittable : boolean; + begin + needs_inittable:=true; + end; + + + function tvariantdef.is_publishable : boolean; + begin + is_publishable:=true; + end; + + +{**************************************************************************** + TABSTRACtpointerdef +****************************************************************************} + + constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef); + begin + inherited create(dt); + pointeddef:=def; + savesize:=sizeof(pint); + end; + + + constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + begin + inherited ppuload(dt,ppufile); + ppufile.getderef(pointeddefderef); + savesize:=sizeof(pint); + end; + + + procedure tabstractpointerdef.buildderef; + begin + inherited buildderef; + pointeddefderef.build(pointeddef); + end; + + + procedure tabstractpointerdef.deref; + begin + inherited deref; + pointeddef:=tdef(pointeddefderef.resolve); + end; + + + procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putderef(pointeddefderef); + end; + + +{**************************************************************************** + tpointerdef +****************************************************************************} + + constructor tpointerdef.create(def:tdef); + begin + inherited create(pointerdef,def); + is_far:=false; + has_pointer_math:=cs_pointermath in current_settings.localswitches; + end; + + + constructor tpointerdef.createfar(def:tdef); + begin + inherited create(pointerdef,def); + is_far:=true; + has_pointer_math:=cs_pointermath in current_settings.localswitches; + end; + + + constructor tpointerdef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(pointerdef,ppufile); + is_far:=(ppufile.getbyte<>0); + has_pointer_math:=(ppufile.getbyte<>0); + end; + + + function tpointerdef.getcopy : tstoreddef; + begin + { don't use direct pointeddef if it is a forwarddef because in other case + one of them will be destroyed on forward type resolve and the second will + point to garbage } + if pointeddef.typ=forwarddef then + result:=tpointerdef.create(tforwarddef(pointeddef).getcopy) + else + result:=tpointerdef.create(pointeddef); + tpointerdef(result).is_far:=is_far; + tpointerdef(result).has_pointer_math:=has_pointer_math; + tpointerdef(result).savesize:=savesize; + end; + + + procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(is_far)); + ppufile.putbyte(byte(has_pointer_math)); + ppufile.writeentry(ibpointerdef); + end; + + + function tpointerdef.GetTypeName : string; + begin + if is_far then + GetTypeName:='^'+pointeddef.typename+';far' + else + GetTypeName:='^'+pointeddef.typename; + end; + + +{**************************************************************************** + TCLASSREFDEF +****************************************************************************} + + constructor tclassrefdef.create(def:tdef); + begin + inherited create(classrefdef,def); + end; + + + constructor tclassrefdef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(classrefdef,ppufile); + end; + + + procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.writeentry(ibclassrefdef); + end; + + + function tclassrefdef.getcopy:tstoreddef; + begin + if pointeddef.typ=forwarddef then + result:=tclassrefdef.create(tforwarddef(pointeddef).getcopy) + else + result:=tclassrefdef.create(pointeddef); + tclassrefdef(result).savesize:=savesize; + end; + + + function tclassrefdef.GetTypeName : string; + begin + GetTypeName:='Class Of '+pointeddef.typename; + end; + + + function tclassrefdef.is_publishable : boolean; + begin + result:=true; + end; + + + function tclassrefdef.rtti_mangledname(rt: trttitype): string; + begin + if (tobjectdef(pointeddef).objecttype<>odt_objcclass) then + result:=inherited rtti_mangledname(rt) + else + result:=tobjectdef(pointeddef).rtti_mangledname(objcmetartti); + end; + + + procedure tclassrefdef.register_created_object_type; + begin + tobjectdef(pointeddef).register_created_classref_type; + end; + +{*************************************************************************** + TSETDEF +***************************************************************************} + + constructor tsetdef.create(def:tdef;low, high : asizeint); + var + setallocbits: aint; + packedsavesize: aint; + begin + inherited create(setdef); + elementdef:=def; + setmax:=high; + if (current_settings.setalloc=0) then + begin + setbase:=0; + if (high<32) then + savesize:=Sizeof(longint) + else if (high<256) then + savesize:=32 + else + savesize:=(high+7) div 8 + end + else + begin + setallocbits:=current_settings.setalloc*8; + setbase:=low and not(setallocbits-1); + packedsavesize:=current_settings.setalloc*((((high+setallocbits)-setbase)) DIV setallocbits); + savesize:=packedsavesize; + if savesize=3 then + savesize:=4; + end; + end; + + + constructor tsetdef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(setdef,ppufile); + ppufile.getderef(elementdefderef); + savesize:=ppufile.getaint; + setbase:=ppufile.getaint; + setmax:=ppufile.getaint; + end; + + + function tsetdef.getcopy : tstoreddef; + begin + result:=tsetdef.create(elementdef,setbase,setmax); + { the copy might have been created with a different setalloc setting } + tsetdef(result).savesize:=savesize; + end; + + + procedure tsetdef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putderef(elementdefderef); + ppufile.putaint(savesize); + ppufile.putaint(setbase); + ppufile.putaint(setmax); + ppufile.writeentry(ibsetdef); + end; + + + procedure tsetdef.buildderef; + begin + inherited buildderef; + elementdefderef.build(elementdef); + end; + + + procedure tsetdef.deref; + begin + inherited deref; + elementdef:=tdef(elementdefderef.resolve); + end; + + + function tsetdef.is_publishable : boolean; + begin + is_publishable:=savesize in [1,2,4]; + end; + + + function tsetdef.GetTypeName : string; + begin + if assigned(elementdef) then + GetTypeName:='Set Of '+elementdef.typename + else + GetTypeName:='Empty Set'; + end; + + +{*************************************************************************** + TFORMALDEF +***************************************************************************} + + constructor tformaldef.create(Atyped:boolean); + begin + inherited create(formaldef); + typed:=Atyped; + savesize:=0; + end; + + + constructor tformaldef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(formaldef,ppufile); + typed:=boolean(ppufile.getbyte); + savesize:=0; + end; + + + procedure tformaldef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(typed)); + ppufile.writeentry(ibformaldef); + end; + + + function tformaldef.GetTypeName : string; + begin + if typed then + GetTypeName:='<Typed formal type>' + else + GetTypeName:='<Formal type>'; + end; + + +{*************************************************************************** + TARRAYDEF +***************************************************************************} + + constructor tarraydef.create(l,h:asizeint;def:tdef); + begin + inherited create(arraydef); + lowrange:=l; + highrange:=h; + rangedef:=def; + _elementdef:=nil; + arrayoptions:=[]; + symtable:=tarraysymtable.create(self); + end; + + destructor tarraydef.destroy; + begin + symtable.free; + symtable:=nil; + inherited; + end; + + constructor tarraydef.create_from_pointer(def:tdef); + begin + { use -1 so that the elecount will not overflow } + self.create(0,high(aint)-1,ptrsinttype); + arrayoptions:=[ado_IsConvertedPointer]; + setelementdef(def); + end; + + + constructor tarraydef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(arraydef,ppufile); + { the addresses are calculated later } + ppufile.getderef(_elementdefderef); + ppufile.getderef(rangedefderef); + lowrange:=ppufile.getaint; + highrange:=ppufile.getaint; + ppufile.getsmallset(arrayoptions); + symtable:=tarraysymtable.create(self); + tarraysymtable(symtable).ppuload(ppufile) + end; + + + function tarraydef.getcopy : tstoreddef; + begin + result:=tarraydef.create(lowrange,highrange,rangedef); + tarraydef(result).arrayoptions:=arrayoptions; + tarraydef(result)._elementdef:=_elementdef; + end; + + + procedure tarraydef.buildderef; + begin + inherited buildderef; + tarraysymtable(symtable).buildderef; + _elementdefderef.build(_elementdef); + rangedefderef.build(rangedef); + end; + + + procedure tarraydef.deref; + begin + inherited deref; + tarraysymtable(symtable).deref; + _elementdef:=tdef(_elementdefderef.resolve); + rangedef:=tdef(rangedefderef.resolve); + end; + + + procedure tarraydef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putderef(_elementdefderef); + ppufile.putderef(rangedefderef); + ppufile.putaint(lowrange); + ppufile.putaint(highrange); + ppufile.putsmallset(arrayoptions); + ppufile.writeentry(ibarraydef); + tarraysymtable(symtable).ppuwrite(ppufile); + end; + + + function tarraydef.elesize : asizeint; + begin + if (ado_IsBitPacked in arrayoptions) then + internalerror(2006080101); + if assigned(_elementdef) then + result:=_elementdef.size + else + result:=0; + end; + + + function tarraydef.elepackedbitsize : asizeint; + begin + if not(ado_IsBitPacked in arrayoptions) then + internalerror(2006080102); + if assigned(_elementdef) then + result:=_elementdef.packedbitsize + else + result:=0; + end; + + + function tarraydef.elecount : asizeuint; + var + qhigh,qlow : qword; + begin + if ado_IsDynamicArray in arrayoptions then + begin + result:=0; + exit; + end; + if (highrange>0) and (lowrange<0) then + begin + qhigh:=highrange; + qlow:=qword(-lowrange); + { prevent overflow, return 0 to indicate overflow } + if qhigh+qlow>qword(high(asizeint)-1) then + result:=0 + else + result:=qhigh+qlow+1; + end + else + result:=int64(highrange)-lowrange+1; + end; + + + function tarraydef.size : asizeint; + var + cachedelecount : asizeuint; + cachedelesize : asizeint; + begin + if ado_IsDynamicArray in arrayoptions then + begin + size:=sizeof(pint); + exit; + end; + + { Tarraydef.size may never be called for an open array! } + if highrange<lowrange then + internalerror(99080501); + if not (ado_IsBitPacked in arrayoptions) then + cachedelesize:=elesize + else + cachedelesize := elepackedbitsize; + cachedelecount:=elecount; + + if (cachedelesize = 0) then + begin + size := 0; + exit; + end; + + if (cachedelecount = 0) then + begin + size := -1; + exit; + end; + + { prevent overflow, return -1 to indicate overflow } + { also make sure we don't need 64/128 bit arithmetic to calculate offsets } + if (cachedelecount > asizeuint(high(asizeint))) or + ((high(asizeint) div cachedelesize) < asizeint(cachedelecount)) or + { also lowrange*elesize must be < high(asizeint) to prevent overflow when + accessing the array, see ncgmem (PFV) } + ((high(asizeint) div cachedelesize) < abs(lowrange)) then + begin + result:=-1; + exit; + end; + + result:=cachedelesize*asizeint(cachedelecount); + if (ado_IsBitPacked in arrayoptions) then + { can't just add 7 and divide by 8, because that may overflow } + result:=result div 8 + ord((result mod 8)<>0); + end; + + + procedure tarraydef.setelementdef(def:tdef); + begin + _elementdef:=def; + if not( + (ado_IsDynamicArray in arrayoptions) or + (ado_IsConvertedPointer in arrayoptions) or + (highrange<lowrange) + ) and + (size=-1) then + Message(sym_e_segment_too_large); + end; + + + function tarraydef.alignment : shortint; + begin + { alignment of dyn. arrays doesn't depend on the element size } + if (ado_IsDynamicArray in arrayoptions) then + alignment:=size_2_align(sizeof(pint)) + { alignment is the alignment of the elements } + else if (elementdef.typ in [arraydef,recorddef,orddef,enumdef,floatdef]) or + ((elementdef.typ=objectdef) and + is_object(elementdef)) then + alignment:=elementdef.alignment + { alignment is the size of the elements } + else if not (ado_IsBitPacked in arrayoptions) then + alignment:=size_2_align(elesize) + else + alignment:=packedbitsloadsize(elepackedbitsize); + end; + + + function tarraydef.needs_inittable : boolean; + begin + needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable; + end; + + + function tarraydef.GetTypeName : string; + begin + if (ado_IsConstString in arrayoptions) then + result:='Constant String' + else if (ado_isarrayofconst in arrayoptions) or + (ado_isConstructor in arrayoptions) then + begin + if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then + GetTypeName:='Array Of Const' + else + GetTypeName:='Array Of Const/Constant Open Array of '+elementdef.typename; + end + else if (ado_IsDynamicArray in arrayoptions) then + GetTypeName:='Dynamic Array Of '+elementdef.typename + else if ((highrange=-1) and (lowrange=0)) then + GetTypeName:='Open Array Of '+elementdef.typename + else + begin + result := ''; + if (ado_IsBitPacked in arrayoptions) then + result:='Packed '; + if rangedef.typ=enumdef then + result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename + else + result:=result+'Array['+tostr(lowrange)+'..'+ + tostr(highrange)+'] Of '+elementdef.typename + end; + end; + + + function tarraydef.getmangledparaname : string; + begin + if ado_isarrayofconst in arrayoptions then + getmangledparaname:='array_of_const' + else + if ((highrange=-1) and (lowrange=0)) then + getmangledparaname:='array_of_'+elementdef.mangledparaname + else + internalerror(200204176); + end; + + + function tarraydef.is_publishable : boolean; + begin + Result:=ado_IsDynamicArray in arrayoptions; + end; + +{*************************************************************************** + tabstractrecorddef +***************************************************************************} + + constructor tabstractrecorddef.create(const n:string; dt:tdeftyp); + begin + inherited create(dt); + objname:=stringdup(upper(n)); + objrealname:=stringdup(n); + objectoptions:=[]; + end; + + constructor tabstractrecorddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + begin + inherited ppuload(dt,ppufile); + objrealname:=stringdup(ppufile.getstring); + objname:=stringdup(upper(objrealname^)); + ppufile.getsmallset(objectoptions); + end; + + procedure tabstractrecorddef.ppuwrite(ppufile: tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.putstring(objrealname^); + ppufile.putsmallset(objectoptions); + end; + + destructor tabstractrecorddef.destroy; + begin + stringdispose(objname); + stringdispose(objrealname); + inherited destroy; + end; + + procedure tabstractrecorddef.check_forwards; + begin + tstoredsymtable(symtable).check_forwards; + end; + + function tabstractrecorddef.find_procdef_bytype(pt:tproctypeoption): tprocdef; + var + i: longint; + sym: tsym; + begin + for i:=0 to symtable.SymList.Count-1 do + begin + sym:=tsym(symtable.SymList[i]); + if sym.typ=procsym then + begin + result:=tprocsym(sym).find_procdef_bytype(pt); + if assigned(result) then + exit; + end; + end; + result:=nil; + end; + + function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable; + begin + if t=gs_record then + GetSymtable:=symtable + else + GetSymtable:=nil; + end; + + + function tabstractrecorddef.is_packed:boolean; + begin + result:=tabstractrecordsymtable(symtable).is_packed; + end; + + function tabstractrecorddef.RttiName: string; + begin + Result:=OwnerHierarchyName+objrealname^; + end; + + function tabstractrecorddef.search_enumerator_get: tprocdef; + var + sym : tsym; + i : integer; + pd : tprocdef; + hashedid : THashedIDString; + begin + result:=nil; + hashedid.id:='GETENUMERATOR'; + sym:=tsym(symtable.FindWithHash(hashedid)); + if assigned(sym) and (sym.typ=procsym) then + begin + for i := 0 to Tprocsym(sym).ProcdefList.Count - 1 do + begin + pd := tprocdef(Tprocsym(sym).ProcdefList[i]); + if (pd.proctypeoption = potype_function) and + (is_class_or_interface_or_object(pd.returndef) or is_record(pd.returndef)) and + (pd.visibility >= vis_public) then + begin + result:=pd; + exit; + end; + end; + end; + end; + + function tabstractrecorddef.search_enumerator_move: tprocdef; + var + sym : tsym; + i : integer; + pd : tprocdef; + hashedid : THashedIDString; + begin + result:=nil; + // first search for po_enumerator_movenext method modifier + // then search for public function MoveNext: Boolean + for i:=0 to symtable.SymList.Count-1 do + begin + sym:=TSym(symtable.SymList[i]); + if (sym.typ=procsym) then + begin + pd:=Tprocsym(sym).find_procdef_byoptions([po_enumerator_movenext]); + if assigned(pd) then + begin + result:=pd; + exit; + end; + end; + end; + hashedid.id:='MOVENEXT'; + sym:=tsym(symtable.FindWithHash(hashedid)); + if assigned(sym) and (sym.typ=procsym) then + begin + for i:=0 to Tprocsym(sym).ProcdefList.Count-1 do + begin + pd := tprocdef(Tprocsym(sym).ProcdefList[i]); + if (pd.proctypeoption = potype_function) and + is_boolean(pd.returndef) and + (pd.minparacount = 0) and + (pd.visibility >= vis_public) then + begin + result:=pd; + exit; + end; + end; + end; + end; + + function tabstractrecorddef.search_enumerator_current: tsym; + var + sym: tsym; + i: integer; + hashedid : THashedIDString; + begin + result:=nil; + // first search for ppo_enumerator_current property modifier + // then search for public property Current + for i:=0 to symtable.SymList.Count-1 do + begin + sym:=TSym(symtable.SymList[i]); + if (sym.typ=propertysym) and (ppo_enumerator_current in tpropertysym(sym).propoptions) then + begin + result:=sym; + exit; + end; + end; + hashedid.id:='CURRENT'; + sym:=tsym(symtable.FindWithHash(hashedid)); + if assigned(sym) and (sym.typ=propertysym) and + (sym.visibility >= vis_public) and not tpropertysym(sym).propaccesslist[palt_read].empty then + begin + result:=sym; + exit; + end; + end; + +{*************************************************************************** + trecorddef +***************************************************************************} + + constructor trecorddef.create(const n:string; p:TSymtable); + begin + inherited create(n,recorddef); + symtable:=p; + { we can own the symtable only if nobody else owns a copy so far } + if symtable.refcount=1 then + symtable.defowner:=self; + isunion:=false; + end; + + + constructor trecorddef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(recorddef,ppufile); + if df_copied_def in defoptions then + ppufile.getderef(cloneddefderef) + else + begin + symtable:=trecordsymtable.create(objrealname^,0); + trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte); + trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte); + trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte); + trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte); + trecordsymtable(symtable).datasize:=ppufile.getasizeint; + trecordsymtable(symtable).paddingsize:=ppufile.getword; + trecordsymtable(symtable).ppuload(ppufile); + { requires usefieldalignment to be set } + symtable.defowner:=self; + end; + isunion:=false; + end; + + + destructor trecorddef.destroy; + begin + if assigned(symtable) then + begin + symtable.free; + symtable:=nil; + end; + inherited destroy; + end; + + + function trecorddef.getcopy : tstoreddef; + begin + result:=trecorddef.create(objrealname^,symtable.getcopy); + trecorddef(result).isunion:=isunion; + include(trecorddef(result).defoptions,df_copied_def); + end; + + + function trecorddef.needs_inittable : boolean; + begin + needs_inittable:=trecordsymtable(symtable).needs_init_final + end; + + + procedure trecorddef.buildderef; + begin + inherited buildderef; + if df_copied_def in defoptions then + cloneddefderef.build(symtable.defowner) + else + tstoredsymtable(symtable).buildderef; + end; + + + procedure trecorddef.deref; + begin + inherited deref; + { now dereference the definitions } + if df_copied_def in defoptions then + begin + cloneddef:=trecorddef(cloneddefderef.resolve); + symtable:=cloneddef.symtable.getcopy; + end + else + tstoredsymtable(symtable).deref; + + { assign TGUID? load only from system unit } + if not(assigned(rec_tguid)) and + (upper(typename)='TGUID') and + assigned(owner) and + assigned(owner.name) and + (owner.name^='SYSTEM') then + rec_tguid:=self; + + { assign JMP_BUF? load only from system unit } + if not(assigned(rec_jmp_buf)) and + (upper(typename)='JMP_BUF') and + assigned(owner) and + assigned(owner.name) and + (owner.name^='SYSTEM') then + rec_jmp_buf:=self; + end; + + + procedure trecorddef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + if df_copied_def in defoptions then + ppufile.putderef(cloneddefderef) + else + begin + ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment)); + ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment)); + ppufile.putbyte(byte(trecordsymtable(symtable).padalignment)); + ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment)); + ppufile.putasizeint(trecordsymtable(symtable).datasize); + ppufile.putword(trecordsymtable(symtable).paddingsize); + end; + + ppufile.writeentry(ibrecorddef); + + if not(df_copied_def in defoptions) then + trecordsymtable(symtable).ppuwrite(ppufile); + end; + + + function trecorddef.size:asizeint; + begin + result:=trecordsymtable(symtable).datasize; + end; + + + function trecorddef.alignment:shortint; + begin + alignment:=trecordsymtable(symtable).recordalignment; + end; + + + function trecorddef.padalignment:shortint; + begin + padalignment := trecordsymtable(symtable).padalignment; + end; + + + function trecorddef.GetTypeName : string; + begin + GetTypeName:='<record type>' + end; + + +{*************************************************************************** + TABSTRACTPROCDEF +***************************************************************************} + + constructor tabstractprocdef.create(dt:tdeftyp;level:byte); + begin + inherited create(dt); + parast:=tparasymtable.create(self,level); + paras:=nil; + minparacount:=0; + maxparacount:=0; + proctypeoption:=potype_none; + proccalloption:=pocall_none; + procoptions:=[]; + returndef:=voidtype; + savesize:=sizeof(pint); + callerargareasize:=0; + calleeargareasize:=0; + has_paraloc_info:=callnoside; + funcretloc[callerside].init; + funcretloc[calleeside].init; + check_mark_as_nested; + end; + + + destructor tabstractprocdef.destroy; + begin + if assigned(paras) then + begin +{$ifdef MEMDEBUG} + memprocpara.start; +{$endif MEMDEBUG} + paras.free; + paras:=nil; +{$ifdef MEMDEBUG} + memprocpara.stop; +{$endif MEMDEBUG} + end; + if assigned(parast) then + begin +{$ifdef MEMDEBUG} + memprocparast.start; +{$endif MEMDEBUG} + parast.free; + parast:=nil; +{$ifdef MEMDEBUG} + memprocparast.stop; +{$endif MEMDEBUG} + end; + funcretloc[callerside].done; + funcretloc[calleeside].done; + inherited destroy; + end; + + + procedure tabstractprocdef.count_para(p:TObject;arg:pointer); + begin + if (tsym(p).typ<>paravarsym) then + exit; + inc(plongint(arg)^); + if not(vo_is_hidden_para in tparavarsym(p).varoptions) then + begin + if not assigned(tparavarsym(p).defaultconstsym) then + inc(minparacount); + inc(maxparacount); + end; + end; + + + procedure tabstractprocdef.insert_para(p:TObject;arg:pointer); + begin + if (tsym(p).typ<>paravarsym) then + exit; + paras.add(p); + end; + + + procedure tabstractprocdef.calcparas; + var + paracount : longint; + begin + { This can already be assigned when + we need to reresolve this unit (PFV) } + if assigned(paras) then + paras.free; + paras:=tparalist.create(false); + paracount:=0; + minparacount:=0; + maxparacount:=0; + parast.SymList.ForEachCall(@count_para,@paracount); + paras.capacity:=paracount; + { Insert parameters in table } + parast.SymList.ForEachCall(@insert_para,nil); + { Order parameters } + paras.sortparas; + end; + + + procedure tabstractprocdef.buildderef; + begin + { released procdef? } + if not assigned(parast) then + exit; + inherited buildderef; + returndefderef.build(returndef); + { parast } + tparasymtable(parast).buildderef; + end; + + + procedure tabstractprocdef.deref; + begin + inherited deref; + returndef:=tdef(returndefderef.resolve); + { parast } + tparasymtable(parast).deref; + { recalculated parameters } + calcparas; + end; + + + constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile); + begin + inherited ppuload(dt,ppufile); + parast:=nil; + Paras:=nil; + minparacount:=0; + maxparacount:=0; + ppufile.getderef(returndefderef); +{ TODO: remove fpu_used loading} + ppufile.getbyte; + proctypeoption:=tproctypeoption(ppufile.getbyte); + proccalloption:=tproccalloption(ppufile.getbyte); + ppufile.getnormalset(procoptions); + + funcretloc[callerside].init; + if po_explicitparaloc in procoptions then + funcretloc[callerside].ppuload(ppufile); + + savesize:=sizeof(pint); + if (po_explicitparaloc in procoptions) then + has_paraloc_info:=callerside; + end; + + + procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile); + var + oldintfcrc : boolean; + begin + { released procdef? } + if not assigned(parast) then + exit; + inherited ppuwrite(ppufile); + ppufile.putderef(returndefderef); + oldintfcrc:=ppufile.do_interface_crc; + ppufile.do_interface_crc:=false; + ppufile.putbyte(0); + ppufile.putbyte(ord(proctypeoption)); + ppufile.putbyte(ord(proccalloption)); + ppufile.putnormalset(procoptions); + ppufile.do_interface_crc:=oldintfcrc; + + if (po_explicitparaloc in procoptions) then + funcretloc[callerside].ppuwrite(ppufile); + end; + + + function tabstractprocdef.typename_paras(showhidden:boolean) : string; + var + hs,s : string; + hp : TParavarsym; + hpc : tconstsym; + first : boolean; + i : integer; + begin + s:=''; + first:=true; + for i:=0 to paras.count-1 do + begin + hp:=tparavarsym(paras[i]); + if not(vo_is_hidden_para in hp.varoptions) or + (showhidden) then + begin + if first then + begin + s:=s+'('; + first:=false; + end + else + s:=s+','; + if vo_is_hidden_para in hp.varoptions then + s:=s+'<'; + case hp.varspez of + vs_var : + s:=s+'var '; + vs_const : + s:=s+'const '; + vs_out : + s:=s+'out '; + vs_constref : + s:=s+'constref '; + end; + if hp.univpara then + s:=s+'univ '; + if assigned(hp.vardef.typesym) then + begin + hs:=hp.vardef.typesym.realname; + if hs[1]<>'$' then + s:=s+hs + else + s:=s+hp.vardef.GetTypeName; + end + else + s:=s+hp.vardef.GetTypeName; + { default value } + if assigned(hp.defaultconstsym) then + begin + hpc:=tconstsym(hp.defaultconstsym); + hs:=''; + case hpc.consttyp of + conststring, + constresourcestring : + begin + If hpc.value.len>0 then + begin + setLength(hs,hpc.value.len); + { don't write past the end of hs if the constant + is > 255 chars } + move(hpc.value.valueptr^,hs[1],length(hs)); + { make sure that constant strings with newline chars + don't create a linebreak in the assembler code, + since comments are line-based. Also remove nulls + because the comments are written as a pchar. } + ReplaceCase(hs,#0,'.'); + ReplaceCase(hs,#10,'.'); + ReplaceCase(hs,#13,'.'); + end; + end; + constreal : + str(pbestreal(hpc.value.valueptr)^,hs); + constpointer : + hs:=tostr(hpc.value.valueordptr); + constord : + begin + if is_boolean(hpc.constdef) then + begin + if hpc.value.valueord<>0 then + hs:='TRUE' + else + hs:='FALSE'; + end + else + hs:=tostr(hpc.value.valueord); + end; + constnil : + hs:='nil'; + constset : + hs:='<set>'; + end; + if hs<>'' then + s:=s+'="'+hs+'"'; + end; + if vo_is_hidden_para in hp.varoptions then + s:=s+'>'; + end; + end; + if not first then + s:=s+')'; + if (po_varargs in procoptions) then + s:=s+';VarArgs'; + typename_paras:=s; + end; + + + function tabstractprocdef.is_methodpointer:boolean; + begin + result:=false; + end; + + + function tabstractprocdef.is_addressonly:boolean; + begin + result:=true; + end; + + function tabstractprocdef.no_self_node: boolean; + begin + Result:=([po_staticmethod,po_classmethod]<=procoptions)or + (proctypeoption in [potype_class_constructor,potype_class_destructor,potype_operator]); + end; + + + procedure tabstractprocdef.check_mark_as_nested; + begin + { nested procvars require that nested functions use the Delphi-style + nested procedure calling convention } + if (parast.symtablelevel>normal_function_level) and + (m_nested_procvars in current_settings.modeswitches) then + include(procoptions,po_delphi_nested_cc); + end; + + + procedure tabstractprocdef.init_paraloc_info(side: tcallercallee); + begin + if (side in [callerside,callbothsides]) and + not(has_paraloc_info in [callerside,callbothsides]) then + begin + callerargareasize:=paramanager.create_paraloc_info(self,callerside); + if has_paraloc_info in [calleeside,callbothsides] then + has_paraloc_info:=callbothsides + else + has_paraloc_info:=callerside; + end; + if (side in [calleeside,callbothsides]) and + not(has_paraloc_info in [calleeside,callbothsides]) then + begin + calleeargareasize:=paramanager.create_paraloc_info(self,calleeside); + if has_paraloc_info in [callerside,callbothsides] then + has_paraloc_info:=callbothsides + else + has_paraloc_info:=calleeside; + end; + end; + + + function tabstractprocdef.stack_tainting_parameter(side: tcallercallee): boolean; + var + p: tparavarsym; + ploc: PCGParalocation; + i: longint; + begin + result:=false; + init_paraloc_info(side); + for i:=0 to parast.SymList.Count-1 do + if tsym(parast.SymList[i]).typ=paravarsym then + begin + p:=tparavarsym(parast.SymList[i]); + { check if no parameter is located on the stack } + if is_open_array(p.vardef) or + is_array_of_const(p.vardef) then + begin + result:=true; + exit; + end; + ploc:=p.paraloc[side].location; + while assigned(ploc) do + begin + if (ploc^.loc=LOC_REFERENCE) then + begin + result:=true; + exit + end; + ploc:=ploc^.next; + end; + end; + end; + + + + +{*************************************************************************** + TPROCDEF +***************************************************************************} + + constructor tprocdef.create(level:byte); + begin + inherited create(procdef,level); + localst:=tlocalsymtable.create(self,parast.symtablelevel); + _mangledname:=nil; + fileinfo:=current_filepos; + extnumber:=$ffff; + aliasnames:=TCmdStrList.create; + funcretsym:=nil; + forwarddef:=true; + interfacedef:=false; + hasforward:=false; + struct := nil; + import_dll:=nil; + import_name:=nil; + import_nr:=0; + inlininginfo:=nil; + deprecatedmsg:=nil; +{$ifdef i386} + fpu_used:=maxfpuregs; +{$endif i386} + interruptvector:=-1; + end; + + + constructor tprocdef.ppuload(ppufile:tcompilerppufile); + var + i,aliasnamescount : longint; + level : byte; + begin + inherited ppuload(procdef,ppufile); + if po_has_mangledname in procoptions then + _mangledname:=stringdup(ppufile.getstring) + else + _mangledname:=nil; + extnumber:=ppufile.getword; + level:=ppufile.getbyte; + ppufile.getderef(structderef); + ppufile.getderef(procsymderef); + ppufile.getposinfo(fileinfo); + visibility:=tvisibility(ppufile.getbyte); + ppufile.getsmallset(symoptions); + if sp_has_deprecated_msg in symoptions then + deprecatedmsg:=stringdup(ppufile.getstring) + else + deprecatedmsg:=nil; +{$ifdef powerpc} + { library symbol for AmigaOS/MorphOS } + ppufile.getderef(libsymderef); +{$endif powerpc} + { import stuff } + if po_has_importdll in procoptions then + import_dll:=stringdup(ppufile.getstring) + else + import_dll:=nil; + if po_has_importname in procoptions then + import_name:=stringdup(ppufile.getstring) + else + import_name:=nil; + import_nr:=ppufile.getword; +{$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE} + if target_info.system in systems_interrupt_table then + interruptvector:=ppufile.getlongint; +{$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE} + if (po_msgint in procoptions) then + messageinf.i:=ppufile.getlongint; + if (po_msgstr in procoptions) then + messageinf.str:=stringdup(ppufile.getstring); + if (po_dispid in procoptions) then + dispid:=ppufile.getlongint; + { inline stuff } + if (po_has_inlininginfo in procoptions) then + begin + ppufile.getderef(funcretsymderef); + new(inlininginfo); + ppufile.getsmallset(inlininginfo^.flags); + end + else + begin + inlininginfo:=nil; + funcretsym:=nil; + end; + + aliasnames:=TCmdStrList.create; + { count alias names } + aliasnamescount:=ppufile.getbyte; + for i:=1 to aliasnamescount do + aliasnames.insert(ppufile.getstring); + + { load para symtable } + parast:=tparasymtable.create(self,level); + tparasymtable(parast).ppuload(ppufile); + { load local symtable } + if (po_has_inlininginfo in procoptions) then + begin + localst:=tlocalsymtable.create(self,level); + tlocalsymtable(localst).ppuload(ppufile); + end + else + localst:=nil; + { inline stuff } + if (po_has_inlininginfo in procoptions) then + inlininginfo^.code:=ppuloadnodetree(ppufile); + { default values for no persistent data } + if (cs_link_deffile in current_settings.globalswitches) and + (tf_need_export in target_info.flags) and + (po_exports in procoptions) then + deffile.AddExport(mangledname); + forwarddef:=false; + interfacedef:=false; + hasforward:=false; + { Disable po_has_inlining until the derefimpl is done } + exclude(procoptions,po_has_inlininginfo); +{$ifdef i386} + fpu_used:=maxfpuregs; +{$endif i386} + end; + + + destructor tprocdef.destroy; + begin + aliasnames.free; + aliasnames:=nil; + if assigned(localst) and + (localst.symtabletype<>staticsymtable) then + begin +{$ifdef MEMDEBUG} + memproclocalst.start; +{$endif MEMDEBUG} + localst.free; + localst:=nil; +{$ifdef MEMDEBUG} + memproclocalst.start; +{$endif MEMDEBUG} + end; + if assigned(inlininginfo) then + begin +{$ifdef MEMDEBUG} + memprocnodetree.start; +{$endif MEMDEBUG} + tnode(inlininginfo^.code).free; +{$ifdef MEMDEBUG} + memprocnodetree.start; +{$endif MEMDEBUG} + dispose(inlininginfo); + inlininginfo:=nil; + end; + stringdispose(resultname); + stringdispose(import_dll); + stringdispose(import_name); + stringdispose(deprecatedmsg); + if (po_msgstr in procoptions) then + stringdispose(messageinf.str); + if assigned(_mangledname) then + begin +{$ifdef MEMDEBUG} + memmanglednames.start; +{$endif MEMDEBUG} + stringdispose(_mangledname); +{$ifdef MEMDEBUG} + memmanglednames.stop; +{$endif MEMDEBUG} + end; + inherited destroy; + end; + + + procedure tprocdef.ppuwrite(ppufile:tcompilerppufile); + var + oldintfcrc : boolean; + aliasnamescount : longint; + item : TCmdStrListItem; + begin + { released procdef? } + if not assigned(parast) then + exit; + + inherited ppuwrite(ppufile); + if po_has_mangledname in procoptions then + ppufile.putstring(_mangledname^); + + ppufile.putword(extnumber); + ppufile.putbyte(parast.symtablelevel); + ppufile.putderef(structderef); + ppufile.putderef(procsymderef); + ppufile.putposinfo(fileinfo); + ppufile.putbyte(byte(visibility)); + ppufile.putsmallset(symoptions); + if sp_has_deprecated_msg in symoptions then + ppufile.putstring(deprecatedmsg^); +{$ifdef powerpc} + { library symbol for AmigaOS/MorphOS } + ppufile.putderef(libsymderef); +{$endif powerpc} + { import } + if po_has_importdll in procoptions then + ppufile.putstring(import_dll^); + if po_has_importname in procoptions then + ppufile.putstring(import_name^); + ppufile.putword(import_nr); +{$ifdef FPC_HAS_SYSTEMS_INTERRUPT_TABLE} + if target_info.system in systems_interrupt_table then + ppufile.putlongint(interruptvector); +{$endif FPC_HAS_SYSTEMS_INTERRUPT_TABLE} + if (po_msgint in procoptions) then + ppufile.putlongint(messageinf.i); + if (po_msgstr in procoptions) then + ppufile.putstring(messageinf.str^); + if (po_dispid in procoptions) then + ppufile.putlongint(dispid); + { inline stuff } + oldintfcrc:=ppufile.do_crc; + ppufile.do_crc:=false; + if (po_has_inlininginfo in procoptions) then + begin + ppufile.putderef(funcretsymderef); + ppufile.putsmallset(inlininginfo^.flags); + end; + + { count alias names } + aliasnamescount:=0; + item:=TCmdStrListItem(aliasnames.first); + while assigned(item) do + begin + inc(aliasnamescount); + item:=TCmdStrListItem(item.next); + end; + if aliasnamescount>255 then + internalerror(200711021); + ppufile.putbyte(aliasnamescount); + item:=TCmdStrListItem(aliasnames.first); + while assigned(item) do + begin + ppufile.putstring(item.str); + item:=TCmdStrListItem(item.next); + end; + + ppufile.do_crc:=oldintfcrc; + + { write this entry } + ppufile.writeentry(ibprocdef); + + { Save the para symtable, this is taken from the interface } + tparasymtable(parast).ppuwrite(ppufile); + + { save localsymtable for inline procedures or when local + browser info is requested, this has no influence on the crc } + if (po_has_inlininginfo in procoptions) then + begin + oldintfcrc:=ppufile.do_crc; + ppufile.do_crc:=false; + tlocalsymtable(localst).ppuwrite(ppufile); + ppufile.do_crc:=oldintfcrc; + end; + + { node tree for inlining } + oldintfcrc:=ppufile.do_crc; + ppufile.do_crc:=false; + if (po_has_inlininginfo in procoptions) then + ppuwritenodetree(ppufile,inlininginfo^.code); + ppufile.do_crc:=oldintfcrc; + end; + + + function tprocdef.fullprocname(showhidden:boolean):string; + var + s : string; + t : ttoken; + begin +{$ifdef EXTDEBUG} + showhidden:=true; +{$endif EXTDEBUG} + s:=''; + if assigned(struct) then + begin + s:=struct.RttiName+'.'; + if (po_classmethod in procoptions) and + not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then + s:='class ' + s; + end; + if proctypeoption=potype_operator then + begin + for t:=NOTOKEN to last_overloaded do + if procsym.realname='$'+overloaded_names[t] then + begin + s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden); + break; + end; + end + else + s:=s+procsym.realname+typename_paras(showhidden); + case proctypeoption of + potype_constructor: + s:='constructor '+s; + potype_destructor: + s:='destructor '+s; + potype_class_constructor: + s:='class constructor '+s; + potype_class_destructor: + s:='class destructor '+s; + else + if assigned(returndef) and + not(is_void(returndef)) then + s:=s+':'+returndef.GetTypeName; + end; + if owner.symtabletype=localsymtable then + s:=s+' is nested'; + s:=s+';'; + { forced calling convention? } + if (po_hascallingconvention in procoptions) then + s:=s+' '+ProcCallOptionStr[proccalloption]+';'; + if (po_staticmethod in procoptions) and + not (proctypeoption in [potype_class_constructor,potype_class_destructor]) then + s:=s+' Static;'; + fullprocname:=s; + end; + + + function tprocdef.is_methodpointer:boolean; + begin + { don't check assigned(_class), that's also the case for nested + procedures inside methods } + result:=owner.symtabletype=ObjectSymtable; + end; + + + function tprocdef.is_addressonly:boolean; + begin + result:=assigned(owner) and + (owner.symtabletype<>ObjectSymtable) and + (not(m_nested_procvars in current_settings.modeswitches) or + not is_nested_pd(self)); + end; + + + procedure tprocdef.make_external; + begin + include(procoptions,po_external); + forwarddef:=false; + end; + + + function tprocdef.GetSymtable(t:tGetSymtable):TSymtable; + begin + case t of + gs_local : + GetSymtable:=localst; + gs_para : + GetSymtable:=parast; + else + GetSymtable:=nil; + end; + end; + + + procedure tprocdef.buildderef; + begin + inherited buildderef; + structderef.build(struct); + { procsym that originaly defined this definition, should be in the + same symtable } + procsymderef.build(procsym); +{$ifdef powerpc} + { library symbol for AmigaOS/MorphOS } + libsymderef.build(libsym); +{$endif powerpc} + end; + + + procedure tprocdef.buildderefimpl; + begin + inherited buildderefimpl; + + { Localst is not available for main/unit init } + if assigned(localst) then + begin + tlocalsymtable(localst).buildderef; + tlocalsymtable(localst).buildderefimpl; + end; + + { inline tree } + if (po_has_inlininginfo in procoptions) then + begin + funcretsymderef.build(funcretsym); + inlininginfo^.code.buildderefimpl; + end; + end; + + + procedure tprocdef.deref; + begin + inherited deref; + struct:=tabstractrecorddef(structderef.resolve); + { procsym that originaly defined this definition, should be in the + same symtable } + procsym:=tprocsym(procsymderef.resolve); +{$ifdef powerpc} + { library symbol for AmigaOS/MorphOS } + libsym:=tsym(libsymderef.resolve); +{$endif powerpc} + end; + + + procedure tprocdef.derefimpl; + begin + { Enable has_inlininginfo when the inlininginfo + structure is available. The has_inlininginfo was disabled + after the load, since the data was invalid } + if assigned(inlininginfo) then + include(procoptions,po_has_inlininginfo); + + { Locals } + if assigned(localst) then + begin + tlocalsymtable(localst).deref; + tlocalsymtable(localst).derefimpl; + end; + + { Inline } + if (po_has_inlininginfo in procoptions) then + begin + inlininginfo^.code.derefimpl; + { funcretsym, this is always located in the localst } + funcretsym:=tsym(funcretsymderef.resolve); + end + else + begin + { safety } + { Not safe! A unit may be reresolved after its interface has been + parsed but before its implementation has been parsed, and in that + case the funcretsym is still required! + funcretsym:=nil; } + end; + end; + + + function tprocdef.GetTypeName : string; + begin + GetTypeName := FullProcName(false); + end; + + + function tprocdef.mangledname : string; + var + hp : TParavarsym; + hs : string; + crc : dword; + newlen, + oldlen, + i : integer; + begin + if assigned(_mangledname) then + begin + {$ifdef compress} + mangledname:=minilzw_decode(_mangledname^); + {$else} + mangledname:=_mangledname^; + {$endif} + exit; + end; + { we need to use the symtable where the procsym is inserted, + because that is visible to the world } + mangledname:=make_mangledname('',procsym.owner,procsym.name); + oldlen:=length(mangledname); + { add parameter types } + for i:=0 to paras.count-1 do + begin + hp:=tparavarsym(paras[i]); + if not(vo_is_hidden_para in hp.varoptions) then + mangledname:=mangledname+'$'+hp.vardef.mangledparaname; + end; + { add resultdef, add $$ as separator to make it unique from a + parameter separator } + if not is_void(returndef) then + mangledname:=mangledname+'$$'+returndef.mangledparaname; + newlen:=length(mangledname); + { Replace with CRC if the parameter line is very long } + if (newlen-oldlen>12) and + ((newlen>100) or (newlen-oldlen>64)) then + begin + crc:=0; + for i:=0 to paras.count-1 do + begin + hp:=tparavarsym(paras[i]); + if not(vo_is_hidden_para in hp.varoptions) then + begin + hs:=hp.vardef.mangledparaname; + crc:=UpdateCrc32(crc,hs[1],length(hs)); + end; + end; + hs:=hp.vardef.mangledparaname; + crc:=UpdateCrc32(crc,hs[1],length(hs)); + mangledname:=Copy(mangledname,1,oldlen)+'$crc'+hexstr(crc,8); + end; + {$ifdef compress} + _mangledname:=stringdup(minilzw_encode(mangledname)); + {$else} + _mangledname:=stringdup(mangledname); + {$endif} + end; + + + function tprocdef.cplusplusmangledname : string; + + function getcppparaname(p : tdef) : string; + + const +{$ifdef NAMEMANGLING_GCC2} + ordtype2str : array[tordtype] of string[2] = ( + '', + 'Uc','Us','Ui','Us', + 'Sc','s','i','x', + 'b','b','b','b','b', + 'c','w','x'); +{$else NAMEMANGLING_GCC2} + ordtype2str : array[tordtype] of string[1] = ( + 'v', + 'h','t','j','y', + 'a','s','i','x', + 'b','b','b','b', + 'b','b','b','b', + 'c','w','x'); + + floattype2str : array[tfloattype] of string[1] = ( + 'f','d','e','e', + 'd','d','g'); +{$endif NAMEMANGLING_GCC2} + + var + s : string; + + begin + case p.typ of + orddef: + s:=ordtype2str[torddef(p).ordtype]; + pointerdef: + s:='P'+getcppparaname(tpointerdef(p).pointeddef); +{$ifndef NAMEMANGLING_GCC2} + floatdef: + s:=floattype2str[tfloatdef(p).floattype]; +{$endif NAMEMANGLING_GCC2} + else + internalerror(2103001); + end; + getcppparaname:=s; + end; + + var + s,s2 : string; + hp : TParavarsym; + i : integer; + + begin +{$ifdef NAMEMANGLING_GCC2} + + { outdated gcc 2.x name mangling scheme } + s := procsym.realname; + if procsym.owner.symtabletype=ObjectSymtable then + begin + s2:=upper(tobjectdef(procsym.owner.defowner).objrealname^); + case proctypeoption of + potype_destructor: + s:='_$_'+tostr(length(s2))+s2; + potype_constructor: + s:='___'+tostr(length(s2))+s2; + else + s:='_'+s+'__'+tostr(length(s2))+s2; + end; + + end + else s:=s+'__'; + + s:=s+'F'; + + { concat modifiers } + { !!!!! } + + { now we handle the parameters } + if maxparacount>0 then + begin + for i:=0 to paras.count-1 do + begin + hp:=tparavarsym(paras[i]); + { no hidden parameters form part of a C++ mangled name: + a) self is not included + b) there are no "high" or other hidden parameters + } + if vo_is_hidden_para in hp.varoptions then + continue; + s2:=getcppparaname(hp.vardef); + if hp.varspez in [vs_var,vs_out] then + s2:='R'+s2; + s:=s+s2; + end; + end + else + s:=s+'v'; + cplusplusmangledname:=s; +{$else NAMEMANGLING_GCC2} + + { gcc 3.x and 4.x name mangling scheme } + { see http://www.codesourcery.com/public/cxx-abi/abi.html#mangling } + if procsym.owner.symtabletype=ObjectSymtable then + begin + s:='_ZN'; + + s2:=tobjectdef(procsym.owner.defowner).objextname^; + s:=s+tostr(length(s2))+s2; + case proctypeoption of + potype_constructor: + s:=s+'C1'; + potype_destructor: + s:=s+'D1'; + else + s:=s+tostr(length(procsym.realname))+procsym.realname; + end; + + s:=s+'E'; + end + else + s:=procsym.realname; + + { now we handle the parameters } + if maxparacount>0 then + begin + for i:=0 to paras.count-1 do + begin + hp:=tparavarsym(paras[i]); + { no hidden parameters form part of a C++ mangled name: + a) self is not included + b) there are no "high" or other hidden parameters + } + if vo_is_hidden_para in hp.varoptions then + continue; + s2:=getcppparaname(hp.vardef); + if hp.varspez in [vs_var,vs_out] then + s2:='R'+s2; + s:=s+s2; + end; + end + else + s:=s+'v'; + cplusplusmangledname:=s; +{$endif NAMEMANGLING_GCC2} + end; + + + function tprocdef.objcmangledname : string; + var + manglednamelen: longint; + iscatmethod : boolean; + begin + if not (po_msgstr in procoptions) then + internalerror(2009030901); + { we may very well need longer strings to handle these... } + manglednamelen:=length(tobjectdef(procsym.owner.defowner).objextname^)+ + length('+"[ ]"')+length(messageinf.str^); + iscatmethod:=oo_is_classhelper in tobjectdef(procsym.owner.defowner).objectoptions; + if (iscatmethod) then + inc(manglednamelen,length(tobjectdef(procsym.owner.defowner).childof.objextname^)+length('()')); + if manglednamelen>255 then + Message1(parser_e_objc_message_name_too_long,messageinf.str^); + if not(po_classmethod in procoptions) then + result:='"-[' + else + result:='"+['; + { quotes are necessary because the +/- otherwise confuse the assembler + into expecting a number + } + if iscatmethod then + result:=result+tobjectdef(procsym.owner.defowner).childof.objextname^+'('; + result:=result+tobjectdef(procsym.owner.defowner).objextname^; + if iscatmethod then + result:=result+')'; + result:=result+' '+messageinf.str^+']"'; + end; + + + procedure tprocdef.setmangledname(const s : string); + begin + { This is not allowed anymore, the forward declaration + already needs to create the correct mangledname, no changes + afterwards are allowed (PFV) } + { Exception: interface definitions in mode macpas, since in that } + { case no reference to the old name can exist yet (JM) } + if assigned(_mangledname) then + if ((m_mac in current_settings.modeswitches) and + (interfacedef)) then + stringdispose(_mangledname) + else + internalerror(200411171); + {$ifdef compress} + _mangledname:=stringdup(minilzw_encode(s)); + {$else} + _mangledname:=stringdup(s); + {$endif} + include(procoptions,po_has_mangledname); + end; + + +{*************************************************************************** + TPROCVARDEF +***************************************************************************} + + constructor tprocvardef.create(level:byte); + begin + inherited create(procvardef,level); + end; + + + constructor tprocvardef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(procvardef,ppufile); + { load para symtable } + parast:=tparasymtable.create(self,ppufile.getbyte); + tparasymtable(parast).ppuload(ppufile); + end; + + + function tprocvardef.getcopy : tstoreddef; + var + i : tcallercallee; + j : longint; + begin + result:=tprocvardef.create(parast.symtablelevel); + tprocvardef(result).returndef:=returndef; + tprocvardef(result).returndefderef:=returndefderef; + tprocvardef(result).parast:=parast.getcopy; + tprocvardef(result).savesize:=savesize; + + { create paralist copy } + tprocvardef(result).paras:=tparalist.create(false); + tprocvardef(result).paras.count:=paras.count; + for j:=0 to paras.count-1 do + tprocvardef(result).paras[j]:=paras[j]; + + tprocvardef(result).proctypeoption:=proctypeoption; + tprocvardef(result).proccalloption:=proccalloption; + tprocvardef(result).procoptions:=procoptions; + tprocvardef(result).callerargareasize:=callerargareasize; + tprocvardef(result).calleeargareasize:=calleeargareasize; + tprocvardef(result).maxparacount:=maxparacount; + tprocvardef(result).minparacount:=minparacount; + for i:=low(tcallercallee) to high(tcallercallee) do + tprocvardef(result).funcretloc[i]:=funcretloc[i].getcopy; + tprocvardef(result).has_paraloc_info:=has_paraloc_info; +{$ifdef m68k} + tprocvardef(result).exp_funcretloc:=exp_funcretloc; +{$endif} + end; + + + procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + + { Save the para symtable level (necessary to distinguish nested + procvars) } + ppufile.putbyte(parast.symtablelevel); + + { Write this entry } + ppufile.writeentry(ibprocvardef); + + { Save the para symtable, this is taken from the interface } + tparasymtable(parast).ppuwrite(ppufile); + end; + + + function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable; + begin + case t of + gs_para : + GetSymtable:=parast; + else + GetSymtable:=nil; + end; + end; + + + function tprocvardef.size : asizeint; + begin + if ((po_methodpointer in procoptions) or + is_nested_pd(self)) and + not(po_addressonly in procoptions) then + size:=2*sizeof(pint) + else + size:=sizeof(pint); + end; + + + function tprocvardef.is_methodpointer:boolean; + begin + result:=(po_methodpointer in procoptions); + end; + + + function tprocvardef.is_addressonly:boolean; + begin + result:=(not(po_methodpointer in procoptions) and + not is_nested_pd(self)) or + (po_addressonly in procoptions); + end; + + + function tprocvardef.getmangledparaname:string; + begin + if not(po_methodpointer in procoptions) then + if not is_nested_pd(self) then + result:='procvar' + else + result:='nestedprovar' + else + result:='procvarofobj' + end; + + + function tprocvardef.is_publishable : boolean; + begin + is_publishable:=(po_methodpointer in procoptions); + end; + + + function tprocvardef.GetTypeName : string; + var + s: string; + showhidden : boolean; + begin +{$ifdef EXTDEBUG} + showhidden:=true; +{$else EXTDEBUG} + showhidden:=false; +{$endif EXTDEBUG} + s:='<'; + if po_classmethod in procoptions then + s := s+'class method type of' + else + if po_addressonly in procoptions then + s := s+'address of' + else + s := s+'procedure variable type of'; + if assigned(returndef) and + (returndef<>voidtype) then + s:=s+' function'+typename_paras(showhidden)+':'+returndef.GetTypeName + else + s:=s+' procedure'+typename_paras(showhidden); + if po_methodpointer in procoptions then + s := s+' of object'; + if is_nested_pd(self) then + s := s+' is nested'; + GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>'; + end; + + +{*************************************************************************** + TOBJECTDEF +***************************************************************************} + + constructor tobjectdef.create(ot:tobjecttyp;const n:string;c:tobjectdef); + begin + inherited create(n,objectdef); + fcurrent_dispid:=0; + objecttype:=ot; + childof:=nil; + if objecttype=odt_helper then + owner.includeoption(sto_has_helper); + symtable:=tObjectSymtable.create(self,n,current_settings.packrecords); + { create space for vmt !! } + vmtentries:=TFPList.Create; + vmt_offset:=0; + set_parent(c); + if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then + prepareguid; + { setup implemented interfaces } + if objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then + ImplementedInterfaces:=TFPObjectList.Create(true) + else + ImplementedInterfaces:=nil; + writing_class_record_dbginfo:=false; + end; + + + constructor tobjectdef.ppuload(ppufile:tcompilerppufile); + var + i, + implintfcount : longint; + d : tderef; + ImplIntf : TImplementedInterface; + vmtentry : pvmtentry; + begin + inherited ppuload(objectdef,ppufile); + objecttype:=tobjecttyp(ppufile.getbyte); + objextname:=stringdup(ppufile.getstring); + { only used for external Objective-C classes/protocols } + if (objextname^='') then + stringdispose(objextname); + import_lib:=stringdup(ppufile.getstring); + { only used for external C++ classes } + if (import_lib^='') then + stringdispose(import_lib); + symtable:=tObjectSymtable.create(self,objrealname^,0); + tObjectSymtable(symtable).datasize:=ppufile.getasizeint; + tObjectSymtable(symtable).paddingsize:=ppufile.getword; + tObjectSymtable(symtable).fieldalignment:=shortint(ppufile.getbyte); + tObjectSymtable(symtable).recordalignment:=shortint(ppufile.getbyte); + vmt_offset:=ppufile.getlongint; + ppufile.getderef(childofderef); + + { load guid } + iidstr:=nil; + if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then + begin + new(iidguid); + ppufile.getguid(iidguid^); + iidstr:=stringdup(ppufile.getstring); + end; + + if objecttype=odt_helper then + ppufile.getderef(extendeddefderef); + + vmtentries:=TFPList.Create; + vmtentries.count:=ppufile.getlongint; + for i:=0 to vmtentries.count-1 do + begin + ppufile.getderef(d); + new(vmtentry); + vmtentry^.procdef:=nil; + vmtentry^.procdefderef:=d; + vmtentry^.visibility:=tvisibility(ppufile.getbyte); + vmtentries[i]:=vmtentry; + end; + + { load implemented interfaces } + if objecttype in [odt_class,odt_objcclass,odt_objcprotocol] then + begin + ImplementedInterfaces:=TFPObjectList.Create(true); + implintfcount:=ppufile.getlongint; + for i:=0 to implintfcount-1 do + begin + ppufile.getderef(d); + ImplIntf:=TImplementedInterface.Create_deref(d); + ImplIntf.IOffset:=ppufile.getlongint; + ImplementedInterfaces.Add(ImplIntf); + end; + end + else + ImplementedInterfaces:=nil; + + if df_copied_def in defoptions then + ppufile.getderef(cloneddefderef) + else + tObjectSymtable(symtable).ppuload(ppufile); + + { handles the predefined class tobject } + { the last TOBJECT which is loaded gets } + { it ! } + if (childof=nil) and + (objecttype=odt_class) and + (objname^='TOBJECT') then + class_tobject:=self; + if (childof=nil) and + (objecttype=odt_interfacecom) then + if (objname^='IUNKNOWN') then + interface_iunknown:=self + else + if (objname^='IDISPATCH') then + interface_idispatch:=self; + if (childof=nil) and + (objecttype=odt_objcclass) and + (objname^='PROTOCOL') then + objc_protocoltype:=self; + writing_class_record_dbginfo:=false; + end; + + + destructor tobjectdef.destroy; + begin + if assigned(symtable) then + begin + symtable.free; + symtable:=nil; + end; + stringdispose(objextname); + stringdispose(import_lib); + stringdispose(iidstr); + if assigned(ImplementedInterfaces) then + begin + ImplementedInterfaces.free; + ImplementedInterfaces:=nil; + end; + if assigned(iidguid) then + begin + dispose(iidguid); + iidguid:=nil; + end; + if assigned(vmtentries) then + begin + resetvmtentries; + vmtentries.free; + vmtentries:=nil; + end; + if assigned(vmcallstaticinfo) then + begin + freemem(vmcallstaticinfo); + vmcallstaticinfo:=nil; + end; + inherited destroy; + end; + + + function tobjectdef.getcopy : tstoreddef; + var + i : longint; + begin + result:=tobjectdef.create(objecttype,objrealname^,childof); + { the constructor allocates a symtable which we release to avoid memory leaks } + tobjectdef(result).symtable.free; + tobjectdef(result).symtable:=symtable.getcopy; + if assigned(objextname) then + tobjectdef(result).objextname:=stringdup(objextname^); + if assigned(import_lib) then + tobjectdef(result).import_lib:=stringdup(import_lib^); + tobjectdef(result).objectoptions:=objectoptions; + include(tobjectdef(result).defoptions,df_copied_def); + tobjectdef(result).extendeddef:=extendeddef; + tobjectdef(result).vmt_offset:=vmt_offset; + if assigned(iidguid) then + begin + new(tobjectdef(result).iidguid); + move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^)); + end; + if assigned(iidstr) then + tobjectdef(result).iidstr:=stringdup(iidstr^); + if assigned(ImplementedInterfaces) then + begin + for i:=0 to ImplementedInterfaces.count-1 do + tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy); + end; + if assigned(vmtentries) then + begin + tobjectdef(result).vmtentries:=TFPList.Create; + tobjectdef(result).copyvmtentries(self); + end; + end; + + + procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile); + var + i : longint; + vmtentry : pvmtentry; + ImplIntf : TImplementedInterface; + old_do_indirect_crc: boolean; + begin + { if class1 in unit A changes, and class2 in unit B inherits from it + (so unit B uses unit A), then unit B with class2 will be recompiled. + However, if there is also a class3 in unit C that only depends on + unit B, then unit C will not be recompiled because nothing changed + to the interface of unit B. Nevertheless, unit C can indirectly + depend on unit A via derefs, and these must be updated -> the + indirect crc keeps track of such changes. } + old_do_indirect_crc:=ppufile.do_indirect_crc; + ppufile.do_indirect_crc:=true; + inherited ppuwrite(ppufile); + ppufile.putbyte(byte(objecttype)); + if assigned(objextname) then + ppufile.putstring(objextname^) + else + ppufile.putstring(''); + if assigned(import_lib) then + ppufile.putstring(import_lib^) + else + ppufile.putstring(''); + ppufile.putasizeint(tObjectSymtable(symtable).datasize); + ppufile.putword(tObjectSymtable(symtable).paddingsize); + ppufile.putbyte(byte(tObjectSymtable(symtable).fieldalignment)); + ppufile.putbyte(byte(tObjectSymtable(symtable).recordalignment)); + ppufile.putlongint(vmt_offset); + ppufile.putderef(childofderef); + if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then + begin + ppufile.putguid(iidguid^); + ppufile.putstring(iidstr^); + end; + if objecttype=odt_helper then + ppufile.putderef(extendeddefderef); + + ppufile.putlongint(vmtentries.count); + for i:=0 to vmtentries.count-1 do + begin + vmtentry:=pvmtentry(vmtentries[i]); + ppufile.putderef(vmtentry^.procdefderef); + ppufile.putbyte(byte(vmtentry^.visibility)); + end; + + + if assigned(ImplementedInterfaces) then + begin + ppufile.putlongint(ImplementedInterfaces.Count); + for i:=0 to ImplementedInterfaces.Count-1 do + begin + ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]); + ppufile.putderef(ImplIntf.intfdefderef); + ppufile.putlongint(ImplIntf.Ioffset); + end; + end; + + if df_copied_def in defoptions then + ppufile.putderef(cloneddefderef); + + ppufile.writeentry(ibobjectdef); + + if not(df_copied_def in defoptions) then + tObjectSymtable(symtable).ppuwrite(ppufile); + + ppufile.do_indirect_crc:=old_do_indirect_crc; + end; + + + function tobjectdef.GetTypeName:string; + begin + { in this case we will go in endless recursion, because then } + { there is no tsym associated yet with the def. It can occur } + { (tests/webtbf/tw4757.pp), so for now give a generic name } + { instead of the actual type name } + if not assigned(typesym) then + result:='<Currently Parsed Class>' + else + result:=typesymbolprettyname; + end; + + + procedure tobjectdef.buildderef; + var + i : longint; + vmtentry : pvmtentry; + begin + inherited buildderef; + childofderef.build(childof); + if df_copied_def in defoptions then + cloneddefderef.build(symtable.defowner) + else + tstoredsymtable(symtable).buildderef; + + if objecttype=odt_helper then + extendeddefderef.build(extendeddef); + + for i:=0 to vmtentries.count-1 do + begin + vmtentry:=pvmtentry(vmtentries[i]); + vmtentry^.procdefderef.build(vmtentry^.procdef); + end; + + if assigned(ImplementedInterfaces) then + begin + for i:=0 to ImplementedInterfaces.count-1 do + TImplementedInterface(ImplementedInterfaces[i]).buildderef; + end; + end; + + + procedure tobjectdef.deref; + var + i : longint; + vmtentry : pvmtentry; + begin + inherited deref; + childof:=tobjectdef(childofderef.resolve); + if df_copied_def in defoptions then + begin + cloneddef:=tobjectdef(cloneddefderef.resolve); + symtable:=cloneddef.symtable.getcopy; + end + else + tstoredsymtable(symtable).deref; + if objecttype=odt_helper then + extendeddef:=tdef(extendeddefderef.resolve); + for i:=0 to vmtentries.count-1 do + begin + vmtentry:=pvmtentry(vmtentries[i]); + vmtentry^.procdef:=tprocdef(vmtentry^.procdefderef.resolve); + end; + if assigned(ImplementedInterfaces) then + begin + for i:=0 to ImplementedInterfaces.count-1 do + TImplementedInterface(ImplementedInterfaces[i]).deref; + end; + end; + + + procedure create_class_helper_for_procdef(def: tobject; arg: pointer); + var + pd: tprocdef absolute def; + st: tsymtable; + psym: tsym; + nname: TIDString; + begin + if (tdef(def).typ<>procdef) then + exit; + { pd.owner = objcclass symtable -> defowner = objcclassdef -> + owner = symtable in which objcclassdef is defined + } + st:=pd.owner.defowner.owner; + nname:=class_helper_prefix+tprocsym(pd.procsym).name; + {Â check for an existing procsym with our special name } + psym:=tsym(st.find(nname)); + if not assigned(psym) then + begin + psym:=tprocsym.create(nname); + { avoid warning about this symbol being unused } + psym.IncRefCount; + { don't check for duplicates: + a) we checked above + b) in case we are in the implementation section of a unit, this + will also check for this symbol in the interface section + (since you normally cannot have symbols with the same name + both interface and implementation), and it's possible to + have class helpers for the same class in the interface and + in the implementation, and they cannot be merged since only + the once in the interface must be saved to the ppu/visible + from other units } + st.insert(psym,false); + end + else if (psym.typ<>procsym) then + internalerror(2009111501); + { add ourselves to this special procsym } + tprocsym(psym).procdeflist.add(def); + end; + + + procedure tobjectdef.buildderefimpl; + begin + inherited buildderefimpl; + if not (df_copied_def in defoptions) then + tstoredsymtable(symtable).buildderefimpl; + end; + + + procedure tobjectdef.derefimpl; + begin + inherited derefimpl; + if not (df_copied_def in defoptions) then + tstoredsymtable(symtable).derefimpl; + { the procdefs are not owned by the class helper procsyms, so they + are not stored/restored either -> re-add them here } + if (objecttype=odt_objcclass) or + (oo_is_classhelper in objectoptions) then + symtable.DefList.ForEachCall(@create_class_helper_for_procdef,nil); + end; + + + procedure tobjectdef.resetvmtentries; + var + i : longint; + begin + for i:=0 to vmtentries.Count-1 do + Dispose(pvmtentry(vmtentries[i])); + vmtentries.clear; + end; + + + procedure tobjectdef.copyvmtentries(objdef:tobjectdef); + var + i : longint; + vmtentry : pvmtentry; + begin + resetvmtentries; + vmtentries.count:=objdef.vmtentries.count; + for i:=0 to objdef.vmtentries.count-1 do + begin + new(vmtentry); + vmtentry^:=pvmtentry(objdef.vmtentries[i])^; + vmtentries[i]:=vmtentry; + end; + end; + + + function tobjectdef.getparentdef:tdef; + begin +{ TODO: Remove getparentdef hack} + { With 2 forward declared classes with the child class before the + parent class the child class is written earlier to the ppu. Leaving it + possible to have a reference to the parent class for property overriding, + but the parent class still has the childof not resolved yet (PFV) } + if childof=nil then + childof:=tobjectdef(childofderef.resolve); + result:=childof; + end; + + + procedure tobjectdef.prepareguid; + begin + { set up guid } + if not assigned(iidguid) then + begin + new(iidguid); + fillchar(iidguid^,sizeof(iidguid^),0); { default null guid } + end; + { setup iidstring } + if not assigned(iidstr) then + iidstr:=stringdup(''); { default is empty string } + end; + + + procedure tobjectdef.set_parent( c : tobjectdef); + begin + if assigned(childof) then + exit; + childof:=c; + if not assigned(c) then + exit; + { inherit options and status } + objectoptions:=objectoptions+(c.objectoptions*inherited_objectoptions); + { add the data of the anchestor class/object } + if (objecttype in [odt_class,odt_object,odt_objcclass]) then + begin + tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize+tObjectSymtable(c.symtable).datasize; + { inherit recordalignment } + tObjectSymtable(symtable).recordalignment:=tObjectSymtable(c.symtable).recordalignment; + { if both the parent and this record use C-alignment, also inherit + the current field alignment } + if (tObjectSymtable(c.symtable).usefieldalignment=C_alignment) and + (tObjectSymtable(symtable).usefieldalignment=C_alignment) then + tObjectSymtable(symtable).fieldalignment:=tObjectSymtable(c.symtable).fieldalignment; + { the padding is not inherited for Objective-C classes (maybe not + for cppclass either?) } + if objecttype=odt_objcclass then + tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-tObjectSymtable(c.symtable).paddingsize; + if (oo_has_vmt in objectoptions) and + (oo_has_vmt in c.objectoptions) then + tObjectSymtable(symtable).datasize:=tObjectSymtable(symtable).datasize-sizeof(pint); + { if parent has a vmt field then the offset is the same for the child PM } + if (oo_has_vmt in c.objectoptions) or is_class(self) then + begin + vmt_offset:=c.vmt_offset; + include(objectoptions,oo_has_vmt); + end; + end; + end; + + + procedure tobjectdef.insertvmt; + var + vs: tfieldvarsym; + begin + if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol] then + exit; + if (oo_has_vmt in objectoptions) then + internalerror(12345) + else + begin + tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize, + tObjectSymtable(symtable).fieldalignment); + + if (tf_requires_proper_alignment in target_info.flags) then + begin + { Align VMT pointer and whole object instance if target CPU requires alignment. } + tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(pint)); + tObjectSymtable(symtable).alignrecord(tObjectSymtable(symtable).datasize,sizeof(pint)); + end; + vs:=tfieldvarsym.create('_vptr$'+objname^,vs_value,voidpointertype,[]); + hidesym(vs); + tObjectSymtable(symtable).insert(vs); + tObjectSymtable(symtable).addfield(vs,vis_hidden); + if (tObjectSymtable(symtable).usefieldalignment<>bit_alignment) then + vmt_offset:=vs.fieldoffset + else + vmt_offset:=vs.fieldoffset div 8; + include(objectoptions,oo_has_vmt); + end; + end; + + + + procedure tobjectdef.check_forwards; + begin + if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcprotocol]) then + inherited; + if (oo_is_forward in objectoptions) then + begin + { ok, in future, the forward can be resolved } + Message1(sym_e_class_forward_not_resolved,objrealname^); + exclude(objectoptions,oo_is_forward); + end; + end; + + + { true if prot implements d (or if they are equal) } + function is_related_protocol(prot: tobjectdef; d : tdef) : boolean; + var + i : longint; + begin + { objcprotocols have multiple inheritance, all protocols from which + the current protocol inherits are stored in implementedinterfaces } + result:=prot=d; + if result then + exit; + + for i:=0 to prot.ImplementedInterfaces.count-1 do + begin + result:=is_related_protocol(TImplementedInterface(prot.ImplementedInterfaces[i]).intfdef,d); + if result then + exit; + end; + end; + + + { true, if self inherits from d (or if they are equal) } + function tobjectdef.is_related(d : tdef) : boolean; + var + hp : tobjectdef; + begin + if self=d then + begin + is_related:=true; + exit; + end; + + if (d.typ<>objectdef) then + begin + is_related:=false; + exit; + end; + + { Objective-C protocols can use multiple inheritance } + if (objecttype=odt_objcprotocol) then + begin + is_related:=is_related_protocol(self,d); + exit + end; + + { formally declared Objective-C classes match Objective-C classes with + the same name } + if (objecttype=odt_objcclass) and + (tobjectdef(d).objecttype=odt_objcclass) and + ((oo_is_formal in objectoptions) or + (oo_is_formal in tobjectdef(d).objectoptions)) and + (objrealname^=tobjectdef(d).objrealname^) then + begin + is_related:=true; + exit; + end; + + hp:=childof; + while assigned(hp) do + begin + if hp=d then + begin + is_related:=true; + exit; + end; + hp:=hp.childof; + end; + is_related:=false; + end; + + function tobjectdef.find_destructor: tprocdef; + var + objdef: tobjectdef; + begin + objdef:=self; + while assigned(objdef) do + begin + result:=objdef.find_procdef_bytype(potype_destructor); + if assigned(result) then + exit; + objdef:=objdef.childof; + end; + result:=nil; + end; + + function tobjectdef.implements_any_interfaces: boolean; + begin + result := (ImplementedInterfaces.Count > 0) or + (assigned(childof) and childof.implements_any_interfaces); + end; + + function tobjectdef.size : asizeint; + begin + if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper] then + result:=sizeof(pint) + else + result:=tObjectSymtable(symtable).datasize; + end; + + + function tobjectdef.alignment:shortint; + begin + if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper] then + alignment:=sizeof(pint) + else + alignment:=tObjectSymtable(symtable).recordalignment; + end; + + + function tobjectdef.vmtmethodoffset(index:longint):longint; + begin + { for offset of methods for classes, see rtl/inc/objpash.inc } + case objecttype of + odt_class: + { the +2*sizeof(pint) is size and -size } + vmtmethodoffset:=(index+10)*sizeof(pint)+2*sizeof(pint); + odt_helper, + odt_objcclass, + odt_objcprotocol: + vmtmethodoffset:=0; + odt_interfacecom,odt_interfacecorba,odt_dispinterface: + vmtmethodoffset:=index*sizeof(pint); + else +{$ifdef WITHDMT} + vmtmethodoffset:=(index+4)*sizeof(pint); +{$else WITHDMT} + vmtmethodoffset:=(index+3)*sizeof(pint); +{$endif WITHDMT} + end; + end; + + + function tobjectdef.vmt_mangledname : string; + begin + if not(oo_has_vmt in objectoptions) then + Message1(parser_n_object_has_no_vmt,objrealname^); + vmt_mangledname:=make_mangledname('VMT',owner,objname^); + end; + + + function tobjectdef.needs_inittable : boolean; + begin + case objecttype of + odt_helper, + odt_class : + needs_inittable:=false; + odt_dispinterface, + odt_interfacecom: + needs_inittable:=true; + odt_interfacecorba: + needs_inittable:=is_related(interface_iunknown); + odt_object: + needs_inittable:=tObjectSymtable(symtable).needs_init_final; + odt_cppclass, + odt_objcclass, + odt_objcprotocol: + needs_inittable:=false; + else + internalerror(200108267); + end; + end; + + + function tobjectdef.rtti_mangledname(rt: trttitype): string; + begin + if not(objecttype in [odt_objcclass,odt_objcprotocol]) then + result:=inherited rtti_mangledname(rt) + else + begin + { necessary in case of a dynamic array of nsobject, or + if an nsobject field appears in a record that needs + init/finalisation } + if rt=initrtti then + begin + result:=voidpointertype.rtti_mangledname(rt); + exit; + end; + + if not(target_info.system in systems_objc_nfabi) then + begin + result:=target_asm.labelprefix; + case objecttype of + odt_objcclass: + begin + case rt of + objcclassrtti: + if not(oo_is_classhelper in objectoptions) then + result:=result+'_OBJC_CLASS_' + else + result:=result+'_OBJC_CATEGORY_'; + objcmetartti: + if not(oo_is_classhelper in objectoptions) then + result:=result+'_OBJC_METACLASS_' + else + internalerror(2009111511); + else + internalerror(2009092302); + end; + end; + odt_objcprotocol: + result:=result+'_OBJC_PROTOCOL_'; + end; + end + else + begin + case objecttype of + odt_objcclass: + begin + if (oo_is_classhelper in objectoptions) and + (rt<>objcclassrtti) then + internalerror(2009111512); + case rt of + objcclassrtti: + if not(oo_is_classhelper in objectoptions) then + result:='_OBJC_CLASS_$_' + else + result:='_OBJC_$_CATEGORY_'; + objcmetartti: + result:='_OBJC_METACLASS_$_'; + objcclassrortti: + result:=lower(target_asm.labelprefix)+'_OBJC_CLASS_RO_$_'; + objcmetarortti: + result:=lower(target_asm.labelprefix)+'_OBJC_METACLASS_RO_$_'; + else + internalerror(2009092303); + end; + end; + odt_objcprotocol: + begin + result:=lower(target_asm.labelprefix); + case rt of + objcclassrtti: + result:=result+'_OBJC_PROTOCOL_$_'; + objcmetartti: + result:=result+'_OBJC_LABEL_PROTOCOL_$_'; + else + internalerror(2009092501); + end; + end; + end; + end; + result:=result+objextname^; + end; + end; + + + function tobjectdef.members_need_inittable : boolean; + begin + members_need_inittable:=tObjectSymtable(symtable).needs_init_final; + end; + + + function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface; + var + ImplIntf : TImplementedInterface; + i : longint; + begin + result:=nil; + if not assigned(ImplementedInterfaces) then + exit; + for i:=0 to ImplementedInterfaces.Count-1 do + begin + ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]); + if ImplIntf.intfdef=aintfdef then + begin + result:=ImplIntf; + exit; + end; + end; + end; + + + function tobjectdef.is_publishable : boolean; + begin + is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]; + end; + + + function tobjectdef.get_next_dispid: longint; + begin + inc(fcurrent_dispid); + result:=fcurrent_dispid; + end; + + function tobjectdef.search_enumerator_get: tprocdef; + begin + result:=inherited; + if not assigned(result) and assigned(childof) then + result:=childof.search_enumerator_get; + end; + + function tobjectdef.search_enumerator_move: tprocdef; + begin + result:=inherited; + if not assigned(result) and assigned(childof) then + result:=childof.search_enumerator_move; + end; + + function tobjectdef.search_enumerator_current: tsym; + begin + result:=inherited; + if not assigned(result) and assigned(childof) then + result:=childof.search_enumerator_current; + end; + + procedure tobjectdef.register_created_classref_type; + begin + if not classref_created_in_current_module then + begin + classref_created_in_current_module:=true; + current_module.wpoinfo.addcreatedobjtypeforclassref(self); + end; + end; + + + procedure tobjectdef.register_created_object_type; + begin + if not created_in_current_module then + begin + created_in_current_module:=true; + current_module.wpoinfo.addcreatedobjtype(self); + end; + end; + + + procedure tobjectdef.register_maybe_created_object_type; + begin + { if we know it has been created for sure, no need + to also record that it maybe can be created in + this module + } + if not (created_in_current_module) and + not (maybe_created_in_current_module) then + begin + maybe_created_in_current_module:=true; + current_module.wpoinfo.addmaybecreatedbyclassref(self); + end; + end; + + + procedure tobjectdef.register_vmt_call(index: longint); + begin + if (is_object(self) or is_class(self)) then + current_module.wpoinfo.addcalledvmtentry(self,index); + end; + + + procedure check_and_finish_msg(data: tobject; arg: pointer); + var + def: tdef absolute data; + pd: tprocdef absolute data; + i, + paracount: longint; + begin + if (def.typ=procdef) then + begin + { add all messages also under a dummy name to the symtable in + which the objcclass/protocol/category is declared, so they can + be called via id.<name> + } + create_class_helper_for_procdef(pd,nil); + + { we have to wait until now to set the mangled name because it + depends on the (possibly external) class name, which is defined + at the very end. } + if not(po_msgstr in pd.procoptions) then + begin + CGMessagePos(pd.fileinfo,parser_e_objc_requires_msgstr); + { recover to avoid internalerror later on } + include(pd.procoptions,po_msgstr); + pd.messageinf.str:=stringdup('MissingDeclaration'); + end; + { Mangled name is already set in case this is a copy of + another type. } + if not(po_has_mangledname in pd.procoptions) then + begin + { check whether the number of formal parameters is correct, + and whether they have valid Objective-C types } + paracount:=0; + for i:=1 to length(pd.messageinf.str^) do + if pd.messageinf.str^[i]=':' then + inc(paracount); + for i:=0 to pd.paras.count-1 do + if not(vo_is_hidden_para in tparavarsym(pd.paras[i]).varoptions) and + not is_array_of_const(tparavarsym(pd.paras[i]).vardef) then + dec(paracount); + if (paracount<>0) then + MessagePos(pd.fileinfo,sym_e_objc_para_mismatch); + + pd.setmangledname(pd.objcmangledname); + end + else + { all checks already done } + exit; + if not(oo_is_external in pd.struct.objectoptions) then + begin + if (po_varargs in pd.procoptions) then + MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external) + else + begin + { check for "array of const" parameters } + for i:=0 to pd.parast.symlist.count-1 do + begin + if (tsym(pd.parast.symlist[i]).typ=paravarsym) and + is_array_of_const(tparavarsym(pd.parast.symlist[i]).vardef) then + MessagePos(pd.fileinfo,parser_e_varargs_need_cdecl_and_external); + end; + end; + end; + end; + end; + + + procedure mark_private_fields_used(data: tobject; arg: pointer); + var + sym: tsym absolute data; + begin + if (sym.typ=fieldvarsym) and + (tfieldvarsym(sym).visibility in [vis_private,vis_strictprivate]) then + sym.IncRefCount; + end; + + + procedure tobjectdef.finish_objc_data; + begin + self.symtable.DefList.foreachcall(@check_and_finish_msg,nil); + if (oo_is_external in objectoptions) then + self.symtable.SymList.ForEachCall(@mark_private_fields_used,nil); + end; + + + procedure verify_objc_vardef(data: tobject; arg: pointer); + var + sym: tabstractvarsym absolute data; + res: pboolean absolute arg; + founderrordef: tdef; + begin + if not(tsym(data).typ in [paravarsym,fieldvarsym]) then + exit; + if (sym.typ=paravarsym) and + ((vo_is_hidden_para in tparavarsym(sym).varoptions) or + is_array_of_const(tparavarsym(sym).vardef)) then + exit; + if not objcchecktype(sym.vardef,founderrordef) then + begin + MessagePos1(sym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename); + res^:=false; + end; + end; + + + procedure verify_objc_procdef_paras(data: tobject; arg: pointer); + var + def: tdef absolute data; + res: pboolean absolute arg; + founderrordef: tdef; + begin + if (def.typ<>procdef) then + exit; + { check parameter types for validity } + tprocdef(def).paras.foreachcall(@verify_objc_vardef,arg); + { check the result type for validity } + if not objcchecktype(tprocdef(def).returndef,founderrordef) then + begin + MessagePos1(tprocdef(def).funcretsym.fileinfo,type_e_objc_type_unsupported,founderrordef.typename); + res^:=false; + end; + end; + + + function tobjectdef.check_objc_types: boolean; + begin + { done in separate step from finish_objc_data, because when + finish_objc_data is called, not all forwarddefs have been resolved + yet and we need to know all types here } + result:=true; + self.symtable.symlist.foreachcall(@verify_objc_vardef,@result); + self.symtable.deflist.foreachcall(@verify_objc_procdef_paras,@result); + end; + + + procedure do_cpp_import_info(data: tobject; arg: pointer); + var + def: tdef absolute data; + pd: tprocdef absolute data; + begin + if (def.typ=procdef) then + begin + pd.setmangledname(target_info.Cprefix+pd.cplusplusmangledname); + if (oo_is_external in pd.struct.objectoptions) then + begin + { copied from psub.read_proc } + if assigned(tobjectdef(pd.struct).import_lib) then + current_module.AddExternalImport(tobjectdef(pd.struct).import_lib^,pd.mangledname,pd.mangledname,0,false,false) + else + begin + { add import name to external list for DLL scanning } + if tf_has_dllscanner in target_info.flags then + current_module.dllscannerinputlist.Add(pd.mangledname,pd); + end; + + end; + end; + end; + + + procedure tobjectdef.finish_cpp_data; + begin + self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil); + end; + +{**************************************************************************** + TImplementedInterface +****************************************************************************} + + constructor TImplementedInterface.create(aintf: tobjectdef); + begin + inherited create; + intfdef:=aintf; + IOffset:=-1; + IType:=etStandard; + NameMappings:=nil; + procdefs:=nil; + end; + + + constructor TImplementedInterface.create_deref(d:tderef); + begin + inherited create; + intfdef:=nil; + intfdefderef:=d; + IOffset:=-1; + IType:=etStandard; + NameMappings:=nil; + procdefs:=nil; + end; + + + destructor TImplementedInterface.destroy; + var + i : longint; + mappedname : pshortstring; + begin + if assigned(NameMappings) then + begin + for i:=0 to NameMappings.Count-1 do + begin + mappedname:=pshortstring(NameMappings[i]); + stringdispose(mappedname); + end; + NameMappings.free; + NameMappings:=nil; + end; + if assigned(procdefs) then + begin + procdefs.free; + procdefs:=nil; + end; + inherited destroy; + end; + + + procedure TImplementedInterface.buildderef; + begin + intfdefderef.build(intfdef); + end; + + + procedure TImplementedInterface.deref; + begin + intfdef:=tobjectdef(intfdefderef.resolve); + end; + + + procedure TImplementedInterface.AddMapping(const origname,newname: string); + begin + if not assigned(NameMappings) then + NameMappings:=TFPHashList.Create; + NameMappings.Add(origname,stringdup(newname)); + end; + + + function TImplementedInterface.GetMapping(const origname: string):string; + var + mappedname : pshortstring; + begin + result:=''; + if not assigned(NameMappings) then + exit; + mappedname:=PShortstring(NameMappings.Find(origname)); + if assigned(mappedname) then + result:=mappedname^; + end; + + + procedure TImplementedInterface.AddImplProc(pd:tprocdef); + begin + if not assigned(procdefs) then + procdefs:=TFPObjectList.Create(false); + { duplicate entries must be stored, because multiple } + { interfaces can declare methods with the same name } + { and all of these get their own VMT entry } + procdefs.Add(pd); + end; + + + function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean; + var + i : longint; + begin + result:=false; + { interfaces being implemented through delegation are not mergable (FK) } + if (IType<>etStandard) or (MergingIntf.IType<>etStandard) or not(assigned(ProcDefs)) or not(assigned(MergingIntf.ProcDefs)) then + exit; + weight:=0; + { empty interface is mergeable } + if ProcDefs.Count=0 then + begin + result:=true; + exit; + end; + { The interface to merge must at least the number of + procedures of this interface } + if MergingIntf.ProcDefs.Count<ProcDefs.Count then + exit; + for i:=0 to ProcDefs.Count-1 do + begin + if MergingIntf.ProcDefs[i]<>ProcDefs[i] then + exit; + end; + weight:=ProcDefs.Count; + result:=true; + end; + + + function TImplementedInterface.getcopy:TImplementedInterface; + begin + Result:=TImplementedInterface.Create(nil); + { 1) the procdefs list will be freed once for each copy + 2) since the procdefs list owns its elements, those will also be freed for each copy + 3) idem for the name mappings + } + { warning: this is completely wrong on so many levels... + Move(pointer(self)^,pointer(result)^,InstanceSize); + We need to make clean copies of the different fields + this is not implemented yet, and thus we generate an internal + error instead PM 2011-06-14 } + internalerror(2011061401); + end; + +{**************************************************************************** + TFORWARDDEF +****************************************************************************} + + constructor tforwarddef.create(const s:string;const pos:tfileposinfo); + begin + inherited create(forwarddef); + tosymname:=stringdup(s); + forwardpos:=pos; + end; + + + function tforwarddef.GetTypeName:string; + begin + GetTypeName:='unresolved forward to '+tosymname^; + end; + + + destructor tforwarddef.destroy; + begin + stringdispose(tosymname); + inherited destroy; + end; + + function tforwarddef.getcopy:tstoreddef; + begin + result:=tforwarddef.create(tosymname^, forwardpos); + end; + +{**************************************************************************** + TUNDEFINEDDEF +****************************************************************************} + + constructor tundefineddef.create; + begin + inherited create(undefineddef); + end; + + + constructor tundefineddef.ppuload(ppufile:tcompilerppufile); + begin + inherited ppuload(undefineddef,ppufile); + end; + + function tundefineddef.GetTypeName:string; + begin + GetTypeName:='<undefined type>'; + end; + + + procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile); + begin + inherited ppuwrite(ppufile); + ppufile.writeentry(ibundefineddef); + end; + + +{**************************************************************************** + TERRORDEF +****************************************************************************} + + constructor terrordef.create; + begin + inherited create(errordef); + { prevent consecutive faults } + savesize:=1; + end; + + + procedure terrordef.ppuwrite(ppufile:tcompilerppufile); + begin + { Can't write errordefs to ppu } + internalerror(200411063); + end; + + + function terrordef.GetTypeName:string; + begin + GetTypeName:='<erroneous type>'; + end; + + + function terrordef.getmangledparaname:string; + begin + getmangledparaname:='error'; + end; + + +{**************************************************************************** + Definition Helpers +****************************************************************************} + + function is_interfacecom(def: tdef): boolean; + begin + is_interfacecom:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_interfacecom); + end; + + function is_interfacecom_or_dispinterface(def: tdef): boolean; + begin + is_interfacecom_or_dispinterface:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_interfacecom,odt_dispinterface]); + end; + + function is_interfacecorba(def: tdef): boolean; + begin + is_interfacecorba:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_interfacecorba); + end; + + function is_interface(def: tdef): boolean; + begin + is_interface:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]); + end; + + + function is_dispinterface(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_dispinterface); + end; + + + function is_class(def: tdef): boolean; + begin + is_class:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_class); + end; + + + function is_object(def: tdef): boolean; + begin + is_object:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_object); + end; + + + function is_cppclass(def: tdef): boolean; + begin + is_cppclass:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_cppclass); + end; + + + function is_objcclass(def: tdef): boolean; + begin + is_objcclass:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_objcclass); + end; + + + function is_objectpascal_helper(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_helper); + end; + + + function is_objcclassref(def: tdef): boolean; + begin + is_objcclassref:= + assigned(def) and + (def.typ=classrefdef) and + is_objcclass(tclassrefdef(def).pointeddef); + end; + + + function is_objcprotocol(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype=odt_objcprotocol); + end; + + + function is_objccategory(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + { if used as a forward type } + ((tobjectdef(def).objecttype=odt_objccategory) or + { if used as after it has been resolved } + ((tobjectdef(def).objecttype=odt_objcclass) and + (oo_is_classhelper in tobjectdef(def).objectoptions))); + end; + + function is_objc_class_or_protocol(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_objcclass,odt_objcprotocol]); + end; + + + function is_objc_protocol_or_category(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + ((tobjectdef(def).objecttype = odt_objcprotocol) or + ((tobjectdef(def).objecttype = odt_objcclass) and + (oo_is_classhelper in tobjectdef(def).objectoptions))); + end; + + function is_classhelper(def: tdef): boolean; + begin + result:= + is_objectpascal_helper(def) or + is_objccategory(def); + end; + + function is_class_or_interface(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]); + end; + + + function is_class_or_interface_or_objc(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_objcclass,odt_objcprotocol]); + end; + + + function is_class_or_interface_or_object(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_object]); + end; + + + function is_class_or_interface_or_dispinterface(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]); + end; + + + function is_implicit_pointer_object_type(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=objectdef) and + (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface,odt_objcclass,odt_objcprotocol,odt_helper]); + 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; + + function is_record(def: tdef): boolean; + begin + result:= + assigned(def) and + (def.typ=recorddef); + end; + + procedure loadobjctypes; + begin + objc_metaclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_CLASS',true).typedef); + objc_superclasstype:=tpointerdef(search_named_unit_globaltype('OBJC','POBJC_SUPER',true).typedef); + objc_idtype:=tpointerdef(search_named_unit_globaltype('OBJC','ID',true).typedef); + objc_seltype:=tpointerdef(search_named_unit_globaltype('OBJC','SEL',true).typedef); + objc_objecttype:=trecorddef(search_named_unit_globaltype('OBJC','OBJC_OBJECT',true).typedef); + end; + + + procedure maybeloadcocoatypes; + var + tsym: ttypesym; + begin + if assigned(objc_fastenumeration) then + exit; + tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONPROTOCOL',false); + if assigned(tsym) then + objc_fastenumeration:=tobjectdef(tsym.typedef) + else + objc_fastenumeration:=nil; + tsym:=search_named_unit_globaltype('COCOAALL','NSFASTENUMERATIONSTATE',false); + if assigned(tsym) then + objc_fastenumerationstate:=trecorddef(tsym.typedef) + else + objc_fastenumerationstate:=nil; + end; + + + function use_vectorfpu(def : tdef) : boolean; + begin +{$ifdef x86} +{$define use_vectorfpuimplemented} + use_vectorfpu:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or + (is_double(def) and (current_settings.fputype in sse_doublescalar)); +{$endif x86} +{$ifdef arm} +{$define use_vectorfpuimplemented} + use_vectorfpu:=(current_settings.fputype in vfp_scalar); +{$endif arm} +{$ifndef use_vectorfpuimplemented} + use_vectorfpu:=false; +{$endif} + end; + +end. |