|
|
@@ -0,0 +1,2546 @@
|
|
|
+{
|
|
|
+ $Id$
|
|
|
+
|
|
|
+ This unit handles definitions
|
|
|
+
|
|
|
+ Copyright (C) 1999 by Daniel Mantione,
|
|
|
+ member of the Free Pascal development team
|
|
|
+
|
|
|
+ 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.
|
|
|
+ ****************************************************************************
|
|
|
+}
|
|
|
+{$ifdef TP}
|
|
|
+ {$N+,E+,F+}
|
|
|
+{$endif}
|
|
|
+
|
|
|
+unit defs;
|
|
|
+
|
|
|
+interface
|
|
|
+
|
|
|
+uses symtable,objects,cobjects,symtablt,globtype
|
|
|
+{$ifdef i386}
|
|
|
+ ,i386base
|
|
|
+{$endif}
|
|
|
+{$ifdef m68k}
|
|
|
+ ,m68k
|
|
|
+{$endif}
|
|
|
+{$ifdef alpha}
|
|
|
+ ,alpha
|
|
|
+{$endif};
|
|
|
+
|
|
|
+type Targconvtyp=(act_convertable,act_equal,act_exact);
|
|
|
+
|
|
|
+ Tvarspez=(vs_value,vs_const,vs_var);
|
|
|
+
|
|
|
+ Tobjprop=(sp_public,sp_private,sp_protected,
|
|
|
+ sp_forwarddef,sp_static);
|
|
|
+ Tobjpropset=set of Tobjprop;
|
|
|
+
|
|
|
+ Tobjoption=(oo_is_abstract, {The object/class has
|
|
|
+ an abstract method => no
|
|
|
+ instances can be created.}
|
|
|
+ oo_is_class, {The object is a class.}
|
|
|
+ oo_has_virtual, {The object/class has
|
|
|
+ virtual methods.}
|
|
|
+ oo_has_private, {The object has private members.}
|
|
|
+ oo_has_protected, {The obejct has protected
|
|
|
+ members.}
|
|
|
+ oo_isforward, {The class is only a forward
|
|
|
+ declared yet.}
|
|
|
+ oo_can_have_published, {True, if the class has rtti, i.e.
|
|
|
+ you can publish properties.}
|
|
|
+ oo_has_constructor, {The object/class has a
|
|
|
+ constructor.}
|
|
|
+ oo_has_destructor, {The object/class has a
|
|
|
+ destructor.}
|
|
|
+ oo_has_vmt, {The object/class has a vmt.}
|
|
|
+ oo_has_msgstr,
|
|
|
+ oo_has_msgint,
|
|
|
+ oo_cppvmt); {The object/class uses an C++
|
|
|
+ compatible vmt, all members of
|
|
|
+ the same class tree, must use
|
|
|
+ then a C++ compatible vmt.}
|
|
|
+ Tobjoptionset=set of Tobjoption;
|
|
|
+
|
|
|
+ {Options for Tprocdef and Tprocvardef}
|
|
|
+ Tprocoption=(povirtualmethod, {Procedure is a virtual method.}
|
|
|
+ poclearstack, {Use IBM flat calling convention.
|
|
|
+ (Used by GCC.)}
|
|
|
+ poconstructor, {Procedure is a constructor.}
|
|
|
+ podestructor, {Procedure is a destructor.}
|
|
|
+ pointernproc, {Procedure has compiler magic.}
|
|
|
+ poexports, {Procedure is exported.}
|
|
|
+ poiocheck, {IO checking should be done after
|
|
|
+ a call to the procedure.}
|
|
|
+ poabstractmethod, {Procedure is an abstract method.}
|
|
|
+ pointerrupt, {Procedure is an interrupt handler.}
|
|
|
+ poinline, {Procedure is an assembler macro.}
|
|
|
+ poassembler, {Procedure is written in assembler.}
|
|
|
+ pooperator, {Procedure defines an operator.}
|
|
|
+ poexternal, {Procedure is external (in other
|
|
|
+ object or lib)}
|
|
|
+ poleftright, {Push parameters from left to right.}
|
|
|
+ poprocinit, {Program initialization.}
|
|
|
+ postaticmethod, {Static method.}
|
|
|
+ pooveridingmethod, {Method with override directive }
|
|
|
+ poclassmethod, {Class method.}
|
|
|
+ pounitinit, {Unit initialization }
|
|
|
+ pomethodpointer, {Method pointer, only in procvardef,
|
|
|
+ also used for 'with object do' }
|
|
|
+ pocdecl, {Procedure uses C styled calling }
|
|
|
+ popalmossyscall, {Procedure is a PalmOS system call }
|
|
|
+ pointernconst, {Procedure has constant evaluator
|
|
|
+ intern.}
|
|
|
+ poregister, {Procedure uses register (fastcall)
|
|
|
+ calling }
|
|
|
+ pounitfinalize, {Unit finalization }
|
|
|
+ postdcall, {Procedure uses stdcall
|
|
|
+ call.}
|
|
|
+ pomsgstr, {Method for string message
|
|
|
+ handling.}
|
|
|
+ pomsgint, {Method for int message handling.}
|
|
|
+ posavestdregs, {Save std regs cdecl and stdcall
|
|
|
+ need that !}
|
|
|
+ pocontainsself, {Self is passed explicit to the
|
|
|
+ compiler.}
|
|
|
+ posafecall); {Safe call calling conventions }
|
|
|
+ Tprocoptionset=set of Tprocoption;
|
|
|
+
|
|
|
+ Tarrayoption=(ap_variant,ap_constructor,ap_arrayofconst);
|
|
|
+ Tarrayoptionset=set of Tarrayoption;
|
|
|
+
|
|
|
+ Pparameter=^Tparameter;
|
|
|
+ Tparameter=object(Tobject)
|
|
|
+ data:Psym;
|
|
|
+ paratyp:Tvarspez;
|
|
|
+ argconvtyp:Targconvtyp;
|
|
|
+ convertlevel:byte;
|
|
|
+ register:Tregister;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Tfiletype=(ft_text,ft_typed,ft_untyped);
|
|
|
+
|
|
|
+ Pfiledef=^Tfiledef;
|
|
|
+ Tfiledef=object(Tdef)
|
|
|
+ filetype:Tfiletype;
|
|
|
+ typed_as:Pdef;
|
|
|
+ constructor init(Aowner:Pcontainingsymtable;
|
|
|
+ ft:Tfiletype;tas:Pdef);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure deref;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ procedure setsize;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist:Paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pformaldef=^Tformaldef;
|
|
|
+ Tformaldef=object(Tdef)
|
|
|
+ constructor init(Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist:Paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Perrordef=^Terrordef;
|
|
|
+ Terrordef=object(Tdef)
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+{$endif GDB}
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pabstractpointerdef=^Tabstractpointerdef;
|
|
|
+ Tabstractpointerdef=object(Tdef)
|
|
|
+ definition:Pdef;
|
|
|
+ defsym:Psym;
|
|
|
+ constructor init(Aowner:Pcontainingsymtable;def:Pdef);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure deref;virtual;
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist:Paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ end;
|
|
|
+
|
|
|
+ Ppointerdef=^Tpointerdef;
|
|
|
+ Tpointerdef=object(Tabstractpointerdef)
|
|
|
+ is_far:boolean;
|
|
|
+ constructor initfar(Aowner:Pcontainingsymtable;def:Pdef);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pclassrefdef=^Tclassrefdef;
|
|
|
+ Tclassrefdef=object(Tpointerdef)
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist : paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pobjectdef=^Tobjectdef;
|
|
|
+ Tobjectdef=object(Tdef)
|
|
|
+ childof:Pobjectdef;
|
|
|
+ objname:Pstring;
|
|
|
+ privatesyms,
|
|
|
+ protectedsyms,
|
|
|
+ publicsyms:Pobjectsymtable;
|
|
|
+ options:Tobjoptionset;
|
|
|
+ {To be able to have a variable vmt position
|
|
|
+ and no vmt field for objects without virtuals }
|
|
|
+ vmt_offset:longint;
|
|
|
+ constructor init(const n:string;Aowner:Pcontainingsymtable;
|
|
|
+ parent:Pobjectdef);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure check_forwards;
|
|
|
+ procedure insertvmt;
|
|
|
+ function isrelated(d:Pobjectdef):boolean;
|
|
|
+ function search(const s:string):Psym;
|
|
|
+ function speedsearch(const s:string;
|
|
|
+ speedvalue:longint):Psym;virtual;
|
|
|
+ function size:longint;virtual;
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ function vmt_mangledname : string;
|
|
|
+ function rtti_name : string;
|
|
|
+
|
|
|
+ procedure set_parent(parent:Pobjectdef);
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure deref;virtual;
|
|
|
+
|
|
|
+ function needs_inittable:boolean;virtual;
|
|
|
+ procedure write_init_data;virtual;
|
|
|
+ procedure write_child_init_data;virtual;
|
|
|
+
|
|
|
+ {Rtti }
|
|
|
+ function get_rtti_label:string;virtual;
|
|
|
+ procedure generate_rtti;virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ procedure write_child_rtti_data;virtual;
|
|
|
+ function next_free_name_index:longint;
|
|
|
+ function is_publishable:boolean;virtual;
|
|
|
+ destructor done;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Parraydef=^Tarraydef;
|
|
|
+ Tarraydef=object(Tdef)
|
|
|
+ lowrange,
|
|
|
+ highrange:Tconstant;
|
|
|
+ definition:Pdef;
|
|
|
+ rangedef:Pdef;
|
|
|
+ options:Tarrayoptionset;
|
|
|
+ constructor init(const l,h:Tconstant;rd:Pdef;
|
|
|
+ Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ function elesize:longint;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist : paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure deref;virtual;
|
|
|
+ function size : longint;virtual;
|
|
|
+ { generates the ranges needed by the asm instruction BOUND (i386)
|
|
|
+ or CMP2 (Motorola) }
|
|
|
+ procedure genrangecheck;
|
|
|
+
|
|
|
+ { returns the label of the range check string }
|
|
|
+ function getrangecheckstring : string;
|
|
|
+ function needs_inittable : boolean;virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ procedure write_child_rtti_data;virtual;
|
|
|
+ private
|
|
|
+ rangenr:longint;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Penumdef=^Tenumdef;
|
|
|
+ Tenumdef=object(Tdef)
|
|
|
+ rangenr,
|
|
|
+ minval,
|
|
|
+ maxval:longint;
|
|
|
+ has_jumps:boolean;
|
|
|
+ symbols:Pcollection;
|
|
|
+ basedef:Penumdef;
|
|
|
+ constructor init(Aowner:Pcontainingsymtable);
|
|
|
+ constructor init_subrange(Abasedef:Penumdef;Amin,Amax:longint;
|
|
|
+ Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure deref;virtual;
|
|
|
+ procedure calcsavesize;
|
|
|
+ function getrangecheckstring:string;
|
|
|
+ procedure genrangecheck;
|
|
|
+ procedure setmax(Amax:longint);
|
|
|
+ procedure setmin(Amin:longint);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure write_child_rtti_data;virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ function is_publishable : boolean;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Tbasetype=(uauto,uvoid,uchar,
|
|
|
+ u8bit,u16bit,u32bit,
|
|
|
+ s8bit,s16bit,s32bit,
|
|
|
+ bool8bit,bool16bit,bool32bit { uwchar,bool1bit,bitfield},
|
|
|
+ u64bit,s64bitint);
|
|
|
+
|
|
|
+ Porddef=^Torddef;
|
|
|
+ Torddef=object(Tdef)
|
|
|
+ low,high:Tconstant;
|
|
|
+ rangenr:longint;
|
|
|
+ typ:Tbasetype;
|
|
|
+ constructor init(t:tbasetype;l,h:Tconstant;
|
|
|
+ Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ procedure setsize;
|
|
|
+
|
|
|
+ { generates the ranges needed by the asm instruction BOUND }
|
|
|
+ { or CMP2 (Motorola) }
|
|
|
+ procedure genrangecheck;
|
|
|
+ { returns the label of the range check string }
|
|
|
+ function getrangecheckstring : string;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ function is_publishable:boolean;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+{$endif GDB}
|
|
|
+ end;
|
|
|
+
|
|
|
+ {S80real is dependant on the cpu, s64comp is also
|
|
|
+ dependant on the size (tp = 80bit for both)
|
|
|
+ The EXTENDED format exists on the motorola FPU
|
|
|
+ but it uses 96 bits instead of 80, with some
|
|
|
+ unused bits within the number itself! Pretty
|
|
|
+ complicated to support, so no support for the
|
|
|
+ moment.
|
|
|
+ S64comp is considered as a real because all
|
|
|
+ calculations are done by the fpu.}
|
|
|
+
|
|
|
+ Tfloattype=(s32real,s64real,s80real,s64comp,f16bit,f32bit);
|
|
|
+
|
|
|
+ Pfloatdef=^Tfloatdef;
|
|
|
+ Tfloatdef=object(tdef)
|
|
|
+ typ:Tfloattype;
|
|
|
+ constructor init(t:Tfloattype;Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ function is_publishable : boolean;virtual;
|
|
|
+ procedure setsize;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Tsettype=(normset,smallset,varset);
|
|
|
+
|
|
|
+ Psetdef=^Tsetdef;
|
|
|
+ Tsetdef=object(Tdef)
|
|
|
+ setof:Pdef;
|
|
|
+ settype:Tsettype;
|
|
|
+ constructor init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist : paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure deref;virtual;
|
|
|
+ function is_publishable : boolean;virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ procedure write_child_rtti_data;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Precorddef=^Trecorddef;
|
|
|
+ Trecorddef=object(Tdef)
|
|
|
+ symtable:Precordsymtable;
|
|
|
+ constructor init(s:Precordsymtable;Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+{$ifdef GDB}
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist : paasmoutput);virtual;
|
|
|
+{$endif GDB}
|
|
|
+ procedure deref;virtual;
|
|
|
+ function needs_inittable : boolean;virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ procedure write_init_data;virtual;
|
|
|
+ procedure write_child_rtti_data;virtual;
|
|
|
+ procedure write_child_init_data;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ destructor done;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pabstractprocdef=^Pabstractprocdef;
|
|
|
+ Tabstractprocdef=object(Tdef)
|
|
|
+ {Saves a definition to the return type }
|
|
|
+ retdef:Pdef;
|
|
|
+ fpu_used:byte; {How many stack fpu must be empty.}
|
|
|
+ options:Tprocoptionset; {Save the procedure options.}
|
|
|
+ parameters:Pcollection;
|
|
|
+ constructor init(Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ destructor done;virtual;
|
|
|
+ procedure deref;virtual;
|
|
|
+ function demangled_paras:string;
|
|
|
+ function para_size:longint;
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ procedure test_if_fpu_result;
|
|
|
+ {$ifdef GDB}
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist : paasmoutput);virtual;
|
|
|
+ {$endif GDB}
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pprocvardef=^Pprocvardef;
|
|
|
+ Tprocvardef=object(Tabstractprocdef)
|
|
|
+ function size:longint;virtual;
|
|
|
+ {$ifdef GDB}
|
|
|
+ function stabstring:Pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist:Paasmoutput); virtual;
|
|
|
+ {$endif GDB}
|
|
|
+ procedure write_child_rtti_data;virtual;
|
|
|
+ function is_publishable:boolean;virtual;
|
|
|
+ procedure write_rtti_data;virtual;
|
|
|
+ function gettypename:string;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+ Pprocdef = ^Tprocdef;
|
|
|
+ Tprocdef = object(tabstractprocdef)
|
|
|
+ objprop:Tobjpropset;
|
|
|
+ extnumber:longint;
|
|
|
+ { where is this function defined, needed here because there
|
|
|
+ is only one symbol for all overloaded functions }
|
|
|
+ fileinfo:Tfileposinfo;
|
|
|
+ { pointer to the local symbol table }
|
|
|
+ localst:Pprocsymtable;
|
|
|
+ _mangledname:Pstring;
|
|
|
+ { it's a tree, but this not easy to handle }
|
|
|
+ { used for inlined procs }
|
|
|
+ code : pointer;
|
|
|
+ { true, if the procedure is only declared }
|
|
|
+ { (forward procedure) }
|
|
|
+ references:Pcollection;
|
|
|
+ forwarddef,
|
|
|
+ { true if the procedure is declared in the interface }
|
|
|
+ interfacedef : boolean;
|
|
|
+ { check the problems of manglednames }
|
|
|
+ count : boolean;
|
|
|
+ is_used : boolean;
|
|
|
+ { set which contains the modified registers }
|
|
|
+ usedregisters:Tregisterset;
|
|
|
+ constructor init(Aowner:Pcontainingsymtable);
|
|
|
+ constructor load(var s:Tstream);
|
|
|
+ procedure store(var s:Tstream);virtual;
|
|
|
+ {$ifdef GDB}
|
|
|
+ function cplusplusmangledname : string;
|
|
|
+ function stabstring : pchar;virtual;
|
|
|
+ procedure concatstabto(asmlist : paasmoutput);virtual;
|
|
|
+ {$endif GDB}
|
|
|
+ procedure deref;virtual;
|
|
|
+ function mangledname:string;
|
|
|
+ procedure setmangledname(const s:string);
|
|
|
+ procedure load_references;
|
|
|
+ function write_references : boolean;
|
|
|
+ destructor done;virtual;
|
|
|
+ end;
|
|
|
+
|
|
|
+var cformaldef:Pformaldef; {Unique formal definition.}
|
|
|
+ voiddef:Porddef; {Pointer to void (procedure) type }
|
|
|
+ cchardef:Porddef; {Pointer to char type.}
|
|
|
+ booldef:Porddef; {Pointer to boolean type.}
|
|
|
+ u8bitdef:Porddef; {Pointer to 8-bit unsigned type.}
|
|
|
+ u16bitdef:Porddef; {Pointer to 16-bit unsigned type.}
|
|
|
+ u32bitdef:Porddef; {Pointer to 32-bit unsigned type.}
|
|
|
+ s32bitdef:Porddef; {Pointer to 32-bit signed type.}
|
|
|
+
|
|
|
+implementation
|
|
|
+
|
|
|
+uses systems,symbols,verbose,globals,aasm,files;
|
|
|
+
|
|
|
+const {If you change one of the following contants,
|
|
|
+ you have also to change the typinfo unit
|
|
|
+ and the rtl/i386,template/rttip.inc files.}
|
|
|
+ tkunknown = 0;
|
|
|
+ tkinteger = 1;
|
|
|
+ tkchar = 2;
|
|
|
+ tkenumeration = 3;
|
|
|
+ tkfloat = 4;
|
|
|
+ tkset = 5;
|
|
|
+ tkmethod = 6;
|
|
|
+ tksstring = 7;
|
|
|
+ tkstring = tksstring;
|
|
|
+ tklstring = 8;
|
|
|
+ tkastring = 9;
|
|
|
+ tkwstring = 10;
|
|
|
+ tkvariant = 11;
|
|
|
+ tkarray = 12;
|
|
|
+ tkrecord = 13;
|
|
|
+ tkinterface = 14;
|
|
|
+ tkclass = 15;
|
|
|
+ tkobject = 16;
|
|
|
+ tkwchar = 17;
|
|
|
+ tkbool = 18;
|
|
|
+
|
|
|
+ otsbyte = 0;
|
|
|
+ otubyte = 1;
|
|
|
+ otsword = 2;
|
|
|
+ otuword = 3;
|
|
|
+ otslong = 4;
|
|
|
+ otulong = 5;
|
|
|
+
|
|
|
+ ftsingle = 0;
|
|
|
+ ftdouble = 1;
|
|
|
+ ftextended = 2;
|
|
|
+ ftcomp = 3;
|
|
|
+ ftcurr = 4;
|
|
|
+ ftfixed16 = 5;
|
|
|
+ ftfixed32 = 6;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tfiledef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+constructor Tfiledef.init(Aowner:Pcontainingsymtable;ft:Tfiletype;tas:Pdef);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ filetype:=ft;
|
|
|
+ typed_as:=tas;
|
|
|
+ setsize;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Tfiledef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+{ filetype:=tfiletype(readbyte);
|
|
|
+ if filetype=ft_typed then
|
|
|
+ typed_as:=readdefref
|
|
|
+ else
|
|
|
+ typed_as:=nil;}
|
|
|
+ setsize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tfiledef.deref;
|
|
|
+
|
|
|
+begin
|
|
|
+{ if filetype=ft_typed then
|
|
|
+ resolvedef(typed_as);}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tfiledef.setsize;
|
|
|
+
|
|
|
+begin
|
|
|
+ case filetype of
|
|
|
+ ft_text:
|
|
|
+ savesize:=572;
|
|
|
+ ft_typed,ft_untyped:
|
|
|
+ savesize:=316;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tfiledef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+{ inherited store(s);
|
|
|
+ writebyte(byte(filetype));
|
|
|
+ if filetype=ft_typed then
|
|
|
+ writedefref(typed_as);
|
|
|
+ current_ppu^.writeentry(ibfiledef);}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tfiledef.gettypename : string;
|
|
|
+
|
|
|
+begin
|
|
|
+ case filetype of
|
|
|
+ ft_untyped:
|
|
|
+ gettypename:='File';
|
|
|
+ ft_typed:
|
|
|
+ gettypename:='File Of '+typed_as^.typename;
|
|
|
+ ft_text:
|
|
|
+ gettypename:='Text'
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tformaldef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+{Tformaldef is used for var parameters without a type.}
|
|
|
+
|
|
|
+constructor Tformaldef.init(Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ savesize:=target_os.size_of_pointer;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Tformaldef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+ savesize:=target_os.size_of_pointer;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tformaldef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+{ current_ppu^.writeentry(ibformaldef);}
|
|
|
+end;
|
|
|
+
|
|
|
+function Tformaldef.gettypename:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='Var';
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Terrordef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+function Terrordef.gettypename:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='<erroneous type>';
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tabstractpointerdef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ definition:=def;
|
|
|
+ savesize:=target_os.size_of_pointer;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Tabstractpointerdef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* {The real address in memory is calculated later (deref).}
|
|
|
+ definition:=readdefref; *)
|
|
|
+ savesize:=target_os.size_of_pointer;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tabstractpointerdef.deref;
|
|
|
+
|
|
|
+begin
|
|
|
+{ resolvedef(definition);}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tabstractpointerdef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+{ writedefref(definition);
|
|
|
+ current_ppu^.writeentry(ibpointerdef);}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tpointerdef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+constructor Tpointerdef.initfar(Aowner:Pcontainingsymtable;def:Pdef);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner,def);
|
|
|
+ is_far:=true;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Tpointerdef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+{ is_far:=(readbyte<>0);}
|
|
|
+end;
|
|
|
+
|
|
|
+function Tpointerdef.gettypename : string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='^'+definition^.typename;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tpointerdef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+{ writebyte(byte(is_far));}
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tclassrefdef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+function Tclassrefdef.gettypename:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='Class of '+definition^.typename;
|
|
|
+end;
|
|
|
+
|
|
|
+{***************************************************************************
|
|
|
+ TOBJECTDEF
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
|
|
|
+ parent:Pobjectdef);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ new(publicsyms,init);
|
|
|
+ publicsyms^.name:=stringdup(n);
|
|
|
+ publicsyms^.defowner:=@self;
|
|
|
+ set_parent(parent);
|
|
|
+ objname:=stringdup(n);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tobjectdef.set_parent(parent:Pobjectdef);
|
|
|
+
|
|
|
+const inherited_options=[oo_has_virtual,oo_has_private,oo_has_protected,
|
|
|
+ oo_has_constructor,oo_has_destructor];
|
|
|
+
|
|
|
+begin
|
|
|
+ {Nothing to do if the parent was not forward !}
|
|
|
+ if childof=nil then
|
|
|
+ begin
|
|
|
+ childof:=parent;
|
|
|
+ {Some options are inherited...}
|
|
|
+ if parent<>nil then
|
|
|
+ begin
|
|
|
+ options:=options+parent^.options*inherited_options;
|
|
|
+ {Add the data of the anchestor class.}
|
|
|
+ inc(publicsyms^.datasize,parent^.publicsyms^.datasize);
|
|
|
+ if parent^.privatesyms<>nil then
|
|
|
+ begin
|
|
|
+ if privatesyms=nil then
|
|
|
+ new(privatesyms,init);
|
|
|
+ inc(privatesyms^.datasize,
|
|
|
+ parent^.privatesyms^.datasize);
|
|
|
+ end;
|
|
|
+ if parent^.protectedsyms<>nil then
|
|
|
+ begin
|
|
|
+ if protectedsyms<>nil then
|
|
|
+ new(protectedsyms,init);
|
|
|
+ inc(protectedsyms^.datasize,
|
|
|
+ parent^.protectedsyms^.datasize);
|
|
|
+ end;
|
|
|
+ if oo_has_vmt in (options*parent^.options) then
|
|
|
+ publicsyms^.datasize:=publicsyms^.datasize-
|
|
|
+ target_os.size_of_pointer;
|
|
|
+ {If parent has a vmt field then
|
|
|
+ the offset is the same for the child PM }
|
|
|
+ if [oo_has_vmt,oo_is_class]*parent^.options<>[] then
|
|
|
+ begin
|
|
|
+ vmt_offset:=parent^.vmt_offset;
|
|
|
+ include(options,oo_has_vmt);
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+ savesize:=publicsyms^.datasize;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Tobjectdef.load(var s:Tstream);
|
|
|
+
|
|
|
+var oldread_member:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* savesize:=readlong;
|
|
|
+ vmt_offset:=readlong;
|
|
|
+ objname:=stringdup(readstring);
|
|
|
+ childof:=pobjectdef(readdefref);
|
|
|
+ options:=readlong;
|
|
|
+ oldread_member:=read_member;
|
|
|
+ read_member:=true;
|
|
|
+ publicsyms:=new(psymtable,loadas(objectsymtable));
|
|
|
+ read_member:=oldread_member;
|
|
|
+ publicsyms^.defowner:=@self;
|
|
|
+ { publicsyms^.datasize:=savesize; }
|
|
|
+ publicsyms^.name := stringdup(objname^);
|
|
|
+
|
|
|
+ { handles the predefined class tobject }
|
|
|
+ { the last TOBJECT which is loaded gets }
|
|
|
+ { it ! }
|
|
|
+ if (objname^='TOBJECT') and
|
|
|
+ isclass and (childof=nil) then
|
|
|
+ class_tobject:=@self;
|
|
|
+ has_rtti:=true;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tobjectdef.insertvmt;
|
|
|
+
|
|
|
+begin
|
|
|
+ if oo_has_vmt in options then
|
|
|
+ internalerror($990803)
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ {First round up to aktpakrecords.}
|
|
|
+ publicsyms^.datasize:=align(publicsyms^.datasize,
|
|
|
+ aktpackrecords);
|
|
|
+ vmt_offset:=publicsyms^.datasize;
|
|
|
+ publicsyms^.datasize:=publicsyms^.datasize+
|
|
|
+ target_os.size_of_pointer;
|
|
|
+ include(options,oo_has_vmt);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tobjectdef.check_forwards;
|
|
|
+
|
|
|
+begin
|
|
|
+ publicsyms^.check_forwards;
|
|
|
+ if oo_isforward in options then
|
|
|
+ begin
|
|
|
+ { ok, in future, the forward can be resolved }
|
|
|
+ message1(sym_e_class_forward_not_resolved,objname^);
|
|
|
+ exclude(options,oo_isforward);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+{ true, if self inherits from d (or if they are equal) }
|
|
|
+function Tobjectdef.isrelated(d:Pobjectdef):boolean;
|
|
|
+
|
|
|
+var hp:Pobjectdef;
|
|
|
+
|
|
|
+begin
|
|
|
+ hp:=@self;
|
|
|
+ isrelated:=false;
|
|
|
+ while assigned(hp) do
|
|
|
+ begin
|
|
|
+ if hp=d then
|
|
|
+ begin
|
|
|
+ isrelated:=true;
|
|
|
+ break;
|
|
|
+ end;
|
|
|
+ hp:=hp^.childof;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tobjectdef.search(const s:string):Psym;
|
|
|
+
|
|
|
+begin
|
|
|
+ search:=speedsearch(s,getspeedvalue(s));
|
|
|
+end;
|
|
|
+
|
|
|
+function Tobjectdef.speedsearch(const s:string;speedvalue:longint):Psym;
|
|
|
+
|
|
|
+var r:Psym;
|
|
|
+
|
|
|
+begin
|
|
|
+ r:=publicsyms^.speedsearch(s,speedvalue);
|
|
|
+ if (r=nil) and (privatesyms<>nil) then
|
|
|
+ r:=privatesyms^.speedsearch(s,speedvalue);
|
|
|
+ if (r=nil) and (protectedsyms<>nil) then
|
|
|
+ r:=protectedsyms^.speedsearch(s,speedvalue);
|
|
|
+end;
|
|
|
+
|
|
|
+function Tobjectdef.size:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ if oo_is_class in options then
|
|
|
+ size:=target_os.size_of_pointer
|
|
|
+ else
|
|
|
+ size:=publicsyms^.datasize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tobjectdef.deref;
|
|
|
+
|
|
|
+var oldrecsyms:Psymtable;
|
|
|
+
|
|
|
+begin
|
|
|
+{ resolvedef(pdef(childof));
|
|
|
+ oldrecsyms:=aktrecordsymtable;
|
|
|
+ aktrecordsymtable:=publicsyms;
|
|
|
+ publicsyms^.deref;
|
|
|
+ aktrecordsymtable:=oldrecsyms;}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tobjectdef.vmt_mangledname:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ if oo_has_vmt in options then
|
|
|
+ message1(parser_object_has_no_vmt,objname^);
|
|
|
+ vmt_mangledname:='VMT_'+owner^.name^+'$_'+objname^;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tobjectdef.rtti_name:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ rtti_name:='RTTI_'+owner^.name^+'$_'+objname^;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tobjectdef.store(var s:Tstream);
|
|
|
+
|
|
|
+var oldread_member:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+(* writelong(size);
|
|
|
+ writelong(vmt_offset);
|
|
|
+ writestring(objname^);
|
|
|
+ writedefref(childof);
|
|
|
+ writelong(options);
|
|
|
+ current_ppu^.writeentry(ibobjectdef);
|
|
|
+
|
|
|
+ oldread_member:=read_member;
|
|
|
+ read_member:=true;
|
|
|
+ publicsyms^.writeas;
|
|
|
+ read_member:=oldread_member;*)
|
|
|
+end;
|
|
|
+
|
|
|
+procedure tobjectdef.write_child_init_data;
|
|
|
+
|
|
|
+begin
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tobjectdef.write_init_data;
|
|
|
+
|
|
|
+var b:byte;
|
|
|
+
|
|
|
+begin
|
|
|
+ if oo_is_class in options then
|
|
|
+ b:=tkclass
|
|
|
+ else
|
|
|
+ b:=tkobject;
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(b)));
|
|
|
+
|
|
|
+ { generate the name }
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(length(objname^))));
|
|
|
+ rttilist^.concat(new(Pai_string,init(objname^)));
|
|
|
+
|
|
|
+(* rttilist^.concat(new(Pai_const,init_32bit(size)));
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
|
|
|
+ rttilist^.concat(new(Pai_const,init_32bit(count)));
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}write_field_inittable);*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tobjectdef.needs_inittable:boolean;
|
|
|
+
|
|
|
+var oldb:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ { there are recursive calls to needs_inittable possible, }
|
|
|
+ { so we have to change to old value how else should }
|
|
|
+ { we do that ? check_rec_rtti can't be a nested }
|
|
|
+ { procedure of needs_rtti ! }
|
|
|
+(* oldb:=binittable;
|
|
|
+ binittable:=false;
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
|
|
|
+ needs_inittable:=binittable;
|
|
|
+ binittable:=oldb;*)
|
|
|
+end;
|
|
|
+
|
|
|
+destructor Tobjectdef.done;
|
|
|
+
|
|
|
+begin
|
|
|
+ if publicsyms<>nil then
|
|
|
+ dispose(publicsyms,done);
|
|
|
+ if privatesyms<>nil then
|
|
|
+ dispose(privatesyms,done);
|
|
|
+ if protectedsyms<>nil then
|
|
|
+ dispose(protectedsyms,done);
|
|
|
+ if oo_isforward in options then
|
|
|
+ message1(sym_e_class_forward_not_resolved,objname^);
|
|
|
+ stringdispose(objname);
|
|
|
+ inherited done;
|
|
|
+end;
|
|
|
+
|
|
|
+var count:longint;
|
|
|
+
|
|
|
+procedure count_published_properties(sym:Pnamedindexobject);
|
|
|
+ {$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(sym^)=typeof(Tpropertysym)) and
|
|
|
+ (ppo_published in Ppropertysym(sym)^.properties) then
|
|
|
+ inc(count);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure write_property_info(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+var proctypesinfo : byte;
|
|
|
+
|
|
|
+procedure writeproc(sym:Psym;def:Pdef;shiftvalue:byte);
|
|
|
+
|
|
|
+var typvalue:byte;
|
|
|
+
|
|
|
+begin
|
|
|
+ if not(assigned(sym)) then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(1)));
|
|
|
+ typvalue:=3;
|
|
|
+ end
|
|
|
+ else if typeof(sym^)=typeof(Tvarsym) then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(
|
|
|
+ Pvarsym(sym)^.address)));
|
|
|
+ typvalue:=0;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+(* if (pprocdef(def)^.options and povirtualmethod)=0 then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(pai_const_symbol,initname(pprocdef(def)^.mangledname)));
|
|
|
+ typvalue:=1;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ {Virtual method, write vmt offset.}
|
|
|
+ rttilist^.concat(new(pai_const,
|
|
|
+ init_32bit(Pprocdef(def)^.extnumber*4+12)));
|
|
|
+ typvalue:=2;
|
|
|
+ end;*)
|
|
|
+ end;
|
|
|
+ proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
|
|
|
+end;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(sym^)=typeof(Tpropertysym)) and
|
|
|
+ (ppo_indexed in Ppropertysym(sym)^.properties) then
|
|
|
+ proctypesinfo:=$40
|
|
|
+ else
|
|
|
+ proctypesinfo:=0;
|
|
|
+ if (typeof(sym^)=typeof(Tpropertysym)) and
|
|
|
+ (ppo_published in Ppropertysym(sym)^.properties) then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(pai_const_symbol,initname(
|
|
|
+ Ppropertysym(sym)^.definition^.get_rtti_label)));
|
|
|
+ writeproc(Ppropertysym(sym)^.readaccesssym,ppropertysym(sym)^.readaccessdef,0);
|
|
|
+ writeproc(Ppropertysym(sym)^.writeaccesssym,ppropertysym(sym)^.writeaccessdef,2);
|
|
|
+ { isn't it stored ? }
|
|
|
+ if (ppo_stored in Ppropertysym(sym)^.properties) then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(1)));
|
|
|
+ proctypesinfo:=proctypesinfo or (3 shl 4);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ writeproc(ppropertysym(sym)^.storedsym,ppropertysym(sym)^.storeddef,4);
|
|
|
+ rttilist^.concat(new(pai_const,
|
|
|
+ init_32bit(ppropertysym(sym)^.index)));
|
|
|
+ rttilist^.concat(new(pai_const,
|
|
|
+ init_32bit(ppropertysym(sym)^.default)));
|
|
|
+ rttilist^.concat(new(pai_const,
|
|
|
+ init_16bit(count)));
|
|
|
+ inc(count);
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
|
|
|
+ rttilist^.concat(new(pai_const,
|
|
|
+ init_8bit(length(ppropertysym(sym)^.name))));
|
|
|
+ rttilist^.concat(new(pai_string,init(ppropertysym(sym)^.name)));
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure generate_published_child_rtti(sym:Pnamedindexobject);
|
|
|
+ {$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(sym^)=typeof(Tpropertysym)) and
|
|
|
+ (ppo_published in Ppropertysym(sym)^.properties) then
|
|
|
+ Ppropertysym(sym)^.definition^.get_rtti_label;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tobjectdef.write_child_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}generate_published_child_rtti);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tobjectdef.generate_rtti;
|
|
|
+
|
|
|
+begin
|
|
|
+{ getdatalabel(rtti_label);
|
|
|
+ write_child_rtti_data;
|
|
|
+ rttilist^.concat(new(pai_symbol,initname_global(rtti_name)));
|
|
|
+ rttilist^.concat(new(pai_label,init(rtti_label)));
|
|
|
+ write_rtti_data;}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tobjectdef.next_free_name_index : longint;
|
|
|
+
|
|
|
+var i:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (childof<>nil) and (oo_can_have_published in childof^.options) then
|
|
|
+ i:=childof^.next_free_name_index
|
|
|
+ else
|
|
|
+ i:=0;
|
|
|
+ count:=0;
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
|
|
|
+ next_free_name_index:=i+count;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tobjectdef.write_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ if oo_is_class in options then
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(tkclass)))
|
|
|
+ else
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(tkobject)));
|
|
|
+
|
|
|
+ {Generate the name }
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
|
|
|
+ rttilist^.concat(new(pai_string,init(objname^)));
|
|
|
+
|
|
|
+ {Write class type }
|
|
|
+ rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));
|
|
|
+
|
|
|
+ { write owner typeinfo }
|
|
|
+ if (childof<>nil) and (oo_can_have_published in childof^.options) then
|
|
|
+ rttilist^.concat(new(pai_const_symbol,
|
|
|
+ initname(childof^.get_rtti_label)))
|
|
|
+ else
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(0)));
|
|
|
+
|
|
|
+ {Count total number of properties }
|
|
|
+ if (childof<>nil) and (oo_can_have_published in childof^.options) then
|
|
|
+ count:=childof^.next_free_name_index
|
|
|
+ else
|
|
|
+ count:=0;
|
|
|
+
|
|
|
+ {Write it>}
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
|
|
|
+ rttilist^.concat(new(Pai_const,init_16bit(count)));
|
|
|
+
|
|
|
+ { write unit name }
|
|
|
+ if owner^.name<>nil then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(length(owner^.name^))));
|
|
|
+ rttilist^.concat(new(Pai_string,init(owner^.name^)));
|
|
|
+ end
|
|
|
+ else
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(0)));
|
|
|
+
|
|
|
+ { write published properties count }
|
|
|
+ count:=0;
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
|
|
|
+ rttilist^.concat(new(pai_const,init_16bit(count)));
|
|
|
+
|
|
|
+ { count is used to write nameindex }
|
|
|
+ { but we need an offset of the owner }
|
|
|
+ { to give each property an own slot }
|
|
|
+ if (childof<>nil) and (oo_can_have_published in childof^.options) then
|
|
|
+ count:=childof^.next_free_name_index
|
|
|
+ else
|
|
|
+ count:=0;
|
|
|
+ publicsyms^.foreach({$ifndef TP}@{$endif}write_property_info);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tobjectdef.is_publishable:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ is_publishable:=oo_is_class in options;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tobjectdef.get_rtti_label:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ get_rtti_label:=rtti_name;
|
|
|
+end;
|
|
|
+
|
|
|
+{***************************************************************************
|
|
|
+ TARRAYDEF
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+constructor Tarraydef.init(const l,h:Tconstant;rd:Pdef;
|
|
|
+ Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ lowrange:=l;
|
|
|
+ highrange:=h;
|
|
|
+ rangedef:=rd;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Tarraydef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* deftype:=arraydef;
|
|
|
+ { the addresses are calculated later }
|
|
|
+ definition:=readdefref;
|
|
|
+ rangedef:=readdefref;
|
|
|
+ lowrange:=readlong;
|
|
|
+ highrange:=readlong;
|
|
|
+ IsArrayOfConst:=boolean(readbyte);*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tarraydef.getrangecheckstring:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (cs_smartlink in aktmoduleswitches) then
|
|
|
+ getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
|
|
|
+ else
|
|
|
+ getrangecheckstring:='R_'+tostr(rangenr);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tarraydef.genrangecheck;
|
|
|
+
|
|
|
+begin
|
|
|
+ if rangenr=0 then
|
|
|
+ begin
|
|
|
+ {Generates the data for range checking }
|
|
|
+ getlabelnr(rangenr);
|
|
|
+ if (cs_smartlink in aktmoduleswitches) then
|
|
|
+ datasegment^.concat(new(pai_symbol,
|
|
|
+ initname_global(getrangecheckstring)))
|
|
|
+ else
|
|
|
+ datasegment^.concat(new(pai_symbol,
|
|
|
+ initname(getrangecheckstring)));
|
|
|
+ datasegment^.concat(new(Pai_const,
|
|
|
+ init_8bit(byte(lowrange.signed))));
|
|
|
+ datasegment^.concat(new(Pai_const,
|
|
|
+ init_32bit(lowrange.values)));
|
|
|
+ datasegment^.concat(new(Pai_const,
|
|
|
+ init_8bit(byte(highrange.signed))));
|
|
|
+ datasegment^.concat(new(Pai_const,
|
|
|
+ init_32bit(highrange.values)));
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tarraydef.deref;
|
|
|
+
|
|
|
+begin
|
|
|
+{ resolvedef(definition);
|
|
|
+ resolvedef(rangedef);}
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tarraydef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+(* writedefref(definition);
|
|
|
+ writedefref(rangedef);
|
|
|
+ writelong(lowrange);
|
|
|
+ writelong(highrange);
|
|
|
+ writebyte(byte(IsArrayOfConst));
|
|
|
+ current_ppu^.writeentry(ibarraydef);*)
|
|
|
+end;
|
|
|
+
|
|
|
+function Tarraydef.elesize:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ elesize:=definition^.size;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tarraydef.size:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (lowrange.signed) and (lowrange.values=-1) then
|
|
|
+ internalerror($990804);
|
|
|
+ if highrange.signed then
|
|
|
+ begin
|
|
|
+ {Check for overflow.}
|
|
|
+ if (highrange.values-lowrange.values=$7fffffff) or
|
|
|
+ (($7fffffff div elesize+elesize-1)>
|
|
|
+ (highrange.values-lowrange.values)) then
|
|
|
+ begin
|
|
|
+{ message(sym_segment_too_large);}
|
|
|
+ size:=1;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ size:=(highrange.values-lowrange.values+1)*elesize;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ {Check for overflow.}
|
|
|
+ if (highrange.valueu-lowrange.valueu=$7fffffff) or
|
|
|
+ (($7fffffff div elesize+elesize-1)>
|
|
|
+ (highrange.valueu-lowrange.valueu)) then
|
|
|
+ begin
|
|
|
+{ message(sym_segment_too_small);}
|
|
|
+ size:=1;
|
|
|
+ end
|
|
|
+ else
|
|
|
+ size:=(highrange.valueu-lowrange.valueu+1)*elesize;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tarraydef.needs_inittable:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ needs_inittable:=definition^.needs_inittable;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tarraydef.write_child_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ definition^.get_rtti_label;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tarraydef.write_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(13)));
|
|
|
+ write_rtti_name;
|
|
|
+ { size of elements }
|
|
|
+ rttilist^.concat(new(Pai_const,init_32bit(definition^.size)));
|
|
|
+ { count of elements }
|
|
|
+ rttilist^.concat(new(Pai_const,
|
|
|
+ init_32bit(highrange.values-lowrange.values+1)));
|
|
|
+ { element type }
|
|
|
+ rttilist^.concat(new(Pai_const_symbol,
|
|
|
+ initname(definition^.get_rtti_label)));
|
|
|
+end;
|
|
|
+
|
|
|
+function Tarraydef.gettypename:string;
|
|
|
+
|
|
|
+var r:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ if [ap_arrayofconst,ap_constructor]*options<>[] then
|
|
|
+ gettypename:='array of const'
|
|
|
+ else if (lowrange.signed) and (lowrange.values=-1) then
|
|
|
+ gettypename:='Array Of '+definition^.typename
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ r:='array[$1..$2 Of $3]';
|
|
|
+ if typeof(rangedef^)=typeof(Tenumdef) then
|
|
|
+ with Penumdef(rangedef)^.symbols^ do
|
|
|
+ begin
|
|
|
+ replace(r,'$1',Penumsym(at(0))^.name);
|
|
|
+ replace(r,'$2',Penumsym(at(count-1))^.name);
|
|
|
+ end
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ if lowrange.signed then
|
|
|
+ replace(r,'$1',tostr(lowrange.values))
|
|
|
+ else
|
|
|
+ replace(r,'$1',tostru(lowrange.valueu));
|
|
|
+ if highrange.signed then
|
|
|
+ replace(r,'$2',tostr(highrange.values))
|
|
|
+ else
|
|
|
+ replace(r,'$2',tostr(highrange.valueu));
|
|
|
+ replace(r,'$3',definition^.typename);
|
|
|
+ end;
|
|
|
+ gettypename:=r;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tenumdef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+constructor Tenumdef.init(Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ new(symbols,init(8,8));
|
|
|
+ calcsavesize;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Tenumdef.init_subrange(Abasedef:Penumdef;Amin,Amax:longint;
|
|
|
+ Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ minval:=Amin;
|
|
|
+ maxval:=Amax;
|
|
|
+ basedef:=Abasedef;
|
|
|
+ symbols:=Abasedef^.symbols;
|
|
|
+ calcsavesize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Tenumdef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* basedef:=penumdef(readdefref);
|
|
|
+ minval:=readlong;
|
|
|
+ maxval:=readlong;
|
|
|
+ savesize:=readlong;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tenumdef.calcsavesize;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (aktpackenum=4) or (minval<0) or (maxval>65535) then
|
|
|
+ savesize:=4
|
|
|
+ else if (aktpackenum=2) or (minval<0) or (maxval>255) then
|
|
|
+ savesize:=2
|
|
|
+ else
|
|
|
+ savesize:=1;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tenumdef.setmax(Amax:longint);
|
|
|
+
|
|
|
+begin
|
|
|
+ maxval:=Amax;
|
|
|
+ calcsavesize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tenumdef.setmin(Amin:longint);
|
|
|
+
|
|
|
+begin
|
|
|
+ minval:=Amin;
|
|
|
+ calcsavesize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tenumdef.deref;
|
|
|
+
|
|
|
+begin
|
|
|
+{ resolvedef(pdef(basedef));}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tenumdef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+(* writedefref(basedef);
|
|
|
+ writelong(min);
|
|
|
+ writelong(max);
|
|
|
+ writelong(savesize);
|
|
|
+ current_ppu^.writeentry(ibenumdef);*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function tenumdef.getrangecheckstring : string;
|
|
|
+begin
|
|
|
+ if (cs_smartlink in aktmoduleswitches) then
|
|
|
+ getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
|
|
|
+ else
|
|
|
+ getrangecheckstring:='R_'+tostr(rangenr);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tenumdef.genrangecheck;
|
|
|
+begin
|
|
|
+ if rangenr=0 then
|
|
|
+ begin
|
|
|
+ { generate two constant for bounds }
|
|
|
+ getlabelnr(rangenr);
|
|
|
+ if (cs_smartlink in aktmoduleswitches) then
|
|
|
+ datasegment^.concat(new(pai_symbol,initname_global(getrangecheckstring)))
|
|
|
+ else
|
|
|
+ datasegment^.concat(new(pai_symbol,initname(getrangecheckstring)));
|
|
|
+ datasegment^.concat(new(pai_const,init_32bit(minval)));
|
|
|
+ datasegment^.concat(new(pai_const,init_32bit(maxval)));
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tenumdef.write_child_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ if assigned(basedef) then
|
|
|
+ basedef^.get_rtti_label;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tenumdef.write_rtti_data;
|
|
|
+
|
|
|
+var i:word;
|
|
|
+
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
|
|
|
+ write_rtti_name;
|
|
|
+ case savesize of
|
|
|
+ 1:
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(otUByte)));
|
|
|
+ 2:
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(otUWord)));
|
|
|
+ 4:
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(otULong)));
|
|
|
+ end;
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(minval)));
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(maxval)));
|
|
|
+ if assigned(basedef) then
|
|
|
+ rttilist^.concat(new(pai_const_symbol,initname(basedef^.get_rtti_label)))
|
|
|
+ else
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(0)));
|
|
|
+ for i:=0 to symbols^.count-1 do
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(Pai_const,
|
|
|
+ init_8bit(length(Penumsym(symbols^.at(i))^.name))));
|
|
|
+ rttilist^.concat(new(Pai_string,
|
|
|
+ init(globals.lower(Penumsym(symbols^.at(i))^.name))));
|
|
|
+ end;
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(0)));
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tenumdef.is_publishable:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ is_publishable:=true;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tenumdef.gettypename:string;
|
|
|
+
|
|
|
+var i:word;
|
|
|
+ v:longint;
|
|
|
+ r:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ r:='(';
|
|
|
+ for i:=0 to symbols^.count-1 do
|
|
|
+ begin
|
|
|
+ v:=Penumsym(symbols^.at(i))^.value;
|
|
|
+ if (v>=minval) and (v<=maxval) then
|
|
|
+ r:=r+Penumsym(symbols^.at(i))^.name+',';
|
|
|
+ end;
|
|
|
+ {Turn ',' into ')'.}
|
|
|
+ r[length(r)]:=')';
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Torddef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+
|
|
|
+constructor Torddef.init(t:Tbasetype;l,h:Tconstant;
|
|
|
+ Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ low:=l;
|
|
|
+ high:=h;
|
|
|
+ typ:=t;
|
|
|
+ setsize;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Torddef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* typ:=tbasetype(readbyte);
|
|
|
+ low:=readlong;
|
|
|
+ high:=readlong;*)
|
|
|
+ setsize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Torddef.setsize;
|
|
|
+
|
|
|
+begin
|
|
|
+ if typ=uauto then
|
|
|
+ begin
|
|
|
+ {Generate a unsigned range if high<0 and low>=0 }
|
|
|
+ if (low.values>=0) and (high.values<=255) then
|
|
|
+ typ:=u8bit
|
|
|
+ else if (low.signed) and (low.values>=-128) and (high.values<=127) then
|
|
|
+ typ:=s8bit
|
|
|
+ else if (low.values>=0) and (high.values<=65536) then
|
|
|
+ typ:=u16bit
|
|
|
+ else if (low.signed) and (low.values>=-32768) and (high.values<=32767) then
|
|
|
+ typ:=s16bit
|
|
|
+ else if low.signed then
|
|
|
+ typ:=s32bit
|
|
|
+ else
|
|
|
+ typ:=u32bit
|
|
|
+ end;
|
|
|
+ case typ of
|
|
|
+ u8bit,s8bit,uchar,bool8bit:
|
|
|
+ savesize:=1;
|
|
|
+
|
|
|
+ u16bit,s16bit,bool16bit:
|
|
|
+ savesize:=2;
|
|
|
+
|
|
|
+ s32bit,u32bit,bool32bit:
|
|
|
+ savesize:=4;
|
|
|
+
|
|
|
+ u64bit,s64bitint:
|
|
|
+ savesize:=8;
|
|
|
+ else
|
|
|
+ savesize:=0;
|
|
|
+ end;
|
|
|
+ rangenr:=0;
|
|
|
+end;
|
|
|
+
|
|
|
+function Torddef.getrangecheckstring:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (cs_smartlink in aktmoduleswitches) then
|
|
|
+ getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
|
|
|
+ else
|
|
|
+ getrangecheckstring:='R_'+tostr(rangenr);
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Torddef.genrangecheck;
|
|
|
+
|
|
|
+begin
|
|
|
+ if rangenr=0 then
|
|
|
+ begin
|
|
|
+ {Generate two constant for bounds.}
|
|
|
+ getlabelnr(rangenr);
|
|
|
+ if (cs_smartlink in aktmoduleswitches) then
|
|
|
+ datasegment^.concat(new(Pai_symbol,
|
|
|
+ initname_global(getrangecheckstring)))
|
|
|
+ else
|
|
|
+ datasegment^.concat(new(Pai_symbol,
|
|
|
+ initname(getrangecheckstring)));
|
|
|
+ datasegment^.concat(new(Pai_const,init_8bit(byte(low.signed))));
|
|
|
+ datasegment^.concat(new(Pai_const,init_32bit(low.values)));
|
|
|
+ datasegment^.concat(new(Pai_const,init_8bit(byte(high.signed))));
|
|
|
+ datasegment^.concat(new(Pai_const,init_32bit(high.values)));
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Torddef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+(* writebyte(byte(typ));
|
|
|
+ writelong(low);
|
|
|
+ writelong(high);
|
|
|
+ current_ppu^.writeentry(iborddef);*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Torddef.write_rtti_data;
|
|
|
+
|
|
|
+const trans:array[uchar..bool8bit] of byte=
|
|
|
+ (otubyte,otubyte,otuword,otulong,
|
|
|
+ otsbyte,otsword,otslong,otubyte);
|
|
|
+
|
|
|
+begin
|
|
|
+ case typ of
|
|
|
+ bool8bit:
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(tkbool)));
|
|
|
+ uchar:
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(tkchar)));
|
|
|
+ else
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(tkinteger)));
|
|
|
+ end;
|
|
|
+ write_rtti_name;
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(byte(trans[typ]))));
|
|
|
+ rttilist^.concat(new(Pai_const,init_32bit(low.values)));
|
|
|
+ rttilist^.concat(new(Pai_const,init_32bit(high.values)));
|
|
|
+end;
|
|
|
+
|
|
|
+function Torddef.is_publishable:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ is_publishable:=typ in [uchar..bool8bit];
|
|
|
+end;
|
|
|
+
|
|
|
+function Torddef.gettypename:string;
|
|
|
+
|
|
|
+const names:array[Tbasetype] of string[20]=('<unknown type>',
|
|
|
+ 'untyped','char','byte','word','dword','shortInt',
|
|
|
+ 'smallint','longInt','boolean','wordbool',
|
|
|
+ 'longbool','qword','int64');
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:=names[typ];
|
|
|
+end;
|
|
|
+
|
|
|
+{****************************************************************************
|
|
|
+ Tfloatdef
|
|
|
+****************************************************************************}
|
|
|
+
|
|
|
+constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ typ:=t;
|
|
|
+ setsize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Tfloatdef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* typ:=Tfloattype(readbyte);*)
|
|
|
+ setsize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tfloatdef.setsize;
|
|
|
+
|
|
|
+begin
|
|
|
+ case typ of
|
|
|
+ f16bit:
|
|
|
+ savesize:=2;
|
|
|
+ f32bit,
|
|
|
+ s32real:
|
|
|
+ savesize:=4;
|
|
|
+ s64real:
|
|
|
+ savesize:=8;
|
|
|
+ s80real:
|
|
|
+ savesize:=extended_size;
|
|
|
+ s64comp:
|
|
|
+ savesize:=8;
|
|
|
+ else
|
|
|
+ savesize:=0;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tfloatdef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+(* writebyte(byte(typ));
|
|
|
+ current_ppu^.writeentry(ibfloatdef);*)
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tfloatdef.write_rtti_data;
|
|
|
+
|
|
|
+const translate:array[Tfloattype] of byte=
|
|
|
+ (ftsingle,ftdouble,ftextended,ftcomp,ftfixed16,ftfixed32);
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(tkfloat)));
|
|
|
+ write_rtti_name;
|
|
|
+ rttilist^.concat(new(Pai_const,init_8bit(translate[typ])));
|
|
|
+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','comp','fixed','shortfixed');
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:=names[typ];
|
|
|
+end;
|
|
|
+
|
|
|
+{***************************************************************************
|
|
|
+ Tsetdef
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+{ For i386 smallsets work,
|
|
|
+ for m68k there are problems
|
|
|
+ can be test by compiling with -dusesmallset PM }
|
|
|
+{$ifdef i386}
|
|
|
+{$define usesmallset}
|
|
|
+{$endif i386}
|
|
|
+
|
|
|
+constructor Tsetdef.init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ setof:=s;
|
|
|
+ if high<32 then
|
|
|
+ begin
|
|
|
+ settype:=smallset;
|
|
|
+ savesize:=4;
|
|
|
+ end
|
|
|
+ else if high<256 then
|
|
|
+ begin
|
|
|
+ settype:=normset;
|
|
|
+ savesize:=32;
|
|
|
+ end
|
|
|
+{$ifdef testvarsets}
|
|
|
+ else if high<$10000 then
|
|
|
+ begin
|
|
|
+ settype:=varset;
|
|
|
+ savesize:=4*((high+31) div 32);
|
|
|
+ end
|
|
|
+{$endif testvarsets}
|
|
|
+ else
|
|
|
+ message(sym_e_ill_type_decl_set);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Tsetdef.load(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* setof:=readdefref;
|
|
|
+ settype:=tsettype(readbyte);
|
|
|
+ case settype of
|
|
|
+ normset:
|
|
|
+ savesize:=32;
|
|
|
+ varset:
|
|
|
+ savesize:=readlong;
|
|
|
+ smallset:
|
|
|
+ savesize:=sizeof(longint);
|
|
|
+ end;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tsetdef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+(* writedefref(setof);
|
|
|
+ writebyte(byte(settype));
|
|
|
+ if settype=varset then
|
|
|
+ writelong(savesize);
|
|
|
+ current_ppu^.writeentry(ibsetdef);*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tsetdef.deref;
|
|
|
+
|
|
|
+begin
|
|
|
+{ resolvedef(setof);}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tsetdef.write_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(tkset)));
|
|
|
+ write_rtti_name;
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(otuLong)));
|
|
|
+ rttilist^.concat(new(pai_const_symbol,initname(setof^.get_rtti_label)));
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tsetdef.write_child_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ setof^.get_rtti_label;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tsetdef.is_publishable:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ is_publishable:=settype=smallset;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tsetdef.gettypename:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='set of '+setof^.typename;
|
|
|
+end;
|
|
|
+{***************************************************************************
|
|
|
+ Trecorddef
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ symtable:=s;
|
|
|
+ savesize:=symtable^.datasize;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Trecorddef.load(var s:Tstream);
|
|
|
+
|
|
|
+var oldread_member:boolean;
|
|
|
+begin
|
|
|
+(* inherited load(s);
|
|
|
+ savesize:=readlong;
|
|
|
+ oldread_member:=read_member;
|
|
|
+ read_member:=true;
|
|
|
+ symtable:=new(psymtable,loadas(recordsymtable));
|
|
|
+ read_member:=oldread_member;
|
|
|
+ symtable^.defowner := @self;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+destructor Trecorddef.done;
|
|
|
+
|
|
|
+begin
|
|
|
+ if symtable<>nil then
|
|
|
+ dispose(symtable,done);
|
|
|
+ inherited done;
|
|
|
+end;
|
|
|
+
|
|
|
+var
|
|
|
+ binittable : boolean;
|
|
|
+
|
|
|
+procedure check_rec_inittable(s:Pnamedindexobject);
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(s^)=typeof(Tvarsym)) and
|
|
|
+ ((typeof((Pvarsym(s)^.definition^))<>typeof(Tobjectdef)) or
|
|
|
+ not (oo_is_class in Pobjectdef(Pvarsym(s)^.definition)^.options)) then
|
|
|
+ binittable:=pvarsym(s)^.definition^.needs_inittable;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Trecorddef.needs_inittable:boolean;
|
|
|
+
|
|
|
+var oldb:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ { there are recursive calls to needs_rtti possible, }
|
|
|
+ { so we have to change to old value how else should }
|
|
|
+ { we do that ? check_rec_rtti can't be a nested }
|
|
|
+ { procedure of needs_rtti ! }
|
|
|
+ oldb:=binittable;
|
|
|
+ binittable:=false;
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
|
|
|
+ needs_inittable:=binittable;
|
|
|
+ binittable:=oldb;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Trecorddef.deref;
|
|
|
+
|
|
|
+var oldrecsyms:Psymtable;
|
|
|
+
|
|
|
+begin
|
|
|
+(* oldrecsyms:=aktrecordsymtable;
|
|
|
+ aktrecordsymtable:=symtable;
|
|
|
+ { now dereference the definitions }
|
|
|
+ symtable^.deref;
|
|
|
+ aktrecordsymtable:=oldrecsyms;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Trecorddef.store(var s:Tstream);
|
|
|
+
|
|
|
+var oldread_member:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+(* oldread_member:=read_member;
|
|
|
+ read_member:=true;
|
|
|
+ inherited store(s);
|
|
|
+ writelong(savesize);
|
|
|
+ current_ppu^.writeentry(ibrecorddef);
|
|
|
+ self.symtable^.writeas;
|
|
|
+ read_member:=oldread_member;*)
|
|
|
+end;
|
|
|
+
|
|
|
+procedure count_inittable_fields(sym:Pnamedindexobject);
|
|
|
+ {$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(sym^)=typeof(Tvarsym)) and
|
|
|
+ (Pvarsym(sym)^.definition^.needs_inittable) then
|
|
|
+ inc(count);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure count_fields(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ inc(count);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure write_field_inittable(sym:Pnamedindexobject);
|
|
|
+ {$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(sym^)=typeof(Tvarsym)) and
|
|
|
+ Pvarsym(sym)^.definition^.needs_inittable then
|
|
|
+ begin
|
|
|
+ rttilist^.concat(new(Pai_const_symbol,
|
|
|
+ init(pvarsym(sym)^.definition^.get_inittable_label)));
|
|
|
+ rttilist^.concat(new(Pai_const,
|
|
|
+ init_32bit(pvarsym(sym)^.address)));
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure write_field_rtti(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(Pai_const_symbol,
|
|
|
+ initname(Pvarsym(sym)^.definition^.get_rtti_label)));
|
|
|
+ rttilist^.concat(new(Pai_const,
|
|
|
+ init_32bit(Pvarsym(sym)^.address)));
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure generate_child_inittable(sym:Pnamedindexobject);
|
|
|
+ {$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+
|
|
|
+begin
|
|
|
+ if (typeof(sym^)=typeof(Tvarsym)) and
|
|
|
+ Pvarsym(sym)^.definition^.needs_inittable then
|
|
|
+ {Force inittable generation }
|
|
|
+ Pvarsym(sym)^.definition^.get_inittable_label;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure generate_child_rtti(sym:Pnamedindexobject);
|
|
|
+ {$ifndef fpc}far;{$endif}
|
|
|
+
|
|
|
+begin
|
|
|
+ Pvarsym(sym)^.definition^.get_rtti_label;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Trecorddef.write_child_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}generate_child_rtti);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Trecorddef.write_child_init_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Trecorddef.write_rtti_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
|
|
|
+ write_rtti_name;
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(size)));
|
|
|
+ count:=0;
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}count_fields);
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(count)));
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}write_field_rtti);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Trecorddef.write_init_data;
|
|
|
+
|
|
|
+begin
|
|
|
+ rttilist^.concat(new(pai_const,init_8bit(14)));
|
|
|
+ write_rtti_name;
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(size)));
|
|
|
+ count:=0;
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
|
|
|
+ rttilist^.concat(new(pai_const,init_32bit(count)));
|
|
|
+ symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable);
|
|
|
+end;
|
|
|
+
|
|
|
+function Trecorddef.gettypename:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='<record type>'
|
|
|
+end;
|
|
|
+
|
|
|
+{***************************************************************************
|
|
|
+ Tabstractprocdef
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ retdef:=voiddef;
|
|
|
+ savesize:=target_os.size_of_pointer;
|
|
|
+end;
|
|
|
+
|
|
|
+constructor Tabstractprocdef.load(var s:Tstream);
|
|
|
+
|
|
|
+var count,i:word;
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* retdef:=readdefref;
|
|
|
+ fpu_used:=readbyte;
|
|
|
+ options:=readlong;
|
|
|
+ count:=readword;
|
|
|
+ new(parameters);
|
|
|
+ savesize:=target_os.size_of_pointer;
|
|
|
+ for i:=1 to count do
|
|
|
+ parameters^.readsymref;*)
|
|
|
+end;
|
|
|
+
|
|
|
+{ all functions returning in FPU are
|
|
|
+ assume to use 2 FPU registers
|
|
|
+ until the function implementation
|
|
|
+ is processed PM }
|
|
|
+procedure Tabstractprocdef.test_if_fpu_result;
|
|
|
+
|
|
|
+begin
|
|
|
+ if (retdef<>nil) and (typeof(retdef^)=typeof(Tfloatdef)) and
|
|
|
+ (Pfloatdef(retdef)^.typ in [f32bit,f16bit]) then
|
|
|
+ fpu_used:=2;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tabstractprocdef.deref;
|
|
|
+
|
|
|
+var i:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited deref;
|
|
|
+{ resolvedef(retdef);}
|
|
|
+ for i:=0 to parameters^.count-1 do
|
|
|
+ Psym(parameters^.at(i))^.deref;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tabstractprocdef.para_size:longint;
|
|
|
+
|
|
|
+var i,l:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ l:=0;
|
|
|
+ for i:=0 to parameters^.count-1 do
|
|
|
+ inc(l,Pparamsym(parameters^.at(i))^.getpushsize);
|
|
|
+ para_size:=l;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tabstractprocdef.store(var s:Tstream);
|
|
|
+
|
|
|
+var count,i:word;
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited store(s);
|
|
|
+{ writedefref(retdef);
|
|
|
+ current_ppu^.do_interface_crc:=false;
|
|
|
+ writebyte(fpu_used);
|
|
|
+ writelong(options);
|
|
|
+ writeword(parameters^.count);
|
|
|
+ for i:=0 to parameters^.count-1 do
|
|
|
+ begin
|
|
|
+ writebyte(byte(hp^.paratyp));
|
|
|
+ writesymfref(hp^.data);
|
|
|
+ end;}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tabstractprocdef.demangled_paras:string;
|
|
|
+
|
|
|
+var i:longint;
|
|
|
+ s:string;
|
|
|
+
|
|
|
+procedure doconcat(p:Pparameter);
|
|
|
+
|
|
|
+begin
|
|
|
+ s:=s+p^.data^.name;
|
|
|
+ if p^.paratyp=vs_var then
|
|
|
+ s:=s+'var'
|
|
|
+ else if p^.paratyp=vs_const then
|
|
|
+ s:=s+'const';
|
|
|
+end;
|
|
|
+
|
|
|
+begin
|
|
|
+ s:='(';
|
|
|
+ for i:=0 to parameters^.count-1 do
|
|
|
+ doconcat(parameters^.at(i));
|
|
|
+ s[length(s)]:=')';
|
|
|
+ demangled_paras:=s;
|
|
|
+end;
|
|
|
+
|
|
|
+destructor Tabstractprocdef.done;
|
|
|
+
|
|
|
+begin
|
|
|
+ dispose(parameters,done);
|
|
|
+ inherited done;
|
|
|
+end;
|
|
|
+
|
|
|
+{***************************************************************************
|
|
|
+ TPROCDEF
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+constructor Tprocdef.init(Aowner:Pcontainingsymtable);
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited init(Aowner);
|
|
|
+ fileinfo:=aktfilepos;
|
|
|
+ extnumber:=-1;
|
|
|
+ new(localst,init);
|
|
|
+ if (cs_browser in aktmoduleswitches) and make_ref then
|
|
|
+ begin
|
|
|
+ new(references,init(2*owner^.index_growsize,
|
|
|
+ owner^.index_growsize));
|
|
|
+ references^.insert(new(Pref,init(tokenpos)));
|
|
|
+ end;
|
|
|
+ {First, we assume that all registers are used }
|
|
|
+ usedregisters:=[low(Tregister)..high(Tregister)];
|
|
|
+ forwarddef:=true;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+constructor Tprocdef.load(var s:Tstream);
|
|
|
+
|
|
|
+var a:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ inherited load(s);
|
|
|
+(* usedregisters:=readlong;
|
|
|
+
|
|
|
+ a:=readstring;
|
|
|
+ setstring(_mangledname,s);
|
|
|
+
|
|
|
+ extnumber:=readlong;
|
|
|
+ nextoerloaded:=pprocdef(readdefref);
|
|
|
+ _class := pobjectdef(readdefref);
|
|
|
+ readposinfo(fileinfo);
|
|
|
+
|
|
|
+ if (cs_link_deffile in aktglobalswitches)
|
|
|
+ and (poexports in options) then
|
|
|
+ deffile.ddexport(mangledname);
|
|
|
+
|
|
|
+ count:=true;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+const local_symtable_index : longint = $8001;
|
|
|
+
|
|
|
+procedure tprocdef.load_references;
|
|
|
+
|
|
|
+var pos:Tfileposinfo;
|
|
|
+ pdo:Pobjectdef;
|
|
|
+ move_last:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+(* move_last:=lastwritten=lastref;
|
|
|
+ while (not current_ppu^.endofentry) do
|
|
|
+ begin
|
|
|
+ readposinfo(pos);
|
|
|
+ inc(refcount);
|
|
|
+ lastref:=new(pref,init(lastref,@pos));
|
|
|
+ lastref^.is_written:=true;
|
|
|
+ if refcount=1 then
|
|
|
+ defref:=lastref;
|
|
|
+ end;
|
|
|
+ if move_last then
|
|
|
+ lastwritten:=lastref;
|
|
|
+ if ((current_module^.flags and uf_local_browser)<>0)
|
|
|
+ and is_in_current then
|
|
|
+ begin
|
|
|
+{$ifndef NOLOCALBROWSER}
|
|
|
+ pdo:=_class;
|
|
|
+ new(parast,loadas(parasymtable));
|
|
|
+ parast^.next:=owner;
|
|
|
+ parast^.load_browser;
|
|
|
+ new(localst,loadas(localsymtable));
|
|
|
+ localst^.next:=parast;
|
|
|
+ localst^.load_browser;
|
|
|
+{$endif NOLOCALBROWSER}
|
|
|
+ end;*)
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tprocdef.write_references:boolean;
|
|
|
+
|
|
|
+var ref:Pref;
|
|
|
+ pdo:Pobjectdef;
|
|
|
+ move_last:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+(* move_last:=lastwritten=lastref;
|
|
|
+ if move_last and (((current_module^.flags and uf_local_browser)=0)
|
|
|
+ or not is_in_current) then
|
|
|
+ exit;
|
|
|
+ {Write address of this symbol }
|
|
|
+ writedefref(@self);
|
|
|
+ {Write refs }
|
|
|
+ if assigned(lastwritten) then
|
|
|
+ ref:=lastwritten
|
|
|
+ else
|
|
|
+ ref:=defref;
|
|
|
+ while assigned(ref) do
|
|
|
+ begin
|
|
|
+ if ref^.moduleindex=current_module^.unit_index then
|
|
|
+ begin
|
|
|
+ writeposinfo(ref^.posinfo);
|
|
|
+ ref^.is_written:=true;
|
|
|
+ if move_last then
|
|
|
+ lastwritten:=ref;
|
|
|
+ end
|
|
|
+ else if not ref^.is_written then
|
|
|
+ move_last:=false
|
|
|
+ else if move_last then
|
|
|
+ lastwritten:=ref;
|
|
|
+ ref:=ref^.nextref;
|
|
|
+ end;
|
|
|
+ current_ppu^.writeentry(ibdefref);
|
|
|
+ write_references:=true;
|
|
|
+ if ((current_module^.flags and uf_local_browser)<>0)
|
|
|
+ and is_in_current then
|
|
|
+ begin
|
|
|
+ pdo:=_class;
|
|
|
+ if (owner^.symtabletype<>localsymtable) then
|
|
|
+ while assigned(pdo) do
|
|
|
+ begin
|
|
|
+ if pdo^.publicsyms<>aktrecordsymtable then
|
|
|
+ begin
|
|
|
+ pdo^.publicsyms^.unitid:=local_symtable_index;
|
|
|
+ inc(local_symtable_index);
|
|
|
+ end;
|
|
|
+ pdo:=pdo^.childof;
|
|
|
+ end;
|
|
|
+
|
|
|
+ {We need TESTLOCALBROWSER para and local symtables
|
|
|
+ PPU files are then easier to read PM.}
|
|
|
+ inc(local_symtable_index);
|
|
|
+ parast^.write_browser;
|
|
|
+ if not assigned(localst) then
|
|
|
+ localst:=new(psymtable,init);
|
|
|
+ localst^.writeas;
|
|
|
+ localst^.unitid:=local_symtable_index;
|
|
|
+ inc(local_symtable_index);
|
|
|
+ localst^.write_browser;
|
|
|
+ {Decrement for.}
|
|
|
+ local_symtable_index:=local_symtable_index-2;
|
|
|
+ pdo:=_class;
|
|
|
+ if (owner^.symtabletype<>localsymtable) then
|
|
|
+ while assigned(pdo) do
|
|
|
+ begin
|
|
|
+ if pdo^.publicsyms<>aktrecordsymtable then
|
|
|
+ dec(local_symtable_index);
|
|
|
+ pdo:=pdo^.childof;
|
|
|
+ end;
|
|
|
+ end;*)
|
|
|
+end;
|
|
|
+
|
|
|
+destructor Tprocdef.done;
|
|
|
+
|
|
|
+begin
|
|
|
+ if references<>nil then
|
|
|
+ dispose(references,done);
|
|
|
+ if (localst<>nil) and (typeof(localst^)<>typeof(Timplsymtable)) then
|
|
|
+ dispose(localst,done);
|
|
|
+{ if (poinline in options) and (code,nil) then
|
|
|
+ disposetree(ptree(code));}
|
|
|
+ if _mangledname<>nil then
|
|
|
+ disposestr(_mangledname);
|
|
|
+ inherited done;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tprocdef.store(var s:Tstream);
|
|
|
+
|
|
|
+begin
|
|
|
+(* inherited store(s);
|
|
|
+ current_ppu^.do_interface_crc:=false;
|
|
|
+ writelong(usedregisters);
|
|
|
+ writestring(mangledname);
|
|
|
+ current_ppu^.do_interface_crc:=true;
|
|
|
+ writelong(extnumber);
|
|
|
+ if (options and pooperator) = 0 then
|
|
|
+ writedefref(nextoverloaded)
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ {Only write the overloads from the same unit }
|
|
|
+ if assigned(nextoverloaded) and
|
|
|
+ (nextoverloaded^.owner=owner) then
|
|
|
+ writedefref(nextoverloaded)
|
|
|
+ else
|
|
|
+ writedefref(nil);
|
|
|
+ end;
|
|
|
+ writedefref(_class);
|
|
|
+ writeposinfo(fileinfo);
|
|
|
+ if (poinline and options) then
|
|
|
+ begin
|
|
|
+ {We need to save
|
|
|
+ - the para and the local symtable
|
|
|
+ - the code ptree !! PM
|
|
|
+ writesymtable(parast);
|
|
|
+ writesymtable(localst);
|
|
|
+ writeptree(ptree(code));
|
|
|
+ }
|
|
|
+ end;
|
|
|
+ current_ppu^.writeentry(ibprocdef);*)
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tprocdef.deref;
|
|
|
+
|
|
|
+begin
|
|
|
+{ inherited deref;
|
|
|
+ resolvedef(pdef(nextoverloaded));
|
|
|
+ resolvedef(pdef(_class));}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tprocdef.mangledname:string;
|
|
|
+
|
|
|
+var i:word;
|
|
|
+ a:byte;
|
|
|
+ s:Pprocsym;
|
|
|
+ r:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ if _mangledname<>nil then
|
|
|
+ mangledname:=_mangledname^
|
|
|
+ else
|
|
|
+ begin
|
|
|
+ {If the procedure is in a unit, we start with the unitname.}
|
|
|
+ if current_module^.is_unit then
|
|
|
+ r:='_'+current_module^.modulename^
|
|
|
+ else
|
|
|
+ r:='';
|
|
|
+ a:=length(r);
|
|
|
+ {If we are a method we add the name of the object we are
|
|
|
+ belonging to.}
|
|
|
+ if (Pprocsym(sym)^._class<>nil) then
|
|
|
+ r:=r+'_M'+Pprocsym(sym)^._class^.sym^.name+'_M';
|
|
|
+ {Then we add the names of the procedures we are defined in
|
|
|
+ (for the case we are a nested procedure).}
|
|
|
+ s:=Pprocsym(sym)^.sub_of;
|
|
|
+ while typeof(s^.owner^)=typeof(Tprocsymtable) do
|
|
|
+ begin
|
|
|
+ insert('_$'+s^.name,r,a);
|
|
|
+ s:=s^.sub_of;
|
|
|
+ end;
|
|
|
+ r:=r+'_'+sym^.name;
|
|
|
+ {Add the types of all parameters.}
|
|
|
+ for i:=0 to parameters^.count-1 do
|
|
|
+ begin
|
|
|
+ r:=r+'$'+Pparameter(parameters^.at(i))^.data^.name;
|
|
|
+ end;
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+procedure Tprocdef.setmangledname(const s:string);
|
|
|
+
|
|
|
+begin
|
|
|
+ if _mangledname<>nil then
|
|
|
+ disposestr(_mangledname);
|
|
|
+ _mangledname:=stringdup(s);
|
|
|
+ if localst<>nil then
|
|
|
+ begin
|
|
|
+ stringdispose(localst^.name);
|
|
|
+ localst^.name:=stringdup('locals of '+s);
|
|
|
+ end;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{***************************************************************************
|
|
|
+ Tprocvardef
|
|
|
+***************************************************************************}
|
|
|
+
|
|
|
+
|
|
|
+function Tprocvardef.size:longint;
|
|
|
+
|
|
|
+begin
|
|
|
+ if pomethodpointer in options then
|
|
|
+ size:=2*target_os.size_of_pointer
|
|
|
+ else
|
|
|
+ size:=target_os.size_of_pointer;
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+{$ifdef GDB}
|
|
|
+function tprocvardef.stabstring : pchar;
|
|
|
+var
|
|
|
+ nss : pchar;
|
|
|
+ i : word;
|
|
|
+ param : pdefcoll;
|
|
|
+begin
|
|
|
+ i := 0;
|
|
|
+ param := para1;
|
|
|
+ while assigned(param) do
|
|
|
+ begin
|
|
|
+ inc(i);
|
|
|
+ param := param^.next;
|
|
|
+ end;
|
|
|
+ getmem(nss,1024);
|
|
|
+ { it is not a function but a function pointer !! (PM) }
|
|
|
+
|
|
|
+ strpcopy(nss,'*f'+retdef^.numberstring{+','+tostr(i)}+';');
|
|
|
+ param := para1;
|
|
|
+ i := 0;
|
|
|
+ { this confuses gdb !!
|
|
|
+ we should use 'F' instead of 'f' but
|
|
|
+ as we use c++ language mode
|
|
|
+ it does not like that either
|
|
|
+ Please do not remove this part
|
|
|
+ might be used once
|
|
|
+ gdb for pascal is ready PM }
|
|
|
+ (* while assigned(param) do
|
|
|
+ begin
|
|
|
+ inc(i);
|
|
|
+ if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
|
|
|
+ {Here we have lost the parameter names !!}
|
|
|
+ pst := strpnew('p'+tostr(i)+':'+param^.data^.numberstring+','+vartyp+';');
|
|
|
+ strcat(nss,pst);
|
|
|
+ strdispose(pst);
|
|
|
+ param := param^.next;
|
|
|
+ end; *)
|
|
|
+ {strpcopy(strend(nss),';');}
|
|
|
+ stabstring := strnew(nss);
|
|
|
+ freemem(nss,1024);
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure tprocvardef.concatstabto(asmlist : paasmoutput);
|
|
|
+begin
|
|
|
+ if ( not assigned(sym) or sym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
|
|
|
+ and not is_def_stab_written then
|
|
|
+ inherited concatstabto(asmlist);
|
|
|
+ is_def_stab_written:=true;
|
|
|
+end;
|
|
|
+{$endif GDB}
|
|
|
+
|
|
|
+
|
|
|
+procedure Tprocvardef.write_rtti_data;
|
|
|
+begin
|
|
|
+ {!!!!!!!}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+procedure Tprocvardef.write_child_rtti_data;
|
|
|
+begin
|
|
|
+ {!!!!!!!!}
|
|
|
+end;
|
|
|
+
|
|
|
+
|
|
|
+function Tprocvardef.is_publishable:boolean;
|
|
|
+
|
|
|
+begin
|
|
|
+ is_publishable:=pomethodpointer in options;
|
|
|
+end;
|
|
|
+
|
|
|
+function Tprocvardef.gettypename:string;
|
|
|
+
|
|
|
+begin
|
|
|
+ gettypename:='<procedure variable type>'
|
|
|
+end;
|
|
|
+
|
|
|
+end.
|
daniel