1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157 |
- {
- $Id$
- Copyright (C) 1998-2000 by Daniel Mantione
- and other members of the Free Pascal development team
- This unit handles definitions
- 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,{$IFDEF TP}xobjects,{$ENDIF}
- cobjects,symtablt,globtype
- {$ifdef i386}
- ,cpubase
- {$endif}
- {$ifdef m68k}
- ,m68k
- {$endif}
- {$ifdef alpha}
- ,alpha
- {$endif};
- type Targconvtyp=(act_convertable,act_equal,act_exact);
- Tvarspez=(vs_value,vs_const,vs_var);
- Tobjoption=(oo_has_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_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.}
- {When has_virtual is set, has_vmt is also set....
- 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;
- {Calling convention for tprocdef and Tprocvardef.}
- Tproccalloption=(po_call_none,
- po_call_clearstack, {Use IBM flat calling
- convention. (Used by GCC.)}
- po_call_leftright, {Push parameters from left to
- right.}
- po_call_cdecl, {Procedure uses C styled
- calling.}
- po_call_register, {Procedure uses register
- (fastcall) calling.}
- po_call_stdcall, {Procedure uses stdcall
- call.}
- po_call_safecall, {Safe call calling
- conventions.}
- po_call_palmossyscall, {Procedure is a PalmOS
- system call.}
- po_call_system,
- po_call_inline, {Procedure is an assembler
- macro.}
- po_call_internproc, {Procedure has compiler
- magic.}
- po_call_internconst); {Procedure has constant
- evaluator intern.}
- Tproccalloptionset=set of Tproccalloption;
- {Basic type for tprocdef and tprocvardef }
- Tproctypeoption=(po_type_none,
- po_type_proginit, {Program initialization.}
- po_type_unitinit, {Unit initialization.}
- po_type_unitfinalize, {Unit finalization.}
- po_type_constructor, {Procedure is a constructor.}
- po_type_destructor, {Procedure is a destructor.}
- po_type_operator); {Procedure defines an
- operator.}
- {Other options for Tprocdef and Tprocvardef.}
- Tprocoption=(po_none,
- po_classmethod, {Class method.}
- po_virtualmethod, {Procedure is a virtual method.}
- po_abstractmethod, {Procedure is an abstract method.}
- po_staticmethod, {Static method.}
- po_overridingmethod, {Method with override directive.}
- po_methodpointer, {Method pointer, only in procvardef, also
- used for 'with object do'.}
- po_containsself, {Self is passed explicit to the
- compiler.}
- po_interrupt, {Procedure is an interrupt handler.}
- po_iocheck, {IO checking should be done after a call
- to the procedure.}
- po_assembler, {Procedure is written in assembler.}
- po_msgstr, {Method for string message handling.}
- po_msgint, {Method for int message handling.}
- po_exports, {Procedure has export directive (needed
- for OS/2).}
- po_external, {Procedure is external (in other object
- or lib).}
- po_savestdregs, {Save std regs cdecl and stdcall need
- that!}
- po_saveregisters); {Save all registers }
- 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;
- definition: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 TP}
- constructor init(Aowner:Pcontainingsymtable);
- {$ENDIF}
- {$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 TP}
- constructor init(Aowner:Pcontainingsymtable;def:Pdef);
- {$ENDIF TP}
- {$ifdef GDB}
- function stabstring : pchar;virtual;
- procedure concatstabto(asmlist : paasmoutput);virtual;
- {$endif GDB}
- function gettypename:string;virtual;
- end;
- Pvmtentry=^Tvmtentry;
- Pglobalvmtentry=^Tglobalvmtentry;
- Plocalvmtentry=^Tlocalvmtentry;
- Pobjectdef=^Tobjectdef;
- Pabstractprocdef=^Pabstractprocdef;
- Pprocvardef=^Tprocvardef;
- Pprocdef = ^Tprocdef;
- Tvmtentry=object(Tobject)
- owner:Pobjectdef;
- constructor init(Aowner:Pobjectdef);
- function mangledname:string;virtual;
- end;
- Tglobalvmtentry=object(Tvmtentry)
- constructor init(Aowner:Pobjectdef;proc:Pprocdef);
- function mangledname:string;virtual;
- private
- def:Pprocdef;
- end;
- Tlocalvmtentry=object(Tvmtentry)
- constructor init(Aowner:Pobjectdef;proc:Pprocdef);
- function mangledname:string;virtual;
- private
- name:Pstring;
- end;
- 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;
- {Contains Tvmtentry objects to describe the layout of the vmt.}
- vmt_layout:Pcollection;
- constructor init(const n:string;Aowner:Pcontainingsymtable;
- parent:Pobjectdef;isclass:boolean);
- constructor load(var s:Tstream);
- procedure check_forwards;
- function insert(Asym:Psym):boolean;
- procedure insertvmt;
- function is_related(d:Pobjectdef):boolean;
- function search(const s:string;search_protected:boolean):Psym;
- function speedsearch(const s:string;speedvalue:longint;
- search_protected:boolean):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,
- s64bit,u64bit,s64bitint,uwidechar);
- 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)
- definition: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;
- {String types}
- Tstringtype=(st_default,st_shortstring,st_longstring,
- st_ansistring,st_widestring);
- {This object needs to be splitted into multiple objects,
- one for each stringtype. This is because all code in this
- object is different for all string types.}
- Pstringdef=^Tstringdef;
- Tstringdef=object(Tdef)
- string_typ:Tstringtype;
- len:longint;
- constructor shortinit(l:byte;Aowner:Pcontainingsymtable);
- constructor shortload(var s:Tstream);
- constructor longinit(l:longint;Aowner:Pcontainingsymtable);
- constructor longload(var s:Tstream);
- constructor ansiinit(l:longint;Aowner:Pcontainingsymtable);
- constructor ansiload(var s:Tstream);
- constructor wideinit(l:longint;Aowner:Pcontainingsymtable);
- constructor wideload(var s:Tstream);
- function stringtypname:string;
- function size:longint;virtual;
- procedure store(var s:Tstream);virtual;
- function gettypename:string;virtual;
- function is_publishable : boolean;virtual;
- { debug }
- {$ifdef GDB}
- function stabstring:Pchar;virtual;
- procedure concatstabto(asmlist : Paasmoutput);virtual;
- {$endif GDB}
- { init/final }
- function needs_inittable : boolean;virtual;
- { rtti }
- procedure write_rtti_data;virtual;
- end;
- Tabstractprocdef=object(Tdef)
- {Saves a definition to the return type }
- retdef:Pdef;
- fpu_used:byte; {How many stack fpu must be empty.}
- proctype:Tproctypeoption;
- options:Tprocoptionset; {Save the procedure options.}
- calloptions:Tproccalloptionset;
- 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;
- Tprocvardef=object(Tabstractprocdef)
- {$IFDEF TP}
- constructor init(Aowner:Pcontainingsymtable);
- {$ENDIF TP}
- 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;
- {This datastructure is used to store the message information
- when a procedure is declared as:
- ;message 'str';
- ;message int;
- ;virtual int;
- }
- Tmessageinf=record
- case integer of
- 0:(str:Pchar);
- 1:(i:longint);
- end;
- {This object can be splitted into a Tprocdef, for normal procedures,
- a Tmethoddef for methods, and a Tinlinedprocdef and a
- Tinlinedmethoddef for inlined procedures.}
- Tprocdef = object(tabstractprocdef)
- messageinf:Tmessageinf;
- { 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;
- vmt_index:longint;
- { 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;
- Pforwarddef=^Tforwarddef;
- Tforwarddef=object(Tdef)
- tosymname:string;
- forwardpos:Tfileposinfo;
- constructor init(Aowner:Pcontainingsymtable;
- const s:string;const pos:Tfileposinfo);
- function gettypename:string;virtual;
- end;
- {Relevant options for assigning a proc or a procvar to a procvar.}
- const po_compatibility_options=[
- po_classmethod,
- po_staticmethod,
- po_methodpointer,
- po_containsself,
- po_interrupt,
- po_iocheck,
- po_exports
- ];
- 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.}
- cu64bitdef:Porddef; {Pointer to 64 bit unsigned def.}
- cs64bitdef:Porddef; {Pointer to 64 bit signed def.}
- voidpointerdef, {Pointer for Void-Pointerdef.}
- charpointerdef, {Pointer for Char-Pointerdef.}
- voidfarpointerdef:ppointerdef;
- s32floatdef : pfloatdef; {Pointer for realconstn.}
- s64floatdef : pfloatdef; {Pointer for realconstn.}
- s80floatdef : pfloatdef; {Pointer to type of temp. floats.}
- s32fixeddef : pfloatdef; {Pointer to type of temp. fixed.}
- cshortstringdef, {Pointer to type of short string const.}
- openshortstringdef, {Pointer to type of an openshortstring,
- needed for readln().}
- clongstringdef, {Pointer to type of long string const.}
- cansistringdef, {Pointer to type of ansi string const.}
- cwidestringdef:Pstringdef; {Pointer to type of wide string const.}
- openchararraydef:Parraydef; {Pointer to type of an open array of
- char, needed for readln().}
- cfiledef:Pfiledef; {Get the same definition for all files
- used for stabs.}
- implementation
- uses systems,symbols,verbose,globals,aasm,files,strings;
- 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);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- filetype:=ft;
- definition:=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 '+definition^.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);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- 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
- ****************************************************************************}
- {$IFDEF TP}
- constructor Terrordef.init(Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- setparent(typeof(Tdef));
- end;
- {$ENDIF TP}
- function Terrordef.gettypename:string;
- begin
- gettypename:='<erroneous type>';
- end;
- {****************************************************************************
- Tabstractpointerdef
- ****************************************************************************}
- constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- include(properties,dp_ret_in_acc);
- 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);
- {$IFDEF TP}setparent(typeof(Tabstractpointerdef));{$ENDIF}
- 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
- ****************************************************************************}
- {$IFDEF TP}
- constructor Tclassrefdef.init(Aowner:Pcontainingsymtable;def:Pdef);
- begin
- inherited init(Aowner,def);
- setparent(typeof(Tpointerdef));
- end;
- {$ENDIF TP}
- function Tclassrefdef.gettypename:string;
- begin
- gettypename:='Class of '+definition^.typename;
- end;
- {***************************************************************************
- TVMTENTRY
- ***************************************************************************}
- constructor Tvmtentry.init(Aowner:Pobjectdef);
- begin
- inherited init;
- {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
- owner:=Aowner;
- end;
- function Tvmtentry.mangledname:string;
- begin
- abstract;
- end;
- {***************************************************************************
- TGLOBALVMTENTRY
- ******************************************************* *******************}
- constructor Tglobalvmtentry.init(Aowner:Pobjectdef;proc:Pprocdef);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tvmtentry));{$ENDIF TP}
- def:=proc;
- end;
- function Tglobalvmtentry.mangledname:string;
- begin
- mangledname:=def^.mangledname;
- end;
- {***************************************************************************
- TLOCALVMTENTRY
- ***************************************************************************}
- constructor Tlocalvmtentry.init(Aowner:Pobjectdef;proc:Pprocdef);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tvmtentry));{$ENDIF TP}
- if po_abstractmethod in proc^.options then
- name:=stringdup('FPC_ABSTRACTERROR')
- else
- name:=stringdup(proc^.mangledname);
- end;
- function Tlocalvmtentry.mangledname:string;
- begin
- mangledname:=name^;
- end;
- {***************************************************************************
- TOBJECTDEF
- ***************************************************************************}
- constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
- parent:Pobjectdef;isclass:boolean);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- new(publicsyms,init);
- publicsyms^.name:=stringdup(n);
- publicsyms^.defowner:=@self;
- set_parent(parent);
- objname:=stringdup(n);
- if isclass then
- begin
- include(properties,dp_ret_in_acc);
- include(options,oo_is_class);
- end;
- end;
- procedure tobjectdef.set_parent(parent:Pobjectdef);
- const inherited_options=[oo_has_virtual,
- 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_virtual 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_virtual,oo_is_class]*parent^.options<>[] then
- begin
- vmt_offset:=parent^.vmt_offset;
- include(options,oo_has_virtual);
- 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;
- var o:Pobjectdef;
- c:Pcollection;
- i:word;
- begin
- if vmt_layout<>nil then
- internalerror($990803);
- {Make room for a vmtlink in the object.
- First round up to aktpakrecords.}
- publicsyms^.datasize:=align(publicsyms^.datasize,
- packrecordalignment[aktpackrecords]);
- vmt_offset:=publicsyms^.datasize;
- publicsyms^.datasize:=publicsyms^.datasize+
- target_os.size_of_pointer;
- {Set up the vmt layout collection.
- First search for a vmt in a parent object.}
- o:=childof;
- c:=nil;
- while o<>nil do
- begin
- if o^.vmt_layout<>nil then
- begin
- c:=vmt_layout;
- break;
- end;
- o:=o^.childof;
- end;
- if c=nil then
- new(vmt_layout,init(8,8))
- else
- begin
- {We should copy the vmt layout of our parent object. Our vmt
- layout will change as soon as methods are overridden or when
- new virtual methods are added.}
- new(vmt_layout,init(c^.limit,8));
- for i:=0 to c^.count-1 do
- vmt_layout^.insert(c^.at(i));
- 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.is_related(d:Pobjectdef):boolean;
- var hp:Pobjectdef;
- begin
- hp:=@self;
- is_related:=false;
- while assigned(hp) do
- begin
- if hp=d then
- begin
- is_related:=true;
- break;
- end;
- hp:=hp^.childof;
- end;
- end;
- function Tobjectdef.insert(Asym:Psym):boolean;
- var speedvalue:longint;
- s:Psym;
- op:Tobjpropset;
- begin
- {First check if the symbol already exists.}
- s:=privatesyms^.speedsearch(Asym^.name,Asym^.speedvalue);
- if s=nil then
- protectedsyms^.speedsearch(Asym^.name,Asym^.speedvalue);
- if s=nil then
- publicsyms^.speedsearch(Asym^.name,Asym^.speedvalue);
- if s<>nil then
- duplicatesym(sym)
- else
- begin
- {Asym is a Tprocsym, Tvarsym or Tpropertysym.}
- if Asym^.is_object(typeof(Tprocsym)) then
- op:=Pprocsym(Asym)^.objprop
- else if Asym^.is_object(typeof(Tvarsym)) then
- op:=Pvarsym(Asym)^.objprop
- else if Asym^.is_object(typeof(Tpropertysym)) then
- op:=Ppropertysym(Asym)^.objprop;
- if sp_private in op then
- insert:=privatesyms^.insert(Asym)
- else if sp_protected in op then
- insert:=protectedsyms^.insert(Asym)
- else if sp_public in op then
- insert:=publicsyms^.insert(Asym);
- end;
- end;
- function Tobjectdef.search(const s:string;search_protected:boolean):Psym;
- begin
- search:=speedsearch(s,getspeedvalue(s),search_protected);
- end;
- function Tobjectdef.speedsearch(const s:string;speedvalue:longint;
- search_protected:boolean):Psym;
- var r:Psym;
- begin
- r:=publicsyms^.speedsearch(s,speedvalue);
- {Privatesyms should be set to nil after compilation of the unit.
- This way, private syms are not found by objects in other units.}
- if (r=nil) and (privatesyms<>nil) then
- r:=privatesyms^.speedsearch(s,speedvalue);
- if (r=nil) and search_protected 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 not(oo_has_virtual 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;
- var i:longint;
- ve:Pvmtentry;
- begin
- {We should be carefull when disposing the vmt_layout; there are
- vmt entries in it which are from methods of our ancestor, we
- should not dispose these. So first set them to nil.}
- for i:=0 to vmt_layout^.count do
- if Pvmtentry(vmt_layout^.at(i))^.owner<>@self then
- vmt_layout^.atput(i,nil);
- dispose(vmt_layout,done);
- 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 sym^.is_object(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(proc:Pcollection;shiftvalue:byte);
- var typvalue:byte;
- begin
- if proc=nil then
- begin
- rttilist^.concat(new(pai_const,init_32bit(1)));
- typvalue:=3;
- end
- else if Psym(proc^.at(0))^.is_object(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)^.readaccess,0);
- writeproc(Ppropertysym(sym)^.writeaccess,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)^.storedaccess,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);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- 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_create_smart 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_create_smart in aktmoduleswitches) then
- datasegment^.concat(new(pai_symbol,
- initname_global(getrangecheckstring,10)))
- else
- datasegment^.concat(new(pai_symbol,
- initname(getrangecheckstring,10)));
- 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);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- include(properties,dp_ret_in_acc);
- 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_create_smart 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_create_smart in aktmoduleswitches) then
- datasegment^.concat(new(Pai_symbol,
- initname_global(getrangecheckstring,8)))
- else
- datasegment^.concat(new(Pai_symbol,
- initname(getrangecheckstring,8)));
- 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);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- include(properties,dp_ret_in_acc);
- 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_create_smart 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_create_smart in aktmoduleswitches) then
- datasegment^.concat(new(Pai_symbol,
- initname_global(getrangecheckstring,10)))
- else
- datasegment^.concat(new(Pai_symbol,
- initname(getrangecheckstring,10)));
- 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','card64','widechar');
- begin
- gettypename:=names[typ];
- end;
- {****************************************************************************
- Tfloatdef
- ****************************************************************************}
- constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- if t=f32bit then
- include(properties,dp_ret_in_acc);
- 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);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- definition:=s;
- if high<32 then
- begin
- settype:=smallset;
- savesize:=4;
- include(properties,dp_ret_in_acc);
- 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(definition^.get_rtti_label)));
- end;
- procedure Tsetdef.write_child_rtti_data;
- begin
- definition^.get_rtti_label;
- end;
- function Tsetdef.is_publishable:boolean;
- begin
- is_publishable:=settype=smallset;
- end;
- function Tsetdef.gettypename:string;
- begin
- gettypename:='set of '+definition^.typename;
- end;
- {***************************************************************************
- Trecorddef
- ***************************************************************************}
- constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- 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;
- {***************************************************************************
- Tstringprocdef
- ***************************************************************************}
- constructor Tstringdef.shortinit(l:byte;Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- string_typ:=st_shortstring;
- len:=l;
- savesize:=len+1;
- end;
- constructor Tstringdef.shortload(var s:Tstream);
- begin
- inherited load(s);
- string_typ:=st_shortstring;
- { len:=readbyte;
- savesize:=len+1;}
- end;
- constructor Tstringdef.longinit(l:longint;Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- string_typ:=st_longstring;
- len:=l;
- savesize:=target_os.size_of_pointer;
- end;
- constructor Tstringdef.longload(var s:Tstream);
- begin
- inherited load(s);
- string_typ:=st_longstring;
- { len:=readlong;
- savesize:=target_os.size_of_pointer;}
- end;
- constructor tstringdef.ansiinit(l:longint;Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- include(properties,dp_ret_in_acc);
- string_typ:=st_ansistring;
- len:=l;
- savesize:=target_os.size_of_pointer;
- end;
- constructor Tstringdef.ansiload(var s:Tstream);
- begin
- inherited load(s);
- string_typ:=st_ansistring;
- { len:=readlong;
- savesize:=target_os.size_of_pointer;}
- end;
- constructor Tstringdef.wideinit(l:longint;Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- include(properties,dp_ret_in_acc);
- string_typ:=st_widestring;
- len:=l;
- savesize:=target_os.size_of_pointer;
- end;
- constructor Tstringdef.wideload(var s:Tstream);
- begin
- inherited load(s);
- string_typ:=st_widestring;
- { len:=readlong;
- savesize:=target_os.size_of_pointer;}
- end;
- function Tstringdef.stringtypname:string;
- const typname:array[tstringtype] of string[8]=
- ('','SHORTSTR','LONGSTR','ANSISTR','WIDESTR');
- begin
- stringtypname:=typname[string_typ];
- end;
- function tstringdef.size:longint;
- begin
- size:=savesize;
- end;
- procedure Tstringdef.store(var s:Tstream);
- begin
- inherited store(s);
- { if string_typ=st_shortstring then
- writebyte(len)
- else
- writelong(len);
- case string_typ of
- st_shortstring:
- current_ppu^.writeentry(ibshortstringdef);
- st_longstring:
- current_ppu^.writeentry(iblongstringdef);
- st_ansistring:
- current_ppu^.writeentry(ibansistringdef);
- st_widestring:
- current_ppu^.writeentry(ibwidestringdef);
- end;}
- end;
- {$ifdef GDB}
- function tstringdef.stabstring : pchar;
- var
- bytest,charst,longst : string;
- begin
- case string_typ of
- st_shortstring:
- begin
- charst := typeglobalnumber('char');
- { this is what I found in stabs.texinfo but
- gdb 4.12 for go32 doesn't understand that !! }
- {$IfDef GDBknowsstrings}
- stabstring := strpnew('n'+charst+';'+tostr(len));
- {$else}
- bytest := typeglobalnumber('byte');
- stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
- +',0,8;st:ar'+bytest
- +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
- {$EndIf}
- end;
- st_longstring:
- begin
- charst := typeglobalnumber('char');
- { this is what I found in stabs.texinfo but
- gdb 4.12 for go32 doesn't understand that !! }
- {$IfDef GDBknowsstrings}
- stabstring := strpnew('n'+charst+';'+tostr(len));
- {$else}
- bytest := typeglobalnumber('byte');
- longst := typeglobalnumber('longint');
- stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
- +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
- +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
- {$EndIf}
- end;
- st_ansistring:
- begin
- { an ansi string looks like a pchar easy !! }
- stabstring:=strpnew('*'+typeglobalnumber('char'));
- end;
- st_widestring:
- begin
- { an ansi string looks like a pchar easy !! }
- stabstring:=strpnew('*'+typeglobalnumber('char'));
- end;
- end;
- end;
- procedure tstringdef.concatstabto(asmlist : paasmoutput);
- begin
- inherited concatstabto(asmlist);
- end;
- {$endif GDB}
- function tstringdef.needs_inittable : boolean;
- begin
- needs_inittable:=string_typ in [st_ansistring,st_widestring];
- end;
- function tstringdef.gettypename : string;
- const
- names : array[tstringtype] of string[20] = ('',
- 'ShortString','LongString','AnsiString','WideString');
- begin
- gettypename:=names[string_typ];
- end;
- procedure tstringdef.write_rtti_data;
- begin
- case string_typ of
- st_ansistring:
- begin
- rttilist^.concat(new(pai_const,init_8bit(tkAString)));
- write_rtti_name;
- end;
- st_widestring:
- begin
- rttilist^.concat(new(pai_const,init_8bit(tkWString)));
- write_rtti_name;
- end;
- st_longstring:
- begin
- rttilist^.concat(new(pai_const,init_8bit(tkLString)));
- write_rtti_name;
- end;
- st_shortstring:
- begin
- rttilist^.concat(new(pai_const,init_8bit(tkSString)));
- write_rtti_name;
- rttilist^.concat(new(pai_const,init_8bit(len)));
- end;
- end;
- end;
- function tstringdef.is_publishable : boolean;
- begin
- is_publishable:=true;
- end;
- {***************************************************************************
- Tabstractprocdef
- ***************************************************************************}
- constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);
- begin
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- include(properties,dp_ret_in_acc);
- 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);
- {$IFDEF TP}setparent(typeof(Tabstractprocdef));{$ENDIF}
- fileinfo:=aktfilepos;
- vmt_index:=-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 po_msgstr in options then
- strdispose(messageinf.str);
- 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
- ***************************************************************************}
- {$IFDEF TP}
- constructor Tprocvardef.init(Aowner:Pcontainingsymtable);
- begin
- setparent(typeof(Tabstractprocdef));
- end;
- {$ENDIF TP}
- function Tprocvardef.size:longint;
- begin
- if po_methodpointer 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:=po_methodpointer in options;
- end;
- function Tprocvardef.gettypename:string;
- begin
- gettypename:='<procedure variable type>'
- end;
- {****************************************************************************
- Tforwarddef
- ****************************************************************************}
- constructor tforwarddef.init(Aowner:Pcontainingsymtable;
- const s:string;const pos:Tfileposinfo);
- var oldregisterdef:boolean;
- begin
- { never register the forwarddefs, they are disposed at the
- end of the type declaration block }
- { oldregisterdef:=registerdef;
- registerdef:=false;}
- inherited init(Aowner);
- {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
- { registerdef:=oldregisterdef;}
- tosymname:=s;
- forwardpos:=pos;
- end;
- function tforwarddef.gettypename:string;
- begin
- gettypename:='unresolved forward to '+tosymname;
- end;
- end.
- {
- $Log$
- Revision 1.2 2002-05-16 19:46:52 carl
- + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
- + try to fix temp allocation (still in ifdef)
- + generic constructor calls
- + start of tassembler / tmodulebase class cleanup
- Revision 1.1 2000/07/13 06:30:13 michael
- + Initial import
- Revision 1.6 2000/03/16 12:52:47 daniel
- * Changed names of procedures flags
- * Changed VMT generation
- Revision 1.5 2000/03/11 21:11:24 daniel
- * Ported hcgdata to new symtable.
- * Alignment code changed as suggested by Peter
- + Usage of my is operator replacement, is_object
- Revision 1.4 2000/03/01 11:43:55 daniel
- * Some more work on the new symtable.
- + Symtable stack unit 'symstack' added.
- }
|