symdef.pas 126 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307
  1. {
  2. Symbol table implementation for the definitions
  3. Copyright (c) 1998-2005 by Florian Klaempfl, Pierre Muller
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit symdef;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. { common }
  22. cclasses,
  23. { global }
  24. globtype,globals,tokens,
  25. { symtable }
  26. symconst,symbase,symtype,
  27. { ppu }
  28. ppu,
  29. { node }
  30. node,
  31. { aasm }
  32. aasmbase,aasmtai,aasmdata,
  33. cpubase,cpuinfo,
  34. cgbase,cgutils,
  35. parabase
  36. ;
  37. type
  38. {************************************************
  39. TDef
  40. ************************************************}
  41. { tstoreddef }
  42. tstoreddef = class(tdef)
  43. protected
  44. typesymderef : tderef;
  45. public
  46. {$ifdef EXTDEBUG}
  47. fileinfo : tfileposinfo;
  48. {$endif}
  49. { generic support }
  50. genericdef : tstoreddef;
  51. genericdefderef : tderef;
  52. generictokenbuf : tdynamicarray;
  53. constructor create(dt:tdeftyp);
  54. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  55. destructor destroy;override;
  56. procedure FreeInstance;override;
  57. procedure reset;virtual;
  58. function getcopy : tstoreddef;virtual;
  59. procedure ppuwrite(ppufile:tcompilerppufile);virtual;
  60. procedure buildderef;override;
  61. procedure buildderefimpl;override;
  62. procedure deref;override;
  63. procedure derefimpl;override;
  64. function size:aint;override;
  65. function getvardef:longint;override;
  66. function alignment:shortint;override;
  67. function is_publishable : boolean;override;
  68. function needs_inittable : boolean;override;
  69. function rtti_mangledname(rt:trttitype):string;override;
  70. { regvars }
  71. function is_intregable : boolean;
  72. function is_fpuregable : boolean;
  73. { generics }
  74. procedure initgeneric;
  75. private
  76. savesize : aint;
  77. end;
  78. tfiletyp = (ft_text,ft_typed,ft_untyped);
  79. tfiledef = class(tstoreddef)
  80. filetyp : tfiletyp;
  81. typedfiledef : tdef;
  82. typedfiledefderef : tderef;
  83. constructor createtext;
  84. constructor createuntyped;
  85. constructor createtyped(def : tdef);
  86. constructor ppuload(ppufile:tcompilerppufile);
  87. function getcopy : tstoreddef;override;
  88. procedure ppuwrite(ppufile:tcompilerppufile);override;
  89. procedure buildderef;override;
  90. procedure deref;override;
  91. function GetTypeName:string;override;
  92. function getmangledparaname:string;override;
  93. procedure setsize;
  94. end;
  95. tvariantdef = class(tstoreddef)
  96. varianttype : tvarianttype;
  97. constructor create(v : tvarianttype);
  98. constructor ppuload(ppufile:tcompilerppufile);
  99. function getcopy : tstoreddef;override;
  100. function GetTypeName:string;override;
  101. procedure ppuwrite(ppufile:tcompilerppufile);override;
  102. procedure setsize;
  103. function is_publishable : boolean;override;
  104. function needs_inittable : boolean;override;
  105. end;
  106. tformaldef = class(tstoreddef)
  107. constructor create;
  108. constructor ppuload(ppufile:tcompilerppufile);
  109. procedure ppuwrite(ppufile:tcompilerppufile);override;
  110. function GetTypeName:string;override;
  111. end;
  112. tforwarddef = class(tstoreddef)
  113. tosymname : pshortstring;
  114. forwardpos : tfileposinfo;
  115. constructor create(const s:string;const pos : tfileposinfo);
  116. destructor destroy;override;
  117. function GetTypeName:string;override;
  118. end;
  119. tundefineddef = class(tstoreddef)
  120. constructor create;
  121. constructor ppuload(ppufile:tcompilerppufile);
  122. procedure ppuwrite(ppufile:tcompilerppufile);override;
  123. function GetTypeName:string;override;
  124. end;
  125. terrordef = class(tstoreddef)
  126. constructor create;
  127. procedure ppuwrite(ppufile:tcompilerppufile);override;
  128. function GetTypeName:string;override;
  129. function getmangledparaname : string;override;
  130. end;
  131. tabstractpointerdef = class(tstoreddef)
  132. pointeddef : tdef;
  133. pointeddefderef : tderef;
  134. constructor create(dt:tdeftyp;def:tdef);
  135. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  136. procedure ppuwrite(ppufile:tcompilerppufile);override;
  137. procedure buildderef;override;
  138. procedure deref;override;
  139. end;
  140. tpointerdef = class(tabstractpointerdef)
  141. is_far : boolean;
  142. constructor create(def:tdef);
  143. constructor createfar(def:tdef);
  144. function getcopy : tstoreddef;override;
  145. constructor ppuload(ppufile:tcompilerppufile);
  146. procedure ppuwrite(ppufile:tcompilerppufile);override;
  147. function GetTypeName:string;override;
  148. end;
  149. tabstractrecorddef= class(tstoreddef)
  150. symtable : TSymtable;
  151. procedure reset;override;
  152. function GetSymtable(t:tGetSymtable):TSymtable;override;
  153. function is_packed:boolean;
  154. end;
  155. trecorddef = class(tabstractrecorddef)
  156. public
  157. isunion : boolean;
  158. constructor create(p : TSymtable);
  159. constructor ppuload(ppufile:tcompilerppufile);
  160. destructor destroy;override;
  161. function getcopy : tstoreddef;override;
  162. procedure ppuwrite(ppufile:tcompilerppufile);override;
  163. procedure buildderef;override;
  164. procedure deref;override;
  165. function size:aint;override;
  166. function alignment : shortint;override;
  167. function padalignment: shortint;
  168. function GetTypeName:string;override;
  169. { debug }
  170. function needs_inittable : boolean;override;
  171. end;
  172. tprocdef = class;
  173. tobjectdef = class;
  174. { TImplementedInterface }
  175. TImplementedInterface = class
  176. IntfDef : tobjectdef;
  177. IntfDefDeref : tderef;
  178. IOffset : longint;
  179. VtblImplIntf : TImplementedInterface;
  180. NameMappings : TFPHashList;
  181. ProcDefs : TFPObjectList;
  182. constructor create(aintf: tobjectdef);
  183. constructor create_deref(d:tderef);
  184. destructor destroy; override;
  185. function getcopy:TImplementedInterface;
  186. procedure buildderef;
  187. procedure deref;
  188. procedure AddMapping(const origname, newname: string);
  189. function GetMapping(const origname: string):string;
  190. procedure AddImplProc(pd:tprocdef);
  191. function IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  192. end;
  193. { tobjectdef }
  194. tobjectdef = class(tabstractrecorddef)
  195. public
  196. childof : tobjectdef;
  197. childofderef : tderef;
  198. objname,
  199. objrealname : pshortstring;
  200. objectoptions : tobjectoptions;
  201. { to be able to have a variable vmt position }
  202. { and no vmt field for objects without virtuals }
  203. vmt_offset : longint;
  204. writing_class_record_dbginfo : boolean;
  205. objecttype : tobjecttyp;
  206. iidguid : pguid;
  207. iidstr : pshortstring;
  208. iitype : tinterfaceentrytype;
  209. iioffset : longint;
  210. lastvtableindex: longint;
  211. { store implemented interfaces defs and name mappings }
  212. ImplementedInterfaces : TFPObjectList;
  213. constructor create(ot : tobjecttyp;const n : string;c : tobjectdef);
  214. constructor ppuload(ppufile:tcompilerppufile);
  215. destructor destroy;override;
  216. function getcopy : tstoreddef;override;
  217. procedure ppuwrite(ppufile:tcompilerppufile);override;
  218. function GetTypeName:string;override;
  219. procedure buildderef;override;
  220. procedure deref;override;
  221. function getparentdef:tdef;override;
  222. function size : aint;override;
  223. function alignment:shortint;override;
  224. function vmtmethodoffset(index:longint):longint;
  225. function members_need_inittable : boolean;
  226. function find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  227. { this should be called when this class implements an interface }
  228. procedure prepareguid;
  229. function is_publishable : boolean;override;
  230. function needs_inittable : boolean;override;
  231. function vmt_mangledname : string;
  232. procedure check_forwards;
  233. function is_related(d : tdef) : boolean;override;
  234. procedure insertvmt;
  235. procedure set_parent(c : tobjectdef);
  236. function FindDestructor : tprocdef;
  237. end;
  238. tclassrefdef = class(tabstractpointerdef)
  239. constructor create(def:tdef);
  240. constructor ppuload(ppufile:tcompilerppufile);
  241. procedure ppuwrite(ppufile:tcompilerppufile);override;
  242. function GetTypeName:string;override;
  243. function is_publishable : boolean;override;
  244. end;
  245. tarraydef = class(tstoreddef)
  246. lowrange,
  247. highrange : aint;
  248. rangedef : tdef;
  249. rangedefderef : tderef;
  250. arrayoptions : tarraydefoptions;
  251. protected
  252. _elementdef : tdef;
  253. _elementdefderef : tderef;
  254. procedure setelementdef(def:tdef);
  255. public
  256. function elesize : aint;
  257. function elepackedbitsize : aint;
  258. function elecount : aint;
  259. constructor create_from_pointer(def:tdef);
  260. constructor create(l,h : aint;def:tdef);
  261. constructor ppuload(ppufile:tcompilerppufile);
  262. function getcopy : tstoreddef;override;
  263. procedure ppuwrite(ppufile:tcompilerppufile);override;
  264. function GetTypeName:string;override;
  265. function getmangledparaname : string;override;
  266. procedure buildderef;override;
  267. procedure deref;override;
  268. function size : aint;override;
  269. function alignment : shortint;override;
  270. { returns the label of the range check string }
  271. function needs_inittable : boolean;override;
  272. property elementdef : tdef read _elementdef write setelementdef;
  273. end;
  274. torddef = class(tstoreddef)
  275. low,high : TConstExprInt;
  276. ordtype : tordtype;
  277. constructor create(t : tordtype;v,b : TConstExprInt);
  278. constructor ppuload(ppufile:tcompilerppufile);
  279. function getcopy : tstoreddef;override;
  280. procedure ppuwrite(ppufile:tcompilerppufile);override;
  281. function is_publishable : boolean;override;
  282. function GetTypeName:string;override;
  283. function alignment:shortint;override;
  284. procedure setsize;
  285. function packedbitsize: aint; override;
  286. function getvardef : longint;override;
  287. end;
  288. tfloatdef = class(tstoreddef)
  289. floattype : tfloattype;
  290. constructor create(t : tfloattype);
  291. constructor ppuload(ppufile:tcompilerppufile);
  292. function getcopy : tstoreddef;override;
  293. procedure ppuwrite(ppufile:tcompilerppufile);override;
  294. function GetTypeName:string;override;
  295. function is_publishable : boolean;override;
  296. function alignment:shortint;override;
  297. procedure setsize;
  298. function getvardef:longint;override;
  299. end;
  300. tabstractprocdef = class(tstoreddef)
  301. { saves a definition to the return type }
  302. returndef : tdef;
  303. returndefderef : tderef;
  304. parast : TSymtable;
  305. paras : tparalist;
  306. proctypeoption : tproctypeoption;
  307. proccalloption : tproccalloption;
  308. procoptions : tprocoptions;
  309. requiredargarea : aint;
  310. { number of user visibile parameters }
  311. maxparacount,
  312. minparacount : byte;
  313. {$ifdef i386}
  314. fpu_used : longint; { how many stack fpu must be empty }
  315. {$endif i386}
  316. {$ifdef m68k}
  317. exp_funcretloc : tregister; { explicit funcretloc for AmigaOS }
  318. {$endif}
  319. funcretloc : array[tcallercallee] of TLocation;
  320. has_paraloc_info : boolean; { paraloc info is available }
  321. constructor create(dt:tdeftyp;level:byte);
  322. constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  323. destructor destroy;override;
  324. procedure ppuwrite(ppufile:tcompilerppufile);override;
  325. procedure buildderef;override;
  326. procedure deref;override;
  327. procedure calcparas;
  328. function typename_paras(showhidden:boolean): string;
  329. procedure test_if_fpu_result;
  330. function is_methodpointer:boolean;virtual;
  331. function is_addressonly:boolean;virtual;
  332. private
  333. procedure count_para(p:TObject;arg:pointer);
  334. procedure insert_para(p:TObject;arg:pointer);
  335. end;
  336. tprocvardef = class(tabstractprocdef)
  337. constructor create(level:byte);
  338. constructor ppuload(ppufile:tcompilerppufile);
  339. function getcopy : tstoreddef;override;
  340. procedure ppuwrite(ppufile:tcompilerppufile);override;
  341. function GetSymtable(t:tGetSymtable):TSymtable;override;
  342. function size : aint;override;
  343. function GetTypeName:string;override;
  344. function is_publishable : boolean;override;
  345. function is_methodpointer:boolean;override;
  346. function is_addressonly:boolean;override;
  347. function getmangledparaname:string;override;
  348. end;
  349. tmessageinf = record
  350. case integer of
  351. 0 : (str : pshortstring);
  352. 1 : (i : longint);
  353. end;
  354. tinlininginfo = record
  355. { node tree }
  356. code : tnode;
  357. flags : tprocinfoflags;
  358. end;
  359. pinlininginfo = ^tinlininginfo;
  360. {$ifdef oldregvars}
  361. { register variables }
  362. pregvarinfo = ^tregvarinfo;
  363. tregvarinfo = record
  364. regvars : array[1..maxvarregs] of tsym;
  365. regvars_para : array[1..maxvarregs] of boolean;
  366. regvars_refs : array[1..maxvarregs] of longint;
  367. fpuregvars : array[1..maxfpuvarregs] of tsym;
  368. fpuregvars_para : array[1..maxfpuvarregs] of boolean;
  369. fpuregvars_refs : array[1..maxfpuvarregs] of longint;
  370. end;
  371. {$endif oldregvars}
  372. tprocdef = class(tabstractprocdef)
  373. private
  374. _mangledname : pshortstring;
  375. public
  376. extnumber : word;
  377. messageinf : tmessageinf;
  378. {$ifndef EXTDEBUG}
  379. { where is this function defined and what were the symbol
  380. flags, needed here because there
  381. is only one symbol for all overloaded functions
  382. EXTDEBUG has fileinfo in tdef (PFV) }
  383. fileinfo : tfileposinfo;
  384. {$endif}
  385. symoptions : tsymoptions;
  386. { symbol owning this definition }
  387. procsym : tsym;
  388. procsymderef : tderef;
  389. { alias names }
  390. aliasnames : tstringlist;
  391. { symtables }
  392. localst : TSymtable;
  393. funcretsym : tsym;
  394. funcretsymderef : tderef;
  395. _class : tobjectdef;
  396. _classderef : tderef;
  397. {$if defined(powerpc) or defined(m68k)}
  398. { library symbol for AmigaOS/MorphOS }
  399. libsym : tsym;
  400. libsymderef : tderef;
  401. {$endif powerpc or m68k}
  402. { name of the result variable to insert in the localsymtable }
  403. resultname : TIDString;
  404. { true, if the procedure is only declared
  405. (forward procedure) }
  406. forwarddef,
  407. { true if the procedure is declared in the interface }
  408. interfacedef : boolean;
  409. { true if the procedure has a forward declaration }
  410. hasforward : boolean;
  411. { import info }
  412. import_dll,
  413. import_name : pshortstring;
  414. import_nr : word;
  415. { info for inlining the subroutine, if this pointer is nil,
  416. the procedure can't be inlined }
  417. inlininginfo : pinlininginfo;
  418. {$ifdef oldregvars}
  419. regvarinfo: pregvarinfo;
  420. {$endif oldregvars}
  421. { position in aasmoutput list }
  422. procstarttai,
  423. procendtai : tai;
  424. constructor create(level:byte);
  425. constructor ppuload(ppufile:tcompilerppufile);
  426. destructor destroy;override;
  427. procedure ppuwrite(ppufile:tcompilerppufile);override;
  428. procedure buildderef;override;
  429. procedure buildderefimpl;override;
  430. procedure deref;override;
  431. procedure derefimpl;override;
  432. procedure reset;override;
  433. function GetSymtable(t:tGetSymtable):TSymtable;override;
  434. function GetTypeName : string;override;
  435. function mangledname : string;
  436. procedure setmangledname(const s : string);
  437. function fullprocname(showhidden:boolean):string;
  438. function cplusplusmangledname : string;
  439. function is_methodpointer:boolean;override;
  440. function is_addressonly:boolean;override;
  441. function is_visible_for_object(currobjdef,contextobjdef:tobjectdef):boolean;
  442. end;
  443. { single linked list of overloaded procs }
  444. pprocdeflist = ^tprocdeflist;
  445. tprocdeflist = record
  446. def : tprocdef;
  447. defderef : tderef;
  448. next : pprocdeflist;
  449. end;
  450. tstringdef = class(tstoreddef)
  451. stringtype : tstringtype;
  452. len : aint;
  453. constructor createshort(l : byte);
  454. constructor loadshort(ppufile:tcompilerppufile);
  455. constructor createlong(l : aint);
  456. constructor loadlong(ppufile:tcompilerppufile);
  457. constructor createansi(l : aint);
  458. constructor loadansi(ppufile:tcompilerppufile);
  459. constructor createwide(l : aint);
  460. constructor loadwide(ppufile:tcompilerppufile);
  461. function getcopy : tstoreddef;override;
  462. function stringtypname:string;
  463. procedure ppuwrite(ppufile:tcompilerppufile);override;
  464. function GetTypeName:string;override;
  465. function getmangledparaname:string;override;
  466. function is_publishable : boolean;override;
  467. function alignment : shortint;override;
  468. function needs_inittable : boolean;override;
  469. function getvardef:longint;override;
  470. end;
  471. tenumdef = class(tstoreddef)
  472. minval,
  473. maxval : aint;
  474. has_jumps : boolean;
  475. firstenum : tsym; {tenumsym}
  476. basedef : tenumdef;
  477. basedefderef : tderef;
  478. constructor create;
  479. constructor create_subrange(_basedef:tenumdef;_min,_max:aint);
  480. constructor ppuload(ppufile:tcompilerppufile);
  481. function getcopy : tstoreddef;override;
  482. procedure ppuwrite(ppufile:tcompilerppufile);override;
  483. procedure buildderef;override;
  484. procedure deref;override;
  485. procedure derefimpl;override;
  486. function GetTypeName:string;override;
  487. function is_publishable : boolean;override;
  488. procedure calcsavesize;
  489. function packedbitsize: aint; override;
  490. procedure setmax(_max:aint);
  491. procedure setmin(_min:aint);
  492. function min:aint;
  493. function max:aint;
  494. end;
  495. tsetdef = class(tstoreddef)
  496. elementdef : tdef;
  497. elementdefderef : tderef;
  498. settype : tsettype;
  499. setbase,
  500. setmax : aint;
  501. constructor create(def:tdef;high : aint);
  502. constructor ppuload(ppufile:tcompilerppufile);
  503. function getcopy : tstoreddef;override;
  504. procedure ppuwrite(ppufile:tcompilerppufile);override;
  505. procedure buildderef;override;
  506. procedure deref;override;
  507. function GetTypeName:string;override;
  508. function is_publishable : boolean;override;
  509. end;
  510. Tdefmatch=(dm_exact,dm_equal,dm_convertl1);
  511. var
  512. aktobjectdef : tobjectdef; { used for private functions check !! }
  513. { default types }
  514. generrordef, { error in definition }
  515. voidpointertype, { pointer for Void-pointeddef }
  516. charpointertype, { pointer for Char-pointeddef }
  517. widecharpointertype, { pointer for WideChar-pointeddef }
  518. voidfarpointertype,
  519. cundefinedtype,
  520. cformaltype, { unique formal definition }
  521. voidtype, { Void (procedure) }
  522. cchartype, { Char }
  523. cwidechartype, { WideChar }
  524. booltype, { boolean type }
  525. bool16type,
  526. bool32type,
  527. bool64type, { implement me }
  528. u8inttype, { 8-Bit unsigned integer }
  529. s8inttype, { 8-Bit signed integer }
  530. u16inttype, { 16-Bit unsigned integer }
  531. s16inttype, { 16-Bit signed integer }
  532. u32inttype, { 32-Bit unsigned integer }
  533. s32inttype, { 32-Bit signed integer }
  534. u64inttype, { 64-bit unsigned integer }
  535. s64inttype, { 64-bit signed integer }
  536. s32floattype, { pointer for realconstn }
  537. s64floattype, { pointer for realconstn }
  538. s80floattype, { pointer to type of temp. floats }
  539. s64currencytype, { pointer to a currency type }
  540. cshortstringtype, { pointer to type of short string const }
  541. clongstringtype, { pointer to type of long string const }
  542. cansistringtype, { pointer to type of ansi string const }
  543. cwidestringtype, { pointer to type of wide string const }
  544. openshortstringtype, { pointer to type of an open shortstring,
  545. needed for readln() }
  546. openchararraytype, { pointer to type of an open array of char,
  547. needed for readln() }
  548. cfiletype, { get the same definition for all file }
  549. { used for stabs }
  550. methodpointertype, { typecasting of methodpointers to extract self }
  551. hresultdef,
  552. { we use only one variant def for every variant class }
  553. cvarianttype,
  554. colevarianttype,
  555. { default integer type s32inttype on 32 bit systems, s64bittype on 64 bit systems }
  556. sinttype,
  557. uinttype,
  558. { unsigned ord type with the same size as a pointer }
  559. ptrinttype,
  560. { several types to simulate more or less C++ objects for GDB }
  561. vmttype,
  562. vmtarraytype,
  563. pvmttype : tdef; { type of classrefs, used for stabs }
  564. { pointer to the anchestor of all classes }
  565. class_tobject : tobjectdef;
  566. { pointer to the ancestor of all COM interfaces }
  567. interface_iunknown : tobjectdef;
  568. { pointer to the TGUID type
  569. of all interfaces }
  570. rec_tguid : trecorddef;
  571. const
  572. {$ifdef i386}
  573. pbestrealtype : ^tdef = @s80floattype;
  574. {$endif}
  575. {$ifdef x86_64}
  576. pbestrealtype : ^tdef = @s80floattype;
  577. {$endif}
  578. {$ifdef m68k}
  579. pbestrealtype : ^tdef = @s64floattype;
  580. {$endif}
  581. {$ifdef alpha}
  582. pbestrealtype : ^tdef = @s64floattype;
  583. {$endif}
  584. {$ifdef powerpc}
  585. pbestrealtype : ^tdef = @s64floattype;
  586. {$endif}
  587. {$ifdef POWERPC64}
  588. pbestrealtype : ^tdef = @s64floattype;
  589. {$endif}
  590. {$ifdef ia64}
  591. pbestrealtype : ^tdef = @s64floattype;
  592. {$endif}
  593. {$ifdef SPARC}
  594. pbestrealtype : ^tdef = @s64floattype;
  595. {$endif SPARC}
  596. {$ifdef vis}
  597. pbestrealtype : ^tdef = @s64floattype;
  598. {$endif vis}
  599. {$ifdef ARM}
  600. pbestrealtype : ^tdef = @s64floattype;
  601. {$endif ARM}
  602. {$ifdef MIPS}
  603. pbestrealtype : ^tdef = @s64floattype;
  604. {$endif MIPS}
  605. function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string;
  606. { should be in the types unit, but the types unit uses the node stuff :( }
  607. function is_interfacecom(def: tdef): boolean;
  608. function is_interfacecorba(def: tdef): boolean;
  609. function is_interface(def: tdef): boolean;
  610. function is_dispinterface(def: tdef): boolean;
  611. function is_object(def: tdef): boolean;
  612. function is_class(def: tdef): boolean;
  613. function is_cppclass(def: tdef): boolean;
  614. function is_class_or_interface(def: tdef): boolean;
  615. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  616. {$ifdef x86}
  617. function use_sse(def : tdef) : boolean;
  618. {$endif x86}
  619. implementation
  620. uses
  621. SysUtils,
  622. cutils,
  623. { global }
  624. verbose,
  625. { target }
  626. systems,aasmcpu,paramgr,
  627. { symtable }
  628. symsym,symtable,symutil,defutil,
  629. { module }
  630. fmodule,
  631. { other }
  632. gendef,
  633. fpccrc
  634. ;
  635. {****************************************************************************
  636. Constants
  637. ****************************************************************************}
  638. const
  639. varempty = 0;
  640. varnull = 1;
  641. varsmallint = 2;
  642. varinteger = 3;
  643. varsingle = 4;
  644. vardouble = 5;
  645. varcurrency = 6;
  646. vardate = 7;
  647. varolestr = 8;
  648. vardispatch = 9;
  649. varerror = 10;
  650. varboolean = 11;
  651. varvariant = 12;
  652. varunknown = 13;
  653. vardecimal = 14;
  654. varshortint = 16;
  655. varbyte = 17;
  656. varword = 18;
  657. varlongword = 19;
  658. varint64 = 20;
  659. varqword = 21;
  660. varUndefined = -1;
  661. varstrarg = $48;
  662. varstring = $100;
  663. varany = $101;
  664. vardefmask = $fff;
  665. vararray = $2000;
  666. varbyref = $4000;
  667. {****************************************************************************
  668. Helpers
  669. ****************************************************************************}
  670. function make_mangledname(const typeprefix:string;st:TSymtable;const suffix:string):string;
  671. var
  672. s,hs,
  673. prefix : string;
  674. oldlen,
  675. newlen,
  676. i : longint;
  677. crc : dword;
  678. hp : tparavarsym;
  679. begin
  680. prefix:='';
  681. if not assigned(st) then
  682. internalerror(200204212);
  683. { sub procedures }
  684. while (st.symtabletype=localsymtable) do
  685. begin
  686. if st.defowner.typ<>procdef then
  687. internalerror(200204173);
  688. { Add the full mangledname of procedure to prevent
  689. conflicts with 2 overloads having both a nested procedure
  690. with the same name, see tb0314 (PFV) }
  691. s:=tprocdef(st.defowner).procsym.name;
  692. oldlen:=length(s);
  693. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  694. begin
  695. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  696. if not(vo_is_hidden_para in hp.varoptions) then
  697. s:=s+'$'+hp.vardef.mangledparaname;
  698. end;
  699. if not is_void(tprocdef(st.defowner).returndef) then
  700. s:=s+'$$'+tprocdef(st.defowner).returndef.mangledparaname;
  701. newlen:=length(s);
  702. { Replace with CRC if the parameter line is very long }
  703. if (newlen-oldlen>12) and
  704. ((newlen>128) or (newlen-oldlen>64)) then
  705. begin
  706. crc:=$ffffffff;
  707. for i:=0 to tprocdef(st.defowner).paras.count-1 do
  708. begin
  709. hp:=tparavarsym(tprocdef(st.defowner).paras[i]);
  710. if not(vo_is_hidden_para in hp.varoptions) then
  711. begin
  712. hs:=hp.vardef.mangledparaname;
  713. crc:=UpdateCrc32(crc,hs[1],length(hs));
  714. end;
  715. end;
  716. hs:=hp.vardef.mangledparaname;
  717. crc:=UpdateCrc32(crc,hs[1],length(hs));
  718. s:=Copy(s,1,oldlen)+'$crc'+hexstr(crc,8);
  719. end;
  720. if prefix<>'' then
  721. prefix:=s+'_'+prefix
  722. else
  723. prefix:=s;
  724. st:=st.defowner.owner;
  725. end;
  726. { object/classes symtable }
  727. if (st.symtabletype=ObjectSymtable) then
  728. begin
  729. if st.defowner.typ<>objectdef then
  730. internalerror(200204174);
  731. prefix:=tobjectdef(st.defowner).objname^+'_$_'+prefix;
  732. st:=st.defowner.owner;
  733. end;
  734. { symtable must now be static or global }
  735. if not(st.symtabletype in [staticsymtable,globalsymtable]) then
  736. internalerror(200204175);
  737. result:='';
  738. if typeprefix<>'' then
  739. result:=result+typeprefix+'_';
  740. { Add P$ for program, which can have the same name as
  741. a unit }
  742. if (TSymtable(main_module.localsymtable)=st) and
  743. (not main_module.is_unit) then
  744. result:=result+'P$'+st.name^
  745. else
  746. result:=result+st.name^;
  747. if prefix<>'' then
  748. result:=result+'_'+prefix;
  749. if suffix<>'' then
  750. result:=result+'_'+suffix;
  751. { the Darwin assembler assumes that all symbols starting with 'L' are local }
  752. if (target_info.system in [system_powerpc_darwin,system_i386_darwin]) and
  753. (result[1] = 'L') then
  754. result := '_' + result;
  755. end;
  756. {****************************************************************************
  757. TDEF (base class for definitions)
  758. ****************************************************************************}
  759. constructor tstoreddef.create(dt:tdeftyp);
  760. var
  761. insertstack : psymtablestackitem;
  762. begin
  763. inherited create(dt);
  764. savesize := 0;
  765. {$ifdef EXTDEBUG}
  766. fileinfo := current_filepos;
  767. {$endif}
  768. generictokenbuf:=nil;
  769. genericdef:=nil;
  770. { Don't register forwarddefs, they are disposed at the
  771. end of an type block }
  772. if (dt=forwarddef) then
  773. exit;
  774. { Register in current_module }
  775. if assigned(current_module) then
  776. begin
  777. current_module.deflist.Add(self);
  778. DefId:=current_module.deflist.Count-1;
  779. end;
  780. { Register in symtable stack }
  781. if assigned(symtablestack) then
  782. begin
  783. insertstack:=symtablestack.stack;
  784. while assigned(insertstack) and
  785. (insertstack^.symtable.symtabletype=withsymtable) do
  786. insertstack:=insertstack^.next;
  787. if not assigned(insertstack) then
  788. internalerror(200602044);
  789. insertstack^.symtable.insertdef(self);
  790. end;
  791. end;
  792. procedure tstoreddef.FreeInstance;
  793. begin
  794. if assigned(owner) and
  795. (not owner.clearing) then
  796. begin
  797. include(defoptions,df_deleted);
  798. exit;
  799. end;
  800. inherited FreeInstance;
  801. end;
  802. destructor tstoreddef.destroy;
  803. begin
  804. { remove also index from symtable }
  805. // if assigned(owner) then
  806. // owner.deletedef(self);
  807. if assigned(generictokenbuf) then
  808. begin
  809. generictokenbuf.free;
  810. generictokenbuf:=nil;
  811. end;
  812. inherited destroy;
  813. end;
  814. constructor tstoreddef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  815. var
  816. sizeleft,i : longint;
  817. buf : array[0..255] of byte;
  818. begin
  819. inherited create(dt);
  820. DefId:=ppufile.getlongint;
  821. current_module.deflist[DefId]:=self;
  822. {$ifdef EXTDEBUG}
  823. fillchar(fileinfo,sizeof(fileinfo),0);
  824. {$endif}
  825. { load }
  826. ppufile.getderef(typesymderef);
  827. ppufile.getsmallset(defoptions);
  828. if df_generic in defoptions then
  829. begin
  830. sizeleft:=ppufile.getlongint;
  831. initgeneric;
  832. while sizeleft>0 do
  833. begin
  834. if sizeleft>sizeof(buf) then
  835. i:=sizeof(buf)
  836. else
  837. i:=sizeleft;
  838. ppufile.getdata(buf,i);
  839. generictokenbuf.write(buf,i);
  840. dec(sizeleft,i);
  841. end;
  842. end;
  843. if df_specialization in defoptions then
  844. ppufile.getderef(genericdefderef);
  845. end;
  846. function Tstoreddef.rtti_mangledname(rt:trttitype):string;
  847. var
  848. prefix : string[4];
  849. begin
  850. if rt=fullrtti then
  851. prefix:='RTTI'
  852. else
  853. prefix:='INIT';
  854. if assigned(typesym) and
  855. (owner.symtabletype=globalsymtable) then
  856. result:=make_mangledname(prefix,owner,typesym.name)
  857. else
  858. result:=make_mangledname(prefix,findunitsymtable(owner),'DEF'+tostr(DefId))
  859. end;
  860. procedure Tstoreddef.reset;
  861. begin
  862. end;
  863. function tstoreddef.getcopy : tstoreddef;
  864. begin
  865. Message(sym_e_cant_create_unique_type);
  866. getcopy:=terrordef.create;
  867. end;
  868. procedure tstoreddef.ppuwrite(ppufile:tcompilerppufile);
  869. var
  870. sizeleft,i : longint;
  871. buf : array[0..255] of byte;
  872. oldintfcrc : boolean;
  873. begin
  874. ppufile.putlongint(DefId);
  875. ppufile.putderef(typesymderef);
  876. ppufile.putsmallset(defoptions);
  877. if df_generic in defoptions then
  878. begin
  879. oldintfcrc:=ppufile.do_interface_crc;
  880. ppufile.do_interface_crc:=false;
  881. if assigned(generictokenbuf) then
  882. begin
  883. sizeleft:=generictokenbuf.size;
  884. generictokenbuf.seek(0);
  885. end
  886. else
  887. sizeleft:=0;
  888. ppufile.putlongint(sizeleft);
  889. while sizeleft>0 do
  890. begin
  891. if sizeleft>sizeof(buf) then
  892. i:=sizeof(buf)
  893. else
  894. i:=sizeleft;
  895. generictokenbuf.read(buf,i);
  896. ppufile.putdata(buf,i);
  897. dec(sizeleft,i);
  898. end;
  899. ppufile.do_interface_crc:=oldintfcrc;
  900. end;
  901. if df_specialization in defoptions then
  902. ppufile.putderef(genericdefderef);
  903. end;
  904. procedure tstoreddef.buildderef;
  905. begin
  906. typesymderef.build(typesym);
  907. genericdefderef.build(genericdef);
  908. end;
  909. procedure tstoreddef.buildderefimpl;
  910. begin
  911. end;
  912. procedure tstoreddef.deref;
  913. begin
  914. typesym:=ttypesym(typesymderef.resolve);
  915. if df_specialization in defoptions then
  916. genericdef:=tstoreddef(genericdefderef.resolve);
  917. end;
  918. procedure tstoreddef.derefimpl;
  919. begin
  920. end;
  921. function tstoreddef.size : aint;
  922. begin
  923. size:=savesize;
  924. end;
  925. function tstoreddef.getvardef:longint;
  926. begin
  927. result:=varUndefined;
  928. end;
  929. function tstoreddef.alignment : shortint;
  930. begin
  931. { natural alignment by default }
  932. alignment:=size_2_align(savesize);
  933. end;
  934. { returns true, if the definition can be published }
  935. function tstoreddef.is_publishable : boolean;
  936. begin
  937. is_publishable:=false;
  938. end;
  939. { needs an init table }
  940. function tstoreddef.needs_inittable : boolean;
  941. begin
  942. needs_inittable:=false;
  943. end;
  944. function tstoreddef.is_intregable : boolean;
  945. var
  946. recsize,temp: longint;
  947. begin
  948. is_intregable:=false;
  949. case typ of
  950. orddef,
  951. pointerdef,
  952. enumdef,
  953. classrefdef:
  954. is_intregable:=true;
  955. procvardef :
  956. is_intregable:=not(po_methodpointer in tprocvardef(self).procoptions);
  957. objectdef:
  958. is_intregable:=is_class(self) or is_interface(self);
  959. setdef:
  960. is_intregable:=(tsetdef(self).settype=smallset);
  961. recorddef:
  962. begin
  963. recsize:=size;
  964. is_intregable:=
  965. ispowerof2(recsize,temp) and
  966. (recsize <= sizeof(aint));
  967. end;
  968. end;
  969. end;
  970. function tstoreddef.is_fpuregable : boolean;
  971. begin
  972. {$ifdef x86}
  973. result:=use_sse(self);
  974. {$else x86}
  975. result:=(typ=floatdef) and not(cs_fp_emulation in current_settings.moduleswitches);
  976. {$endif x86}
  977. end;
  978. procedure tstoreddef.initgeneric;
  979. begin
  980. if assigned(generictokenbuf) then
  981. internalerror(200512131);
  982. generictokenbuf:=tdynamicarray.create(256);
  983. end;
  984. {****************************************************************************
  985. Tstringdef
  986. ****************************************************************************}
  987. constructor tstringdef.createshort(l : byte);
  988. begin
  989. inherited create(stringdef);
  990. stringtype:=st_shortstring;
  991. len:=l;
  992. savesize:=len+1;
  993. end;
  994. constructor tstringdef.loadshort(ppufile:tcompilerppufile);
  995. begin
  996. inherited ppuload(stringdef,ppufile);
  997. stringtype:=st_shortstring;
  998. len:=ppufile.getbyte;
  999. savesize:=len+1;
  1000. end;
  1001. constructor tstringdef.createlong(l : aint);
  1002. begin
  1003. inherited create(stringdef);
  1004. stringtype:=st_longstring;
  1005. len:=l;
  1006. savesize:=sizeof(aint);
  1007. end;
  1008. constructor tstringdef.loadlong(ppufile:tcompilerppufile);
  1009. begin
  1010. inherited ppuload(stringdef,ppufile);
  1011. stringtype:=st_longstring;
  1012. len:=ppufile.getaint;
  1013. savesize:=sizeof(aint);
  1014. end;
  1015. constructor tstringdef.createansi(l:aint);
  1016. begin
  1017. inherited create(stringdef);
  1018. stringtype:=st_ansistring;
  1019. len:=l;
  1020. savesize:=sizeof(aint);
  1021. end;
  1022. constructor tstringdef.loadansi(ppufile:tcompilerppufile);
  1023. begin
  1024. inherited ppuload(stringdef,ppufile);
  1025. stringtype:=st_ansistring;
  1026. len:=ppufile.getaint;
  1027. savesize:=sizeof(aint);
  1028. end;
  1029. constructor tstringdef.createwide(l : aint);
  1030. begin
  1031. inherited create(stringdef);
  1032. stringtype:=st_widestring;
  1033. len:=l;
  1034. savesize:=sizeof(aint);
  1035. end;
  1036. constructor tstringdef.loadwide(ppufile:tcompilerppufile);
  1037. begin
  1038. inherited ppuload(stringdef,ppufile);
  1039. stringtype:=st_widestring;
  1040. len:=ppufile.getaint;
  1041. savesize:=sizeof(aint);
  1042. end;
  1043. function tstringdef.getcopy : tstoreddef;
  1044. begin
  1045. result:=tstringdef.create(typ);
  1046. result.typ:=stringdef;
  1047. tstringdef(result).stringtype:=stringtype;
  1048. tstringdef(result).len:=len;
  1049. tstringdef(result).savesize:=savesize;
  1050. end;
  1051. function tstringdef.stringtypname:string;
  1052. const
  1053. typname:array[tstringtype] of string[8]=(
  1054. 'shortstr','longstr','ansistr','widestr'
  1055. );
  1056. begin
  1057. stringtypname:=typname[stringtype];
  1058. end;
  1059. procedure tstringdef.ppuwrite(ppufile:tcompilerppufile);
  1060. begin
  1061. inherited ppuwrite(ppufile);
  1062. if stringtype=st_shortstring then
  1063. begin
  1064. {$ifdef extdebug}
  1065. if len > 255 then internalerror(12122002);
  1066. {$endif}
  1067. ppufile.putbyte(byte(len))
  1068. end
  1069. else
  1070. ppufile.putaint(len);
  1071. case stringtype of
  1072. st_shortstring : ppufile.writeentry(ibshortstringdef);
  1073. st_longstring : ppufile.writeentry(iblongstringdef);
  1074. st_ansistring : ppufile.writeentry(ibansistringdef);
  1075. st_widestring : ppufile.writeentry(ibwidestringdef);
  1076. end;
  1077. end;
  1078. function tstringdef.needs_inittable : boolean;
  1079. begin
  1080. needs_inittable:=stringtype in [st_ansistring,st_widestring];
  1081. end;
  1082. function tstringdef.GetTypeName : string;
  1083. const
  1084. names : array[tstringtype] of string[11] = (
  1085. 'ShortString','LongString','AnsiString','WideString');
  1086. begin
  1087. GetTypeName:=names[stringtype];
  1088. end;
  1089. function tstringdef.getvardef : longint;
  1090. const
  1091. vardef : array[tstringtype] of longint = (
  1092. varUndefined,varUndefined,varString,varOleStr);
  1093. begin
  1094. result:=vardef[stringtype];
  1095. end;
  1096. function tstringdef.alignment : shortint;
  1097. begin
  1098. case stringtype of
  1099. st_widestring,
  1100. st_ansistring:
  1101. alignment:=size_2_align(savesize);
  1102. st_longstring,
  1103. st_shortstring:
  1104. {$ifdef cpurequiresproperalignment}
  1105. { char to string accesses byte 0 and 1 with one word access }
  1106. alignment:=size_2_align(2);
  1107. {$else cpurequiresproperalignment}
  1108. alignment:=size_2_align(1);
  1109. {$endif cpurequiresproperalignment}
  1110. else
  1111. internalerror(200412301);
  1112. end;
  1113. end;
  1114. function tstringdef.getmangledparaname : string;
  1115. begin
  1116. getmangledparaname:='STRING';
  1117. end;
  1118. function tstringdef.is_publishable : boolean;
  1119. begin
  1120. is_publishable:=true;
  1121. end;
  1122. {****************************************************************************
  1123. TENUMDEF
  1124. ****************************************************************************}
  1125. constructor tenumdef.create;
  1126. begin
  1127. inherited create(enumdef);
  1128. minval:=0;
  1129. maxval:=0;
  1130. calcsavesize;
  1131. has_jumps:=false;
  1132. basedef:=nil;
  1133. firstenum:=nil;
  1134. end;
  1135. constructor tenumdef.create_subrange(_basedef:tenumdef;_min,_max:aint);
  1136. begin
  1137. inherited create(enumdef);
  1138. minval:=_min;
  1139. maxval:=_max;
  1140. basedef:=_basedef;
  1141. calcsavesize;
  1142. has_jumps:=false;
  1143. firstenum:=basedef.firstenum;
  1144. while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
  1145. firstenum:=tenumsym(firstenum).nextenum;
  1146. end;
  1147. constructor tenumdef.ppuload(ppufile:tcompilerppufile);
  1148. begin
  1149. inherited ppuload(enumdef,ppufile);
  1150. ppufile.getderef(basedefderef);
  1151. minval:=ppufile.getaint;
  1152. maxval:=ppufile.getaint;
  1153. savesize:=ppufile.getaint;
  1154. has_jumps:=false;
  1155. firstenum:=Nil;
  1156. end;
  1157. function tenumdef.getcopy : tstoreddef;
  1158. begin
  1159. if assigned(basedef) then
  1160. result:=tenumdef.create_subrange(basedef,minval,maxval)
  1161. else
  1162. begin
  1163. result:=tenumdef.create;
  1164. tenumdef(result).minval:=minval;
  1165. tenumdef(result).maxval:=maxval;
  1166. end;
  1167. tenumdef(result).has_jumps:=has_jumps;
  1168. tenumdef(result).firstenum:=firstenum;
  1169. tenumdef(result).basedefderef:=basedefderef;
  1170. end;
  1171. procedure tenumdef.calcsavesize;
  1172. begin
  1173. if (current_settings.packenum=8) or (min<low(longint)) or (int64(max)>high(cardinal)) then
  1174. savesize:=8
  1175. else
  1176. if (current_settings.packenum=4) or (min<low(smallint)) or (max>high(word)) then
  1177. savesize:=4
  1178. else
  1179. if (current_settings.packenum=2) or (min<low(shortint)) or (max>high(byte)) then
  1180. savesize:=2
  1181. else
  1182. savesize:=1;
  1183. end;
  1184. function tenumdef.packedbitsize: aint;
  1185. var
  1186. power: longint;
  1187. begin
  1188. result := 0;
  1189. if (minval < 0) then
  1190. result := inherited packedbitsize
  1191. else
  1192. begin
  1193. if (maxval <= 1) then
  1194. result := 1
  1195. else
  1196. begin
  1197. { 256 must become 512 etc. }
  1198. nextpowerof2(maxval+1,power);
  1199. result := power;
  1200. end;
  1201. end;
  1202. end;
  1203. procedure tenumdef.setmax(_max:aint);
  1204. begin
  1205. maxval:=_max;
  1206. calcsavesize;
  1207. end;
  1208. procedure tenumdef.setmin(_min:aint);
  1209. begin
  1210. minval:=_min;
  1211. calcsavesize;
  1212. end;
  1213. function tenumdef.min:aint;
  1214. begin
  1215. min:=minval;
  1216. end;
  1217. function tenumdef.max:aint;
  1218. begin
  1219. max:=maxval;
  1220. end;
  1221. procedure tenumdef.buildderef;
  1222. begin
  1223. inherited buildderef;
  1224. basedefderef.build(basedef);
  1225. end;
  1226. procedure tenumdef.deref;
  1227. begin
  1228. inherited deref;
  1229. basedef:=tenumdef(basedefderef.resolve);
  1230. { restart ordering }
  1231. firstenum:=nil;
  1232. end;
  1233. procedure tenumdef.derefimpl;
  1234. begin
  1235. if assigned(basedef) and
  1236. (firstenum=nil) then
  1237. begin
  1238. firstenum:=basedef.firstenum;
  1239. while assigned(firstenum) and (tenumsym(firstenum).value<>minval) do
  1240. firstenum:=tenumsym(firstenum).nextenum;
  1241. end;
  1242. end;
  1243. procedure tenumdef.ppuwrite(ppufile:tcompilerppufile);
  1244. begin
  1245. inherited ppuwrite(ppufile);
  1246. ppufile.putderef(basedefderef);
  1247. ppufile.putaint(min);
  1248. ppufile.putaint(max);
  1249. ppufile.putaint(savesize);
  1250. ppufile.writeentry(ibenumdef);
  1251. end;
  1252. function tenumdef.is_publishable : boolean;
  1253. begin
  1254. is_publishable:=true;
  1255. end;
  1256. function tenumdef.GetTypeName : string;
  1257. begin
  1258. GetTypeName:='<enumeration type>';
  1259. end;
  1260. {****************************************************************************
  1261. TORDDEF
  1262. ****************************************************************************}
  1263. constructor torddef.create(t : tordtype;v,b : TConstExprInt);
  1264. begin
  1265. inherited create(orddef);
  1266. low:=v;
  1267. high:=b;
  1268. ordtype:=t;
  1269. setsize;
  1270. end;
  1271. constructor torddef.ppuload(ppufile:tcompilerppufile);
  1272. begin
  1273. inherited ppuload(orddef,ppufile);
  1274. ordtype:=tordtype(ppufile.getbyte);
  1275. if sizeof(TConstExprInt)=8 then
  1276. begin
  1277. low:=ppufile.getint64;
  1278. high:=ppufile.getint64;
  1279. end
  1280. else
  1281. begin
  1282. low:=ppufile.getlongint;
  1283. high:=ppufile.getlongint;
  1284. end;
  1285. setsize;
  1286. end;
  1287. function torddef.getcopy : tstoreddef;
  1288. begin
  1289. result:=torddef.create(ordtype,low,high);
  1290. result.typ:=orddef;
  1291. torddef(result).low:=low;
  1292. torddef(result).high:=high;
  1293. torddef(result).ordtype:=ordtype;
  1294. torddef(result).savesize:=savesize;
  1295. end;
  1296. function torddef.alignment:shortint;
  1297. begin
  1298. if (target_info.system = system_i386_darwin) and
  1299. (ordtype in [s64bit,u64bit]) then
  1300. result := 4
  1301. else
  1302. result := inherited alignment;
  1303. end;
  1304. procedure torddef.setsize;
  1305. const
  1306. sizetbl : array[tordtype] of longint = (
  1307. 0,
  1308. 1,2,4,8,
  1309. 1,2,4,8,
  1310. 1,2,4,8,
  1311. 1,2,8
  1312. );
  1313. begin
  1314. savesize:=sizetbl[ordtype];
  1315. end;
  1316. function torddef.packedbitsize: aint;
  1317. var
  1318. power: longint;
  1319. begin
  1320. result := 0;
  1321. if ordtype = uvoid then
  1322. exit;
  1323. if (low < 0) then
  1324. result := inherited packedbitsize
  1325. else
  1326. begin
  1327. if (high <= 1) then
  1328. result := 1
  1329. else if (ordtype = u64bit) then
  1330. result := 64
  1331. else
  1332. begin
  1333. { 256 must become 512 etc. }
  1334. nextpowerof2(high+1,power);
  1335. result := power;
  1336. end;
  1337. end;
  1338. end;
  1339. function torddef.getvardef : longint;
  1340. const
  1341. basetype2vardef : array[tordtype] of longint = (
  1342. varUndefined,
  1343. varbyte,varqword,varlongword,varqword,
  1344. varshortint,varsmallint,varinteger,varint64,
  1345. varboolean,varUndefined,varUndefined,varUndefined,
  1346. varUndefined,varUndefined,varCurrency);
  1347. begin
  1348. result:=basetype2vardef[ordtype];
  1349. end;
  1350. procedure torddef.ppuwrite(ppufile:tcompilerppufile);
  1351. begin
  1352. inherited ppuwrite(ppufile);
  1353. ppufile.putbyte(byte(ordtype));
  1354. if sizeof(TConstExprInt)=8 then
  1355. begin
  1356. ppufile.putint64(low);
  1357. ppufile.putint64(high);
  1358. end
  1359. else
  1360. begin
  1361. ppufile.putlongint(low);
  1362. ppufile.putlongint(high);
  1363. end;
  1364. ppufile.writeentry(iborddef);
  1365. end;
  1366. function torddef.is_publishable : boolean;
  1367. begin
  1368. is_publishable:=(ordtype<>uvoid);
  1369. end;
  1370. function torddef.GetTypeName : string;
  1371. const
  1372. names : array[tordtype] of string[20] = (
  1373. 'untyped',
  1374. 'Byte','Word','DWord','QWord',
  1375. 'ShortInt','SmallInt','LongInt','Int64',
  1376. 'Boolean','WordBool','LongBool','QWordBool',
  1377. 'Char','WideChar','Currency');
  1378. begin
  1379. GetTypeName:=names[ordtype];
  1380. end;
  1381. {****************************************************************************
  1382. TFLOATDEF
  1383. ****************************************************************************}
  1384. constructor tfloatdef.create(t : tfloattype);
  1385. begin
  1386. inherited create(floatdef);
  1387. floattype:=t;
  1388. setsize;
  1389. end;
  1390. constructor tfloatdef.ppuload(ppufile:tcompilerppufile);
  1391. begin
  1392. inherited ppuload(floatdef,ppufile);
  1393. floattype:=tfloattype(ppufile.getbyte);
  1394. setsize;
  1395. end;
  1396. function tfloatdef.getcopy : tstoreddef;
  1397. begin
  1398. result:=tfloatdef.create(floattype);
  1399. result.typ:=floatdef;
  1400. tfloatdef(result).savesize:=savesize;
  1401. end;
  1402. function tfloatdef.alignment:shortint;
  1403. begin
  1404. if (target_info.system = system_i386_darwin) then
  1405. case floattype of
  1406. s80real : result:=16;
  1407. s64real,
  1408. s64currency,
  1409. s64comp : result:=4;
  1410. else
  1411. result := inherited alignment;
  1412. end
  1413. else
  1414. result := inherited alignment;
  1415. end;
  1416. procedure tfloatdef.setsize;
  1417. begin
  1418. case floattype of
  1419. s32real : savesize:=4;
  1420. s80real : savesize:=10;
  1421. s64real,
  1422. s64currency,
  1423. s64comp : savesize:=8;
  1424. else
  1425. savesize:=0;
  1426. end;
  1427. end;
  1428. function tfloatdef.getvardef : longint;
  1429. const
  1430. floattype2vardef : array[tfloattype] of longint = (
  1431. varSingle,varDouble,varUndefined,
  1432. varUndefined,varCurrency,varUndefined);
  1433. begin
  1434. if (upper(typename)='TDATETIME') and
  1435. assigned(owner) and
  1436. assigned(owner.name) and
  1437. (owner.name^='SYSTEM') then
  1438. result:=varDate
  1439. else
  1440. result:=floattype2vardef[floattype];
  1441. end;
  1442. procedure tfloatdef.ppuwrite(ppufile:tcompilerppufile);
  1443. begin
  1444. inherited ppuwrite(ppufile);
  1445. ppufile.putbyte(byte(floattype));
  1446. ppufile.writeentry(ibfloatdef);
  1447. end;
  1448. function tfloatdef.is_publishable : boolean;
  1449. begin
  1450. is_publishable:=true;
  1451. end;
  1452. function tfloatdef.GetTypeName : string;
  1453. const
  1454. names : array[tfloattype] of string[20] = (
  1455. 'Single','Double','Extended','Comp','Currency','Float128');
  1456. begin
  1457. GetTypeName:=names[floattype];
  1458. end;
  1459. {****************************************************************************
  1460. TFILEDEF
  1461. ****************************************************************************}
  1462. constructor tfiledef.createtext;
  1463. begin
  1464. inherited create(filedef);
  1465. filetyp:=ft_text;
  1466. typedfiledef:=nil;
  1467. setsize;
  1468. end;
  1469. constructor tfiledef.createuntyped;
  1470. begin
  1471. inherited create(filedef);
  1472. filetyp:=ft_untyped;
  1473. typedfiledef:=nil;
  1474. setsize;
  1475. end;
  1476. constructor tfiledef.createtyped(def:tdef);
  1477. begin
  1478. inherited create(filedef);
  1479. filetyp:=ft_typed;
  1480. typedfiledef:=def;
  1481. setsize;
  1482. end;
  1483. constructor tfiledef.ppuload(ppufile:tcompilerppufile);
  1484. begin
  1485. inherited ppuload(filedef,ppufile);
  1486. filetyp:=tfiletyp(ppufile.getbyte);
  1487. if filetyp=ft_typed then
  1488. ppufile.getderef(typedfiledefderef)
  1489. else
  1490. typedfiledef:=nil;
  1491. setsize;
  1492. end;
  1493. function tfiledef.getcopy : tstoreddef;
  1494. begin
  1495. case filetyp of
  1496. ft_typed:
  1497. result:=tfiledef.createtyped(typedfiledef);
  1498. ft_untyped:
  1499. result:=tfiledef.createuntyped;
  1500. ft_text:
  1501. result:=tfiledef.createtext;
  1502. else
  1503. internalerror(2004121201);
  1504. end;
  1505. end;
  1506. procedure tfiledef.buildderef;
  1507. begin
  1508. inherited buildderef;
  1509. if filetyp=ft_typed then
  1510. typedfiledefderef.build(typedfiledef);
  1511. end;
  1512. procedure tfiledef.deref;
  1513. begin
  1514. inherited deref;
  1515. if filetyp=ft_typed then
  1516. typedfiledef:=tdef(typedfiledefderef.resolve);
  1517. end;
  1518. procedure tfiledef.setsize;
  1519. begin
  1520. {$ifdef cpu64bit}
  1521. case filetyp of
  1522. ft_text :
  1523. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1524. savesize:=632
  1525. else
  1526. savesize:=628;
  1527. ft_typed,
  1528. ft_untyped :
  1529. if target_info.system in [system_x86_64_win64,system_ia64_win64] then
  1530. savesize:=372
  1531. else
  1532. savesize:=368;
  1533. end;
  1534. {$else cpu64bit}
  1535. case filetyp of
  1536. ft_text :
  1537. savesize:=592;
  1538. ft_typed,
  1539. ft_untyped :
  1540. savesize:=332;
  1541. end;
  1542. {$endif cpu64bit}
  1543. end;
  1544. procedure tfiledef.ppuwrite(ppufile:tcompilerppufile);
  1545. begin
  1546. inherited ppuwrite(ppufile);
  1547. ppufile.putbyte(byte(filetyp));
  1548. if filetyp=ft_typed then
  1549. ppufile.putderef(typedfiledefderef);
  1550. ppufile.writeentry(ibfiledef);
  1551. end;
  1552. function tfiledef.GetTypeName : string;
  1553. begin
  1554. case filetyp of
  1555. ft_untyped:
  1556. GetTypeName:='File';
  1557. ft_typed:
  1558. GetTypeName:='File Of '+typedfiledef.typename;
  1559. ft_text:
  1560. GetTypeName:='Text'
  1561. end;
  1562. end;
  1563. function tfiledef.getmangledparaname : string;
  1564. begin
  1565. case filetyp of
  1566. ft_untyped:
  1567. getmangledparaname:='FILE';
  1568. ft_typed:
  1569. getmangledparaname:='FILE$OF$'+typedfiledef.mangledparaname;
  1570. ft_text:
  1571. getmangledparaname:='TEXT'
  1572. end;
  1573. end;
  1574. {****************************************************************************
  1575. TVARIANTDEF
  1576. ****************************************************************************}
  1577. constructor tvariantdef.create(v : tvarianttype);
  1578. begin
  1579. inherited create(variantdef);
  1580. varianttype:=v;
  1581. setsize;
  1582. end;
  1583. constructor tvariantdef.ppuload(ppufile:tcompilerppufile);
  1584. begin
  1585. inherited ppuload(variantdef,ppufile);
  1586. varianttype:=tvarianttype(ppufile.getbyte);
  1587. setsize;
  1588. end;
  1589. function tvariantdef.getcopy : tstoreddef;
  1590. begin
  1591. result:=tvariantdef.create(varianttype);
  1592. end;
  1593. procedure tvariantdef.ppuwrite(ppufile:tcompilerppufile);
  1594. begin
  1595. inherited ppuwrite(ppufile);
  1596. ppufile.putbyte(byte(varianttype));
  1597. ppufile.writeentry(ibvariantdef);
  1598. end;
  1599. procedure tvariantdef.setsize;
  1600. begin
  1601. {$ifdef cpu64bit}
  1602. savesize:=24;
  1603. {$else cpu64bit}
  1604. savesize:=16;
  1605. {$endif cpu64bit}
  1606. end;
  1607. function tvariantdef.GetTypeName : string;
  1608. begin
  1609. case varianttype of
  1610. vt_normalvariant:
  1611. GetTypeName:='Variant';
  1612. vt_olevariant:
  1613. GetTypeName:='OleVariant';
  1614. end;
  1615. end;
  1616. function tvariantdef.needs_inittable : boolean;
  1617. begin
  1618. needs_inittable:=true;
  1619. end;
  1620. function tvariantdef.is_publishable : boolean;
  1621. begin
  1622. is_publishable:=true;
  1623. end;
  1624. {****************************************************************************
  1625. TABSTRACtpointerdef
  1626. ****************************************************************************}
  1627. constructor tabstractpointerdef.create(dt:tdeftyp;def:tdef);
  1628. begin
  1629. inherited create(dt);
  1630. pointeddef:=def;
  1631. savesize:=sizeof(aint);
  1632. end;
  1633. constructor tabstractpointerdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  1634. begin
  1635. inherited ppuload(dt,ppufile);
  1636. ppufile.getderef(pointeddefderef);
  1637. savesize:=sizeof(aint);
  1638. end;
  1639. procedure tabstractpointerdef.buildderef;
  1640. begin
  1641. inherited buildderef;
  1642. pointeddefderef.build(pointeddef);
  1643. end;
  1644. procedure tabstractpointerdef.deref;
  1645. begin
  1646. inherited deref;
  1647. pointeddef:=tdef(pointeddefderef.resolve);
  1648. end;
  1649. procedure tabstractpointerdef.ppuwrite(ppufile:tcompilerppufile);
  1650. begin
  1651. inherited ppuwrite(ppufile);
  1652. ppufile.putderef(pointeddefderef);
  1653. end;
  1654. {****************************************************************************
  1655. tpointerdef
  1656. ****************************************************************************}
  1657. constructor tpointerdef.create(def:tdef);
  1658. begin
  1659. inherited create(pointerdef,def);
  1660. is_far:=false;
  1661. end;
  1662. constructor tpointerdef.createfar(def:tdef);
  1663. begin
  1664. inherited create(pointerdef,def);
  1665. is_far:=true;
  1666. end;
  1667. constructor tpointerdef.ppuload(ppufile:tcompilerppufile);
  1668. begin
  1669. inherited ppuload(pointerdef,ppufile);
  1670. is_far:=(ppufile.getbyte<>0);
  1671. end;
  1672. function tpointerdef.getcopy : tstoreddef;
  1673. begin
  1674. result:=tpointerdef.create(pointeddef);
  1675. tpointerdef(result).is_far:=is_far;
  1676. tpointerdef(result).savesize:=savesize;
  1677. end;
  1678. procedure tpointerdef.ppuwrite(ppufile:tcompilerppufile);
  1679. begin
  1680. inherited ppuwrite(ppufile);
  1681. ppufile.putbyte(byte(is_far));
  1682. ppufile.writeentry(ibpointerdef);
  1683. end;
  1684. function tpointerdef.GetTypeName : string;
  1685. begin
  1686. if is_far then
  1687. GetTypeName:='^'+pointeddef.typename+';far'
  1688. else
  1689. GetTypeName:='^'+pointeddef.typename;
  1690. end;
  1691. {****************************************************************************
  1692. TCLASSREFDEF
  1693. ****************************************************************************}
  1694. constructor tclassrefdef.create(def:tdef);
  1695. begin
  1696. inherited create(classrefdef,def);
  1697. end;
  1698. constructor tclassrefdef.ppuload(ppufile:tcompilerppufile);
  1699. begin
  1700. inherited ppuload(classrefdef,ppufile);
  1701. end;
  1702. procedure tclassrefdef.ppuwrite(ppufile:tcompilerppufile);
  1703. begin
  1704. inherited ppuwrite(ppufile);
  1705. ppufile.writeentry(ibclassrefdef);
  1706. end;
  1707. function tclassrefdef.GetTypeName : string;
  1708. begin
  1709. GetTypeName:='Class Of '+pointeddef.typename;
  1710. end;
  1711. function tclassrefdef.is_publishable : boolean;
  1712. begin
  1713. result:=true;
  1714. end;
  1715. {***************************************************************************
  1716. TSETDEF
  1717. ***************************************************************************}
  1718. constructor tsetdef.create(def:tdef;high : aint);
  1719. begin
  1720. inherited create(setdef);
  1721. elementdef:=def;
  1722. // setbase:=low;
  1723. setmax:=high;
  1724. if high<32 then
  1725. begin
  1726. settype:=smallset;
  1727. if current_settings.setalloc=0 then { $PACKSET Fixed?}
  1728. savesize:=Sizeof(longint)
  1729. else {No, use $PACKSET VALUE for rounding}
  1730. savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
  1731. end
  1732. else
  1733. if high<256 then
  1734. begin
  1735. settype:=normset;
  1736. if current_settings.setalloc=0 then { $PACKSET Fixed?}
  1737. savesize:=32
  1738. else {No, use $PACKSET VALUE for rounding}
  1739. savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
  1740. end
  1741. else
  1742. savesize:=current_settings.setalloc*((high+current_settings.setalloc*8-1) DIV (current_settings.setalloc*8));
  1743. end;
  1744. constructor tsetdef.ppuload(ppufile:tcompilerppufile);
  1745. begin
  1746. inherited ppuload(setdef,ppufile);
  1747. ppufile.getderef(elementdefderef);
  1748. settype:=tsettype(ppufile.getbyte);
  1749. case settype of
  1750. normset : savesize:=32;
  1751. varset : savesize:=ppufile.getlongint;
  1752. smallset : savesize:=Sizeof(longint);
  1753. end;
  1754. end;
  1755. function tsetdef.getcopy : tstoreddef;
  1756. begin
  1757. case settype of
  1758. smallset:
  1759. result:=tsetdef.create(elementdef,31);
  1760. normset:
  1761. result:=tsetdef.create(elementdef,255);
  1762. else
  1763. internalerror(2004121202);
  1764. end;
  1765. end;
  1766. procedure tsetdef.ppuwrite(ppufile:tcompilerppufile);
  1767. begin
  1768. inherited ppuwrite(ppufile);
  1769. ppufile.putderef(elementdefderef);
  1770. ppufile.putbyte(byte(settype));
  1771. if settype=varset then
  1772. ppufile.putlongint(savesize);
  1773. if settype=normset then
  1774. ppufile.putaint(savesize);
  1775. ppufile.writeentry(ibsetdef);
  1776. end;
  1777. procedure tsetdef.buildderef;
  1778. begin
  1779. inherited buildderef;
  1780. elementdefderef.build(elementdef);
  1781. end;
  1782. procedure tsetdef.deref;
  1783. begin
  1784. inherited deref;
  1785. elementdef:=tdef(elementdefderef.resolve);
  1786. end;
  1787. function tsetdef.is_publishable : boolean;
  1788. begin
  1789. is_publishable:=(settype=smallset);
  1790. end;
  1791. function tsetdef.GetTypeName : string;
  1792. begin
  1793. if assigned(elementdef) then
  1794. GetTypeName:='Set Of '+elementdef.typename
  1795. else
  1796. GetTypeName:='Empty Set';
  1797. end;
  1798. {***************************************************************************
  1799. TFORMALDEF
  1800. ***************************************************************************}
  1801. constructor tformaldef.create;
  1802. begin
  1803. inherited create(formaldef);
  1804. savesize:=0;
  1805. end;
  1806. constructor tformaldef.ppuload(ppufile:tcompilerppufile);
  1807. begin
  1808. inherited ppuload(formaldef,ppufile);
  1809. savesize:=0;
  1810. end;
  1811. procedure tformaldef.ppuwrite(ppufile:tcompilerppufile);
  1812. begin
  1813. inherited ppuwrite(ppufile);
  1814. ppufile.writeentry(ibformaldef);
  1815. end;
  1816. function tformaldef.GetTypeName : string;
  1817. begin
  1818. GetTypeName:='<Formal type>';
  1819. end;
  1820. {***************************************************************************
  1821. TARRAYDEF
  1822. ***************************************************************************}
  1823. constructor tarraydef.create(l,h : aint;def:tdef);
  1824. begin
  1825. inherited create(arraydef);
  1826. lowrange:=l;
  1827. highrange:=h;
  1828. rangedef:=def;
  1829. _elementdef:=nil;
  1830. arrayoptions:=[];
  1831. end;
  1832. constructor tarraydef.create_from_pointer(def:tdef);
  1833. begin
  1834. self.create(0,$7fffffff,s32inttype);
  1835. arrayoptions:=[ado_IsConvertedPointer];
  1836. setelementdef(def);
  1837. end;
  1838. constructor tarraydef.ppuload(ppufile:tcompilerppufile);
  1839. begin
  1840. inherited ppuload(arraydef,ppufile);
  1841. { the addresses are calculated later }
  1842. ppufile.getderef(_elementdefderef);
  1843. ppufile.getderef(rangedefderef);
  1844. lowrange:=ppufile.getaint;
  1845. highrange:=ppufile.getaint;
  1846. ppufile.getsmallset(arrayoptions);
  1847. end;
  1848. function tarraydef.getcopy : tstoreddef;
  1849. begin
  1850. result:=tarraydef.create(lowrange,highrange,rangedef);
  1851. tarraydef(result).arrayoptions:=arrayoptions;
  1852. tarraydef(result)._elementdef:=_elementdef;
  1853. end;
  1854. procedure tarraydef.buildderef;
  1855. begin
  1856. inherited buildderef;
  1857. _elementdefderef.build(_elementdef);
  1858. rangedefderef.build(rangedef);
  1859. end;
  1860. procedure tarraydef.deref;
  1861. begin
  1862. inherited deref;
  1863. _elementdef:=tdef(_elementdefderef.resolve);
  1864. rangedef:=tdef(rangedefderef.resolve);
  1865. end;
  1866. procedure tarraydef.ppuwrite(ppufile:tcompilerppufile);
  1867. begin
  1868. inherited ppuwrite(ppufile);
  1869. ppufile.putderef(_elementdefderef);
  1870. ppufile.putderef(rangedefderef);
  1871. ppufile.putaint(lowrange);
  1872. ppufile.putaint(highrange);
  1873. ppufile.putsmallset(arrayoptions);
  1874. ppufile.writeentry(ibarraydef);
  1875. end;
  1876. function tarraydef.elesize : aint;
  1877. begin
  1878. if (ado_IsBitPacked in arrayoptions) then
  1879. internalerror(2006080101);
  1880. if assigned(_elementdef) then
  1881. result:=_elementdef.size
  1882. else
  1883. result:=0;
  1884. end;
  1885. function tarraydef.elepackedbitsize : aint;
  1886. begin
  1887. if not(ado_IsBitPacked in arrayoptions) then
  1888. internalerror(2006080102);
  1889. if assigned(_elementdef) then
  1890. result:=_elementdef.packedbitsize
  1891. else
  1892. result:=0;
  1893. end;
  1894. function tarraydef.elecount : aint;
  1895. var
  1896. qhigh,qlow : qword;
  1897. begin
  1898. if ado_IsDynamicArray in arrayoptions then
  1899. begin
  1900. result:=0;
  1901. exit;
  1902. end;
  1903. if (highrange>0) and (lowrange<0) then
  1904. begin
  1905. qhigh:=highrange;
  1906. qlow:=qword(-lowrange);
  1907. { prevent overflow, return -1 to indicate overflow }
  1908. if qhigh+qlow>qword(high(aint)-1) then
  1909. result:=-1
  1910. else
  1911. result:=qhigh+qlow+1;
  1912. end
  1913. else
  1914. result:=int64(highrange)-lowrange+1;
  1915. end;
  1916. function tarraydef.size : aint;
  1917. var
  1918. cachedelecount,
  1919. cachedelesize : aint;
  1920. begin
  1921. if ado_IsDynamicArray in arrayoptions then
  1922. begin
  1923. size:=sizeof(aint);
  1924. exit;
  1925. end;
  1926. { Tarraydef.size may never be called for an open array! }
  1927. if highrange<lowrange then
  1928. internalerror(99080501);
  1929. if not (ado_IsBitPacked in arrayoptions) then
  1930. cachedelesize:=elesize
  1931. else
  1932. cachedelesize := elepackedbitsize;
  1933. cachedelecount:=elecount;
  1934. if (cachedelesize = 0) then
  1935. begin
  1936. size := 0;
  1937. exit;
  1938. end;
  1939. if (cachedelecount = -1) then
  1940. begin
  1941. size := -1;
  1942. exit;
  1943. end;
  1944. { prevent overflow, return -1 to indicate overflow }
  1945. { also make sure we don't need 64/128 bit arithmetic to calculate offsets }
  1946. if (cachedelecount > high(aint)) or
  1947. ((high(aint) div cachedelesize) < cachedelecount) or
  1948. { also lowrange*elesize must be < high(aint) to prevent overflow when
  1949. accessing the array, see ncgmem (PFV) }
  1950. ((high(aint) div cachedelesize) < abs(lowrange)) then
  1951. begin
  1952. result:=-1;
  1953. exit;
  1954. end;
  1955. if (ado_IsBitPacked in arrayoptions) then
  1956. size:=(cachedelesize * cachedelecount + 7) div 8
  1957. else
  1958. result:=cachedelesize*cachedelecount;
  1959. end;
  1960. procedure tarraydef.setelementdef(def:tdef);
  1961. begin
  1962. _elementdef:=def;
  1963. if not(
  1964. (ado_IsDynamicArray in arrayoptions) or
  1965. (ado_IsConvertedPointer in arrayoptions) or
  1966. (highrange<lowrange)
  1967. ) and
  1968. (size=-1) then
  1969. Message(sym_e_segment_too_large);
  1970. end;
  1971. function tarraydef.alignment : shortint;
  1972. begin
  1973. { alignment is the size of the elements }
  1974. if (elementdef.typ in [arraydef,recorddef]) or
  1975. ((elementdef.typ=objectdef) and
  1976. is_object(elementdef)) then
  1977. alignment:=elementdef.alignment
  1978. else if not (ado_IsBitPacked in arrayoptions) then
  1979. alignment:=size_2_align(elesize)
  1980. else
  1981. alignment:=packedbitsloadsize(elepackedbitsize);
  1982. end;
  1983. function tarraydef.needs_inittable : boolean;
  1984. begin
  1985. needs_inittable:=(ado_IsDynamicArray in arrayoptions) or elementdef.needs_inittable;
  1986. end;
  1987. function tarraydef.GetTypeName : string;
  1988. begin
  1989. if (ado_IsConstString in arrayoptions) then
  1990. result:='Constant String'
  1991. else if (ado_isarrayofconst in arrayoptions) or
  1992. (ado_isConstructor in arrayoptions) then
  1993. begin
  1994. if (ado_isvariant in arrayoptions) or ((highrange=-1) and (lowrange=0)) then
  1995. GetTypeName:='Array Of Const'
  1996. else
  1997. GetTypeName:='Array Of '+elementdef.typename;
  1998. end
  1999. else if ((highrange=-1) and (lowrange=0)) or (ado_IsDynamicArray in arrayoptions) then
  2000. GetTypeName:='Array Of '+elementdef.typename
  2001. else
  2002. begin
  2003. result := '';
  2004. if (ado_IsBitPacked in arrayoptions) then
  2005. result:='Packed ';
  2006. if rangedef.typ=enumdef then
  2007. result:=result+'Array['+rangedef.typename+'] Of '+elementdef.typename
  2008. else
  2009. result:=result+'Array['+tostr(lowrange)+'..'+
  2010. tostr(highrange)+'] Of '+elementdef.typename
  2011. end;
  2012. end;
  2013. function tarraydef.getmangledparaname : string;
  2014. begin
  2015. if ado_isarrayofconst in arrayoptions then
  2016. getmangledparaname:='array_of_const'
  2017. else
  2018. if ((highrange=-1) and (lowrange=0)) then
  2019. getmangledparaname:='array_of_'+elementdef.mangledparaname
  2020. else
  2021. internalerror(200204176);
  2022. end;
  2023. {***************************************************************************
  2024. tabstractrecorddef
  2025. ***************************************************************************}
  2026. function tabstractrecorddef.GetSymtable(t:tGetSymtable):TSymtable;
  2027. begin
  2028. if t=gs_record then
  2029. GetSymtable:=symtable
  2030. else
  2031. GetSymtable:=nil;
  2032. end;
  2033. procedure tabstractrecorddef.reset;
  2034. begin
  2035. inherited reset;
  2036. tstoredsymtable(symtable).reset_all_defs;
  2037. end;
  2038. function tabstractrecorddef.is_packed:boolean;
  2039. begin
  2040. result:=tabstractrecordsymtable(symtable).is_packed;
  2041. end;
  2042. {***************************************************************************
  2043. trecorddef
  2044. ***************************************************************************}
  2045. constructor trecorddef.create(p : TSymtable);
  2046. begin
  2047. inherited create(recorddef);
  2048. symtable:=p;
  2049. symtable.defowner:=self;
  2050. isunion:=false;
  2051. end;
  2052. constructor trecorddef.ppuload(ppufile:tcompilerppufile);
  2053. begin
  2054. inherited ppuload(recorddef,ppufile);
  2055. symtable:=trecordsymtable.create(0);
  2056. trecordsymtable(symtable).datasize:=ppufile.getaint;
  2057. trecordsymtable(symtable).fieldalignment:=shortint(ppufile.getbyte);
  2058. trecordsymtable(symtable).recordalignment:=shortint(ppufile.getbyte);
  2059. trecordsymtable(symtable).padalignment:=shortint(ppufile.getbyte);
  2060. trecordsymtable(symtable).usefieldalignment:=shortint(ppufile.getbyte);
  2061. trecordsymtable(symtable).ppuload(ppufile);
  2062. symtable.defowner:=self;
  2063. isunion:=false;
  2064. end;
  2065. destructor trecorddef.destroy;
  2066. begin
  2067. if assigned(symtable) then
  2068. begin
  2069. symtable.free;
  2070. symtable:=nil;
  2071. end;
  2072. inherited destroy;
  2073. end;
  2074. function trecorddef.getcopy : tstoreddef;
  2075. begin
  2076. result:=trecorddef.create(symtable.getcopy);
  2077. trecorddef(result).isunion:=isunion;
  2078. end;
  2079. function trecorddef.needs_inittable : boolean;
  2080. begin
  2081. needs_inittable:=trecordsymtable(symtable).needs_init_final
  2082. end;
  2083. procedure trecorddef.buildderef;
  2084. begin
  2085. inherited buildderef;
  2086. tstoredsymtable(symtable).buildderef;
  2087. end;
  2088. procedure trecorddef.deref;
  2089. begin
  2090. inherited deref;
  2091. { now dereference the definitions }
  2092. tstoredsymtable(symtable).deref;
  2093. { assign TGUID? load only from system unit }
  2094. if not(assigned(rec_tguid)) and
  2095. (upper(typename)='TGUID') and
  2096. assigned(owner) and
  2097. assigned(owner.name) and
  2098. (owner.name^='SYSTEM') then
  2099. rec_tguid:=self;
  2100. end;
  2101. procedure trecorddef.ppuwrite(ppufile:tcompilerppufile);
  2102. begin
  2103. inherited ppuwrite(ppufile);
  2104. ppufile.putaint(trecordsymtable(symtable).datasize);
  2105. ppufile.putbyte(byte(trecordsymtable(symtable).fieldalignment));
  2106. ppufile.putbyte(byte(trecordsymtable(symtable).recordalignment));
  2107. ppufile.putbyte(byte(trecordsymtable(symtable).padalignment));
  2108. ppufile.putbyte(byte(trecordsymtable(symtable).usefieldalignment));
  2109. ppufile.writeentry(ibrecorddef);
  2110. trecordsymtable(symtable).ppuwrite(ppufile);
  2111. end;
  2112. function trecorddef.size:aint;
  2113. begin
  2114. result:=trecordsymtable(symtable).datasize;
  2115. end;
  2116. function trecorddef.alignment:shortint;
  2117. begin
  2118. alignment:=trecordsymtable(symtable).recordalignment;
  2119. end;
  2120. function trecorddef.padalignment:shortint;
  2121. begin
  2122. padalignment := trecordsymtable(symtable).padalignment;
  2123. end;
  2124. function trecorddef.GetTypeName : string;
  2125. begin
  2126. GetTypeName:='<record type>'
  2127. end;
  2128. {***************************************************************************
  2129. TABSTRACTPROCDEF
  2130. ***************************************************************************}
  2131. constructor tabstractprocdef.create(dt:tdeftyp;level:byte);
  2132. begin
  2133. inherited create(dt);
  2134. parast:=tparasymtable.create(self,level);
  2135. paras:=nil;
  2136. minparacount:=0;
  2137. maxparacount:=0;
  2138. proctypeoption:=potype_none;
  2139. proccalloption:=pocall_none;
  2140. procoptions:=[];
  2141. returndef:=voidtype;
  2142. {$ifdef i386}
  2143. fpu_used:=0;
  2144. {$endif i386}
  2145. savesize:=sizeof(aint);
  2146. requiredargarea:=0;
  2147. has_paraloc_info:=false;
  2148. location_reset(funcretloc[callerside],LOC_INVALID,OS_NO);
  2149. location_reset(funcretloc[calleeside],LOC_INVALID,OS_NO);
  2150. end;
  2151. destructor tabstractprocdef.destroy;
  2152. begin
  2153. if assigned(paras) then
  2154. begin
  2155. {$ifdef MEMDEBUG}
  2156. memprocpara.start;
  2157. {$endif MEMDEBUG}
  2158. paras.free;
  2159. paras:=nil;
  2160. {$ifdef MEMDEBUG}
  2161. memprocpara.stop;
  2162. {$endif MEMDEBUG}
  2163. end;
  2164. if assigned(parast) then
  2165. begin
  2166. {$ifdef MEMDEBUG}
  2167. memprocparast.start;
  2168. {$endif MEMDEBUG}
  2169. parast.free;
  2170. parast:=nil;
  2171. {$ifdef MEMDEBUG}
  2172. memprocparast.stop;
  2173. {$endif MEMDEBUG}
  2174. end;
  2175. inherited destroy;
  2176. end;
  2177. procedure tabstractprocdef.count_para(p:TObject;arg:pointer);
  2178. begin
  2179. if (tsym(p).typ<>paravarsym) then
  2180. exit;
  2181. inc(plongint(arg)^);
  2182. if not(vo_is_hidden_para in tparavarsym(p).varoptions) then
  2183. begin
  2184. if not assigned(tparavarsym(p).defaultconstsym) then
  2185. inc(minparacount);
  2186. inc(maxparacount);
  2187. end;
  2188. end;
  2189. procedure tabstractprocdef.insert_para(p:TObject;arg:pointer);
  2190. begin
  2191. if (tsym(p).typ<>paravarsym) then
  2192. exit;
  2193. paras.add(p);
  2194. end;
  2195. procedure tabstractprocdef.calcparas;
  2196. var
  2197. paracount : longint;
  2198. begin
  2199. { This can already be assigned when
  2200. we need to reresolve this unit (PFV) }
  2201. if assigned(paras) then
  2202. paras.free;
  2203. paras:=tparalist.create(false);
  2204. paracount:=0;
  2205. minparacount:=0;
  2206. maxparacount:=0;
  2207. parast.SymList.ForEachCall(@count_para,@paracount);
  2208. paras.capacity:=paracount;
  2209. { Insert parameters in table }
  2210. parast.SymList.ForEachCall(@insert_para,nil);
  2211. { Order parameters }
  2212. paras.sortparas;
  2213. end;
  2214. { all functions returning in FPU are
  2215. assume to use 2 FPU registers
  2216. until the function implementation
  2217. is processed PM }
  2218. procedure tabstractprocdef.test_if_fpu_result;
  2219. begin
  2220. {$ifdef i386}
  2221. if assigned(returndef) and
  2222. (returndef.typ=floatdef) then
  2223. fpu_used:=maxfpuregs;
  2224. {$endif i386}
  2225. end;
  2226. procedure tabstractprocdef.buildderef;
  2227. begin
  2228. { released procdef? }
  2229. if not assigned(parast) then
  2230. exit;
  2231. inherited buildderef;
  2232. returndefderef.build(returndef);
  2233. { parast }
  2234. tparasymtable(parast).buildderef;
  2235. end;
  2236. procedure tabstractprocdef.deref;
  2237. begin
  2238. inherited deref;
  2239. returndef:=tdef(returndefderef.resolve);
  2240. { parast }
  2241. tparasymtable(parast).deref;
  2242. { recalculated parameters }
  2243. calcparas;
  2244. end;
  2245. constructor tabstractprocdef.ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
  2246. var
  2247. b : byte;
  2248. begin
  2249. inherited ppuload(dt,ppufile);
  2250. parast:=nil;
  2251. Paras:=nil;
  2252. minparacount:=0;
  2253. maxparacount:=0;
  2254. ppufile.getderef(returndefderef);
  2255. {$ifdef i386}
  2256. fpu_used:=ppufile.getbyte;
  2257. {$else}
  2258. ppufile.getbyte;
  2259. {$endif i386}
  2260. proctypeoption:=tproctypeoption(ppufile.getbyte);
  2261. proccalloption:=tproccalloption(ppufile.getbyte);
  2262. ppufile.getnormalset(procoptions);
  2263. location_reset(funcretloc[callerside],LOC_INVALID,OS_NO);
  2264. location_reset(funcretloc[calleeside],LOC_INVALID,OS_NO);
  2265. if po_explicitparaloc in procoptions then
  2266. begin
  2267. b:=ppufile.getbyte;
  2268. if b<>sizeof(funcretloc[callerside]) then
  2269. internalerror(200411154);
  2270. ppufile.getdata(funcretloc[callerside],sizeof(funcretloc[callerside]));
  2271. end;
  2272. savesize:=sizeof(aint);
  2273. has_paraloc_info:=(po_explicitparaloc in procoptions);
  2274. end;
  2275. procedure tabstractprocdef.ppuwrite(ppufile:tcompilerppufile);
  2276. var
  2277. oldintfcrc : boolean;
  2278. begin
  2279. { released procdef? }
  2280. if not assigned(parast) then
  2281. exit;
  2282. inherited ppuwrite(ppufile);
  2283. ppufile.putderef(returndefderef);
  2284. oldintfcrc:=ppufile.do_interface_crc;
  2285. ppufile.do_interface_crc:=false;
  2286. {$ifdef i386}
  2287. if simplify_ppu then
  2288. fpu_used:=0;
  2289. ppufile.putbyte(fpu_used);
  2290. {$else}
  2291. ppufile.putbyte(0);
  2292. {$endif}
  2293. ppufile.putbyte(ord(proctypeoption));
  2294. ppufile.putbyte(ord(proccalloption));
  2295. ppufile.putnormalset(procoptions);
  2296. ppufile.do_interface_crc:=oldintfcrc;
  2297. if (po_explicitparaloc in procoptions) then
  2298. begin
  2299. { Make a 'valid' funcretloc for procedures }
  2300. ppufile.putbyte(sizeof(funcretloc[callerside]));
  2301. ppufile.putdata(funcretloc[callerside],sizeof(funcretloc[callerside]));
  2302. end;
  2303. end;
  2304. function tabstractprocdef.typename_paras(showhidden:boolean) : string;
  2305. var
  2306. hs,s : string;
  2307. hp : TParavarsym;
  2308. hpc : tconstsym;
  2309. first : boolean;
  2310. i : integer;
  2311. begin
  2312. s:='';
  2313. first:=true;
  2314. for i:=0 to paras.count-1 do
  2315. begin
  2316. hp:=tparavarsym(paras[i]);
  2317. if not(vo_is_hidden_para in hp.varoptions) or
  2318. (showhidden) then
  2319. begin
  2320. if first then
  2321. begin
  2322. s:=s+'(';
  2323. first:=false;
  2324. end
  2325. else
  2326. s:=s+',';
  2327. if vo_is_hidden_para in hp.varoptions then
  2328. s:=s+'<';
  2329. case hp.varspez of
  2330. vs_var :
  2331. s:=s+'var';
  2332. vs_const :
  2333. s:=s+'const';
  2334. vs_out :
  2335. s:=s+'out';
  2336. end;
  2337. if assigned(hp.vardef.typesym) then
  2338. begin
  2339. if s<>'(' then
  2340. s:=s+' ';
  2341. hs:=hp.vardef.typesym.realname;
  2342. if hs[1]<>'$' then
  2343. s:=s+hp.vardef.typesym.realname
  2344. else
  2345. s:=s+hp.vardef.GetTypeName;
  2346. end
  2347. else
  2348. s:=s+hp.vardef.GetTypeName;
  2349. { default value }
  2350. if assigned(hp.defaultconstsym) then
  2351. begin
  2352. hpc:=tconstsym(hp.defaultconstsym);
  2353. hs:='';
  2354. case hpc.consttyp of
  2355. conststring,
  2356. constresourcestring :
  2357. hs:=strpas(pchar(hpc.value.valueptr));
  2358. constreal :
  2359. str(pbestreal(hpc.value.valueptr)^,hs);
  2360. constpointer :
  2361. hs:=tostr(hpc.value.valueordptr);
  2362. constord :
  2363. begin
  2364. if is_boolean(hpc.constdef) then
  2365. begin
  2366. if hpc.value.valueord<>0 then
  2367. hs:='TRUE'
  2368. else
  2369. hs:='FALSE';
  2370. end
  2371. else
  2372. hs:=tostr(hpc.value.valueord);
  2373. end;
  2374. constnil :
  2375. hs:='nil';
  2376. constset :
  2377. hs:='<set>';
  2378. end;
  2379. if hs<>'' then
  2380. s:=s+'="'+hs+'"';
  2381. end;
  2382. if vo_is_hidden_para in hp.varoptions then
  2383. s:=s+'>';
  2384. end;
  2385. end;
  2386. if not first then
  2387. s:=s+')';
  2388. if (po_varargs in procoptions) then
  2389. s:=s+';VarArgs';
  2390. typename_paras:=s;
  2391. end;
  2392. function tabstractprocdef.is_methodpointer:boolean;
  2393. begin
  2394. result:=false;
  2395. end;
  2396. function tabstractprocdef.is_addressonly:boolean;
  2397. begin
  2398. result:=true;
  2399. end;
  2400. {***************************************************************************
  2401. TPROCDEF
  2402. ***************************************************************************}
  2403. constructor tprocdef.create(level:byte);
  2404. begin
  2405. inherited create(procdef,level);
  2406. localst:=tlocalsymtable.create(self,parast.symtablelevel);
  2407. _mangledname:=nil;
  2408. fileinfo:=current_filepos;
  2409. extnumber:=$ffff;
  2410. aliasnames:=tstringlist.create;
  2411. funcretsym:=nil;
  2412. forwarddef:=true;
  2413. interfacedef:=false;
  2414. hasforward:=false;
  2415. _class := nil;
  2416. import_dll:=nil;
  2417. import_name:=nil;
  2418. import_nr:=0;
  2419. inlininginfo:=nil;
  2420. end;
  2421. constructor tprocdef.ppuload(ppufile:tcompilerppufile);
  2422. var
  2423. level : byte;
  2424. begin
  2425. inherited ppuload(procdef,ppufile);
  2426. if po_has_mangledname in procoptions then
  2427. _mangledname:=stringdup(ppufile.getstring)
  2428. else
  2429. _mangledname:=nil;
  2430. extnumber:=ppufile.getword;
  2431. level:=ppufile.getbyte;
  2432. ppufile.getderef(_classderef);
  2433. ppufile.getderef(procsymderef);
  2434. ppufile.getposinfo(fileinfo);
  2435. ppufile.getsmallset(symoptions);
  2436. {$ifdef powerpc}
  2437. { library symbol for AmigaOS/MorphOS }
  2438. ppufile.getderef(libsymderef);
  2439. {$endif powerpc}
  2440. { import stuff }
  2441. if po_has_importdll in procoptions then
  2442. import_dll:=stringdup(ppufile.getstring)
  2443. else
  2444. import_dll:=nil;
  2445. if po_has_importname in procoptions then
  2446. import_name:=stringdup(ppufile.getstring)
  2447. else
  2448. import_name:=nil;
  2449. import_nr:=ppufile.getword;
  2450. if (po_msgint in procoptions) then
  2451. messageinf.i:=ppufile.getlongint;
  2452. if (po_msgstr in procoptions) then
  2453. messageinf.str:=stringdup(ppufile.getstring);
  2454. { inline stuff }
  2455. if (po_has_inlininginfo in procoptions) then
  2456. begin
  2457. ppufile.getderef(funcretsymderef);
  2458. new(inlininginfo);
  2459. ppufile.getsmallset(inlininginfo^.flags);
  2460. end
  2461. else
  2462. begin
  2463. inlininginfo:=nil;
  2464. funcretsym:=nil;
  2465. end;
  2466. { load para symtable }
  2467. parast:=tparasymtable.create(self,level);
  2468. tparasymtable(parast).ppuload(ppufile);
  2469. { load local symtable }
  2470. if (po_has_inlininginfo in procoptions) then
  2471. begin
  2472. localst:=tlocalsymtable.create(self,level);
  2473. tlocalsymtable(localst).ppuload(ppufile);
  2474. end
  2475. else
  2476. localst:=nil;
  2477. { inline stuff }
  2478. if (po_has_inlininginfo in procoptions) then
  2479. inlininginfo^.code:=ppuloadnodetree(ppufile);
  2480. { default values for no persistent data }
  2481. if (cs_link_deffile in current_settings.globalswitches) and
  2482. (tf_need_export in target_info.flags) and
  2483. (po_exports in procoptions) then
  2484. deffile.AddExport(mangledname);
  2485. aliasnames:=tstringlist.create;
  2486. forwarddef:=false;
  2487. interfacedef:=false;
  2488. hasforward:=false;
  2489. { Disable po_has_inlining until the derefimpl is done }
  2490. exclude(procoptions,po_has_inlininginfo);
  2491. end;
  2492. destructor tprocdef.destroy;
  2493. begin
  2494. aliasnames.free;
  2495. aliasnames:=nil;
  2496. if assigned(localst) and
  2497. (localst.symtabletype<>staticsymtable) then
  2498. begin
  2499. {$ifdef MEMDEBUG}
  2500. memproclocalst.start;
  2501. {$endif MEMDEBUG}
  2502. localst.free;
  2503. localst:=nil;
  2504. {$ifdef MEMDEBUG}
  2505. memproclocalst.start;
  2506. {$endif MEMDEBUG}
  2507. end;
  2508. if assigned(inlininginfo) then
  2509. begin
  2510. {$ifdef MEMDEBUG}
  2511. memprocnodetree.start;
  2512. {$endif MEMDEBUG}
  2513. tnode(inlininginfo^.code).free;
  2514. {$ifdef MEMDEBUG}
  2515. memprocnodetree.start;
  2516. {$endif MEMDEBUG}
  2517. dispose(inlininginfo);
  2518. inlininginfo:=nil;
  2519. end;
  2520. stringdispose(import_dll);
  2521. stringdispose(import_name);
  2522. if (po_msgstr in procoptions) then
  2523. stringdispose(messageinf.str);
  2524. if assigned(_mangledname) then
  2525. begin
  2526. {$ifdef MEMDEBUG}
  2527. memmanglednames.start;
  2528. {$endif MEMDEBUG}
  2529. stringdispose(_mangledname);
  2530. {$ifdef MEMDEBUG}
  2531. memmanglednames.stop;
  2532. {$endif MEMDEBUG}
  2533. end;
  2534. inherited destroy;
  2535. end;
  2536. procedure tprocdef.ppuwrite(ppufile:tcompilerppufile);
  2537. var
  2538. oldintfcrc : boolean;
  2539. begin
  2540. { released procdef? }
  2541. if not assigned(parast) then
  2542. exit;
  2543. inherited ppuwrite(ppufile);
  2544. if po_has_mangledname in procoptions then
  2545. ppufile.putstring(_mangledname^);
  2546. ppufile.putword(extnumber);
  2547. ppufile.putbyte(parast.symtablelevel);
  2548. ppufile.putderef(_classderef);
  2549. ppufile.putderef(procsymderef);
  2550. ppufile.putposinfo(fileinfo);
  2551. ppufile.putsmallset(symoptions);
  2552. {$ifdef powerpc}
  2553. { library symbol for AmigaOS/MorphOS }
  2554. ppufile.putderef(libsymderef);
  2555. {$endif powerpc}
  2556. { import }
  2557. if po_has_importdll in procoptions then
  2558. ppufile.putstring(import_dll^);
  2559. if po_has_importname in procoptions then
  2560. ppufile.putstring(import_name^);
  2561. ppufile.putword(import_nr);
  2562. if (po_msgint in procoptions) then
  2563. ppufile.putlongint(messageinf.i);
  2564. if (po_msgstr in procoptions) then
  2565. ppufile.putstring(messageinf.str^);
  2566. { inline stuff }
  2567. oldintfcrc:=ppufile.do_crc;
  2568. ppufile.do_crc:=false;
  2569. if (po_has_inlininginfo in procoptions) then
  2570. begin
  2571. ppufile.putderef(funcretsymderef);
  2572. ppufile.putsmallset(inlininginfo^.flags);
  2573. end;
  2574. ppufile.do_crc:=oldintfcrc;
  2575. { write this entry }
  2576. ppufile.writeentry(ibprocdef);
  2577. { Save the para symtable, this is taken from the interface }
  2578. tparasymtable(parast).ppuwrite(ppufile);
  2579. { save localsymtable for inline procedures or when local
  2580. browser info is requested, this has no influence on the crc }
  2581. if (po_has_inlininginfo in procoptions) then
  2582. begin
  2583. oldintfcrc:=ppufile.do_crc;
  2584. ppufile.do_crc:=false;
  2585. tlocalsymtable(localst).ppuwrite(ppufile);
  2586. ppufile.do_crc:=oldintfcrc;
  2587. end;
  2588. { node tree for inlining }
  2589. oldintfcrc:=ppufile.do_crc;
  2590. ppufile.do_crc:=false;
  2591. if (po_has_inlininginfo in procoptions) then
  2592. ppuwritenodetree(ppufile,inlininginfo^.code);
  2593. ppufile.do_crc:=oldintfcrc;
  2594. end;
  2595. procedure tprocdef.reset;
  2596. begin
  2597. inherited reset;
  2598. procstarttai:=nil;
  2599. procendtai:=nil;
  2600. end;
  2601. function tprocdef.fullprocname(showhidden:boolean):string;
  2602. var
  2603. s : string;
  2604. t : ttoken;
  2605. begin
  2606. {$ifdef EXTDEBUG}
  2607. showhidden:=true;
  2608. {$endif EXTDEBUG}
  2609. s:='';
  2610. if owner.symtabletype=localsymtable then
  2611. s:=s+'local ';
  2612. if assigned(_class) then
  2613. begin
  2614. if po_classmethod in procoptions then
  2615. s:=s+'class ';
  2616. s:=s+_class.objrealname^+'.';
  2617. end;
  2618. if proctypeoption=potype_operator then
  2619. begin
  2620. for t:=NOTOKEN to last_overloaded do
  2621. if procsym.realname='$'+overloaded_names[t] then
  2622. begin
  2623. s:='operator '+arraytokeninfo[t].str+typename_paras(showhidden);
  2624. break;
  2625. end;
  2626. end
  2627. else
  2628. s:=s+procsym.realname+typename_paras(showhidden);
  2629. case proctypeoption of
  2630. potype_constructor:
  2631. s:='constructor '+s;
  2632. potype_destructor:
  2633. s:='destructor '+s;
  2634. else
  2635. if assigned(returndef) and
  2636. not(is_void(returndef)) then
  2637. s:=s+':'+returndef.GetTypeName;
  2638. end;
  2639. { forced calling convention? }
  2640. if (po_hascallingconvention in procoptions) then
  2641. s:=s+';'+ProcCallOptionStr[proccalloption];
  2642. fullprocname:=s;
  2643. end;
  2644. function tprocdef.is_methodpointer:boolean;
  2645. begin
  2646. result:=assigned(_class);
  2647. end;
  2648. function tprocdef.is_addressonly:boolean;
  2649. begin
  2650. result:=assigned(owner) and
  2651. (owner.symtabletype<>ObjectSymtable);
  2652. end;
  2653. function tprocdef.is_visible_for_object(currobjdef,contextobjdef:tobjectdef):boolean;
  2654. var
  2655. contextst : TSymtable;
  2656. begin
  2657. result:=false;
  2658. { Support passing a context in which module we are to find protected members }
  2659. if assigned(contextobjdef) then
  2660. contextst:=contextobjdef.owner
  2661. else
  2662. contextst:=nil;
  2663. { private symbols are allowed when we are in the same
  2664. module as they are defined }
  2665. if (sp_private in symoptions) and
  2666. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  2667. not(owner.defowner.owner.iscurrentunit or (owner.defowner.owner=contextst)) then
  2668. exit;
  2669. if (sp_strictprivate in symoptions) then
  2670. begin
  2671. result:=currobjdef=tobjectdef(owner.defowner);
  2672. exit;
  2673. end;
  2674. if (sp_strictprotected in symoptions) then
  2675. begin
  2676. result:=assigned(currobjdef) and
  2677. currobjdef.is_related(tobjectdef(owner.defowner));
  2678. exit;
  2679. end;
  2680. { protected symbols are visible in the module that defines them and
  2681. also visible to related objects. The related object must be defined
  2682. in the current module }
  2683. if (sp_protected in symoptions) and
  2684. (
  2685. (
  2686. (owner.defowner.owner.symtabletype in [globalsymtable,staticsymtable]) and
  2687. not((owner.defowner.owner.iscurrentunit) or (owner.defowner.owner=contextst))
  2688. ) and
  2689. not(
  2690. assigned(currobjdef) and
  2691. (currobjdef.owner.symtabletype in [globalsymtable,staticsymtable]) and
  2692. (currobjdef.owner.iscurrentunit) and
  2693. currobjdef.is_related(tobjectdef(owner.defowner))
  2694. )
  2695. ) then
  2696. exit;
  2697. result:=true;
  2698. end;
  2699. function tprocdef.GetSymtable(t:tGetSymtable):TSymtable;
  2700. begin
  2701. case t of
  2702. gs_local :
  2703. GetSymtable:=localst;
  2704. gs_para :
  2705. GetSymtable:=parast;
  2706. else
  2707. GetSymtable:=nil;
  2708. end;
  2709. end;
  2710. procedure tprocdef.buildderef;
  2711. begin
  2712. inherited buildderef;
  2713. _classderef.build(_class);
  2714. { procsym that originaly defined this definition, should be in the
  2715. same symtable }
  2716. procsymderef.build(procsym);
  2717. {$ifdef powerpc}
  2718. { library symbol for AmigaOS/MorphOS }
  2719. libsymderef.build(libsym);
  2720. {$endif powerpc}
  2721. end;
  2722. procedure tprocdef.buildderefimpl;
  2723. begin
  2724. inherited buildderefimpl;
  2725. { Localst is not available for main/unit init }
  2726. if assigned(localst) then
  2727. begin
  2728. tlocalsymtable(localst).buildderef;
  2729. tlocalsymtable(localst).buildderefimpl;
  2730. end;
  2731. { inline tree }
  2732. if (po_has_inlininginfo in procoptions) then
  2733. begin
  2734. funcretsymderef.build(funcretsym);
  2735. inlininginfo^.code.buildderefimpl;
  2736. end;
  2737. end;
  2738. procedure tprocdef.deref;
  2739. begin
  2740. inherited deref;
  2741. _class:=tobjectdef(_classderef.resolve);
  2742. { procsym that originaly defined this definition, should be in the
  2743. same symtable }
  2744. procsym:=tprocsym(procsymderef.resolve);
  2745. {$ifdef powerpc}
  2746. { library symbol for AmigaOS/MorphOS }
  2747. libsym:=tsym(libsymderef.resolve);
  2748. {$endif powerpc}
  2749. end;
  2750. procedure tprocdef.derefimpl;
  2751. begin
  2752. { Enable has_inlininginfo when the inlininginfo
  2753. structure is available. The has_inlininginfo was disabled
  2754. after the load, since the data was invalid }
  2755. if assigned(inlininginfo) then
  2756. include(procoptions,po_has_inlininginfo);
  2757. { Locals }
  2758. if assigned(localst) then
  2759. begin
  2760. tlocalsymtable(localst).deref;
  2761. tlocalsymtable(localst).derefimpl;
  2762. end;
  2763. { Inline }
  2764. if (po_has_inlininginfo in procoptions) then
  2765. begin
  2766. inlininginfo^.code.derefimpl;
  2767. { funcretsym, this is always located in the localst }
  2768. funcretsym:=tsym(funcretsymderef.resolve);
  2769. end
  2770. else
  2771. begin
  2772. { safety }
  2773. funcretsym:=nil;
  2774. end;
  2775. end;
  2776. function tprocdef.GetTypeName : string;
  2777. begin
  2778. GetTypeName := FullProcName(false);
  2779. end;
  2780. function tprocdef.mangledname : string;
  2781. var
  2782. hp : TParavarsym;
  2783. hs : string;
  2784. crc : dword;
  2785. newlen,
  2786. oldlen,
  2787. i : integer;
  2788. begin
  2789. if assigned(_mangledname) then
  2790. begin
  2791. {$ifdef compress}
  2792. mangledname:=minilzw_decode(_mangledname^);
  2793. {$else}
  2794. mangledname:=_mangledname^;
  2795. {$endif}
  2796. exit;
  2797. end;
  2798. { we need to use the symtable where the procsym is inserted,
  2799. because that is visible to the world }
  2800. mangledname:=make_mangledname('',procsym.owner,procsym.name);
  2801. oldlen:=length(mangledname);
  2802. { add parameter types }
  2803. for i:=0 to paras.count-1 do
  2804. begin
  2805. hp:=tparavarsym(paras[i]);
  2806. if not(vo_is_hidden_para in hp.varoptions) then
  2807. mangledname:=mangledname+'$'+hp.vardef.mangledparaname;
  2808. end;
  2809. { add resultdef, add $$ as separator to make it unique from a
  2810. parameter separator }
  2811. if not is_void(returndef) then
  2812. mangledname:=mangledname+'$$'+returndef.mangledparaname;
  2813. newlen:=length(mangledname);
  2814. { Replace with CRC if the parameter line is very long }
  2815. if (newlen-oldlen>12) and
  2816. ((newlen>128) or (newlen-oldlen>64)) then
  2817. begin
  2818. crc:=$ffffffff;
  2819. for i:=0 to paras.count-1 do
  2820. begin
  2821. hp:=tparavarsym(paras[i]);
  2822. if not(vo_is_hidden_para in hp.varoptions) then
  2823. begin
  2824. hs:=hp.vardef.mangledparaname;
  2825. crc:=UpdateCrc32(crc,hs[1],length(hs));
  2826. end;
  2827. end;
  2828. hs:=hp.vardef.mangledparaname;
  2829. crc:=UpdateCrc32(crc,hs[1],length(hs));
  2830. mangledname:=Copy(mangledname,1,oldlen)+'$crc'+hexstr(crc,8);
  2831. end;
  2832. {$ifdef compress}
  2833. _mangledname:=stringdup(minilzw_encode(mangledname));
  2834. {$else}
  2835. _mangledname:=stringdup(mangledname);
  2836. {$endif}
  2837. end;
  2838. function tprocdef.cplusplusmangledname : string;
  2839. function getcppparaname(p : tdef) : string;
  2840. const
  2841. ordtype2str : array[tordtype] of string[2] = (
  2842. '',
  2843. 'Uc','Us','Ui','Us',
  2844. 'Sc','s','i','x',
  2845. 'b','b','b','b',
  2846. 'c','w','x');
  2847. var
  2848. s : string;
  2849. begin
  2850. case p.typ of
  2851. orddef:
  2852. s:=ordtype2str[torddef(p).ordtype];
  2853. pointerdef:
  2854. s:='P'+getcppparaname(tpointerdef(p).pointeddef);
  2855. else
  2856. internalerror(2103001);
  2857. end;
  2858. getcppparaname:=s;
  2859. end;
  2860. var
  2861. s,s2 : string;
  2862. hp : TParavarsym;
  2863. i : integer;
  2864. begin
  2865. s := procsym.realname;
  2866. if procsym.owner.symtabletype=ObjectSymtable then
  2867. begin
  2868. s2:=upper(tobjectdef(procsym.owner.defowner).typesym.realname);
  2869. case proctypeoption of
  2870. potype_destructor:
  2871. s:='_$_'+tostr(length(s2))+s2;
  2872. potype_constructor:
  2873. s:='___'+tostr(length(s2))+s2;
  2874. else
  2875. s:='_'+s+'__'+tostr(length(s2))+s2;
  2876. end;
  2877. end
  2878. else s:=s+'__';
  2879. s:=s+'F';
  2880. { concat modifiers }
  2881. { !!!!! }
  2882. { now we handle the parameters }
  2883. if maxparacount>0 then
  2884. begin
  2885. for i:=0 to paras.count-1 do
  2886. begin
  2887. hp:=tparavarsym(paras[i]);
  2888. s2:=getcppparaname(hp.vardef);
  2889. if hp.varspez in [vs_var,vs_out] then
  2890. s2:='R'+s2;
  2891. s:=s+s2;
  2892. end;
  2893. end
  2894. else
  2895. s:=s+'v';
  2896. cplusplusmangledname:=s;
  2897. end;
  2898. procedure tprocdef.setmangledname(const s : string);
  2899. begin
  2900. { This is not allowed anymore, the forward declaration
  2901. already needs to create the correct mangledname, no changes
  2902. afterwards are allowed (PFV) }
  2903. { Exception: interface definitions in mode macpas, since in that }
  2904. { case no reference to the old name can exist yet (JM) }
  2905. if assigned(_mangledname) then
  2906. if ((m_mac in current_settings.modeswitches) and
  2907. (interfacedef)) then
  2908. stringdispose(_mangledname)
  2909. else
  2910. internalerror(200411171);
  2911. {$ifdef compress}
  2912. _mangledname:=stringdup(minilzw_encode(s));
  2913. {$else}
  2914. _mangledname:=stringdup(s);
  2915. {$endif}
  2916. include(procoptions,po_has_mangledname);
  2917. end;
  2918. {***************************************************************************
  2919. TPROCVARDEF
  2920. ***************************************************************************}
  2921. constructor tprocvardef.create(level:byte);
  2922. begin
  2923. inherited create(procvardef,level);
  2924. end;
  2925. constructor tprocvardef.ppuload(ppufile:tcompilerppufile);
  2926. begin
  2927. inherited ppuload(procvardef,ppufile);
  2928. { load para symtable }
  2929. parast:=tparasymtable.create(self,unknown_level);
  2930. tparasymtable(parast).ppuload(ppufile);
  2931. end;
  2932. function tprocvardef.getcopy : tstoreddef;
  2933. begin
  2934. result:=self;
  2935. (*
  2936. { saves a definition to the return type }
  2937. returndef : ttype;
  2938. parast : TSymtable;
  2939. paras : tparalist;
  2940. proctypeoption : tproctypeoption;
  2941. proccalloption : tproccalloption;
  2942. procoptions : tprocoptions;
  2943. requiredargarea : aint;
  2944. { number of user visibile parameters }
  2945. maxparacount,
  2946. minparacount : byte;
  2947. {$ifdef i386}
  2948. fpu_used : longint; { how many stack fpu must be empty }
  2949. {$endif i386}
  2950. funcretloc : array[tcallercallee] of TLocation;
  2951. has_paraloc_info : boolean; { paraloc info is available }
  2952. tprocvardef = class(tabstractprocdef)
  2953. constructor create(level:byte);
  2954. constructor ppuload(ppufile:tcompilerppufile);
  2955. function getcopy : tstoreddef;override;
  2956. *)
  2957. end;
  2958. procedure tprocvardef.ppuwrite(ppufile:tcompilerppufile);
  2959. begin
  2960. { here we cannot get a real good value so just give something }
  2961. { plausible (PM) }
  2962. { a more secure way would be
  2963. to allways store in a temp }
  2964. {$ifdef i386}
  2965. if is_fpu(returndef) then
  2966. fpu_used:={2}maxfpuregs
  2967. else
  2968. fpu_used:=0;
  2969. {$endif i386}
  2970. inherited ppuwrite(ppufile);
  2971. { Write this entry }
  2972. ppufile.writeentry(ibprocvardef);
  2973. { Save the para symtable, this is taken from the interface }
  2974. tparasymtable(parast).ppuwrite(ppufile);
  2975. end;
  2976. function tprocvardef.GetSymtable(t:tGetSymtable):TSymtable;
  2977. begin
  2978. case t of
  2979. gs_para :
  2980. GetSymtable:=parast;
  2981. else
  2982. GetSymtable:=nil;
  2983. end;
  2984. end;
  2985. function tprocvardef.size : aint;
  2986. begin
  2987. if (po_methodpointer in procoptions) and
  2988. not(po_addressonly in procoptions) then
  2989. size:=2*sizeof(aint)
  2990. else
  2991. size:=sizeof(aint);
  2992. end;
  2993. function tprocvardef.is_methodpointer:boolean;
  2994. begin
  2995. result:=(po_methodpointer in procoptions);
  2996. end;
  2997. function tprocvardef.is_addressonly:boolean;
  2998. begin
  2999. result:=not(po_methodpointer in procoptions) or
  3000. (po_addressonly in procoptions);
  3001. end;
  3002. function tprocvardef.getmangledparaname:string;
  3003. begin
  3004. result:='procvar';
  3005. end;
  3006. function tprocvardef.is_publishable : boolean;
  3007. begin
  3008. is_publishable:=(po_methodpointer in procoptions);
  3009. end;
  3010. function tprocvardef.GetTypeName : string;
  3011. var
  3012. s: string;
  3013. showhidden : boolean;
  3014. begin
  3015. {$ifdef EXTDEBUG}
  3016. showhidden:=true;
  3017. {$else EXTDEBUG}
  3018. showhidden:=false;
  3019. {$endif EXTDEBUG}
  3020. s:='<';
  3021. if po_classmethod in procoptions then
  3022. s := s+'class method type of'
  3023. else
  3024. if po_addressonly in procoptions then
  3025. s := s+'address of'
  3026. else
  3027. s := s+'procedure variable type of';
  3028. if po_local in procoptions then
  3029. s := s+' local';
  3030. if assigned(returndef) and
  3031. (returndef<>voidtype) then
  3032. s:=s+' function'+typename_paras(showhidden)+':'+returndef.GetTypeName
  3033. else
  3034. s:=s+' procedure'+typename_paras(showhidden);
  3035. if po_methodpointer in procoptions then
  3036. s := s+' of object';
  3037. GetTypeName := s+';'+ProcCallOptionStr[proccalloption]+'>';
  3038. end;
  3039. {***************************************************************************
  3040. TOBJECTDEF
  3041. ***************************************************************************}
  3042. constructor tobjectdef.create(ot : tobjecttyp;const n : string;c : tobjectdef);
  3043. begin
  3044. inherited create(objectdef);
  3045. objecttype:=ot;
  3046. objectoptions:=[];
  3047. childof:=nil;
  3048. symtable:=tObjectSymtable.create(self,n,current_settings.packrecords);
  3049. { create space for vmt !! }
  3050. vmt_offset:=0;
  3051. lastvtableindex:=0;
  3052. set_parent(c);
  3053. objname:=stringdup(upper(n));
  3054. objrealname:=stringdup(n);
  3055. if objecttype in [odt_interfacecorba,odt_interfacecom,odt_dispinterface] then
  3056. prepareguid;
  3057. { setup implemented interfaces }
  3058. if objecttype in [odt_class,odt_interfacecorba] then
  3059. ImplementedInterfaces:=TFPObjectList.Create(true)
  3060. else
  3061. ImplementedInterfaces:=nil;
  3062. writing_class_record_dbginfo:=false;
  3063. iitype := etStandard;
  3064. end;
  3065. constructor tobjectdef.ppuload(ppufile:tcompilerppufile);
  3066. var
  3067. i,
  3068. implintfcount : longint;
  3069. d : tderef;
  3070. ImplIntf : TImplementedInterface;
  3071. begin
  3072. inherited ppuload(objectdef,ppufile);
  3073. objecttype:=tobjecttyp(ppufile.getbyte);
  3074. objrealname:=stringdup(ppufile.getstring);
  3075. objname:=stringdup(upper(objrealname^));
  3076. symtable:=tObjectSymtable.create(self,objrealname^,0);
  3077. tObjectSymtable(symtable).datasize:=ppufile.getaint;
  3078. tObjectSymtable(symtable).fieldalignment:=ppufile.getbyte;
  3079. tObjectSymtable(symtable).recordalignment:=ppufile.getbyte;
  3080. vmt_offset:=ppufile.getlongint;
  3081. ppufile.getderef(childofderef);
  3082. ppufile.getsmallset(objectoptions);
  3083. { load guid }
  3084. iidstr:=nil;
  3085. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3086. begin
  3087. new(iidguid);
  3088. ppufile.getguid(iidguid^);
  3089. iidstr:=stringdup(ppufile.getstring);
  3090. lastvtableindex:=ppufile.getlongint;
  3091. end;
  3092. { load implemented interfaces }
  3093. if objecttype in [odt_class,odt_interfacecorba] then
  3094. begin
  3095. ImplementedInterfaces:=TFPObjectList.Create(true);
  3096. implintfcount:=ppufile.getlongint;
  3097. for i:=0 to implintfcount-1 do
  3098. begin
  3099. ppufile.getderef(d);
  3100. ImplIntf:=TImplementedInterface.Create_deref(d);
  3101. ImplIntf.IOffset:=ppufile.getlongint;
  3102. ImplementedInterfaces.Add(ImplIntf);
  3103. end;
  3104. end
  3105. else
  3106. ImplementedInterfaces:=nil;
  3107. tObjectSymtable(symtable).ppuload(ppufile);
  3108. { handles the predefined class tobject }
  3109. { the last TOBJECT which is loaded gets }
  3110. { it ! }
  3111. if (childof=nil) and
  3112. (objecttype=odt_class) and
  3113. (objname^='TOBJECT') then
  3114. class_tobject:=self;
  3115. if (childof=nil) and
  3116. (objecttype=odt_interfacecom) and
  3117. (objname^='IUNKNOWN') then
  3118. interface_iunknown:=self;
  3119. writing_class_record_dbginfo:=false;
  3120. end;
  3121. destructor tobjectdef.destroy;
  3122. begin
  3123. if assigned(symtable) then
  3124. begin
  3125. symtable.free;
  3126. symtable:=nil;
  3127. end;
  3128. stringdispose(objname);
  3129. stringdispose(objrealname);
  3130. stringdispose(iidstr);
  3131. if assigned(ImplementedInterfaces) then
  3132. begin
  3133. ImplementedInterfaces.free;
  3134. ImplementedInterfaces:=nil;
  3135. end;
  3136. if assigned(iidguid) then
  3137. begin
  3138. dispose(iidguid);
  3139. iidguid:=nil;
  3140. end;
  3141. inherited destroy;
  3142. end;
  3143. function tobjectdef.getcopy : tstoreddef;
  3144. var
  3145. i : longint;
  3146. begin
  3147. result:=tobjectdef.create(objecttype,objname^,childof);
  3148. tobjectdef(result).symtable:=symtable.getcopy;
  3149. if assigned(objname) then
  3150. tobjectdef(result).objname:=stringdup(objname^);
  3151. if assigned(objrealname) then
  3152. tobjectdef(result).objrealname:=stringdup(objrealname^);
  3153. tobjectdef(result).objectoptions:=objectoptions;
  3154. tobjectdef(result).vmt_offset:=vmt_offset;
  3155. if assigned(iidguid) then
  3156. begin
  3157. new(tobjectdef(result).iidguid);
  3158. move(iidguid^,tobjectdef(result).iidguid^,sizeof(iidguid^));
  3159. end;
  3160. if assigned(iidstr) then
  3161. tobjectdef(result).iidstr:=stringdup(iidstr^);
  3162. tobjectdef(result).lastvtableindex:=lastvtableindex;
  3163. if assigned(ImplementedInterfaces) then
  3164. begin
  3165. for i:=0 to ImplementedInterfaces.count-1 do
  3166. tobjectdef(result).ImplementedInterfaces.Add(TImplementedInterface(ImplementedInterfaces[i]).Getcopy);
  3167. end;
  3168. end;
  3169. procedure tobjectdef.ppuwrite(ppufile:tcompilerppufile);
  3170. var
  3171. i : longint;
  3172. ImplIntf : TImplementedInterface;
  3173. begin
  3174. inherited ppuwrite(ppufile);
  3175. ppufile.putbyte(byte(objecttype));
  3176. ppufile.putstring(objrealname^);
  3177. ppufile.putaint(tObjectSymtable(symtable).datasize);
  3178. ppufile.putbyte(tObjectSymtable(symtable).fieldalignment);
  3179. ppufile.putbyte(tObjectSymtable(symtable).recordalignment);
  3180. ppufile.putlongint(vmt_offset);
  3181. ppufile.putderef(childofderef);
  3182. ppufile.putsmallset(objectoptions);
  3183. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3184. begin
  3185. ppufile.putguid(iidguid^);
  3186. ppufile.putstring(iidstr^);
  3187. ppufile.putlongint(lastvtableindex);
  3188. end;
  3189. if objecttype in [odt_class,odt_interfacecorba] then
  3190. begin
  3191. ppufile.putlongint(ImplementedInterfaces.Count);
  3192. for i:=0 to ImplementedInterfaces.Count-1 do
  3193. begin
  3194. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  3195. ppufile.putderef(ImplIntf.intfdefderef);
  3196. ppufile.putlongint(ImplIntf.Ioffset);
  3197. end;
  3198. end;
  3199. ppufile.writeentry(ibobjectdef);
  3200. tObjectSymtable(symtable).ppuwrite(ppufile);
  3201. end;
  3202. function tobjectdef.GetTypeName:string;
  3203. begin
  3204. if (self <> aktobjectdef) then
  3205. GetTypeName:=typename
  3206. else
  3207. { in this case we will go in endless recursion, because then }
  3208. { there is no tsym associated yet with the def. It can occur }
  3209. { (tests/webtbf/tw4757.pp), so for now give a generic name }
  3210. { instead of the actual type name }
  3211. GetTypeName:='<Currently Parsed Class>';
  3212. end;
  3213. procedure tobjectdef.buildderef;
  3214. var
  3215. i : longint;
  3216. begin
  3217. inherited buildderef;
  3218. childofderef.build(childof);
  3219. tstoredsymtable(symtable).buildderef;
  3220. if objecttype in [odt_class,odt_interfacecorba] then
  3221. begin
  3222. for i:=0 to ImplementedInterfaces.count-1 do
  3223. TImplementedInterface(ImplementedInterfaces[i]).buildderef;
  3224. end;
  3225. end;
  3226. procedure tobjectdef.deref;
  3227. var
  3228. i : longint;
  3229. begin
  3230. inherited deref;
  3231. childof:=tobjectdef(childofderef.resolve);
  3232. tstoredsymtable(symtable).deref;
  3233. if objecttype in [odt_class,odt_interfacecorba] then
  3234. begin
  3235. for i:=0 to ImplementedInterfaces.count-1 do
  3236. TImplementedInterface(ImplementedInterfaces[i]).deref;
  3237. end;
  3238. end;
  3239. function tobjectdef.getparentdef:tdef;
  3240. begin
  3241. {$warning TODO Remove getparentdef hack}
  3242. { With 2 forward declared classes with the child class before the
  3243. parent class the child class is written earlier to the ppu. Leaving it
  3244. possible to have a reference to the parent class for property overriding,
  3245. but the parent class still has the childof not resolved yet (PFV) }
  3246. if childof=nil then
  3247. childof:=tobjectdef(childofderef.resolve);
  3248. result:=childof;
  3249. end;
  3250. procedure tobjectdef.prepareguid;
  3251. begin
  3252. { set up guid }
  3253. if not assigned(iidguid) then
  3254. begin
  3255. new(iidguid);
  3256. fillchar(iidguid^,sizeof(iidguid^),0); { default null guid }
  3257. end;
  3258. { setup iidstring }
  3259. if not assigned(iidstr) then
  3260. iidstr:=stringdup(''); { default is empty string }
  3261. end;
  3262. procedure tobjectdef.set_parent( c : tobjectdef);
  3263. begin
  3264. { nothing to do if the parent was not forward !}
  3265. if assigned(childof) then
  3266. exit;
  3267. childof:=c;
  3268. { some options are inherited !! }
  3269. if assigned(c) then
  3270. begin
  3271. { only important for classes }
  3272. lastvtableindex:=c.lastvtableindex;
  3273. objectoptions:=objectoptions+(c.objectoptions*
  3274. inherited_objectoptions);
  3275. if not (objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) then
  3276. begin
  3277. { add the data of the anchestor class }
  3278. inc(tObjectSymtable(symtable).datasize,tObjectSymtable(c.symtable).datasize);
  3279. if (oo_has_vmt in objectoptions) and
  3280. (oo_has_vmt in c.objectoptions) then
  3281. dec(tObjectSymtable(symtable).datasize,sizeof(aint));
  3282. { if parent has a vmt field then
  3283. the offset is the same for the child PM }
  3284. if (oo_has_vmt in c.objectoptions) or is_class(self) then
  3285. begin
  3286. vmt_offset:=c.vmt_offset;
  3287. include(objectoptions,oo_has_vmt);
  3288. end;
  3289. end;
  3290. end;
  3291. end;
  3292. procedure tobjectdef.insertvmt;
  3293. begin
  3294. if objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3295. exit;
  3296. if (oo_has_vmt in objectoptions) then
  3297. internalerror(12345)
  3298. else
  3299. begin
  3300. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,
  3301. tObjectSymtable(symtable).fieldalignment);
  3302. {$ifdef cpurequiresproperalignment}
  3303. tObjectSymtable(symtable).datasize:=align(tObjectSymtable(symtable).datasize,sizeof(aint));
  3304. {$endif cpurequiresproperalignment}
  3305. vmt_offset:=tObjectSymtable(symtable).datasize;
  3306. inc(tObjectSymtable(symtable).datasize,sizeof(aint));
  3307. include(objectoptions,oo_has_vmt);
  3308. end;
  3309. end;
  3310. procedure tobjectdef.check_forwards;
  3311. begin
  3312. if not(objecttype in [odt_interfacecom,odt_interfacecorba,odt_dispinterface]) then
  3313. tstoredsymtable(symtable).check_forwards;
  3314. if (oo_is_forward in objectoptions) then
  3315. begin
  3316. { ok, in future, the forward can be resolved }
  3317. Message1(sym_e_class_forward_not_resolved,objrealname^);
  3318. exclude(objectoptions,oo_is_forward);
  3319. end;
  3320. end;
  3321. { true, if self inherits from d (or if they are equal) }
  3322. function tobjectdef.is_related(d : tdef) : boolean;
  3323. var
  3324. hp : tobjectdef;
  3325. begin
  3326. hp:=self;
  3327. while assigned(hp) do
  3328. begin
  3329. if hp=d then
  3330. begin
  3331. is_related:=true;
  3332. exit;
  3333. end;
  3334. hp:=hp.childof;
  3335. end;
  3336. is_related:=false;
  3337. end;
  3338. function tobjectdef.FindDestructor : tprocdef;
  3339. var
  3340. objdef : tobjectdef;
  3341. i : longint;
  3342. sym : tsym;
  3343. pd : tprocdef;
  3344. begin
  3345. result:=nil;
  3346. objdef:=self;
  3347. while assigned(objdef) do
  3348. begin
  3349. for i:=0 to objdef.symtable.SymList.Count-1 do
  3350. begin
  3351. sym:=TSym(objdef.symtable.SymList[i]);
  3352. if sym.typ=procsym then
  3353. begin
  3354. pd:=Tprocsym(sym).Find_procdef_bytype(potype_destructor);
  3355. if assigned(pd) then
  3356. begin
  3357. result:=pd;
  3358. exit;
  3359. end;
  3360. end;
  3361. end;
  3362. objdef:=objdef.childof;
  3363. end;
  3364. end;
  3365. function tobjectdef.size : aint;
  3366. begin
  3367. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3368. result:=sizeof(aint)
  3369. else
  3370. result:=tObjectSymtable(symtable).datasize;
  3371. end;
  3372. function tobjectdef.alignment:shortint;
  3373. begin
  3374. if objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  3375. alignment:=sizeof(aint)
  3376. else
  3377. alignment:=tObjectSymtable(symtable).recordalignment;
  3378. end;
  3379. function tobjectdef.vmtmethodoffset(index:longint):longint;
  3380. begin
  3381. { for offset of methods for classes, see rtl/inc/objpash.inc }
  3382. case objecttype of
  3383. odt_class:
  3384. { the +2*sizeof(Aint) is size and -size }
  3385. vmtmethodoffset:=(index+10)*sizeof(aint)+2*sizeof(AInt);
  3386. odt_interfacecom,odt_interfacecorba:
  3387. vmtmethodoffset:=index*sizeof(aint);
  3388. else
  3389. {$ifdef WITHDMT}
  3390. vmtmethodoffset:=(index+4)*sizeof(aint);
  3391. {$else WITHDMT}
  3392. vmtmethodoffset:=(index+3)*sizeof(aint);
  3393. {$endif WITHDMT}
  3394. end;
  3395. end;
  3396. function tobjectdef.vmt_mangledname : string;
  3397. begin
  3398. if not(oo_has_vmt in objectoptions) then
  3399. Message1(parser_n_object_has_no_vmt,objrealname^);
  3400. vmt_mangledname:=make_mangledname('VMT',owner,objname^);
  3401. end;
  3402. function tobjectdef.needs_inittable : boolean;
  3403. begin
  3404. case objecttype of
  3405. odt_dispinterface,
  3406. odt_class :
  3407. needs_inittable:=false;
  3408. odt_interfacecom:
  3409. needs_inittable:=true;
  3410. odt_interfacecorba:
  3411. needs_inittable:=is_related(interface_iunknown);
  3412. odt_object:
  3413. needs_inittable:=tObjectSymtable(symtable).needs_init_final;
  3414. else
  3415. internalerror(200108267);
  3416. end;
  3417. end;
  3418. function tobjectdef.members_need_inittable : boolean;
  3419. begin
  3420. members_need_inittable:=tObjectSymtable(symtable).needs_init_final;
  3421. end;
  3422. function tobjectdef.find_implemented_interface(aintfdef:tobjectdef):TImplementedInterface;
  3423. var
  3424. ImplIntf : TImplementedInterface;
  3425. i : longint;
  3426. begin
  3427. result:=nil;
  3428. if not assigned(ImplementedInterfaces) then
  3429. exit;
  3430. for i:=0 to ImplementedInterfaces.Count-1 do
  3431. begin
  3432. ImplIntf:=TImplementedInterface(ImplementedInterfaces[i]);
  3433. if ImplIntf.intfdef=aintfdef then
  3434. begin
  3435. result:=ImplIntf;
  3436. exit;
  3437. end;
  3438. end;
  3439. end;
  3440. function tobjectdef.is_publishable : boolean;
  3441. begin
  3442. is_publishable:=objecttype in [odt_class,odt_interfacecom,odt_interfacecorba];
  3443. end;
  3444. {****************************************************************************
  3445. TImplementedInterface
  3446. ****************************************************************************}
  3447. constructor TImplementedInterface.create(aintf: tobjectdef);
  3448. begin
  3449. inherited create;
  3450. intfdef:=aintf;
  3451. ioffset:=-1;
  3452. NameMappings:=nil;
  3453. procdefs:=nil;
  3454. end;
  3455. constructor TImplementedInterface.create_deref(d:tderef);
  3456. begin
  3457. inherited create;
  3458. intfdef:=nil;
  3459. intfdefderef:=d;
  3460. ioffset:=-1;
  3461. NameMappings:=nil;
  3462. procdefs:=nil;
  3463. end;
  3464. destructor TImplementedInterface.destroy;
  3465. var
  3466. i : longint;
  3467. mappedname : pshortstring;
  3468. begin
  3469. if assigned(NameMappings) then
  3470. begin
  3471. for i:=0 to NameMappings.Count-1 do
  3472. begin
  3473. mappedname:=pshortstring(NameMappings[i]);
  3474. stringdispose(mappedname);
  3475. end;
  3476. NameMappings.free;
  3477. NameMappings:=nil;
  3478. end;
  3479. if assigned(procdefs) then
  3480. begin
  3481. procdefs.free;
  3482. procdefs:=nil;
  3483. end;
  3484. inherited destroy;
  3485. end;
  3486. procedure TImplementedInterface.buildderef;
  3487. begin
  3488. intfdefderef.build(intfdef);
  3489. end;
  3490. procedure TImplementedInterface.deref;
  3491. begin
  3492. intfdef:=tobjectdef(intfdefderef.resolve);
  3493. end;
  3494. procedure TImplementedInterface.AddMapping(const origname,newname: string);
  3495. begin
  3496. if not assigned(NameMappings) then
  3497. NameMappings:=TFPHashList.Create;
  3498. NameMappings.Add(origname,stringdup(newname));
  3499. end;
  3500. function TImplementedInterface.GetMapping(const origname: string):string;
  3501. var
  3502. mappedname : pshortstring;
  3503. begin
  3504. result:='';
  3505. if not assigned(NameMappings) then
  3506. exit;
  3507. mappedname:=PShortstring(NameMappings.Find(origname));
  3508. if assigned(mappedname) then
  3509. result:=mappedname^;
  3510. end;
  3511. procedure TImplementedInterface.AddImplProc(pd:tprocdef);
  3512. var
  3513. i : longint;
  3514. found : boolean;
  3515. begin
  3516. if not assigned(procdefs) then
  3517. procdefs:=TFPObjectList.Create(false);
  3518. { No duplicate entries of the same procdef }
  3519. found:=false;
  3520. for i:=0 to procdefs.count-1 do
  3521. if tprocdef(procdefs[i])=pd then
  3522. begin
  3523. found:=true;
  3524. break;
  3525. end;
  3526. if not found then
  3527. procdefs.Add(pd);
  3528. end;
  3529. function TImplementedInterface.IsImplMergePossible(MergingIntf:TImplementedInterface;out weight: longint): boolean;
  3530. var
  3531. i : longint;
  3532. begin
  3533. result:=false;
  3534. weight:=0;
  3535. { empty interface is mergeable }
  3536. if ProcDefs.Count=0 then
  3537. begin
  3538. result:=true;
  3539. exit;
  3540. end;
  3541. { The interface to merge must at least the number of
  3542. procedures of this interface }
  3543. if MergingIntf.ProcDefs.Count<ProcDefs.Count then
  3544. exit;
  3545. for i:=0 to ProcDefs.Count-1 do
  3546. begin
  3547. if MergingIntf.ProcDefs[i]<>ProcDefs[i] then
  3548. exit;
  3549. end;
  3550. weight:=ProcDefs.Count;
  3551. result:=true;
  3552. end;
  3553. function TImplementedInterface.getcopy:TImplementedInterface;
  3554. begin
  3555. Result:=TImplementedInterface.Create(nil);
  3556. Move(pointer(self)^,pointer(result)^,InstanceSize);
  3557. end;
  3558. {****************************************************************************
  3559. TFORWARDDEF
  3560. ****************************************************************************}
  3561. constructor tforwarddef.create(const s:string;const pos : tfileposinfo);
  3562. begin
  3563. inherited create(forwarddef);
  3564. tosymname:=stringdup(s);
  3565. forwardpos:=pos;
  3566. end;
  3567. function tforwarddef.GetTypeName:string;
  3568. begin
  3569. GetTypeName:='unresolved forward to '+tosymname^;
  3570. end;
  3571. destructor tforwarddef.destroy;
  3572. begin
  3573. stringdispose(tosymname);
  3574. inherited destroy;
  3575. end;
  3576. {****************************************************************************
  3577. TUNDEFINEDDEF
  3578. ****************************************************************************}
  3579. constructor tundefineddef.create;
  3580. begin
  3581. inherited create(undefineddef);
  3582. end;
  3583. constructor tundefineddef.ppuload(ppufile:tcompilerppufile);
  3584. begin
  3585. inherited ppuload(undefineddef,ppufile);
  3586. end;
  3587. function tundefineddef.GetTypeName:string;
  3588. begin
  3589. GetTypeName:='<undefined type>';
  3590. end;
  3591. procedure tundefineddef.ppuwrite(ppufile:tcompilerppufile);
  3592. begin
  3593. inherited ppuwrite(ppufile);
  3594. ppufile.writeentry(ibundefineddef);
  3595. end;
  3596. {****************************************************************************
  3597. TERRORDEF
  3598. ****************************************************************************}
  3599. constructor terrordef.create;
  3600. begin
  3601. inherited create(errordef);
  3602. end;
  3603. procedure terrordef.ppuwrite(ppufile:tcompilerppufile);
  3604. begin
  3605. { Can't write errordefs to ppu }
  3606. internalerror(200411063);
  3607. end;
  3608. function terrordef.GetTypeName:string;
  3609. begin
  3610. GetTypeName:='<erroneous type>';
  3611. end;
  3612. function terrordef.getmangledparaname:string;
  3613. begin
  3614. getmangledparaname:='error';
  3615. end;
  3616. {****************************************************************************
  3617. Definition Helpers
  3618. ****************************************************************************}
  3619. function is_interfacecom(def: tdef): boolean;
  3620. begin
  3621. is_interfacecom:=
  3622. assigned(def) and
  3623. (def.typ=objectdef) and
  3624. (tobjectdef(def).objecttype=odt_interfacecom);
  3625. end;
  3626. function is_interfacecorba(def: tdef): boolean;
  3627. begin
  3628. is_interfacecorba:=
  3629. assigned(def) and
  3630. (def.typ=objectdef) and
  3631. (tobjectdef(def).objecttype=odt_interfacecorba);
  3632. end;
  3633. function is_interface(def: tdef): boolean;
  3634. begin
  3635. is_interface:=
  3636. assigned(def) and
  3637. (def.typ=objectdef) and
  3638. (tobjectdef(def).objecttype in [odt_interfacecom,odt_interfacecorba]);
  3639. end;
  3640. function is_dispinterface(def: tdef): boolean;
  3641. begin
  3642. result:=
  3643. assigned(def) and
  3644. (def.typ=objectdef) and
  3645. (tobjectdef(def).objecttype=odt_dispinterface);
  3646. end;
  3647. function is_class(def: tdef): boolean;
  3648. begin
  3649. is_class:=
  3650. assigned(def) and
  3651. (def.typ=objectdef) and
  3652. (tobjectdef(def).objecttype=odt_class);
  3653. end;
  3654. function is_object(def: tdef): boolean;
  3655. begin
  3656. is_object:=
  3657. assigned(def) and
  3658. (def.typ=objectdef) and
  3659. (tobjectdef(def).objecttype=odt_object);
  3660. end;
  3661. function is_cppclass(def: tdef): boolean;
  3662. begin
  3663. is_cppclass:=
  3664. assigned(def) and
  3665. (def.typ=objectdef) and
  3666. (tobjectdef(def).objecttype=odt_cppclass);
  3667. end;
  3668. function is_class_or_interface(def: tdef): boolean;
  3669. begin
  3670. is_class_or_interface:=
  3671. assigned(def) and
  3672. (def.typ=objectdef) and
  3673. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba]);
  3674. end;
  3675. function is_class_or_interface_or_dispinterface(def: tdef): boolean;
  3676. begin
  3677. result:=
  3678. assigned(def) and
  3679. (def.typ=objectdef) and
  3680. (tobjectdef(def).objecttype in [odt_class,odt_interfacecom,odt_interfacecorba,odt_dispinterface]);
  3681. end;
  3682. {$ifdef x86}
  3683. function use_sse(def : tdef) : boolean;
  3684. begin
  3685. use_sse:=(is_single(def) and (current_settings.fputype in sse_singlescalar)) or
  3686. (is_double(def) and (current_settings.fputype in sse_doublescalar));
  3687. end;
  3688. {$endif x86}
  3689. end.