defs.pas 88 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157
  1. {
  2. $Id$
  3. Copyright (C) 1998-2000 by Daniel Mantione
  4. and other members of the Free Pascal development team
  5. This unit handles definitions
  6. This program is free software; you can redistribute it and/or modify
  7. it under the terms of the GNU General Public License as published by
  8. the Free Software Foundation; either version 2 of the License, or
  9. (at your option) any later version.
  10. This program is distributed in the hope that it will be useful,
  11. but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  13. GNU General Public License for more details.
  14. You should have received a copy of the GNU General Public License
  15. along with this program; if not, write to the Free Software
  16. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17. ****************************************************************************
  18. }
  19. {$ifdef TP}
  20. {$N+,E+,F+}
  21. {$endif}
  22. unit defs;
  23. interface
  24. uses symtable,objects,{$IFDEF TP}xobjects,{$ENDIF}
  25. cobjects,symtablt,globtype
  26. {$ifdef i386}
  27. ,cpubase
  28. {$endif}
  29. {$ifdef m68k}
  30. ,m68k
  31. {$endif}
  32. {$ifdef alpha}
  33. ,alpha
  34. {$endif};
  35. type Targconvtyp=(act_convertable,act_equal,act_exact);
  36. Tvarspez=(vs_value,vs_const,vs_var);
  37. Tobjoption=(oo_has_abstract, {The object/class has
  38. an abstract method => no
  39. instances can be created.}
  40. oo_is_class, {The object is a class.}
  41. oo_has_virtual, {The object/class has
  42. virtual methods.}
  43. oo_isforward, {The class is only a forward
  44. declared yet.}
  45. oo_can_have_published, {True, if the class has rtti, i.e.
  46. you can publish properties.}
  47. oo_has_constructor, {The object/class has a
  48. constructor.}
  49. oo_has_destructor, {The object/class has a
  50. destructor.}
  51. {When has_virtual is set, has_vmt is also set....
  52. oo_has_vmt, The object/class has a vmt.}
  53. oo_has_msgstr,
  54. oo_has_msgint,
  55. oo_cppvmt); {The object/class uses an C++
  56. compatible vmt, all members of
  57. the same class tree, must use
  58. then a C++ compatible vmt.}
  59. Tobjoptionset=set of Tobjoption;
  60. {Calling convention for tprocdef and Tprocvardef.}
  61. Tproccalloption=(po_call_none,
  62. po_call_clearstack, {Use IBM flat calling
  63. convention. (Used by GCC.)}
  64. po_call_leftright, {Push parameters from left to
  65. right.}
  66. po_call_cdecl, {Procedure uses C styled
  67. calling.}
  68. po_call_register, {Procedure uses register
  69. (fastcall) calling.}
  70. po_call_stdcall, {Procedure uses stdcall
  71. call.}
  72. po_call_safecall, {Safe call calling
  73. conventions.}
  74. po_call_palmossyscall, {Procedure is a PalmOS
  75. system call.}
  76. po_call_system,
  77. po_call_inline, {Procedure is an assembler
  78. macro.}
  79. po_call_internproc, {Procedure has compiler
  80. magic.}
  81. po_call_internconst); {Procedure has constant
  82. evaluator intern.}
  83. Tproccalloptionset=set of Tproccalloption;
  84. {Basic type for tprocdef and tprocvardef }
  85. Tproctypeoption=(po_type_none,
  86. po_type_proginit, {Program initialization.}
  87. po_type_unitinit, {Unit initialization.}
  88. po_type_unitfinalize, {Unit finalization.}
  89. po_type_constructor, {Procedure is a constructor.}
  90. po_type_destructor, {Procedure is a destructor.}
  91. po_type_operator); {Procedure defines an
  92. operator.}
  93. {Other options for Tprocdef and Tprocvardef.}
  94. Tprocoption=(po_none,
  95. po_classmethod, {Class method.}
  96. po_virtualmethod, {Procedure is a virtual method.}
  97. po_abstractmethod, {Procedure is an abstract method.}
  98. po_staticmethod, {Static method.}
  99. po_overridingmethod, {Method with override directive.}
  100. po_methodpointer, {Method pointer, only in procvardef, also
  101. used for 'with object do'.}
  102. po_containsself, {Self is passed explicit to the
  103. compiler.}
  104. po_interrupt, {Procedure is an interrupt handler.}
  105. po_iocheck, {IO checking should be done after a call
  106. to the procedure.}
  107. po_assembler, {Procedure is written in assembler.}
  108. po_msgstr, {Method for string message handling.}
  109. po_msgint, {Method for int message handling.}
  110. po_exports, {Procedure has export directive (needed
  111. for OS/2).}
  112. po_external, {Procedure is external (in other object
  113. or lib).}
  114. po_savestdregs, {Save std regs cdecl and stdcall need
  115. that!}
  116. po_saveregisters); {Save all registers }
  117. Tprocoptionset=set of Tprocoption;
  118. Tarrayoption=(ap_variant,ap_constructor,ap_arrayofconst);
  119. Tarrayoptionset=set of Tarrayoption;
  120. Pparameter=^Tparameter;
  121. Tparameter=object(Tobject)
  122. data:Psym;
  123. paratyp:Tvarspez;
  124. argconvtyp:Targconvtyp;
  125. convertlevel:byte;
  126. register:Tregister;
  127. end;
  128. Tfiletype=(ft_text,ft_typed,ft_untyped);
  129. Pfiledef=^Tfiledef;
  130. Tfiledef=object(Tdef)
  131. filetype:Tfiletype;
  132. definition:Pdef;
  133. constructor init(Aowner:Pcontainingsymtable;
  134. ft:Tfiletype;tas:Pdef);
  135. constructor load(var s:Tstream);
  136. procedure deref;virtual;
  137. function gettypename:string;virtual;
  138. procedure setsize;
  139. {$ifdef GDB}
  140. function stabstring:Pchar;virtual;
  141. procedure concatstabto(asmlist:Paasmoutput);virtual;
  142. {$endif GDB}
  143. procedure store(var s:Tstream);virtual;
  144. end;
  145. Pformaldef=^Tformaldef;
  146. Tformaldef=object(Tdef)
  147. constructor init(Aowner:Pcontainingsymtable);
  148. constructor load(var s:Tstream);
  149. procedure store(var s:Tstream);virtual;
  150. {$ifdef GDB}
  151. function stabstring:Pchar;virtual;
  152. procedure concatstabto(asmlist:Paasmoutput);virtual;
  153. {$endif GDB}
  154. function gettypename:string;virtual;
  155. end;
  156. Perrordef=^Terrordef;
  157. Terrordef=object(Tdef)
  158. {$IFDEF TP}
  159. constructor init(Aowner:Pcontainingsymtable);
  160. {$ENDIF}
  161. {$ifdef GDB}
  162. function stabstring:Pchar;virtual;
  163. {$endif GDB}
  164. function gettypename:string;virtual;
  165. end;
  166. Pabstractpointerdef=^Tabstractpointerdef;
  167. Tabstractpointerdef=object(Tdef)
  168. definition:Pdef;
  169. defsym:Psym;
  170. constructor init(Aowner:Pcontainingsymtable;def:Pdef);
  171. constructor load(var s:Tstream);
  172. procedure deref;virtual;
  173. procedure store(var s:Tstream);virtual;
  174. {$ifdef GDB}
  175. function stabstring:Pchar;virtual;
  176. procedure concatstabto(asmlist:Paasmoutput);virtual;
  177. {$endif GDB}
  178. end;
  179. Ppointerdef=^Tpointerdef;
  180. Tpointerdef=object(Tabstractpointerdef)
  181. is_far:boolean;
  182. constructor initfar(Aowner:Pcontainingsymtable;def:Pdef);
  183. constructor load(var s:Tstream);
  184. procedure store(var s:Tstream);virtual;
  185. function gettypename:string;virtual;
  186. end;
  187. Pclassrefdef=^Tclassrefdef;
  188. Tclassrefdef=object(Tpointerdef)
  189. {$IFDEF TP}
  190. constructor init(Aowner:Pcontainingsymtable;def:Pdef);
  191. {$ENDIF TP}
  192. {$ifdef GDB}
  193. function stabstring : pchar;virtual;
  194. procedure concatstabto(asmlist : paasmoutput);virtual;
  195. {$endif GDB}
  196. function gettypename:string;virtual;
  197. end;
  198. Pvmtentry=^Tvmtentry;
  199. Pglobalvmtentry=^Tglobalvmtentry;
  200. Plocalvmtentry=^Tlocalvmtentry;
  201. Pobjectdef=^Tobjectdef;
  202. Pabstractprocdef=^Pabstractprocdef;
  203. Pprocvardef=^Tprocvardef;
  204. Pprocdef = ^Tprocdef;
  205. Tvmtentry=object(Tobject)
  206. owner:Pobjectdef;
  207. constructor init(Aowner:Pobjectdef);
  208. function mangledname:string;virtual;
  209. end;
  210. Tglobalvmtentry=object(Tvmtentry)
  211. constructor init(Aowner:Pobjectdef;proc:Pprocdef);
  212. function mangledname:string;virtual;
  213. private
  214. def:Pprocdef;
  215. end;
  216. Tlocalvmtentry=object(Tvmtentry)
  217. constructor init(Aowner:Pobjectdef;proc:Pprocdef);
  218. function mangledname:string;virtual;
  219. private
  220. name:Pstring;
  221. end;
  222. Tobjectdef=object(Tdef)
  223. childof:Pobjectdef;
  224. objname:Pstring;
  225. privatesyms,
  226. protectedsyms,
  227. publicsyms:Pobjectsymtable;
  228. options:Tobjoptionset;
  229. {To be able to have a variable vmt position
  230. and no vmt field for objects without virtuals.}
  231. vmt_offset:longint;
  232. {Contains Tvmtentry objects to describe the layout of the vmt.}
  233. vmt_layout:Pcollection;
  234. constructor init(const n:string;Aowner:Pcontainingsymtable;
  235. parent:Pobjectdef;isclass:boolean);
  236. constructor load(var s:Tstream);
  237. procedure check_forwards;
  238. function insert(Asym:Psym):boolean;
  239. procedure insertvmt;
  240. function is_related(d:Pobjectdef):boolean;
  241. function search(const s:string;search_protected:boolean):Psym;
  242. function speedsearch(const s:string;speedvalue:longint;
  243. search_protected:boolean):Psym;virtual;
  244. function size:longint;virtual;
  245. procedure store(var s:Tstream);virtual;
  246. function vmt_mangledname : string;
  247. function rtti_name : string;
  248. procedure set_parent(parent:Pobjectdef);
  249. {$ifdef GDB}
  250. function stabstring : pchar;virtual;
  251. {$endif GDB}
  252. procedure deref;virtual;
  253. function needs_inittable:boolean;virtual;
  254. procedure write_init_data;virtual;
  255. procedure write_child_init_data;virtual;
  256. {Rtti }
  257. function get_rtti_label:string;virtual;
  258. procedure generate_rtti;virtual;
  259. procedure write_rtti_data;virtual;
  260. procedure write_child_rtti_data;virtual;
  261. function next_free_name_index:longint;
  262. function is_publishable:boolean;virtual;
  263. destructor done;virtual;
  264. end;
  265. Parraydef=^Tarraydef;
  266. Tarraydef=object(Tdef)
  267. lowrange,
  268. highrange:Tconstant;
  269. definition:Pdef;
  270. rangedef:Pdef;
  271. options:Tarrayoptionset;
  272. constructor init(const l,h:Tconstant;rd:Pdef;
  273. Aowner:Pcontainingsymtable);
  274. constructor load(var s:Tstream);
  275. function elesize:longint;
  276. function gettypename:string;virtual;
  277. procedure store(var s:Tstream);virtual;
  278. {$ifdef GDB}
  279. function stabstring : pchar;virtual;
  280. procedure concatstabto(asmlist : paasmoutput);virtual;
  281. {$endif GDB}
  282. procedure deref;virtual;
  283. function size : longint;virtual;
  284. { generates the ranges needed by the asm instruction BOUND (i386)
  285. or CMP2 (Motorola) }
  286. procedure genrangecheck;
  287. { returns the label of the range check string }
  288. function getrangecheckstring : string;
  289. function needs_inittable : boolean;virtual;
  290. procedure write_rtti_data;virtual;
  291. procedure write_child_rtti_data;virtual;
  292. private
  293. rangenr:longint;
  294. end;
  295. Penumdef=^Tenumdef;
  296. Tenumdef=object(Tdef)
  297. rangenr,
  298. minval,
  299. maxval:longint;
  300. has_jumps:boolean;
  301. symbols:Pcollection;
  302. basedef:Penumdef;
  303. constructor init(Aowner:Pcontainingsymtable);
  304. constructor init_subrange(Abasedef:Penumdef;Amin,Amax:longint;
  305. Aowner:Pcontainingsymtable);
  306. constructor load(var s:Tstream);
  307. procedure deref;virtual;
  308. procedure calcsavesize;
  309. function getrangecheckstring:string;
  310. procedure genrangecheck;
  311. procedure setmax(Amax:longint);
  312. procedure setmin(Amin:longint);
  313. procedure store(var s:Tstream);virtual;
  314. {$ifdef GDB}
  315. function stabstring:Pchar;virtual;
  316. {$endif GDB}
  317. procedure write_child_rtti_data;virtual;
  318. procedure write_rtti_data;virtual;
  319. function is_publishable : boolean;virtual;
  320. function gettypename:string;virtual;
  321. end;
  322. Tbasetype=(uauto,uvoid,uchar,
  323. u8bit,u16bit,u32bit,
  324. s8bit,s16bit,s32bit,
  325. bool8bit,bool16bit,bool32bit,
  326. s64bit,u64bit,s64bitint,uwidechar);
  327. Porddef=^Torddef;
  328. Torddef=object(Tdef)
  329. low,high:Tconstant;
  330. rangenr:longint;
  331. typ:Tbasetype;
  332. constructor init(t:tbasetype;l,h:Tconstant;
  333. Aowner:Pcontainingsymtable);
  334. constructor load(var s:Tstream);
  335. procedure store(var s:Tstream);virtual;
  336. procedure setsize;
  337. { generates the ranges needed by the asm instruction BOUND }
  338. { or CMP2 (Motorola) }
  339. procedure genrangecheck;
  340. { returns the label of the range check string }
  341. function getrangecheckstring : string;
  342. procedure write_rtti_data;virtual;
  343. function is_publishable:boolean;virtual;
  344. function gettypename:string;virtual;
  345. {$ifdef GDB}
  346. function stabstring:Pchar;virtual;
  347. {$endif GDB}
  348. end;
  349. {S80real is dependant on the cpu, s64comp is also
  350. dependant on the size (tp = 80bit for both)
  351. The EXTENDED format exists on the motorola FPU
  352. but it uses 96 bits instead of 80, with some
  353. unused bits within the number itself! Pretty
  354. complicated to support, so no support for the
  355. moment.
  356. S64comp is considered as a real because all
  357. calculations are done by the fpu.}
  358. Tfloattype=(s32real,s64real,s80real,s64comp,f16bit,f32bit);
  359. Pfloatdef=^Tfloatdef;
  360. Tfloatdef=object(tdef)
  361. typ:Tfloattype;
  362. constructor init(t:Tfloattype;Aowner:Pcontainingsymtable);
  363. constructor load(var s:Tstream);
  364. function is_publishable : boolean;virtual;
  365. procedure setsize;
  366. {$ifdef GDB}
  367. function stabstring:Pchar;virtual;
  368. {$endif GDB}
  369. procedure store(var s:Tstream);virtual;
  370. procedure write_rtti_data;virtual;
  371. function gettypename:string;virtual;
  372. end;
  373. Tsettype=(normset,smallset,varset);
  374. Psetdef=^Tsetdef;
  375. Tsetdef=object(Tdef)
  376. definition:Pdef;
  377. settype:Tsettype;
  378. constructor init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
  379. constructor load(var s:Tstream);
  380. procedure store(var s:Tstream);virtual;
  381. {$ifdef GDB}
  382. function stabstring : pchar;virtual;
  383. procedure concatstabto(asmlist : paasmoutput);virtual;
  384. {$endif GDB}
  385. procedure deref;virtual;
  386. function is_publishable : boolean;virtual;
  387. procedure write_rtti_data;virtual;
  388. procedure write_child_rtti_data;virtual;
  389. function gettypename:string;virtual;
  390. end;
  391. Precorddef=^Trecorddef;
  392. Trecorddef=object(Tdef)
  393. symtable:Precordsymtable;
  394. constructor init(s:Precordsymtable;Aowner:Pcontainingsymtable);
  395. constructor load(var s:Tstream);
  396. procedure store(var s:Tstream);virtual;
  397. {$ifdef GDB}
  398. function stabstring : pchar;virtual;
  399. procedure concatstabto(asmlist : paasmoutput);virtual;
  400. {$endif GDB}
  401. procedure deref;virtual;
  402. function needs_inittable : boolean;virtual;
  403. procedure write_rtti_data;virtual;
  404. procedure write_init_data;virtual;
  405. procedure write_child_rtti_data;virtual;
  406. procedure write_child_init_data;virtual;
  407. function gettypename:string;virtual;
  408. destructor done;virtual;
  409. end;
  410. {String types}
  411. Tstringtype=(st_default,st_shortstring,st_longstring,
  412. st_ansistring,st_widestring);
  413. {This object needs to be splitted into multiple objects,
  414. one for each stringtype. This is because all code in this
  415. object is different for all string types.}
  416. Pstringdef=^Tstringdef;
  417. Tstringdef=object(Tdef)
  418. string_typ:Tstringtype;
  419. len:longint;
  420. constructor shortinit(l:byte;Aowner:Pcontainingsymtable);
  421. constructor shortload(var s:Tstream);
  422. constructor longinit(l:longint;Aowner:Pcontainingsymtable);
  423. constructor longload(var s:Tstream);
  424. constructor ansiinit(l:longint;Aowner:Pcontainingsymtable);
  425. constructor ansiload(var s:Tstream);
  426. constructor wideinit(l:longint;Aowner:Pcontainingsymtable);
  427. constructor wideload(var s:Tstream);
  428. function stringtypname:string;
  429. function size:longint;virtual;
  430. procedure store(var s:Tstream);virtual;
  431. function gettypename:string;virtual;
  432. function is_publishable : boolean;virtual;
  433. { debug }
  434. {$ifdef GDB}
  435. function stabstring:Pchar;virtual;
  436. procedure concatstabto(asmlist : Paasmoutput);virtual;
  437. {$endif GDB}
  438. { init/final }
  439. function needs_inittable : boolean;virtual;
  440. { rtti }
  441. procedure write_rtti_data;virtual;
  442. end;
  443. Tabstractprocdef=object(Tdef)
  444. {Saves a definition to the return type }
  445. retdef:Pdef;
  446. fpu_used:byte; {How many stack fpu must be empty.}
  447. proctype:Tproctypeoption;
  448. options:Tprocoptionset; {Save the procedure options.}
  449. calloptions:Tproccalloptionset;
  450. parameters:Pcollection;
  451. constructor init(Aowner:Pcontainingsymtable);
  452. constructor load(var s:Tstream);
  453. destructor done;virtual;
  454. procedure deref;virtual;
  455. function demangled_paras:string;
  456. function para_size:longint;
  457. procedure store(var s:Tstream);virtual;
  458. procedure test_if_fpu_result;
  459. {$ifdef GDB}
  460. function stabstring : pchar;virtual;
  461. procedure concatstabto(asmlist : paasmoutput);virtual;
  462. {$endif GDB}
  463. end;
  464. Tprocvardef=object(Tabstractprocdef)
  465. {$IFDEF TP}
  466. constructor init(Aowner:Pcontainingsymtable);
  467. {$ENDIF TP}
  468. function size:longint;virtual;
  469. {$ifdef GDB}
  470. function stabstring:Pchar;virtual;
  471. procedure concatstabto(asmlist:Paasmoutput); virtual;
  472. {$endif GDB}
  473. procedure write_child_rtti_data;virtual;
  474. function is_publishable:boolean;virtual;
  475. procedure write_rtti_data;virtual;
  476. function gettypename:string;virtual;
  477. end;
  478. {This datastructure is used to store the message information
  479. when a procedure is declared as:
  480. ;message 'str';
  481. ;message int;
  482. ;virtual int;
  483. }
  484. Tmessageinf=record
  485. case integer of
  486. 0:(str:Pchar);
  487. 1:(i:longint);
  488. end;
  489. {This object can be splitted into a Tprocdef, for normal procedures,
  490. a Tmethoddef for methods, and a Tinlinedprocdef and a
  491. Tinlinedmethoddef for inlined procedures.}
  492. Tprocdef = object(tabstractprocdef)
  493. messageinf:Tmessageinf;
  494. { where is this function defined, needed here because there
  495. is only one symbol for all overloaded functions }
  496. fileinfo:Tfileposinfo;
  497. { pointer to the local symbol table }
  498. localst:Pprocsymtable;
  499. _mangledname:Pstring;
  500. { it's a tree, but this not easy to handle }
  501. { used for inlined procs }
  502. code : pointer;
  503. vmt_index:longint;
  504. { true, if the procedure is only declared }
  505. { (forward procedure) }
  506. references:Pcollection;
  507. forwarddef,
  508. { true if the procedure is declared in the interface }
  509. interfacedef : boolean;
  510. { check the problems of manglednames }
  511. count : boolean;
  512. is_used : boolean;
  513. { set which contains the modified registers }
  514. usedregisters:Tregisterset;
  515. constructor init(Aowner:Pcontainingsymtable);
  516. constructor load(var s:Tstream);
  517. procedure store(var s:Tstream);virtual;
  518. {$ifdef GDB}
  519. function cplusplusmangledname : string;
  520. function stabstring : pchar;virtual;
  521. procedure concatstabto(asmlist : paasmoutput);virtual;
  522. {$endif GDB}
  523. procedure deref;virtual;
  524. function mangledname:string;
  525. procedure setmangledname(const s:string);
  526. procedure load_references;
  527. function write_references:boolean;
  528. destructor done;virtual;
  529. end;
  530. Pforwarddef=^Tforwarddef;
  531. Tforwarddef=object(Tdef)
  532. tosymname:string;
  533. forwardpos:Tfileposinfo;
  534. constructor init(Aowner:Pcontainingsymtable;
  535. const s:string;const pos:Tfileposinfo);
  536. function gettypename:string;virtual;
  537. end;
  538. {Relevant options for assigning a proc or a procvar to a procvar.}
  539. const po_compatibility_options=[
  540. po_classmethod,
  541. po_staticmethod,
  542. po_methodpointer,
  543. po_containsself,
  544. po_interrupt,
  545. po_iocheck,
  546. po_exports
  547. ];
  548. var cformaldef:Pformaldef; {Unique formal definition.}
  549. voiddef:Porddef; {Pointer to void (procedure) type.}
  550. cchardef:Porddef; {Pointer to char type.}
  551. booldef:Porddef; {Pointer to boolean type.}
  552. u8bitdef:Porddef; {Pointer to 8-bit unsigned type.}
  553. u16bitdef:Porddef; {Pointer to 16-bit unsigned type.}
  554. u32bitdef:Porddef; {Pointer to 32-bit unsigned type.}
  555. s32bitdef:Porddef; {Pointer to 32-bit signed type.}
  556. cu64bitdef:Porddef; {Pointer to 64 bit unsigned def.}
  557. cs64bitdef:Porddef; {Pointer to 64 bit signed def.}
  558. voidpointerdef, {Pointer for Void-Pointerdef.}
  559. charpointerdef, {Pointer for Char-Pointerdef.}
  560. voidfarpointerdef:ppointerdef;
  561. s32floatdef : pfloatdef; {Pointer for realconstn.}
  562. s64floatdef : pfloatdef; {Pointer for realconstn.}
  563. s80floatdef : pfloatdef; {Pointer to type of temp. floats.}
  564. s32fixeddef : pfloatdef; {Pointer to type of temp. fixed.}
  565. cshortstringdef, {Pointer to type of short string const.}
  566. openshortstringdef, {Pointer to type of an openshortstring,
  567. needed for readln().}
  568. clongstringdef, {Pointer to type of long string const.}
  569. cansistringdef, {Pointer to type of ansi string const.}
  570. cwidestringdef:Pstringdef; {Pointer to type of wide string const.}
  571. openchararraydef:Parraydef; {Pointer to type of an open array of
  572. char, needed for readln().}
  573. cfiledef:Pfiledef; {Get the same definition for all files
  574. used for stabs.}
  575. implementation
  576. uses systems,symbols,verbose,globals,aasm,files,strings;
  577. const {If you change one of the following contants,
  578. you have also to change the typinfo unit
  579. and the rtl/i386,template/rttip.inc files.}
  580. tkunknown = 0;
  581. tkinteger = 1;
  582. tkchar = 2;
  583. tkenumeration = 3;
  584. tkfloat = 4;
  585. tkset = 5;
  586. tkmethod = 6;
  587. tksstring = 7;
  588. tkstring = tksstring;
  589. tklstring = 8;
  590. tkastring = 9;
  591. tkwstring = 10;
  592. tkvariant = 11;
  593. tkarray = 12;
  594. tkrecord = 13;
  595. tkinterface = 14;
  596. tkclass = 15;
  597. tkobject = 16;
  598. tkwchar = 17;
  599. tkbool = 18;
  600. otsbyte = 0;
  601. otubyte = 1;
  602. otsword = 2;
  603. otuword = 3;
  604. otslong = 4;
  605. otulong = 5;
  606. ftsingle = 0;
  607. ftdouble = 1;
  608. ftextended = 2;
  609. ftcomp = 3;
  610. ftcurr = 4;
  611. ftfixed16 = 5;
  612. ftfixed32 = 6;
  613. {****************************************************************************
  614. Tfiledef
  615. ****************************************************************************}
  616. constructor Tfiledef.init(Aowner:Pcontainingsymtable;ft:Tfiletype;tas:Pdef);
  617. begin
  618. inherited init(Aowner);
  619. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  620. filetype:=ft;
  621. definition:=tas;
  622. setsize;
  623. end;
  624. constructor Tfiledef.load(var s:Tstream);
  625. begin
  626. inherited load(s);
  627. { filetype:=tfiletype(readbyte);
  628. if filetype=ft_typed then
  629. typed_as:=readdefref
  630. else
  631. typed_as:=nil;}
  632. setsize;
  633. end;
  634. procedure Tfiledef.deref;
  635. begin
  636. { if filetype=ft_typed then
  637. resolvedef(typed_as);}
  638. end;
  639. procedure Tfiledef.setsize;
  640. begin
  641. case filetype of
  642. ft_text:
  643. savesize:=572;
  644. ft_typed,ft_untyped:
  645. savesize:=316;
  646. end;
  647. end;
  648. procedure Tfiledef.store(var s:Tstream);
  649. begin
  650. { inherited store(s);
  651. writebyte(byte(filetype));
  652. if filetype=ft_typed then
  653. writedefref(typed_as);
  654. current_ppu^.writeentry(ibfiledef);}
  655. end;
  656. function Tfiledef.gettypename : string;
  657. begin
  658. case filetype of
  659. ft_untyped:
  660. gettypename:='File';
  661. ft_typed:
  662. gettypename:='File Of '+definition^.typename;
  663. ft_text:
  664. gettypename:='Text'
  665. end;
  666. end;
  667. {****************************************************************************
  668. Tformaldef
  669. ****************************************************************************}
  670. {Tformaldef is used for var parameters without a type.}
  671. constructor Tformaldef.init(Aowner:Pcontainingsymtable);
  672. begin
  673. inherited init(Aowner);
  674. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  675. savesize:=target_os.size_of_pointer;
  676. end;
  677. constructor Tformaldef.load(var s:Tstream);
  678. begin
  679. inherited load(s);
  680. savesize:=target_os.size_of_pointer;
  681. end;
  682. procedure Tformaldef.store(var s:Tstream);
  683. begin
  684. inherited store(s);
  685. { current_ppu^.writeentry(ibformaldef);}
  686. end;
  687. function Tformaldef.gettypename:string;
  688. begin
  689. gettypename:='Var';
  690. end;
  691. {****************************************************************************
  692. Terrordef
  693. ****************************************************************************}
  694. {$IFDEF TP}
  695. constructor Terrordef.init(Aowner:Pcontainingsymtable);
  696. begin
  697. inherited init(Aowner);
  698. setparent(typeof(Tdef));
  699. end;
  700. {$ENDIF TP}
  701. function Terrordef.gettypename:string;
  702. begin
  703. gettypename:='<erroneous type>';
  704. end;
  705. {****************************************************************************
  706. Tabstractpointerdef
  707. ****************************************************************************}
  708. constructor Tabstractpointerdef.init(Aowner:Pcontainingsymtable;def:Pdef);
  709. begin
  710. inherited init(Aowner);
  711. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  712. include(properties,dp_ret_in_acc);
  713. definition:=def;
  714. savesize:=target_os.size_of_pointer;
  715. end;
  716. constructor Tabstractpointerdef.load(var s:Tstream);
  717. begin
  718. inherited load(s);
  719. (* {The real address in memory is calculated later (deref).}
  720. definition:=readdefref; *)
  721. savesize:=target_os.size_of_pointer;
  722. end;
  723. procedure Tabstractpointerdef.deref;
  724. begin
  725. { resolvedef(definition);}
  726. end;
  727. procedure Tabstractpointerdef.store(var s:Tstream);
  728. begin
  729. inherited store(s);
  730. { writedefref(definition);
  731. current_ppu^.writeentry(ibpointerdef);}
  732. end;
  733. {****************************************************************************
  734. Tpointerdef
  735. ****************************************************************************}
  736. constructor Tpointerdef.initfar(Aowner:Pcontainingsymtable;def:Pdef);
  737. begin
  738. inherited init(Aowner,def);
  739. {$IFDEF TP}setparent(typeof(Tabstractpointerdef));{$ENDIF}
  740. is_far:=true;
  741. end;
  742. constructor Tpointerdef.load(var s:Tstream);
  743. begin
  744. inherited load(s);
  745. { is_far:=(readbyte<>0);}
  746. end;
  747. function Tpointerdef.gettypename : string;
  748. begin
  749. gettypename:='^'+definition^.typename;
  750. end;
  751. procedure Tpointerdef.store(var s:Tstream);
  752. begin
  753. inherited store(s);
  754. { writebyte(byte(is_far));}
  755. end;
  756. {****************************************************************************
  757. Tclassrefdef
  758. ****************************************************************************}
  759. {$IFDEF TP}
  760. constructor Tclassrefdef.init(Aowner:Pcontainingsymtable;def:Pdef);
  761. begin
  762. inherited init(Aowner,def);
  763. setparent(typeof(Tpointerdef));
  764. end;
  765. {$ENDIF TP}
  766. function Tclassrefdef.gettypename:string;
  767. begin
  768. gettypename:='Class of '+definition^.typename;
  769. end;
  770. {***************************************************************************
  771. TVMTENTRY
  772. ***************************************************************************}
  773. constructor Tvmtentry.init(Aowner:Pobjectdef);
  774. begin
  775. inherited init;
  776. {$IFDEF TP}setparent(typeof(Tobject));{$ENDIF}
  777. owner:=Aowner;
  778. end;
  779. function Tvmtentry.mangledname:string;
  780. begin
  781. abstract;
  782. end;
  783. {***************************************************************************
  784. TGLOBALVMTENTRY
  785. ******************************************************* *******************}
  786. constructor Tglobalvmtentry.init(Aowner:Pobjectdef;proc:Pprocdef);
  787. begin
  788. inherited init(Aowner);
  789. {$IFDEF TP}setparent(typeof(Tvmtentry));{$ENDIF TP}
  790. def:=proc;
  791. end;
  792. function Tglobalvmtentry.mangledname:string;
  793. begin
  794. mangledname:=def^.mangledname;
  795. end;
  796. {***************************************************************************
  797. TLOCALVMTENTRY
  798. ***************************************************************************}
  799. constructor Tlocalvmtentry.init(Aowner:Pobjectdef;proc:Pprocdef);
  800. begin
  801. inherited init(Aowner);
  802. {$IFDEF TP}setparent(typeof(Tvmtentry));{$ENDIF TP}
  803. if po_abstractmethod in proc^.options then
  804. name:=stringdup('FPC_ABSTRACTERROR')
  805. else
  806. name:=stringdup(proc^.mangledname);
  807. end;
  808. function Tlocalvmtentry.mangledname:string;
  809. begin
  810. mangledname:=name^;
  811. end;
  812. {***************************************************************************
  813. TOBJECTDEF
  814. ***************************************************************************}
  815. constructor Tobjectdef.init(const n:string;Aowner:Pcontainingsymtable;
  816. parent:Pobjectdef;isclass:boolean);
  817. begin
  818. inherited init(Aowner);
  819. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  820. new(publicsyms,init);
  821. publicsyms^.name:=stringdup(n);
  822. publicsyms^.defowner:=@self;
  823. set_parent(parent);
  824. objname:=stringdup(n);
  825. if isclass then
  826. begin
  827. include(properties,dp_ret_in_acc);
  828. include(options,oo_is_class);
  829. end;
  830. end;
  831. procedure tobjectdef.set_parent(parent:Pobjectdef);
  832. const inherited_options=[oo_has_virtual,
  833. oo_has_constructor,oo_has_destructor];
  834. begin
  835. {Nothing to do if the parent was not forward !}
  836. if childof=nil then
  837. begin
  838. childof:=parent;
  839. {Some options are inherited...}
  840. if parent<>nil then
  841. begin
  842. options:=options+parent^.options*inherited_options;
  843. {Add the data of the anchestor class.}
  844. inc(publicsyms^.datasize,parent^.publicsyms^.datasize);
  845. if parent^.privatesyms<>nil then
  846. begin
  847. if privatesyms=nil then
  848. new(privatesyms,init);
  849. inc(privatesyms^.datasize,
  850. parent^.privatesyms^.datasize);
  851. end;
  852. if parent^.protectedsyms<>nil then
  853. begin
  854. if protectedsyms<>nil then
  855. new(protectedsyms,init);
  856. inc(protectedsyms^.datasize,
  857. parent^.protectedsyms^.datasize);
  858. end;
  859. if oo_has_virtual in (options*parent^.options) then
  860. publicsyms^.datasize:=publicsyms^.datasize-
  861. target_os.size_of_pointer;
  862. {If parent has a vmt field then
  863. the offset is the same for the child PM }
  864. if [oo_has_virtual,oo_is_class]*parent^.options<>[] then
  865. begin
  866. vmt_offset:=parent^.vmt_offset;
  867. include(options,oo_has_virtual);
  868. end;
  869. end;
  870. savesize:=publicsyms^.datasize;
  871. end;
  872. end;
  873. constructor Tobjectdef.load(var s:Tstream);
  874. var oldread_member:boolean;
  875. begin
  876. inherited load(s);
  877. (* savesize:=readlong;
  878. vmt_offset:=readlong;
  879. objname:=stringdup(readstring);
  880. childof:=pobjectdef(readdefref);
  881. options:=readlong;
  882. oldread_member:=read_member;
  883. read_member:=true;
  884. publicsyms:=new(psymtable,loadas(objectsymtable));
  885. read_member:=oldread_member;
  886. publicsyms^.defowner:=@self;
  887. { publicsyms^.datasize:=savesize; }
  888. publicsyms^.name := stringdup(objname^);
  889. { handles the predefined class tobject }
  890. { the last TOBJECT which is loaded gets }
  891. { it ! }
  892. if (objname^='TOBJECT') and
  893. isclass and (childof=nil) then
  894. class_tobject:=@self;
  895. has_rtti:=true;*)
  896. end;
  897. procedure Tobjectdef.insertvmt;
  898. var o:Pobjectdef;
  899. c:Pcollection;
  900. i:word;
  901. begin
  902. if vmt_layout<>nil then
  903. internalerror($990803);
  904. {Make room for a vmtlink in the object.
  905. First round up to aktpakrecords.}
  906. publicsyms^.datasize:=align(publicsyms^.datasize,
  907. packrecordalignment[aktpackrecords]);
  908. vmt_offset:=publicsyms^.datasize;
  909. publicsyms^.datasize:=publicsyms^.datasize+
  910. target_os.size_of_pointer;
  911. {Set up the vmt layout collection.
  912. First search for a vmt in a parent object.}
  913. o:=childof;
  914. c:=nil;
  915. while o<>nil do
  916. begin
  917. if o^.vmt_layout<>nil then
  918. begin
  919. c:=vmt_layout;
  920. break;
  921. end;
  922. o:=o^.childof;
  923. end;
  924. if c=nil then
  925. new(vmt_layout,init(8,8))
  926. else
  927. begin
  928. {We should copy the vmt layout of our parent object. Our vmt
  929. layout will change as soon as methods are overridden or when
  930. new virtual methods are added.}
  931. new(vmt_layout,init(c^.limit,8));
  932. for i:=0 to c^.count-1 do
  933. vmt_layout^.insert(c^.at(i));
  934. end;
  935. end;
  936. procedure Tobjectdef.check_forwards;
  937. begin
  938. publicsyms^.check_forwards;
  939. if oo_isforward in options then
  940. begin
  941. { ok, in future, the forward can be resolved }
  942. message1(sym_e_class_forward_not_resolved,objname^);
  943. exclude(options,oo_isforward);
  944. end;
  945. end;
  946. { true, if self inherits from d (or if they are equal) }
  947. function Tobjectdef.is_related(d:Pobjectdef):boolean;
  948. var hp:Pobjectdef;
  949. begin
  950. hp:=@self;
  951. is_related:=false;
  952. while assigned(hp) do
  953. begin
  954. if hp=d then
  955. begin
  956. is_related:=true;
  957. break;
  958. end;
  959. hp:=hp^.childof;
  960. end;
  961. end;
  962. function Tobjectdef.insert(Asym:Psym):boolean;
  963. var speedvalue:longint;
  964. s:Psym;
  965. op:Tobjpropset;
  966. begin
  967. {First check if the symbol already exists.}
  968. s:=privatesyms^.speedsearch(Asym^.name,Asym^.speedvalue);
  969. if s=nil then
  970. protectedsyms^.speedsearch(Asym^.name,Asym^.speedvalue);
  971. if s=nil then
  972. publicsyms^.speedsearch(Asym^.name,Asym^.speedvalue);
  973. if s<>nil then
  974. duplicatesym(sym)
  975. else
  976. begin
  977. {Asym is a Tprocsym, Tvarsym or Tpropertysym.}
  978. if Asym^.is_object(typeof(Tprocsym)) then
  979. op:=Pprocsym(Asym)^.objprop
  980. else if Asym^.is_object(typeof(Tvarsym)) then
  981. op:=Pvarsym(Asym)^.objprop
  982. else if Asym^.is_object(typeof(Tpropertysym)) then
  983. op:=Ppropertysym(Asym)^.objprop;
  984. if sp_private in op then
  985. insert:=privatesyms^.insert(Asym)
  986. else if sp_protected in op then
  987. insert:=protectedsyms^.insert(Asym)
  988. else if sp_public in op then
  989. insert:=publicsyms^.insert(Asym);
  990. end;
  991. end;
  992. function Tobjectdef.search(const s:string;search_protected:boolean):Psym;
  993. begin
  994. search:=speedsearch(s,getspeedvalue(s),search_protected);
  995. end;
  996. function Tobjectdef.speedsearch(const s:string;speedvalue:longint;
  997. search_protected:boolean):Psym;
  998. var r:Psym;
  999. begin
  1000. r:=publicsyms^.speedsearch(s,speedvalue);
  1001. {Privatesyms should be set to nil after compilation of the unit.
  1002. This way, private syms are not found by objects in other units.}
  1003. if (r=nil) and (privatesyms<>nil) then
  1004. r:=privatesyms^.speedsearch(s,speedvalue);
  1005. if (r=nil) and search_protected and (protectedsyms<>nil) then
  1006. r:=protectedsyms^.speedsearch(s,speedvalue);
  1007. end;
  1008. function Tobjectdef.size:longint;
  1009. begin
  1010. if oo_is_class in options then
  1011. size:=target_os.size_of_pointer
  1012. else
  1013. size:=publicsyms^.datasize;
  1014. end;
  1015. procedure tobjectdef.deref;
  1016. var oldrecsyms:Psymtable;
  1017. begin
  1018. { resolvedef(pdef(childof));
  1019. oldrecsyms:=aktrecordsymtable;
  1020. aktrecordsymtable:=publicsyms;
  1021. publicsyms^.deref;
  1022. aktrecordsymtable:=oldrecsyms;}
  1023. end;
  1024. function Tobjectdef.vmt_mangledname:string;
  1025. begin
  1026. if not(oo_has_virtual in options) then
  1027. message1(parser_object_has_no_vmt,objname^);
  1028. vmt_mangledname:='VMT_'+owner^.name^+'$_'+objname^;
  1029. end;
  1030. function Tobjectdef.rtti_name:string;
  1031. begin
  1032. rtti_name:='RTTI_'+owner^.name^+'$_'+objname^;
  1033. end;
  1034. procedure Tobjectdef.store(var s:Tstream);
  1035. var oldread_member:boolean;
  1036. begin
  1037. inherited store(s);
  1038. (* writelong(size);
  1039. writelong(vmt_offset);
  1040. writestring(objname^);
  1041. writedefref(childof);
  1042. writelong(options);
  1043. current_ppu^.writeentry(ibobjectdef);
  1044. oldread_member:=read_member;
  1045. read_member:=true;
  1046. publicsyms^.writeas;
  1047. read_member:=oldread_member;*)
  1048. end;
  1049. procedure tobjectdef.write_child_init_data;
  1050. begin
  1051. end;
  1052. procedure Tobjectdef.write_init_data;
  1053. var b:byte;
  1054. begin
  1055. if oo_is_class in options then
  1056. b:=tkclass
  1057. else
  1058. b:=tkobject;
  1059. rttilist^.concat(new(Pai_const,init_8bit(b)));
  1060. { generate the name }
  1061. rttilist^.concat(new(Pai_const,init_8bit(length(objname^))));
  1062. rttilist^.concat(new(Pai_string,init(objname^)));
  1063. (* rttilist^.concat(new(Pai_const,init_32bit(size)));
  1064. publicsyms^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
  1065. rttilist^.concat(new(Pai_const,init_32bit(count)));
  1066. publicsyms^.foreach({$ifndef TP}@{$endif}write_field_inittable);*)
  1067. end;
  1068. function Tobjectdef.needs_inittable:boolean;
  1069. var oldb:boolean;
  1070. begin
  1071. { there are recursive calls to needs_inittable possible, }
  1072. { so we have to change to old value how else should }
  1073. { we do that ? check_rec_rtti can't be a nested }
  1074. { procedure of needs_rtti ! }
  1075. (* oldb:=binittable;
  1076. binittable:=false;
  1077. publicsyms^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
  1078. needs_inittable:=binittable;
  1079. binittable:=oldb;*)
  1080. end;
  1081. destructor Tobjectdef.done;
  1082. var i:longint;
  1083. ve:Pvmtentry;
  1084. begin
  1085. {We should be carefull when disposing the vmt_layout; there are
  1086. vmt entries in it which are from methods of our ancestor, we
  1087. should not dispose these. So first set them to nil.}
  1088. for i:=0 to vmt_layout^.count do
  1089. if Pvmtentry(vmt_layout^.at(i))^.owner<>@self then
  1090. vmt_layout^.atput(i,nil);
  1091. dispose(vmt_layout,done);
  1092. if publicsyms<>nil then
  1093. dispose(publicsyms,done);
  1094. if privatesyms<>nil then
  1095. dispose(privatesyms,done);
  1096. if protectedsyms<>nil then
  1097. dispose(protectedsyms,done);
  1098. if oo_isforward in options then
  1099. message1(sym_e_class_forward_not_resolved,objname^);
  1100. stringdispose(objname);
  1101. inherited done;
  1102. end;
  1103. var count:longint;
  1104. procedure count_published_properties(sym:Pnamedindexobject);
  1105. {$ifndef fpc}far;{$endif}
  1106. begin
  1107. if sym^.is_object(typeof(Tpropertysym)) and
  1108. (ppo_published in Ppropertysym(sym)^.properties) then
  1109. inc(count);
  1110. end;
  1111. procedure write_property_info(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}
  1112. var proctypesinfo:byte;
  1113. procedure writeproc(proc:Pcollection;shiftvalue:byte);
  1114. var typvalue:byte;
  1115. begin
  1116. if proc=nil then
  1117. begin
  1118. rttilist^.concat(new(pai_const,init_32bit(1)));
  1119. typvalue:=3;
  1120. end
  1121. else if Psym(proc^.at(0))^.is_object(typeof(Tvarsym)) then
  1122. begin
  1123. rttilist^.concat(new(pai_const,init_32bit(
  1124. Pvarsym(sym)^.address)));
  1125. typvalue:=0;
  1126. end
  1127. else
  1128. begin
  1129. (* if (pprocdef(def)^.options and povirtualmethod)=0 then
  1130. begin
  1131. rttilist^.concat(new(pai_const_symbol,initname(pprocdef(def)^.mangledname)));
  1132. typvalue:=1;
  1133. end
  1134. else
  1135. begin
  1136. {Virtual method, write vmt offset.}
  1137. rttilist^.concat(new(pai_const,
  1138. init_32bit(Pprocdef(def)^.extnumber*4+12)));
  1139. typvalue:=2;
  1140. end;*)
  1141. end;
  1142. proctypesinfo:=proctypesinfo or (typvalue shl shiftvalue);
  1143. end;
  1144. begin
  1145. if (typeof(sym^)=typeof(Tpropertysym)) and
  1146. (ppo_indexed in Ppropertysym(sym)^.properties) then
  1147. proctypesinfo:=$40
  1148. else
  1149. proctypesinfo:=0;
  1150. if (typeof(sym^)=typeof(Tpropertysym)) and
  1151. (ppo_published in Ppropertysym(sym)^.properties) then
  1152. begin
  1153. rttilist^.concat(new(pai_const_symbol,initname(
  1154. Ppropertysym(sym)^.definition^.get_rtti_label)));
  1155. writeproc(Ppropertysym(sym)^.readaccess,0);
  1156. writeproc(Ppropertysym(sym)^.writeaccess,2);
  1157. { isn't it stored ? }
  1158. if (ppo_stored in Ppropertysym(sym)^.properties) then
  1159. begin
  1160. rttilist^.concat(new(pai_const,init_32bit(1)));
  1161. proctypesinfo:=proctypesinfo or (3 shl 4);
  1162. end
  1163. else
  1164. writeproc(ppropertysym(sym)^.storedaccess,4);
  1165. rttilist^.concat(new(pai_const,
  1166. init_32bit(ppropertysym(sym)^.index)));
  1167. rttilist^.concat(new(pai_const,
  1168. init_32bit(ppropertysym(sym)^.default)));
  1169. rttilist^.concat(new(pai_const,
  1170. init_16bit(count)));
  1171. inc(count);
  1172. rttilist^.concat(new(pai_const,init_8bit(proctypesinfo)));
  1173. rttilist^.concat(new(pai_const,
  1174. init_8bit(length(ppropertysym(sym)^.name))));
  1175. rttilist^.concat(new(pai_string,init(ppropertysym(sym)^.name)));
  1176. end;
  1177. end;
  1178. procedure generate_published_child_rtti(sym:Pnamedindexobject);
  1179. {$ifndef fpc}far;{$endif}
  1180. begin
  1181. if (typeof(sym^)=typeof(Tpropertysym)) and
  1182. (ppo_published in Ppropertysym(sym)^.properties) then
  1183. Ppropertysym(sym)^.definition^.get_rtti_label;
  1184. end;
  1185. procedure tobjectdef.write_child_rtti_data;
  1186. begin
  1187. publicsyms^.foreach({$ifndef TP}@{$endif}generate_published_child_rtti);
  1188. end;
  1189. procedure Tobjectdef.generate_rtti;
  1190. begin
  1191. { getdatalabel(rtti_label);
  1192. write_child_rtti_data;
  1193. rttilist^.concat(new(pai_symbol,initname_global(rtti_name)));
  1194. rttilist^.concat(new(pai_label,init(rtti_label)));
  1195. write_rtti_data;}
  1196. end;
  1197. function Tobjectdef.next_free_name_index : longint;
  1198. var i:longint;
  1199. begin
  1200. if (childof<>nil) and (oo_can_have_published in childof^.options) then
  1201. i:=childof^.next_free_name_index
  1202. else
  1203. i:=0;
  1204. count:=0;
  1205. publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
  1206. next_free_name_index:=i+count;
  1207. end;
  1208. procedure tobjectdef.write_rtti_data;
  1209. begin
  1210. if oo_is_class in options then
  1211. rttilist^.concat(new(pai_const,init_8bit(tkclass)))
  1212. else
  1213. rttilist^.concat(new(pai_const,init_8bit(tkobject)));
  1214. {Generate the name }
  1215. rttilist^.concat(new(pai_const,init_8bit(length(objname^))));
  1216. rttilist^.concat(new(pai_string,init(objname^)));
  1217. {Write class type }
  1218. rttilist^.concat(new(pai_const_symbol,initname(vmt_mangledname)));
  1219. { write owner typeinfo }
  1220. if (childof<>nil) and (oo_can_have_published in childof^.options) then
  1221. rttilist^.concat(new(pai_const_symbol,
  1222. initname(childof^.get_rtti_label)))
  1223. else
  1224. rttilist^.concat(new(pai_const,init_32bit(0)));
  1225. {Count total number of properties }
  1226. if (childof<>nil) and (oo_can_have_published in childof^.options) then
  1227. count:=childof^.next_free_name_index
  1228. else
  1229. count:=0;
  1230. {Write it>}
  1231. publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
  1232. rttilist^.concat(new(Pai_const,init_16bit(count)));
  1233. { write unit name }
  1234. if owner^.name<>nil then
  1235. begin
  1236. rttilist^.concat(new(Pai_const,init_8bit(length(owner^.name^))));
  1237. rttilist^.concat(new(Pai_string,init(owner^.name^)));
  1238. end
  1239. else
  1240. rttilist^.concat(new(Pai_const,init_8bit(0)));
  1241. { write published properties count }
  1242. count:=0;
  1243. publicsyms^.foreach({$ifndef TP}@{$endif}count_published_properties);
  1244. rttilist^.concat(new(pai_const,init_16bit(count)));
  1245. { count is used to write nameindex }
  1246. { but we need an offset of the owner }
  1247. { to give each property an own slot }
  1248. if (childof<>nil) and (oo_can_have_published in childof^.options) then
  1249. count:=childof^.next_free_name_index
  1250. else
  1251. count:=0;
  1252. publicsyms^.foreach({$ifndef TP}@{$endif}write_property_info);
  1253. end;
  1254. function Tobjectdef.is_publishable:boolean;
  1255. begin
  1256. is_publishable:=oo_is_class in options;
  1257. end;
  1258. function Tobjectdef.get_rtti_label:string;
  1259. begin
  1260. get_rtti_label:=rtti_name;
  1261. end;
  1262. {***************************************************************************
  1263. TARRAYDEF
  1264. ***************************************************************************}
  1265. constructor Tarraydef.init(const l,h:Tconstant;rd:Pdef;
  1266. Aowner:Pcontainingsymtable);
  1267. begin
  1268. inherited init(Aowner);
  1269. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1270. lowrange:=l;
  1271. highrange:=h;
  1272. rangedef:=rd;
  1273. end;
  1274. constructor Tarraydef.load(var s:Tstream);
  1275. begin
  1276. inherited load(s);
  1277. (* deftype:=arraydef;
  1278. { the addresses are calculated later }
  1279. definition:=readdefref;
  1280. rangedef:=readdefref;
  1281. lowrange:=readlong;
  1282. highrange:=readlong;
  1283. IsArrayOfConst:=boolean(readbyte);*)
  1284. end;
  1285. function Tarraydef.getrangecheckstring:string;
  1286. begin
  1287. if (cs_create_smart in aktmoduleswitches) then
  1288. getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
  1289. else
  1290. getrangecheckstring:='R_'+tostr(rangenr);
  1291. end;
  1292. procedure Tarraydef.genrangecheck;
  1293. begin
  1294. if rangenr=0 then
  1295. begin
  1296. {Generates the data for range checking }
  1297. getlabelnr(rangenr);
  1298. if (cs_create_smart in aktmoduleswitches) then
  1299. datasegment^.concat(new(pai_symbol,
  1300. initname_global(getrangecheckstring,10)))
  1301. else
  1302. datasegment^.concat(new(pai_symbol,
  1303. initname(getrangecheckstring,10)));
  1304. datasegment^.concat(new(Pai_const,
  1305. init_8bit(byte(lowrange.signed))));
  1306. datasegment^.concat(new(Pai_const,
  1307. init_32bit(lowrange.values)));
  1308. datasegment^.concat(new(Pai_const,
  1309. init_8bit(byte(highrange.signed))));
  1310. datasegment^.concat(new(Pai_const,
  1311. init_32bit(highrange.values)));
  1312. end;
  1313. end;
  1314. procedure Tarraydef.deref;
  1315. begin
  1316. { resolvedef(definition);
  1317. resolvedef(rangedef);}
  1318. end;
  1319. procedure Tarraydef.store(var s:Tstream);
  1320. begin
  1321. inherited store(s);
  1322. (* writedefref(definition);
  1323. writedefref(rangedef);
  1324. writelong(lowrange);
  1325. writelong(highrange);
  1326. writebyte(byte(IsArrayOfConst));
  1327. current_ppu^.writeentry(ibarraydef);*)
  1328. end;
  1329. function Tarraydef.elesize:longint;
  1330. begin
  1331. elesize:=definition^.size;
  1332. end;
  1333. function Tarraydef.size:longint;
  1334. begin
  1335. if (lowrange.signed) and (lowrange.values=-1) then
  1336. internalerror($990804);
  1337. if highrange.signed then
  1338. begin
  1339. {Check for overflow.}
  1340. if (highrange.values-lowrange.values=$7fffffff) or
  1341. (($7fffffff div elesize+elesize-1)>
  1342. (highrange.values-lowrange.values)) then
  1343. begin
  1344. { message(sym_segment_too_large);}
  1345. size:=1;
  1346. end
  1347. else
  1348. size:=(highrange.values-lowrange.values+1)*elesize;
  1349. end
  1350. else
  1351. begin
  1352. {Check for overflow.}
  1353. if (highrange.valueu-lowrange.valueu=$7fffffff) or
  1354. (($7fffffff div elesize+elesize-1)>
  1355. (highrange.valueu-lowrange.valueu)) then
  1356. begin
  1357. { message(sym_segment_too_small);}
  1358. size:=1;
  1359. end
  1360. else
  1361. size:=(highrange.valueu-lowrange.valueu+1)*elesize;
  1362. end;
  1363. end;
  1364. function Tarraydef.needs_inittable:boolean;
  1365. begin
  1366. needs_inittable:=definition^.needs_inittable;
  1367. end;
  1368. procedure Tarraydef.write_child_rtti_data;
  1369. begin
  1370. definition^.get_rtti_label;
  1371. end;
  1372. procedure tarraydef.write_rtti_data;
  1373. begin
  1374. rttilist^.concat(new(Pai_const,init_8bit(13)));
  1375. write_rtti_name;
  1376. { size of elements }
  1377. rttilist^.concat(new(Pai_const,init_32bit(definition^.size)));
  1378. { count of elements }
  1379. rttilist^.concat(new(Pai_const,
  1380. init_32bit(highrange.values-lowrange.values+1)));
  1381. { element type }
  1382. rttilist^.concat(new(Pai_const_symbol,
  1383. initname(definition^.get_rtti_label)));
  1384. end;
  1385. function Tarraydef.gettypename:string;
  1386. var r:string;
  1387. begin
  1388. if [ap_arrayofconst,ap_constructor]*options<>[] then
  1389. gettypename:='array of const'
  1390. else if (lowrange.signed) and (lowrange.values=-1) then
  1391. gettypename:='Array Of '+definition^.typename
  1392. else
  1393. begin
  1394. r:='array[$1..$2 Of $3]';
  1395. if typeof(rangedef^)=typeof(Tenumdef) then
  1396. with Penumdef(rangedef)^.symbols^ do
  1397. begin
  1398. replace(r,'$1',Penumsym(at(0))^.name);
  1399. replace(r,'$2',Penumsym(at(count-1))^.name);
  1400. end
  1401. else
  1402. begin
  1403. if lowrange.signed then
  1404. replace(r,'$1',tostr(lowrange.values))
  1405. else
  1406. replace(r,'$1',tostru(lowrange.valueu));
  1407. if highrange.signed then
  1408. replace(r,'$2',tostr(highrange.values))
  1409. else
  1410. replace(r,'$2',tostr(highrange.valueu));
  1411. replace(r,'$3',definition^.typename);
  1412. end;
  1413. gettypename:=r;
  1414. end;
  1415. end;
  1416. {****************************************************************************
  1417. Tenumdef
  1418. ****************************************************************************}
  1419. constructor Tenumdef.init(Aowner:Pcontainingsymtable);
  1420. begin
  1421. inherited init(Aowner);
  1422. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1423. include(properties,dp_ret_in_acc);
  1424. new(symbols,init(8,8));
  1425. calcsavesize;
  1426. end;
  1427. constructor Tenumdef.init_subrange(Abasedef:Penumdef;Amin,Amax:longint;
  1428. Aowner:Pcontainingsymtable);
  1429. begin
  1430. inherited init(Aowner);
  1431. minval:=Amin;
  1432. maxval:=Amax;
  1433. basedef:=Abasedef;
  1434. symbols:=Abasedef^.symbols;
  1435. calcsavesize;
  1436. end;
  1437. constructor Tenumdef.load(var s:Tstream);
  1438. begin
  1439. inherited load(s);
  1440. (* basedef:=penumdef(readdefref);
  1441. minval:=readlong;
  1442. maxval:=readlong;
  1443. savesize:=readlong;*)
  1444. end;
  1445. procedure Tenumdef.calcsavesize;
  1446. begin
  1447. if (aktpackenum=4) or (minval<0) or (maxval>65535) then
  1448. savesize:=4
  1449. else if (aktpackenum=2) or (minval<0) or (maxval>255) then
  1450. savesize:=2
  1451. else
  1452. savesize:=1;
  1453. end;
  1454. procedure Tenumdef.setmax(Amax:longint);
  1455. begin
  1456. maxval:=Amax;
  1457. calcsavesize;
  1458. end;
  1459. procedure Tenumdef.setmin(Amin:longint);
  1460. begin
  1461. minval:=Amin;
  1462. calcsavesize;
  1463. end;
  1464. procedure tenumdef.deref;
  1465. begin
  1466. { resolvedef(pdef(basedef));}
  1467. end;
  1468. procedure Tenumdef.store(var s:Tstream);
  1469. begin
  1470. inherited store(s);
  1471. (* writedefref(basedef);
  1472. writelong(min);
  1473. writelong(max);
  1474. writelong(savesize);
  1475. current_ppu^.writeentry(ibenumdef);*)
  1476. end;
  1477. function tenumdef.getrangecheckstring : string;
  1478. begin
  1479. if (cs_create_smart in aktmoduleswitches) then
  1480. getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
  1481. else
  1482. getrangecheckstring:='R_'+tostr(rangenr);
  1483. end;
  1484. procedure tenumdef.genrangecheck;
  1485. begin
  1486. if rangenr=0 then
  1487. begin
  1488. { generate two constant for bounds }
  1489. getlabelnr(rangenr);
  1490. if (cs_create_smart in aktmoduleswitches) then
  1491. datasegment^.concat(new(Pai_symbol,
  1492. initname_global(getrangecheckstring,8)))
  1493. else
  1494. datasegment^.concat(new(Pai_symbol,
  1495. initname(getrangecheckstring,8)));
  1496. datasegment^.concat(new(pai_const,init_32bit(minval)));
  1497. datasegment^.concat(new(pai_const,init_32bit(maxval)));
  1498. end;
  1499. end;
  1500. procedure Tenumdef.write_child_rtti_data;
  1501. begin
  1502. if assigned(basedef) then
  1503. basedef^.get_rtti_label;
  1504. end;
  1505. procedure Tenumdef.write_rtti_data;
  1506. var i:word;
  1507. begin
  1508. rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
  1509. write_rtti_name;
  1510. case savesize of
  1511. 1:
  1512. rttilist^.concat(new(Pai_const,init_8bit(otUByte)));
  1513. 2:
  1514. rttilist^.concat(new(Pai_const,init_8bit(otUWord)));
  1515. 4:
  1516. rttilist^.concat(new(Pai_const,init_8bit(otULong)));
  1517. end;
  1518. rttilist^.concat(new(pai_const,init_32bit(minval)));
  1519. rttilist^.concat(new(pai_const,init_32bit(maxval)));
  1520. if assigned(basedef) then
  1521. rttilist^.concat(new(pai_const_symbol,initname(basedef^.get_rtti_label)))
  1522. else
  1523. rttilist^.concat(new(pai_const,init_32bit(0)));
  1524. for i:=0 to symbols^.count-1 do
  1525. begin
  1526. rttilist^.concat(new(Pai_const,
  1527. init_8bit(length(Penumsym(symbols^.at(i))^.name))));
  1528. rttilist^.concat(new(Pai_string,
  1529. init(globals.lower(Penumsym(symbols^.at(i))^.name))));
  1530. end;
  1531. rttilist^.concat(new(pai_const,init_8bit(0)));
  1532. end;
  1533. function Tenumdef.is_publishable:boolean;
  1534. begin
  1535. is_publishable:=true;
  1536. end;
  1537. function Tenumdef.gettypename:string;
  1538. var i:word;
  1539. v:longint;
  1540. r:string;
  1541. begin
  1542. r:='(';
  1543. for i:=0 to symbols^.count-1 do
  1544. begin
  1545. v:=Penumsym(symbols^.at(i))^.value;
  1546. if (v>=minval) and (v<=maxval) then
  1547. r:=r+Penumsym(symbols^.at(i))^.name+',';
  1548. end;
  1549. {Turn ',' into ')'.}
  1550. r[length(r)]:=')';
  1551. end;
  1552. {****************************************************************************
  1553. Torddef
  1554. ****************************************************************************}
  1555. constructor Torddef.init(t:Tbasetype;l,h:Tconstant;
  1556. Aowner:Pcontainingsymtable);
  1557. begin
  1558. inherited init(Aowner);
  1559. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1560. include(properties,dp_ret_in_acc);
  1561. low:=l;
  1562. high:=h;
  1563. typ:=t;
  1564. setsize;
  1565. end;
  1566. constructor Torddef.load(var s:Tstream);
  1567. begin
  1568. inherited load(s);
  1569. (* typ:=tbasetype(readbyte);
  1570. low:=readlong;
  1571. high:=readlong;*)
  1572. setsize;
  1573. end;
  1574. procedure Torddef.setsize;
  1575. begin
  1576. if typ=uauto then
  1577. begin
  1578. {Generate a unsigned range if high<0 and low>=0 }
  1579. if (low.values>=0) and (high.values<=255) then
  1580. typ:=u8bit
  1581. else if (low.signed) and (low.values>=-128) and (high.values<=127) then
  1582. typ:=s8bit
  1583. else if (low.values>=0) and (high.values<=65536) then
  1584. typ:=u16bit
  1585. else if (low.signed) and (low.values>=-32768) and (high.values<=32767) then
  1586. typ:=s16bit
  1587. else if low.signed then
  1588. typ:=s32bit
  1589. else
  1590. typ:=u32bit
  1591. end;
  1592. case typ of
  1593. u8bit,s8bit,uchar,bool8bit:
  1594. savesize:=1;
  1595. u16bit,s16bit,bool16bit:
  1596. savesize:=2;
  1597. s32bit,u32bit,bool32bit:
  1598. savesize:=4;
  1599. u64bit,s64bitint:
  1600. savesize:=8;
  1601. else
  1602. savesize:=0;
  1603. end;
  1604. rangenr:=0;
  1605. end;
  1606. function Torddef.getrangecheckstring:string;
  1607. begin
  1608. if (cs_create_smart in aktmoduleswitches) then
  1609. getrangecheckstring:='R_'+current_module^.modulename^+tostr(rangenr)
  1610. else
  1611. getrangecheckstring:='R_'+tostr(rangenr);
  1612. end;
  1613. procedure Torddef.genrangecheck;
  1614. begin
  1615. if rangenr=0 then
  1616. begin
  1617. {Generate two constant for bounds.}
  1618. getlabelnr(rangenr);
  1619. if (cs_create_smart in aktmoduleswitches) then
  1620. datasegment^.concat(new(Pai_symbol,
  1621. initname_global(getrangecheckstring,10)))
  1622. else
  1623. datasegment^.concat(new(Pai_symbol,
  1624. initname(getrangecheckstring,10)));
  1625. datasegment^.concat(new(Pai_const,init_8bit(byte(low.signed))));
  1626. datasegment^.concat(new(Pai_const,init_32bit(low.values)));
  1627. datasegment^.concat(new(Pai_const,init_8bit(byte(high.signed))));
  1628. datasegment^.concat(new(Pai_const,init_32bit(high.values)));
  1629. end;
  1630. end;
  1631. procedure Torddef.store(var s:Tstream);
  1632. begin
  1633. inherited store(s);
  1634. (* writebyte(byte(typ));
  1635. writelong(low);
  1636. writelong(high);
  1637. current_ppu^.writeentry(iborddef);*)
  1638. end;
  1639. procedure Torddef.write_rtti_data;
  1640. const trans:array[uchar..bool8bit] of byte=
  1641. (otubyte,otubyte,otuword,otulong,
  1642. otsbyte,otsword,otslong,otubyte);
  1643. begin
  1644. case typ of
  1645. bool8bit:
  1646. rttilist^.concat(new(Pai_const,init_8bit(tkbool)));
  1647. uchar:
  1648. rttilist^.concat(new(Pai_const,init_8bit(tkchar)));
  1649. else
  1650. rttilist^.concat(new(Pai_const,init_8bit(tkinteger)));
  1651. end;
  1652. write_rtti_name;
  1653. rttilist^.concat(new(Pai_const,init_8bit(byte(trans[typ]))));
  1654. rttilist^.concat(new(Pai_const,init_32bit(low.values)));
  1655. rttilist^.concat(new(Pai_const,init_32bit(high.values)));
  1656. end;
  1657. function Torddef.is_publishable:boolean;
  1658. begin
  1659. is_publishable:=typ in [uchar..bool8bit];
  1660. end;
  1661. function Torddef.gettypename:string;
  1662. const names:array[Tbasetype] of string[20]=('<unknown type>',
  1663. 'untyped','char','byte','word','dword','shortInt',
  1664. 'smallint','longInt','boolean','wordbool',
  1665. 'longbool','qword','int64','card64','widechar');
  1666. begin
  1667. gettypename:=names[typ];
  1668. end;
  1669. {****************************************************************************
  1670. Tfloatdef
  1671. ****************************************************************************}
  1672. constructor Tfloatdef.init(t:Tfloattype;Aowner:Pcontainingsymtable);
  1673. begin
  1674. inherited init(Aowner);
  1675. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1676. if t=f32bit then
  1677. include(properties,dp_ret_in_acc);
  1678. typ:=t;
  1679. setsize;
  1680. end;
  1681. constructor Tfloatdef.load(var s:Tstream);
  1682. begin
  1683. inherited load(s);
  1684. (* typ:=Tfloattype(readbyte);*)
  1685. setsize;
  1686. end;
  1687. procedure tfloatdef.setsize;
  1688. begin
  1689. case typ of
  1690. f16bit:
  1691. savesize:=2;
  1692. f32bit,
  1693. s32real:
  1694. savesize:=4;
  1695. s64real:
  1696. savesize:=8;
  1697. s80real:
  1698. savesize:=extended_size;
  1699. s64comp:
  1700. savesize:=8;
  1701. else
  1702. savesize:=0;
  1703. end;
  1704. end;
  1705. procedure Tfloatdef.store(var s:Tstream);
  1706. begin
  1707. inherited store(s);
  1708. (* writebyte(byte(typ));
  1709. current_ppu^.writeentry(ibfloatdef);*)
  1710. end;
  1711. procedure Tfloatdef.write_rtti_data;
  1712. const translate:array[Tfloattype] of byte=
  1713. (ftsingle,ftdouble,ftextended,ftcomp,ftfixed16,ftfixed32);
  1714. begin
  1715. rttilist^.concat(new(Pai_const,init_8bit(tkfloat)));
  1716. write_rtti_name;
  1717. rttilist^.concat(new(Pai_const,init_8bit(translate[typ])));
  1718. end;
  1719. function Tfloatdef.is_publishable:boolean;
  1720. begin
  1721. is_publishable:=true;
  1722. end;
  1723. function Tfloatdef.gettypename:string;
  1724. const names:array[Tfloattype] of string[20]=(
  1725. 'single','double','extended','comp','fixed','shortfixed');
  1726. begin
  1727. gettypename:=names[typ];
  1728. end;
  1729. {***************************************************************************
  1730. Tsetdef
  1731. ***************************************************************************}
  1732. { For i386 smallsets work,
  1733. for m68k there are problems
  1734. can be test by compiling with -dusesmallset PM }
  1735. {$ifdef i386}
  1736. {$define usesmallset}
  1737. {$endif i386}
  1738. constructor Tsetdef.init(s:Pdef;high:longint;Aowner:Pcontainingsymtable);
  1739. begin
  1740. inherited init(Aowner);
  1741. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1742. definition:=s;
  1743. if high<32 then
  1744. begin
  1745. settype:=smallset;
  1746. savesize:=4;
  1747. include(properties,dp_ret_in_acc);
  1748. end
  1749. else if high<256 then
  1750. begin
  1751. settype:=normset;
  1752. savesize:=32;
  1753. end
  1754. {$ifdef testvarsets}
  1755. else if high<$10000 then
  1756. begin
  1757. settype:=varset;
  1758. savesize:=4*((high+31) div 32);
  1759. end
  1760. {$endif testvarsets}
  1761. else
  1762. message(sym_e_ill_type_decl_set);
  1763. end;
  1764. constructor Tsetdef.load(var s:Tstream);
  1765. begin
  1766. inherited load(s);
  1767. (* setof:=readdefref;
  1768. settype:=tsettype(readbyte);
  1769. case settype of
  1770. normset:
  1771. savesize:=32;
  1772. varset:
  1773. savesize:=readlong;
  1774. smallset:
  1775. savesize:=sizeof(longint);
  1776. end;*)
  1777. end;
  1778. procedure Tsetdef.store(var s:Tstream);
  1779. begin
  1780. inherited store(s);
  1781. (* writedefref(setof);
  1782. writebyte(byte(settype));
  1783. if settype=varset then
  1784. writelong(savesize);
  1785. current_ppu^.writeentry(ibsetdef);*)
  1786. end;
  1787. procedure Tsetdef.deref;
  1788. begin
  1789. { resolvedef(setof);}
  1790. end;
  1791. procedure Tsetdef.write_rtti_data;
  1792. begin
  1793. rttilist^.concat(new(pai_const,init_8bit(tkset)));
  1794. write_rtti_name;
  1795. rttilist^.concat(new(pai_const,init_8bit(otuLong)));
  1796. rttilist^.concat(new(pai_const_symbol,initname(definition^.get_rtti_label)));
  1797. end;
  1798. procedure Tsetdef.write_child_rtti_data;
  1799. begin
  1800. definition^.get_rtti_label;
  1801. end;
  1802. function Tsetdef.is_publishable:boolean;
  1803. begin
  1804. is_publishable:=settype=smallset;
  1805. end;
  1806. function Tsetdef.gettypename:string;
  1807. begin
  1808. gettypename:='set of '+definition^.typename;
  1809. end;
  1810. {***************************************************************************
  1811. Trecorddef
  1812. ***************************************************************************}
  1813. constructor Trecorddef.init(s:Precordsymtable;Aowner:Pcontainingsymtable);
  1814. begin
  1815. inherited init(Aowner);
  1816. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1817. symtable:=s;
  1818. savesize:=symtable^.datasize;
  1819. end;
  1820. constructor Trecorddef.load(var s:Tstream);
  1821. var oldread_member:boolean;
  1822. begin
  1823. (* inherited load(s);
  1824. savesize:=readlong;
  1825. oldread_member:=read_member;
  1826. read_member:=true;
  1827. symtable:=new(psymtable,loadas(recordsymtable));
  1828. read_member:=oldread_member;
  1829. symtable^.defowner := @self;*)
  1830. end;
  1831. destructor Trecorddef.done;
  1832. begin
  1833. if symtable<>nil then
  1834. dispose(symtable,done);
  1835. inherited done;
  1836. end;
  1837. var
  1838. binittable : boolean;
  1839. procedure check_rec_inittable(s:Pnamedindexobject);
  1840. begin
  1841. if (typeof(s^)=typeof(Tvarsym)) and
  1842. ((typeof((Pvarsym(s)^.definition^))<>typeof(Tobjectdef)) or
  1843. not (oo_is_class in Pobjectdef(Pvarsym(s)^.definition)^.options)) then
  1844. binittable:=pvarsym(s)^.definition^.needs_inittable;
  1845. end;
  1846. function Trecorddef.needs_inittable:boolean;
  1847. var oldb:boolean;
  1848. begin
  1849. { there are recursive calls to needs_rtti possible, }
  1850. { so we have to change to old value how else should }
  1851. { we do that ? check_rec_rtti can't be a nested }
  1852. { procedure of needs_rtti ! }
  1853. oldb:=binittable;
  1854. binittable:=false;
  1855. symtable^.foreach({$ifndef TP}@{$endif}check_rec_inittable);
  1856. needs_inittable:=binittable;
  1857. binittable:=oldb;
  1858. end;
  1859. procedure Trecorddef.deref;
  1860. var oldrecsyms:Psymtable;
  1861. begin
  1862. (* oldrecsyms:=aktrecordsymtable;
  1863. aktrecordsymtable:=symtable;
  1864. { now dereference the definitions }
  1865. symtable^.deref;
  1866. aktrecordsymtable:=oldrecsyms;*)
  1867. end;
  1868. procedure Trecorddef.store(var s:Tstream);
  1869. var oldread_member:boolean;
  1870. begin
  1871. (* oldread_member:=read_member;
  1872. read_member:=true;
  1873. inherited store(s);
  1874. writelong(savesize);
  1875. current_ppu^.writeentry(ibrecorddef);
  1876. self.symtable^.writeas;
  1877. read_member:=oldread_member;*)
  1878. end;
  1879. procedure count_inittable_fields(sym:Pnamedindexobject);
  1880. {$ifndef fpc}far;{$endif}
  1881. begin
  1882. if (typeof(sym^)=typeof(Tvarsym)) and
  1883. (Pvarsym(sym)^.definition^.needs_inittable) then
  1884. inc(count);
  1885. end;
  1886. procedure count_fields(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}
  1887. begin
  1888. inc(count);
  1889. end;
  1890. procedure write_field_inittable(sym:Pnamedindexobject);
  1891. {$ifndef fpc}far;{$endif}
  1892. begin
  1893. if (typeof(sym^)=typeof(Tvarsym)) and
  1894. Pvarsym(sym)^.definition^.needs_inittable then
  1895. begin
  1896. rttilist^.concat(new(Pai_const_symbol,
  1897. init(pvarsym(sym)^.definition^.get_inittable_label)));
  1898. rttilist^.concat(new(Pai_const,
  1899. init_32bit(pvarsym(sym)^.address)));
  1900. end;
  1901. end;
  1902. procedure write_field_rtti(sym:Pnamedindexobject);{$ifndef fpc}far;{$endif}
  1903. begin
  1904. rttilist^.concat(new(Pai_const_symbol,
  1905. initname(Pvarsym(sym)^.definition^.get_rtti_label)));
  1906. rttilist^.concat(new(Pai_const,
  1907. init_32bit(Pvarsym(sym)^.address)));
  1908. end;
  1909. procedure generate_child_inittable(sym:Pnamedindexobject);
  1910. {$ifndef fpc}far;{$endif}
  1911. begin
  1912. if (typeof(sym^)=typeof(Tvarsym)) and
  1913. Pvarsym(sym)^.definition^.needs_inittable then
  1914. {Force inittable generation }
  1915. Pvarsym(sym)^.definition^.get_inittable_label;
  1916. end;
  1917. procedure generate_child_rtti(sym:Pnamedindexobject);
  1918. {$ifndef fpc}far;{$endif}
  1919. begin
  1920. Pvarsym(sym)^.definition^.get_rtti_label;
  1921. end;
  1922. procedure Trecorddef.write_child_rtti_data;
  1923. begin
  1924. symtable^.foreach({$ifndef TP}@{$endif}generate_child_rtti);
  1925. end;
  1926. procedure Trecorddef.write_child_init_data;
  1927. begin
  1928. symtable^.foreach({$ifndef TP}@{$endif}generate_child_inittable);
  1929. end;
  1930. procedure Trecorddef.write_rtti_data;
  1931. begin
  1932. rttilist^.concat(new(pai_const,init_8bit(tkrecord)));
  1933. write_rtti_name;
  1934. rttilist^.concat(new(pai_const,init_32bit(size)));
  1935. count:=0;
  1936. symtable^.foreach({$ifndef TP}@{$endif}count_fields);
  1937. rttilist^.concat(new(pai_const,init_32bit(count)));
  1938. symtable^.foreach({$ifndef TP}@{$endif}write_field_rtti);
  1939. end;
  1940. procedure Trecorddef.write_init_data;
  1941. begin
  1942. rttilist^.concat(new(pai_const,init_8bit(14)));
  1943. write_rtti_name;
  1944. rttilist^.concat(new(pai_const,init_32bit(size)));
  1945. count:=0;
  1946. symtable^.foreach({$ifndef TP}@{$endif}count_inittable_fields);
  1947. rttilist^.concat(new(pai_const,init_32bit(count)));
  1948. symtable^.foreach({$ifndef TP}@{$endif}write_field_inittable);
  1949. end;
  1950. function Trecorddef.gettypename:string;
  1951. begin
  1952. gettypename:='<record type>'
  1953. end;
  1954. {***************************************************************************
  1955. Tstringprocdef
  1956. ***************************************************************************}
  1957. constructor Tstringdef.shortinit(l:byte;Aowner:Pcontainingsymtable);
  1958. begin
  1959. inherited init(Aowner);
  1960. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  1961. string_typ:=st_shortstring;
  1962. len:=l;
  1963. savesize:=len+1;
  1964. end;
  1965. constructor Tstringdef.shortload(var s:Tstream);
  1966. begin
  1967. inherited load(s);
  1968. string_typ:=st_shortstring;
  1969. { len:=readbyte;
  1970. savesize:=len+1;}
  1971. end;
  1972. constructor Tstringdef.longinit(l:longint;Aowner:Pcontainingsymtable);
  1973. begin
  1974. inherited init(Aowner);
  1975. string_typ:=st_longstring;
  1976. len:=l;
  1977. savesize:=target_os.size_of_pointer;
  1978. end;
  1979. constructor Tstringdef.longload(var s:Tstream);
  1980. begin
  1981. inherited load(s);
  1982. string_typ:=st_longstring;
  1983. { len:=readlong;
  1984. savesize:=target_os.size_of_pointer;}
  1985. end;
  1986. constructor tstringdef.ansiinit(l:longint;Aowner:Pcontainingsymtable);
  1987. begin
  1988. inherited init(Aowner);
  1989. include(properties,dp_ret_in_acc);
  1990. string_typ:=st_ansistring;
  1991. len:=l;
  1992. savesize:=target_os.size_of_pointer;
  1993. end;
  1994. constructor Tstringdef.ansiload(var s:Tstream);
  1995. begin
  1996. inherited load(s);
  1997. string_typ:=st_ansistring;
  1998. { len:=readlong;
  1999. savesize:=target_os.size_of_pointer;}
  2000. end;
  2001. constructor Tstringdef.wideinit(l:longint;Aowner:Pcontainingsymtable);
  2002. begin
  2003. inherited init(Aowner);
  2004. include(properties,dp_ret_in_acc);
  2005. string_typ:=st_widestring;
  2006. len:=l;
  2007. savesize:=target_os.size_of_pointer;
  2008. end;
  2009. constructor Tstringdef.wideload(var s:Tstream);
  2010. begin
  2011. inherited load(s);
  2012. string_typ:=st_widestring;
  2013. { len:=readlong;
  2014. savesize:=target_os.size_of_pointer;}
  2015. end;
  2016. function Tstringdef.stringtypname:string;
  2017. const typname:array[tstringtype] of string[8]=
  2018. ('','SHORTSTR','LONGSTR','ANSISTR','WIDESTR');
  2019. begin
  2020. stringtypname:=typname[string_typ];
  2021. end;
  2022. function tstringdef.size:longint;
  2023. begin
  2024. size:=savesize;
  2025. end;
  2026. procedure Tstringdef.store(var s:Tstream);
  2027. begin
  2028. inherited store(s);
  2029. { if string_typ=st_shortstring then
  2030. writebyte(len)
  2031. else
  2032. writelong(len);
  2033. case string_typ of
  2034. st_shortstring:
  2035. current_ppu^.writeentry(ibshortstringdef);
  2036. st_longstring:
  2037. current_ppu^.writeentry(iblongstringdef);
  2038. st_ansistring:
  2039. current_ppu^.writeentry(ibansistringdef);
  2040. st_widestring:
  2041. current_ppu^.writeentry(ibwidestringdef);
  2042. end;}
  2043. end;
  2044. {$ifdef GDB}
  2045. function tstringdef.stabstring : pchar;
  2046. var
  2047. bytest,charst,longst : string;
  2048. begin
  2049. case string_typ of
  2050. st_shortstring:
  2051. begin
  2052. charst := typeglobalnumber('char');
  2053. { this is what I found in stabs.texinfo but
  2054. gdb 4.12 for go32 doesn't understand that !! }
  2055. {$IfDef GDBknowsstrings}
  2056. stabstring := strpnew('n'+charst+';'+tostr(len));
  2057. {$else}
  2058. bytest := typeglobalnumber('byte');
  2059. stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
  2060. +',0,8;st:ar'+bytest
  2061. +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
  2062. {$EndIf}
  2063. end;
  2064. st_longstring:
  2065. begin
  2066. charst := typeglobalnumber('char');
  2067. { this is what I found in stabs.texinfo but
  2068. gdb 4.12 for go32 doesn't understand that !! }
  2069. {$IfDef GDBknowsstrings}
  2070. stabstring := strpnew('n'+charst+';'+tostr(len));
  2071. {$else}
  2072. bytest := typeglobalnumber('byte');
  2073. longst := typeglobalnumber('longint');
  2074. stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
  2075. +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
  2076. +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
  2077. {$EndIf}
  2078. end;
  2079. st_ansistring:
  2080. begin
  2081. { an ansi string looks like a pchar easy !! }
  2082. stabstring:=strpnew('*'+typeglobalnumber('char'));
  2083. end;
  2084. st_widestring:
  2085. begin
  2086. { an ansi string looks like a pchar easy !! }
  2087. stabstring:=strpnew('*'+typeglobalnumber('char'));
  2088. end;
  2089. end;
  2090. end;
  2091. procedure tstringdef.concatstabto(asmlist : paasmoutput);
  2092. begin
  2093. inherited concatstabto(asmlist);
  2094. end;
  2095. {$endif GDB}
  2096. function tstringdef.needs_inittable : boolean;
  2097. begin
  2098. needs_inittable:=string_typ in [st_ansistring,st_widestring];
  2099. end;
  2100. function tstringdef.gettypename : string;
  2101. const
  2102. names : array[tstringtype] of string[20] = ('',
  2103. 'ShortString','LongString','AnsiString','WideString');
  2104. begin
  2105. gettypename:=names[string_typ];
  2106. end;
  2107. procedure tstringdef.write_rtti_data;
  2108. begin
  2109. case string_typ of
  2110. st_ansistring:
  2111. begin
  2112. rttilist^.concat(new(pai_const,init_8bit(tkAString)));
  2113. write_rtti_name;
  2114. end;
  2115. st_widestring:
  2116. begin
  2117. rttilist^.concat(new(pai_const,init_8bit(tkWString)));
  2118. write_rtti_name;
  2119. end;
  2120. st_longstring:
  2121. begin
  2122. rttilist^.concat(new(pai_const,init_8bit(tkLString)));
  2123. write_rtti_name;
  2124. end;
  2125. st_shortstring:
  2126. begin
  2127. rttilist^.concat(new(pai_const,init_8bit(tkSString)));
  2128. write_rtti_name;
  2129. rttilist^.concat(new(pai_const,init_8bit(len)));
  2130. end;
  2131. end;
  2132. end;
  2133. function tstringdef.is_publishable : boolean;
  2134. begin
  2135. is_publishable:=true;
  2136. end;
  2137. {***************************************************************************
  2138. Tabstractprocdef
  2139. ***************************************************************************}
  2140. constructor Tabstractprocdef.init(Aowner:Pcontainingsymtable);
  2141. begin
  2142. inherited init(Aowner);
  2143. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  2144. include(properties,dp_ret_in_acc);
  2145. retdef:=voiddef;
  2146. savesize:=target_os.size_of_pointer;
  2147. end;
  2148. constructor Tabstractprocdef.load(var s:Tstream);
  2149. var count,i:word;
  2150. begin
  2151. inherited load(s);
  2152. (* retdef:=readdefref;
  2153. fpu_used:=readbyte;
  2154. options:=readlong;
  2155. count:=readword;
  2156. new(parameters);
  2157. savesize:=target_os.size_of_pointer;
  2158. for i:=1 to count do
  2159. parameters^.readsymref;*)
  2160. end;
  2161. { all functions returning in FPU are
  2162. assume to use 2 FPU registers
  2163. until the function implementation
  2164. is processed PM }
  2165. procedure Tabstractprocdef.test_if_fpu_result;
  2166. begin
  2167. if (retdef<>nil) and (typeof(retdef^)=typeof(Tfloatdef)) and
  2168. (Pfloatdef(retdef)^.typ in [f32bit,f16bit]) then
  2169. fpu_used:=2;
  2170. end;
  2171. procedure Tabstractprocdef.deref;
  2172. var i:longint;
  2173. begin
  2174. inherited deref;
  2175. { resolvedef(retdef);}
  2176. for i:=0 to parameters^.count-1 do
  2177. Psym(parameters^.at(i))^.deref;
  2178. end;
  2179. function Tabstractprocdef.para_size:longint;
  2180. var i,l:longint;
  2181. begin
  2182. l:=0;
  2183. for i:=0 to parameters^.count-1 do
  2184. inc(l,Pparamsym(parameters^.at(i))^.getpushsize);
  2185. para_size:=l;
  2186. end;
  2187. procedure Tabstractprocdef.store(var s:Tstream);
  2188. var count,i:word;
  2189. begin
  2190. inherited store(s);
  2191. { writedefref(retdef);
  2192. current_ppu^.do_interface_crc:=false;
  2193. writebyte(fpu_used);
  2194. writelong(options);
  2195. writeword(parameters^.count);
  2196. for i:=0 to parameters^.count-1 do
  2197. begin
  2198. writebyte(byte(hp^.paratyp));
  2199. writesymfref(hp^.data);
  2200. end;}
  2201. end;
  2202. function Tabstractprocdef.demangled_paras:string;
  2203. var i:longint;
  2204. s:string;
  2205. procedure doconcat(p:Pparameter);
  2206. begin
  2207. s:=s+p^.data^.name;
  2208. if p^.paratyp=vs_var then
  2209. s:=s+'var'
  2210. else if p^.paratyp=vs_const then
  2211. s:=s+'const';
  2212. end;
  2213. begin
  2214. s:='(';
  2215. for i:=0 to parameters^.count-1 do
  2216. doconcat(parameters^.at(i));
  2217. s[length(s)]:=')';
  2218. demangled_paras:=s;
  2219. end;
  2220. destructor Tabstractprocdef.done;
  2221. begin
  2222. dispose(parameters,done);
  2223. inherited done;
  2224. end;
  2225. {***************************************************************************
  2226. TPROCDEF
  2227. ***************************************************************************}
  2228. constructor Tprocdef.init(Aowner:Pcontainingsymtable);
  2229. begin
  2230. inherited init(Aowner);
  2231. {$IFDEF TP}setparent(typeof(Tabstractprocdef));{$ENDIF}
  2232. fileinfo:=aktfilepos;
  2233. vmt_index:=-1;
  2234. new(localst,init);
  2235. if (cs_browser in aktmoduleswitches) and make_ref then
  2236. begin
  2237. new(references,init(2*owner^.index_growsize,
  2238. owner^.index_growsize));
  2239. references^.insert(new(Pref,init(tokenpos)));
  2240. end;
  2241. {First, we assume that all registers are used }
  2242. usedregisters:=[low(Tregister)..high(Tregister)];
  2243. forwarddef:=true;
  2244. end;
  2245. constructor Tprocdef.load(var s:Tstream);
  2246. var a:string;
  2247. begin
  2248. inherited load(s);
  2249. (* usedregisters:=readlong;
  2250. a:=readstring;
  2251. setstring(_mangledname,s);
  2252. extnumber:=readlong;
  2253. nextoerloaded:=pprocdef(readdefref);
  2254. _class := pobjectdef(readdefref);
  2255. readposinfo(fileinfo);
  2256. if (cs_link_deffile in aktglobalswitches)
  2257. and (poexports in options) then
  2258. deffile.ddexport(mangledname);
  2259. count:=true;*)
  2260. end;
  2261. const local_symtable_index : longint = $8001;
  2262. procedure tprocdef.load_references;
  2263. var pos:Tfileposinfo;
  2264. pdo:Pobjectdef;
  2265. move_last:boolean;
  2266. begin
  2267. (* move_last:=lastwritten=lastref;
  2268. while (not current_ppu^.endofentry) do
  2269. begin
  2270. readposinfo(pos);
  2271. inc(refcount);
  2272. lastref:=new(pref,init(lastref,@pos));
  2273. lastref^.is_written:=true;
  2274. if refcount=1 then
  2275. defref:=lastref;
  2276. end;
  2277. if move_last then
  2278. lastwritten:=lastref;
  2279. if ((current_module^.flags and uf_local_browser)<>0)
  2280. and is_in_current then
  2281. begin
  2282. {$ifndef NOLOCALBROWSER}
  2283. pdo:=_class;
  2284. new(parast,loadas(parasymtable));
  2285. parast^.next:=owner;
  2286. parast^.load_browser;
  2287. new(localst,loadas(localsymtable));
  2288. localst^.next:=parast;
  2289. localst^.load_browser;
  2290. {$endif NOLOCALBROWSER}
  2291. end;*)
  2292. end;
  2293. function Tprocdef.write_references:boolean;
  2294. var ref:Pref;
  2295. pdo:Pobjectdef;
  2296. move_last:boolean;
  2297. begin
  2298. (* move_last:=lastwritten=lastref;
  2299. if move_last and (((current_module^.flags and uf_local_browser)=0)
  2300. or not is_in_current) then
  2301. exit;
  2302. {Write address of this symbol }
  2303. writedefref(@self);
  2304. {Write refs }
  2305. if assigned(lastwritten) then
  2306. ref:=lastwritten
  2307. else
  2308. ref:=defref;
  2309. while assigned(ref) do
  2310. begin
  2311. if ref^.moduleindex=current_module^.unit_index then
  2312. begin
  2313. writeposinfo(ref^.posinfo);
  2314. ref^.is_written:=true;
  2315. if move_last then
  2316. lastwritten:=ref;
  2317. end
  2318. else if not ref^.is_written then
  2319. move_last:=false
  2320. else if move_last then
  2321. lastwritten:=ref;
  2322. ref:=ref^.nextref;
  2323. end;
  2324. current_ppu^.writeentry(ibdefref);
  2325. write_references:=true;
  2326. if ((current_module^.flags and uf_local_browser)<>0)
  2327. and is_in_current then
  2328. begin
  2329. pdo:=_class;
  2330. if (owner^.symtabletype<>localsymtable) then
  2331. while assigned(pdo) do
  2332. begin
  2333. if pdo^.publicsyms<>aktrecordsymtable then
  2334. begin
  2335. pdo^.publicsyms^.unitid:=local_symtable_index;
  2336. inc(local_symtable_index);
  2337. end;
  2338. pdo:=pdo^.childof;
  2339. end;
  2340. {We need TESTLOCALBROWSER para and local symtables
  2341. PPU files are then easier to read PM.}
  2342. inc(local_symtable_index);
  2343. parast^.write_browser;
  2344. if not assigned(localst) then
  2345. localst:=new(psymtable,init);
  2346. localst^.writeas;
  2347. localst^.unitid:=local_symtable_index;
  2348. inc(local_symtable_index);
  2349. localst^.write_browser;
  2350. {Decrement for.}
  2351. local_symtable_index:=local_symtable_index-2;
  2352. pdo:=_class;
  2353. if (owner^.symtabletype<>localsymtable) then
  2354. while assigned(pdo) do
  2355. begin
  2356. if pdo^.publicsyms<>aktrecordsymtable then
  2357. dec(local_symtable_index);
  2358. pdo:=pdo^.childof;
  2359. end;
  2360. end;*)
  2361. end;
  2362. destructor Tprocdef.done;
  2363. begin
  2364. if po_msgstr in options then
  2365. strdispose(messageinf.str);
  2366. if references<>nil then
  2367. dispose(references,done);
  2368. if (localst<>nil) and (typeof(localst^)<>typeof(Timplsymtable)) then
  2369. dispose(localst,done);
  2370. { if (poinline in options) and (code,nil) then
  2371. disposetree(ptree(code));}
  2372. if _mangledname<>nil then
  2373. disposestr(_mangledname);
  2374. inherited done;
  2375. end;
  2376. procedure Tprocdef.store(var s:Tstream);
  2377. begin
  2378. (* inherited store(s);
  2379. current_ppu^.do_interface_crc:=false;
  2380. writelong(usedregisters);
  2381. writestring(mangledname);
  2382. current_ppu^.do_interface_crc:=true;
  2383. writelong(extnumber);
  2384. if (options and pooperator) = 0 then
  2385. writedefref(nextoverloaded)
  2386. else
  2387. begin
  2388. {Only write the overloads from the same unit }
  2389. if assigned(nextoverloaded) and
  2390. (nextoverloaded^.owner=owner) then
  2391. writedefref(nextoverloaded)
  2392. else
  2393. writedefref(nil);
  2394. end;
  2395. writedefref(_class);
  2396. writeposinfo(fileinfo);
  2397. if (poinline and options) then
  2398. begin
  2399. {We need to save
  2400. - the para and the local symtable
  2401. - the code ptree !! PM
  2402. writesymtable(parast);
  2403. writesymtable(localst);
  2404. writeptree(ptree(code));
  2405. }
  2406. end;
  2407. current_ppu^.writeentry(ibprocdef);*)
  2408. end;
  2409. procedure Tprocdef.deref;
  2410. begin
  2411. { inherited deref;
  2412. resolvedef(pdef(nextoverloaded));
  2413. resolvedef(pdef(_class));}
  2414. end;
  2415. function Tprocdef.mangledname:string;
  2416. var i:word;
  2417. a:byte;
  2418. s:Pprocsym;
  2419. r:string;
  2420. begin
  2421. if _mangledname<>nil then
  2422. mangledname:=_mangledname^
  2423. else
  2424. begin
  2425. {If the procedure is in a unit, we start with the unitname.}
  2426. if current_module^.is_unit then
  2427. r:='_'+current_module^.modulename^
  2428. else
  2429. r:='';
  2430. a:=length(r);
  2431. {If we are a method we add the name of the object we are
  2432. belonging to.}
  2433. if (Pprocsym(sym)^._class<>nil) then
  2434. r:=r+'_M'+Pprocsym(sym)^._class^.sym^.name+'_M';
  2435. {Then we add the names of the procedures we are defined in
  2436. (for the case we are a nested procedure).}
  2437. s:=Pprocsym(sym)^.sub_of;
  2438. while typeof(s^.owner^)=typeof(Tprocsymtable) do
  2439. begin
  2440. insert('_$'+s^.name,r,a);
  2441. s:=s^.sub_of;
  2442. end;
  2443. r:=r+'_'+sym^.name;
  2444. {Add the types of all parameters.}
  2445. for i:=0 to parameters^.count-1 do
  2446. begin
  2447. r:=r+'$'+Pparameter(parameters^.at(i))^.data^.name;
  2448. end;
  2449. end;
  2450. end;
  2451. procedure Tprocdef.setmangledname(const s:string);
  2452. begin
  2453. if _mangledname<>nil then
  2454. disposestr(_mangledname);
  2455. _mangledname:=stringdup(s);
  2456. if localst<>nil then
  2457. begin
  2458. stringdispose(localst^.name);
  2459. localst^.name:=stringdup('locals of '+s);
  2460. end;
  2461. end;
  2462. {***************************************************************************
  2463. Tprocvardef
  2464. ***************************************************************************}
  2465. {$IFDEF TP}
  2466. constructor Tprocvardef.init(Aowner:Pcontainingsymtable);
  2467. begin
  2468. setparent(typeof(Tabstractprocdef));
  2469. end;
  2470. {$ENDIF TP}
  2471. function Tprocvardef.size:longint;
  2472. begin
  2473. if po_methodpointer in options then
  2474. size:=2*target_os.size_of_pointer
  2475. else
  2476. size:=target_os.size_of_pointer;
  2477. end;
  2478. {$ifdef GDB}
  2479. function tprocvardef.stabstring : pchar;
  2480. var
  2481. nss : pchar;
  2482. i : word;
  2483. param : pdefcoll;
  2484. begin
  2485. i := 0;
  2486. param := para1;
  2487. while assigned(param) do
  2488. begin
  2489. inc(i);
  2490. param := param^.next;
  2491. end;
  2492. getmem(nss,1024);
  2493. { it is not a function but a function pointer !! (PM) }
  2494. strpcopy(nss,'*f'+retdef^.numberstring{+','+tostr(i)}+';');
  2495. param := para1;
  2496. i := 0;
  2497. { this confuses gdb !!
  2498. we should use 'F' instead of 'f' but
  2499. as we use c++ language mode
  2500. it does not like that either
  2501. Please do not remove this part
  2502. might be used once
  2503. gdb for pascal is ready PM }
  2504. (* while assigned(param) do
  2505. begin
  2506. inc(i);
  2507. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  2508. {Here we have lost the parameter names !!}
  2509. pst := strpnew('p'+tostr(i)+':'+param^.data^.numberstring+','+vartyp+';');
  2510. strcat(nss,pst);
  2511. strdispose(pst);
  2512. param := param^.next;
  2513. end; *)
  2514. {strpcopy(strend(nss),';');}
  2515. stabstring := strnew(nss);
  2516. freemem(nss,1024);
  2517. end;
  2518. procedure tprocvardef.concatstabto(asmlist : paasmoutput);
  2519. begin
  2520. if ( not assigned(sym) or sym^.isusedinstab or (cs_gdb_dbx in aktglobalswitches))
  2521. and not is_def_stab_written then
  2522. inherited concatstabto(asmlist);
  2523. is_def_stab_written:=true;
  2524. end;
  2525. {$endif GDB}
  2526. procedure Tprocvardef.write_rtti_data;
  2527. begin
  2528. {!!!!!!!}
  2529. end;
  2530. procedure Tprocvardef.write_child_rtti_data;
  2531. begin
  2532. {!!!!!!!!}
  2533. end;
  2534. function Tprocvardef.is_publishable:boolean;
  2535. begin
  2536. is_publishable:=po_methodpointer in options;
  2537. end;
  2538. function Tprocvardef.gettypename:string;
  2539. begin
  2540. gettypename:='<procedure variable type>'
  2541. end;
  2542. {****************************************************************************
  2543. Tforwarddef
  2544. ****************************************************************************}
  2545. constructor tforwarddef.init(Aowner:Pcontainingsymtable;
  2546. const s:string;const pos:Tfileposinfo);
  2547. var oldregisterdef:boolean;
  2548. begin
  2549. { never register the forwarddefs, they are disposed at the
  2550. end of the type declaration block }
  2551. { oldregisterdef:=registerdef;
  2552. registerdef:=false;}
  2553. inherited init(Aowner);
  2554. {$IFDEF TP}setparent(typeof(Tdef));{$ENDIF}
  2555. { registerdef:=oldregisterdef;}
  2556. tosymname:=s;
  2557. forwardpos:=pos;
  2558. end;
  2559. function tforwarddef.gettypename:string;
  2560. begin
  2561. gettypename:='unresolved forward to '+tosymname;
  2562. end;
  2563. end.
  2564. {
  2565. $Log$
  2566. Revision 1.2 2002-05-16 19:46:52 carl
  2567. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  2568. + try to fix temp allocation (still in ifdef)
  2569. + generic constructor calls
  2570. + start of tassembler / tmodulebase class cleanup
  2571. Revision 1.1 2000/07/13 06:30:13 michael
  2572. + Initial import
  2573. Revision 1.6 2000/03/16 12:52:47 daniel
  2574. * Changed names of procedures flags
  2575. * Changed VMT generation
  2576. Revision 1.5 2000/03/11 21:11:24 daniel
  2577. * Ported hcgdata to new symtable.
  2578. * Alignment code changed as suggested by Peter
  2579. + Usage of my is operator replacement, is_object
  2580. Revision 1.4 2000/03/01 11:43:55 daniel
  2581. * Some more work on the new symtable.
  2582. + Symtable stack unit 'symstack' added.
  2583. }