ppudump.pp 90 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108
  1. {
  2. Copyright (c) 1998-2013 by the FPC Development Team
  3. Dumps the contents of a FPC unit file (PPU File)
  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. program ppudump;
  17. {$i fpcdefs.inc}
  18. {$H+}
  19. {$define IN_PPUDUMP}
  20. uses
  21. { do NOT add symconst or globtype to make merging easier }
  22. { do include symconst and globtype now before splitting 2.5 PM 2011-06-15 }
  23. SysUtils,
  24. constexp,
  25. symconst,
  26. ppu,
  27. systems,
  28. globals,
  29. globtype,
  30. widestr,
  31. tokens;
  32. const
  33. Version = 'Version 2.7.1';
  34. Title = 'PPU-Analyser';
  35. Copyright = 'Copyright (c) 1998-2013 by the Free Pascal Development Team';
  36. { verbosity }
  37. v_none = $0;
  38. v_header = $1;
  39. v_defs = $2;
  40. v_syms = $4;
  41. v_interface = $8;
  42. v_implementation = $10;
  43. // v_browser = $20;
  44. v_all = $ff;
  45. { not needed anymore $i systems.inc }
  46. { List of all supported cpus }
  47. const
  48. CpuTxt : array[tsystemcpu] of string[9]=
  49. (
  50. { 0 } 'none',
  51. { 1 } 'i386',
  52. { 2 } 'm68k',
  53. { 3 } 'alpha',
  54. { 4 } 'powerpc',
  55. { 5 } 'sparc',
  56. { 6 } 'vis',
  57. { 7 } 'ia64',
  58. { 8 } 'x86_64',
  59. { 9 } 'mipseb',
  60. { 10 } 'arm',
  61. { 11 } 'powerpc64',
  62. { 12 } 'avr',
  63. { 13 } 'mipsel',
  64. { 14 } 'jvm'
  65. );
  66. { List of all supported system-cpu couples }
  67. const
  68. Targets : array[tsystem] of string[18]=(
  69. { 0 } 'none',
  70. { 1 } 'GO32V1 (obsolete)',
  71. { 2 } 'GO32V2',
  72. { 3 } 'Linux-i386',
  73. { 4 } 'OS/2',
  74. { 5 } 'Win32',
  75. { 6 } 'FreeBSD-i386',
  76. { 7 } 'Amiga',
  77. { 8 } 'Atari',
  78. { 9 } 'MacOS-m68k',
  79. { 10 } 'Linux-m68k',
  80. { 11 } 'PalmOS-m68k',
  81. { 12 } 'Linux-alpha',
  82. { 13 } 'Linux-ppc',
  83. { 14 } 'MacOS-ppc',
  84. { 15 } 'Solaris-i386',
  85. { 16 } 'BeOS-i386',
  86. { 17 } 'NetBSD-i386',
  87. { 18 } 'NetBSD-m68k',
  88. { 19 } 'Netware-i386-clib',
  89. { 20 } 'Qnx-i386',
  90. { 21 } 'WDOSX-i386',
  91. { 22 } 'Solaris-sparc',
  92. { 23 } 'Linux-sparc',
  93. { 24 } 'OpenBSD-i386',
  94. { 25 } 'OpenBSD-m68k',
  95. { 26 } 'Linux-x86-64',
  96. { 27 } 'MacOSX-ppc',
  97. { 28 } 'OS/2 via EMX',
  98. { 29 } 'NetBSD-powerpc',
  99. { 30 } 'OpenBSD-powerpc',
  100. { 31 } 'Linux-arm',
  101. { 32 } 'Watcom-i386',
  102. { 33 } 'MorphOS-powerpc',
  103. { 34 } 'FreeBSD-x86-64',
  104. { 35 } 'Netware-i386-libc',
  105. { 36 } 'Amiga-PowerPC',
  106. { 37 } 'Win64-x64',
  107. { 38 } 'WinCE-ARM',
  108. { 39 } 'Win64-iA64',
  109. { 40 } 'WinCE-i386',
  110. { 41 } 'Linux-x64',
  111. { 42 } 'GBA-arm',
  112. { 43 } 'Linux-powerpc64',
  113. { 44 } 'Darwin-i386',
  114. { 45 } 'PalmOS-arm',
  115. { 46 } 'MacOSX-powerpc64',
  116. { 47 } 'NDS-arm',
  117. { 48 } 'Embedded-i386',
  118. { 49 } 'Embedded-m68k',
  119. { 50 } 'Embedded-alpha',
  120. { 51 } 'Embedded-powerpc',
  121. { 52 } 'Embedded-sparc',
  122. { 53 } 'Embedded-vm',
  123. { 54 } 'Embedded-iA64',
  124. { 55 } 'Embedded-x64',
  125. { 56 } 'Embedded-mips',
  126. { 57 } 'Embedded-arm',
  127. { 58 } 'Embedded-powerpc64',
  128. { 59 } 'Symbian-i386',
  129. { 60 } 'Symbian-arm',
  130. { 61 } 'MacOSX-x64',
  131. { 62 } 'Embedded-avr',
  132. { 63 } 'Haiku-i386',
  133. { 64 } 'Darwin-ARM',
  134. { 65 } 'Solaris-x86-64',
  135. { 66 } 'Linux-MIPS',
  136. { 67 } 'Linux-MIPSel',
  137. { 68 } 'NativeNT-i386',
  138. { 69 } 'iPhoneSim-i386',
  139. { 70 } 'Wii-powerpc',
  140. { 71 } 'OpenBSD-x86-64',
  141. { 72 } 'NetBSD-x86-64',
  142. { 73 } 'AIX-powerpc',
  143. { 74 } 'AIX-powerpc64',
  144. { 75 } 'Java-JVM',
  145. { 76 } 'Android-JVM',
  146. { 77 } 'Android-arm',
  147. { 78 } 'Android-i386'
  148. );
  149. const
  150. { in widestr, we have the following definition
  151. type
  152. tcompilerwidechar = word;
  153. thus widecharsize seems to always be 2 bytes }
  154. widecharsize : longint = 2;
  155. cpu : tsystemcpu = cpu_no;
  156. { This type is defined in scanner.pas unit }
  157. type
  158. tspecialgenerictoken = (
  159. ST_LOADSETTINGS,
  160. ST_LINE,
  161. ST_COLUMN,
  162. ST_FILEINDEX,
  163. ST_LOADMESSAGES);
  164. var
  165. ppufile : tppufile;
  166. ppuversion : dword;
  167. space : string;
  168. verbose : longint;
  169. derefdata : pbyte;
  170. derefdatalen : longint;
  171. {****************************************************************************
  172. Helper Routines
  173. ****************************************************************************}
  174. {****************************************************************************
  175. Routine to read 80-bit reals
  176. ****************************************************************************
  177. }
  178. type
  179. TSplit80bitReal = packed record
  180. case byte of
  181. 0: (bytes: Array[0..9] of byte);
  182. 1: (words: Array[0..4] of word);
  183. 2: (cards: Array[0..1] of cardinal; w: word);
  184. end;
  185. const
  186. maxDigits = 17;
  187. function Real80bitToStr(var e : TSplit80bitReal) : string;
  188. var
  189. Temp : string;
  190. new : TSplit80bitReal;
  191. fraczero, expmaximal, sign, outside_double : boolean;
  192. exp : smallint;
  193. ext : extended;
  194. d : double;
  195. i : longint;
  196. mantval : qword;
  197. begin
  198. if ppufile.change_endian then
  199. begin
  200. for i:=0 to 9 do
  201. new.bytes[i]:=e.bytes[9-i];
  202. e:=new;
  203. end;
  204. if sizeof(ext)=10 then
  205. begin
  206. ext:=pextended(@e)^;
  207. str(ext,result);
  208. exit;
  209. end;
  210. { extended, format (MSB): 1 Sign bit, 15 bit exponent, 64 bit mantissa }
  211. sign := (e.w and $8000) <> 0;
  212. expMaximal := (e.w and $7fff) = 32767;
  213. exp:=(e.w and $7fff) - 16383 - 63;
  214. fraczero := (e.cards[0] = 0) and
  215. ((e.cards[1] and $7fffffff) = 0);
  216. mantval := qword(e.cards[0]) or (qword(e.cards[1]) shl 32);
  217. if expMaximal then
  218. if fraczero then
  219. if sign then
  220. temp := '-Inf'
  221. else temp := '+Inf'
  222. else temp := 'Nan'
  223. else
  224. begin
  225. d:=double(mantval);
  226. if sign then
  227. d:=-d;
  228. outside_double:=false;
  229. Try
  230. if exp > 0 then
  231. begin
  232. for i:=1 to exp do
  233. d:=d *2.0;
  234. end
  235. else if exp < 0 then
  236. begin
  237. for i:=1 to -exp do
  238. d:=d /2.0;
  239. end;
  240. Except
  241. outside_double:=true;
  242. end;
  243. if (mantval<>0) and (d=0.0) then
  244. outside_double:=true;
  245. if outside_double then
  246. Temp:='Extended value outside double bound'
  247. else
  248. system.str(d,temp);
  249. end;
  250. result:=temp;
  251. end;
  252. const has_errors : boolean = false;
  253. has_more_infos : boolean = false;
  254. Procedure HasMoreInfos;
  255. begin
  256. Writeln('!! Entry has more information stored');
  257. has_more_infos:=true;
  258. end;
  259. procedure SetHasErrors;
  260. begin
  261. has_errors:=true;
  262. end;
  263. Procedure WriteError(const S : string);
  264. Begin
  265. Writeln(S);
  266. SetHasErrors;
  267. End;
  268. function Unknown(const st : string; val :longint) : string;
  269. Begin
  270. Unknown:='<!! Unknown'+st+' value '+tostr(val)+'>';
  271. SetHasErrors;
  272. end;
  273. function ToStr(w:longint):String;
  274. begin
  275. Str(w,ToStr);
  276. end;
  277. Function Target2Str(w:longint):string;
  278. begin
  279. if w<=ord(high(tsystem)) then
  280. Target2Str:=Targets[tsystem(w)]
  281. else
  282. Target2Str:=Unknown('target',w);
  283. end;
  284. Function Cpu2Str(w:longint):string;
  285. begin
  286. if w<=ord(high(tsystemcpu)) then
  287. begin
  288. cpu:=tsystemcpu(w);
  289. Cpu2Str:=CpuTxt[cpu];
  290. end
  291. else
  292. Cpu2Str:=Unknown('cpu',w);
  293. end;
  294. Function Varspez2Str(w:longint):string;
  295. const
  296. { in symconst unit
  297. tvarspez = (vs_value,vs_const,vs_var,vs_out,vs_constref); }
  298. varspezstr : array[tvarspez] of string[8]=('Value','Const','Var','Out','ConstRef','Final');
  299. begin
  300. if w<=ord(high(varspezstr)) then
  301. Varspez2Str:=varspezstr[tvarspez(w)]
  302. else
  303. Varspez2Str:=Unknown('varspez',w);
  304. end;
  305. Function VarRegable2Str(w:longint):string;
  306. { tvarregable type is defined in symconst unit }
  307. const
  308. varregableStr : array[tvarregable] of string[6]=('None','IntReg','FPUReg','MMReg','Addr');
  309. begin
  310. if w<=ord(high(varregablestr)) then
  311. Varregable2Str:=varregablestr[tvarregable(w)]
  312. else
  313. Varregable2Str:=Unknown('regable',w);
  314. end;
  315. Function Visibility2Str(w:longint):string;
  316. const
  317. { tvisibility type is defined in symconst unit }
  318. visibilityName : array[tvisibility] of string[16] = (
  319. 'hidden','strict private','private','strict protected','protected',
  320. 'public','published','<none>'
  321. );
  322. begin
  323. if w<=ord(high(visibilityName)) then
  324. result:=visibilityName[tvisibility(w)]
  325. else
  326. result:=Unknown('visibility',w);
  327. end;
  328. Function Synthetic2Str(w: byte): string;
  329. const
  330. syntheticName : array[tsynthetickind] of string[length('jvm procvar intf constructor')] = (
  331. '<none>','anon inherited','jvm clone','record deep copy',
  332. 'record initilializer', 'empty routine', 'typed const initializer',
  333. 'callthough', 'callthrough if not abstract', 'jvm enum values',
  334. 'jvm enum valueof', 'jvm enum class constructor',
  335. 'jvm enum jumps constructor', 'jvm enum fpcordinal',
  336. 'jvm enum fpcvalueof', 'jvm enum long2set',
  337. 'jvm enum bitset2set', 'jvm enum set2set',
  338. 'jvm procvar invoke', 'jvm procvar intf constructor',
  339. 'jvm virtual class method', 'jvm field getter', 'jvm field setter');
  340. begin
  341. if w<=ord(high(syntheticName)) then
  342. result:=syntheticName[tsynthetickind(w)]
  343. else
  344. result:=Unknown('synthetickind',w);
  345. end;
  346. function PPUFlags2Str(flags:longint):string;
  347. type
  348. tflagopt=record
  349. mask : longint;
  350. str : string[30];
  351. end;
  352. const
  353. flagopts=24;
  354. flagopt : array[1..flagopts] of tflagopt=(
  355. (mask: $1 ;str:'init'),
  356. (mask: $2 ;str:'final'),
  357. (mask: $4 ;str:'big_endian'),
  358. (mask: $8 ;str:'dbx'),
  359. // (mask: $10 ;str:'browser'),
  360. (mask: $20 ;str:'in_library'),
  361. (mask: $40 ;str:'smart_linked'),
  362. (mask: $80 ;str:'static_linked'),
  363. (mask: $100 ;str:'shared_linked'),
  364. // (mask: $200 ;str:'local_browser'),
  365. (mask: $400 ;str:'no_link'),
  366. (mask: $800 ;str:'has_resources'),
  367. (mask: $1000 ;str:'little_endian'),
  368. (mask: $2000 ;str:'release'),
  369. (mask: $4000 ;str:'local_threadvars'),
  370. (mask: $8000 ;str:'fpu_emulation_on'),
  371. (mask: $210000 ;str:'has_debug_info'),
  372. (mask: $10000 ;str:'stabs_debug_info'),
  373. (mask: $200000 ;str:'dwarf_debug_info'),
  374. (mask: $20000 ;str:'local_symtable'),
  375. (mask: $40000 ;str:'uses_variants'),
  376. (mask: $80000 ;str:'has_resourcefiles'),
  377. (mask: $100000 ;str:'has_exports'),
  378. (mask: $400000 ;str:'has_wideinits'),
  379. (mask: $800000 ;str:'has_classinits'),
  380. (mask: $1000000 ;str:'has_resstrinits')
  381. );
  382. var
  383. i,ntflags : longint;
  384. first : boolean;
  385. s : string;
  386. begin
  387. s:='';
  388. if flags<>0 then
  389. begin
  390. ntflags:=flags;
  391. first:=true;
  392. for i:=1to flagopts do
  393. if (flags and flagopt[i].mask)<>0 then
  394. begin
  395. if first then
  396. first:=false
  397. else
  398. s:=s+', ';
  399. s:=s+flagopt[i].str;
  400. ntflags:=ntflags and (not flagopt[i].mask);
  401. end;
  402. end
  403. else
  404. s:='none';
  405. if ntflags<>0 then
  406. begin
  407. s:=s+' unknown '+hexstr(ntflags,8);
  408. SetHasErrors;
  409. end;
  410. PPUFlags2Str:=s;
  411. end;
  412. Function L0(l:longint):string;
  413. {
  414. return the string of value l, if l<10 then insert a zero, so
  415. the string is always at least 2 chars '01','02',etc
  416. }
  417. var
  418. s : string;
  419. begin
  420. Str(l,s);
  421. if l<10 then
  422. s:='0'+s;
  423. L0:=s;
  424. end;
  425. function filetimestring( t : longint) : string;
  426. {
  427. convert dos datetime t to a string YY/MM/DD HH:MM:SS
  428. }
  429. var
  430. DT : TDateTime;
  431. hsec : word;
  432. Year,Month,Day: Word;
  433. hour,min,sec : word;
  434. begin
  435. if t=-1 then
  436. begin
  437. Result := 'Not Found';
  438. SetHasErrors;
  439. exit;
  440. end;
  441. DT := FileDateToDateTime(t);
  442. DecodeTime(DT,hour,min,sec,hsec);
  443. DecodeDate(DT,year,month,day);
  444. Result := L0(Year)+'/'+L0(Month)+'/'+L0(Day)+' '+L0(Hour)+':'+L0(min)+':'+L0(sec);
  445. end;
  446. {****************************************************************************
  447. Read Routines
  448. ****************************************************************************}
  449. procedure readrecsymtableoptions;
  450. var
  451. usefieldalignment : shortint;
  452. begin
  453. if ppufile.readentry<>ibrecsymtableoptions then
  454. begin
  455. SetHasErrors;
  456. exit;
  457. end;
  458. writeln(space,' recordalignment: ',shortint(ppufile.getbyte));
  459. usefieldalignment:=shortint(ppufile.getbyte);
  460. writeln(space,' usefieldalignment: ',usefieldalignment);
  461. if (usefieldalignment=C_alignment) then
  462. writeln(space,' fieldalignment: ',shortint(ppufile.getbyte));
  463. end;
  464. procedure readsymtableoptions(const s: string);
  465. type
  466. tsymtblopt=record
  467. mask : tsymtableoption;
  468. str : string[30];
  469. end;
  470. const
  471. symtblopts=ord(high(tsymtableoption)) + 1;
  472. symtblopt : array[1..symtblopts] of tsymtblopt=(
  473. (mask:sto_has_helper; str:'Has helper'),
  474. (mask:sto_has_generic; str:'Has generic')
  475. );
  476. var
  477. options : tsymtableoptions;
  478. first : boolean;
  479. i : integer;
  480. begin
  481. if ppufile.readentry<>ibsymtableoptions then
  482. begin
  483. SetHasErrors;
  484. exit;
  485. end;
  486. ppufile.getsmallset(options);
  487. if space<>'' then
  488. writeln(space,'------ ',s,' ------');
  489. write(space,'Symtable options: ');
  490. if options<>[] then
  491. begin
  492. first:=true;
  493. for i:=1 to symtblopts do
  494. if (symtblopt[i].mask in options) then
  495. begin
  496. if first then
  497. first:=false
  498. else
  499. write(', ');
  500. write(symtblopt[i].str);
  501. end;
  502. end
  503. else
  504. write('none');
  505. writeln;
  506. end;
  507. procedure readdefinitions(const s:string); forward;
  508. procedure readsymbols(const s:string); forward;
  509. procedure readsymtable(const s: string);
  510. begin
  511. readsymtableoptions(s);
  512. readdefinitions(s);
  513. readsymbols(s);
  514. end;
  515. Procedure ReadLinkContainer(const prefix:string);
  516. {
  517. Read a serie of strings and write to the screen starting every line
  518. with prefix
  519. }
  520. function maskstr(m:longint):string;
  521. { link options are in globtype unit
  522. const
  523. link_none = $0;
  524. link_always = $1;
  525. link_static = $2;
  526. link_smart = $4;
  527. link_shared = $8; }
  528. var
  529. s : string;
  530. begin
  531. s:='';
  532. if (m and link_always)<>0 then
  533. s:=s+'always ';
  534. if (m and link_static)<>0 then
  535. s:=s+'static ';
  536. if (m and link_smart)<>0 then
  537. s:=s+'smart ';
  538. if (m and link_shared)<>0 then
  539. s:=s+'shared ';
  540. maskstr:=s;
  541. end;
  542. var
  543. s : string;
  544. m : longint;
  545. begin
  546. while not ppufile.endofentry do
  547. begin
  548. s:=ppufile.getstring;
  549. m:=ppufile.getlongint;
  550. WriteLn(prefix,s,' (',maskstr(m),')');
  551. end;
  552. end;
  553. Procedure ReadContainer(const prefix:string);
  554. {
  555. Read a serie of strings and write to the screen starting every line
  556. with prefix
  557. }
  558. begin
  559. while not ppufile.endofentry do
  560. WriteLn(prefix,ppufile.getstring);
  561. end;
  562. procedure ReadLoadUnit;
  563. var
  564. ucrc,uintfcrc, indcrc : cardinal;
  565. begin
  566. while not ppufile.EndOfEntry do
  567. begin
  568. write('Uses unit: ',ppufile.getstring);
  569. ucrc:=cardinal(ppufile.getlongint);
  570. uintfcrc:=cardinal(ppufile.getlongint);
  571. indcrc:=cardinal(ppufile.getlongint);
  572. writeln(' (Crc: ',hexstr(ucrc,8),', IntfcCrc: ',hexstr(uintfcrc,8),', IndCrc: ',hexstr(indcrc,8),')');
  573. end;
  574. end;
  575. Procedure ReadDerefmap;
  576. var
  577. i,mapsize : longint;
  578. begin
  579. mapsize:=ppufile.getlongint;
  580. writeln('DerefMapsize: ',mapsize);
  581. for i:=0 to mapsize-1 do
  582. writeln('DerefMap[',i,'] = ',ppufile.getstring);
  583. end;
  584. Procedure ReadImportSymbols;
  585. var
  586. extlibname : string;
  587. j,
  588. extsymcnt : longint;
  589. extsymname : string;
  590. extsymmangledname : string;
  591. extsymordnr : longint;
  592. extsymisvar : boolean;
  593. begin
  594. while not ppufile.endofentry do
  595. begin
  596. extlibname:=ppufile.getstring;
  597. extsymcnt:=ppufile.getlongint;
  598. writeln('External Library: ',extlibname,' (',extsymcnt,' imports)');
  599. for j:=0 to extsymcnt-1 do
  600. begin
  601. extsymname:=ppufile.getstring;
  602. if ppuversion>130 then
  603. extsymmangledname:=ppufile.getstring
  604. else
  605. extsymmangledname:=extsymname;
  606. extsymordnr:=ppufile.getlongint;
  607. extsymisvar:=ppufile.getbyte<>0;
  608. writeln(' ',extsymname,' as ',extsymmangledname,
  609. '(OrdNr: ',extsymordnr,' IsVar: ',extsymisvar,')');
  610. end;
  611. end;
  612. end;
  613. Procedure ReadDerefdata;
  614. begin
  615. derefdatalen:=ppufile.entrysize;
  616. if derefdatalen=0 then
  617. begin
  618. WriteError('!! Error: derefdatalen=0');
  619. exit;
  620. end;
  621. Writeln('Derefdata length: ',derefdatalen);
  622. derefdata:=allocmem(derefdatalen);
  623. ppufile.getdata(derefdata^,derefdatalen);
  624. end;
  625. Procedure FreeDerefdata;
  626. begin
  627. if assigned(derefdata) then
  628. begin
  629. FreeMem(derefdata);
  630. derefdata:=nil;
  631. derefdatalen:=0;
  632. end;
  633. end;
  634. Procedure ReadWpoFileInfo;
  635. begin
  636. Writeln('Compiled with input whole-program optimisation from ',ppufile.getstring,' ',filetimestring(ppufile.getlongint));
  637. end;
  638. Procedure ReadAsmSymbols;
  639. type
  640. { Copied from aasmbase.pas }
  641. TAsmsymbind=(
  642. AB_NONE,AB_EXTERNAL,AB_COMMON,AB_LOCAL,AB_GLOBAL,AB_WEAK_EXTERNAL,
  643. { global in the current program/library, but not visible outside it }
  644. AB_PRIVATE_EXTERN,AB_LAZY,AB_IMPORT);
  645. TAsmsymtype=(
  646. AT_NONE,AT_FUNCTION,AT_DATA,AT_SECTION,AT_LABEL,
  647. {
  648. the address of this code label is taken somewhere in the code
  649. so it must be taken care of it when creating pic
  650. }
  651. AT_ADDR
  652. );
  653. var
  654. s,
  655. bindstr,
  656. typestr : string;
  657. i : longint;
  658. begin
  659. writeln(space,'Number of AsmSymbols: ',ppufile.getlongint);
  660. i:=0;
  661. while (not ppufile.endofentry) and (not ppufile.error) do
  662. begin
  663. s:=ppufile.getstring;
  664. case tasmsymbind(ppufile.getbyte) of
  665. AB_EXTERNAL :
  666. bindstr:='External';
  667. AB_COMMON :
  668. bindstr:='Common';
  669. AB_LOCAL :
  670. bindstr:='Local';
  671. AB_GLOBAL :
  672. bindstr:='Global';
  673. AB_WEAK_EXTERNAL :
  674. bindstr:='Weak external';
  675. AB_PRIVATE_EXTERN :
  676. bindstr:='Private extern';
  677. AB_LAZY :
  678. bindstr:='Lazy';
  679. AB_IMPORT :
  680. bindstr:='Import';
  681. else
  682. begin
  683. bindstr:='<Error !!>';
  684. SetHasErrors;
  685. end;
  686. end;
  687. case tasmsymtype(ppufile.getbyte) of
  688. AT_FUNCTION :
  689. typestr:='Function';
  690. AT_DATA :
  691. typestr:='Data';
  692. AT_SECTION :
  693. typestr:='Section';
  694. AT_LABEL :
  695. typestr:='Label';
  696. AT_ADDR :
  697. typestr:='Label (with address taken)';
  698. else
  699. begin
  700. typestr:='<Error !!>';
  701. SetHasErrors;
  702. end;
  703. end;
  704. Writeln(space,' ',i,' : ',s,' [',bindstr,',',typestr,']');
  705. inc(i);
  706. end;
  707. end;
  708. function getexprint:Tconstexprint;
  709. begin
  710. getexprint.overflow:=false;
  711. getexprint.signed:=boolean(ppufile.getbyte);
  712. getexprint.svalue:=ppufile.getint64;
  713. end;
  714. Procedure ReadPosInfo;
  715. var
  716. info : byte;
  717. fileindex,line,column : longint;
  718. begin
  719. with ppufile do
  720. begin
  721. {
  722. info byte layout in bits:
  723. 0-1 - amount of bytes for fileindex
  724. 2-3 - amount of bytes for line
  725. 4-5 - amount of bytes for column
  726. }
  727. info:=getbyte;
  728. case (info and $03) of
  729. 0 : fileindex:=getbyte;
  730. 1 : fileindex:=getword;
  731. 2 : fileindex:=(getbyte shl 16) or getword;
  732. 3 : fileindex:=getlongint;
  733. end;
  734. case ((info shr 2) and $03) of
  735. 0 : line:=getbyte;
  736. 1 : line:=getword;
  737. 2 : line:=(getbyte shl 16) or getword;
  738. 3 : line:=getlongint;
  739. end;
  740. case ((info shr 4) and $03) of
  741. 0 : column:=getbyte;
  742. 1 : column:=getword;
  743. 2 : column:=(getbyte shl 16) or getword;
  744. 3 : column:=getlongint;
  745. end;
  746. Writeln(fileindex,' (',line,',',column,')');
  747. end;
  748. end;
  749. procedure readderef(const derefspace: string);
  750. var
  751. b : tdereftype;
  752. first : boolean;
  753. idx : longint;
  754. i,n : byte;
  755. pdata : pbyte;
  756. begin
  757. if not assigned(derefdata) then
  758. exit;
  759. first:=true;
  760. idx:=ppufile.getlongint;
  761. if (idx>derefdatalen) then
  762. begin
  763. writeln('!! Error: Deref idx ',idx,' > ',derefdatalen);
  764. SetHasErrors;
  765. exit;
  766. end;
  767. write(derefspace,'(',idx,') ');
  768. pdata:=@derefdata[idx];
  769. i:=0;
  770. n:=pdata[i];
  771. inc(i);
  772. if n<1 then
  773. begin
  774. WriteError('!! Error: Deref len < 1');
  775. exit;
  776. end;
  777. while (i<=n) do
  778. begin
  779. if not first then
  780. write(', ')
  781. else
  782. first:=false;
  783. b:=tdereftype(pdata[i]);
  784. inc(i);
  785. case b of
  786. deref_nil :
  787. write('Nil');
  788. deref_symid :
  789. begin
  790. idx:=pdata[i] shl 24 or pdata[i+1] shl 16 or pdata[i+2] shl 8 or pdata[i+3];
  791. inc(i,4);
  792. write('SymId ',idx);
  793. end;
  794. deref_defid :
  795. begin
  796. idx:=pdata[i] shl 24 or pdata[i+1] shl 16 or pdata[i+2] shl 8 or pdata[i+3];
  797. inc(i,4);
  798. write('DefId ',idx);
  799. end;
  800. deref_unit :
  801. begin
  802. idx:=pdata[i] shl 8 or pdata[i+1];
  803. inc(i,2);
  804. write('Unit ',idx);
  805. end;
  806. else
  807. begin
  808. writeln('!! unsupported dereftyp: ',ord(b));
  809. SetHasErrors;
  810. break;
  811. end;
  812. end;
  813. end;
  814. writeln;
  815. end;
  816. procedure readpropaccesslist(const s:string);
  817. { type tsltype is in symconst unit }
  818. const
  819. slstr : array[tsltype] of string[12] = (
  820. '',
  821. 'load',
  822. 'call',
  823. 'subscript',
  824. 'vec',
  825. 'typeconv',
  826. 'absolutetype'
  827. );
  828. var
  829. sl : tsltype;
  830. begin
  831. readderef('');
  832. repeat
  833. sl:=tsltype(ppufile.getbyte);
  834. if sl=sl_none then
  835. break;
  836. write(s,'(',slstr[sl],') ');
  837. case sl of
  838. sl_call,
  839. sl_load,
  840. sl_subscript :
  841. readderef('');
  842. sl_absolutetype,
  843. sl_typeconv :
  844. readderef('');
  845. sl_vec :
  846. begin
  847. writeln(ppufile.getlongint);
  848. readderef('');
  849. end;
  850. end;
  851. until false;
  852. end;
  853. (*
  854. talignmentinfo = packed record
  855. procalign,
  856. loopalign,
  857. jumpalign,
  858. constalignmin,
  859. constalignmax,
  860. varalignmin,
  861. varalignmax,
  862. localalignmin,
  863. localalignmax,
  864. recordalignmin,
  865. recordalignmax,
  866. maxCrecordalign : longint;
  867. end;
  868. tsettings = packed record
  869. alignment : talignmentinfo;
  870. globalswitches : tglobalswitches;
  871. moduleswitches : tmoduleswitches;
  872. localswitches : tlocalswitches;
  873. modeswitches : tmodeswitches;
  874. optimizerswitches : toptimizerswitches;
  875. { generate information necessary to perform these wpo's during a subsequent compilation }
  876. genwpoptimizerswitches: twpoptimizerswitches;
  877. { perform these wpo's using information generated during a previous compilation }
  878. dowpoptimizerswitches: twpoptimizerswitches;
  879. debugswitches : tdebugswitches;
  880. { 0: old behaviour for sets <=256 elements
  881. >0: round to this size }
  882. setalloc,
  883. packenum : shortint;
  884. packrecords : shortint;
  885. maxfpuregisters : shortint;
  886. cputype,
  887. optimizecputype : tcputype;
  888. fputype : tfputype;
  889. asmmode : tasmmode;
  890. interfacetype : tinterfacetypes;
  891. defproccall : tproccalloption;
  892. sourcecodepage : tcodepagestring;
  893. minfpconstprec : tfloattype;
  894. disabledircache : boolean;
  895. { CPU targets with microcontroller support can add a controller specific unit }
  896. {$if defined(ARM) or defined(AVR)}
  897. controllertype : tcontrollertype;
  898. {$endif defined(ARM) or defined(AVR)}
  899. { WARNING: this pointer cannot be written as such in record token }
  900. pmessage : pmessagestaterecord;
  901. end;
  902. *)
  903. procedure readprocinfooptions(space : string);
  904. (*
  905. tprocinfoflag=(
  906. { procedure has at least one assembler block }
  907. pi_has_assembler_block,
  908. { procedure does a call }
  909. pi_do_call,
  910. { procedure has a try statement = no register optimization }
  911. pi_uses_exceptions,
  912. { procedure is declared as @var(assembler), don't optimize}
  913. pi_is_assembler,
  914. { procedure contains data which needs to be finalized }
  915. pi_needs_implicit_finally,
  916. { procedure has the implicit try..finally generated }
  917. pi_has_implicit_finally,
  918. { procedure uses fpu}
  919. pi_uses_fpu,
  920. { procedure uses GOT for PIC code }
  921. pi_needs_got,
  922. { references var/proc/type/const in static symtable,
  923. i.e. not allowed for inlining from other units }
  924. pi_uses_static_symtable,
  925. { set if the procedure has to push parameters onto the stack }
  926. pi_has_stackparameter,
  927. { set if the procedure has at least one label }
  928. pi_has_label,
  929. { calls itself recursive }
  930. pi_is_recursive,
  931. { stack frame optimization not possible (only on x86 probably) }
  932. pi_needs_stackframe,
  933. { set if the procedure has at least one register saved on the stack }
  934. pi_has_saved_regs,
  935. { dfa was generated for this proc }
  936. pi_dfaavailable,
  937. { subroutine contains interprocedural used labels }
  938. pi_has_interproclabel,
  939. { subroutine contains interprocedural gotos }
  940. pi_has_global_goto
  941. ); *)
  942. type
  943. tprocinfoopt=record
  944. mask : tprocinfoflag;
  945. str : string[81];
  946. end;
  947. const
  948. procinfoopts=ord(high(tprocinfoflag)) - ord(low(tprocinfoflag));
  949. procinfoopt : array[0..procinfoopts] of tprocinfoopt=(
  950. (mask:pi_has_assembler_block;
  951. str:' has at least one assembler block'),
  952. (mask:pi_do_call;
  953. str:' does a call'),
  954. (mask:pi_uses_exceptions;
  955. str:' has a try statement = no register optimization '),
  956. (mask:pi_is_assembler;
  957. str:' is declared as @var(assembler), don''t optimize'),
  958. (mask:pi_needs_implicit_finally;
  959. str:' contains data which needs to be finalized '),
  960. (mask:pi_has_implicit_finally;
  961. str:' has the implicit try..finally generated '),
  962. (mask:pi_uses_fpu;
  963. str:' uses fpu'),
  964. (mask:pi_needs_got;
  965. str:' uses GOT for PIC code '),
  966. (mask:pi_uses_static_symtable;
  967. str:' references var/proc/type/const in static symtable'),
  968. (mask:pi_has_stackparameter;
  969. str:' set if the procedure has to push parameters onto the stack '),
  970. (mask:pi_has_label;
  971. str:' set if the procedure has at least one label '),
  972. (mask:pi_is_recursive;
  973. str:' calls itself recursive '),
  974. (mask:pi_needs_stackframe;
  975. str:' stack frame optimization not possible (only on x86 probably) '),
  976. (mask:pi_has_saved_regs;
  977. str:' set if the procedure has at least one register saved on the stack '),
  978. (mask:pi_dfaavailable;
  979. str:' dfa was generated for this proc '),
  980. (mask:pi_has_interproclabel;
  981. str:' subroutine contains interprocedural used labels '),
  982. (mask:pi_has_unwind_info;
  983. str:' unwinding info was generated for this proc '),
  984. (mask:pi_has_global_goto;
  985. str:' subroutine contains interprocedural goto '),
  986. (mask:pi_has_inherited;
  987. str:' subroutine contains inherited call '),
  988. (mask:pi_has_nested_exit;
  989. str:' subroutine contains a nested subroutine which calls the exit of the current one ')
  990. );
  991. var
  992. procinfooptions : tprocinfoflags;
  993. i : longint;
  994. first : boolean;
  995. begin
  996. ppufile.getsmallset(procinfooptions);
  997. if procinfooptions<>[] then
  998. begin
  999. first:=true;
  1000. for i:=0 to procinfoopts do
  1001. if (procinfoopt[i].mask in procinfooptions) then
  1002. begin
  1003. if first then
  1004. first:=false
  1005. else
  1006. write(', ');
  1007. write(procinfoopt[i].str);
  1008. end;
  1009. end;
  1010. writeln;
  1011. end;
  1012. procedure readsymoptions(space : string);
  1013. type
  1014. tsymopt=record
  1015. mask : tsymoption;
  1016. str : string[30];
  1017. end;
  1018. const
  1019. symopts=ord(high(tsymoption)) - ord(low(tsymoption));
  1020. { sp_none = 0 corresponds to nothing }
  1021. symopt : array[1..symopts] of tsymopt=(
  1022. (mask:sp_static; str:'Static'),
  1023. (mask:sp_hint_deprecated; str:'Hint Deprecated'),
  1024. (mask:sp_hint_platform; str:'Hint Platform'),
  1025. (mask:sp_hint_library; str:'Hint Library'),
  1026. (mask:sp_hint_unimplemented; str:'Hint Unimplemented'),
  1027. (mask:sp_hint_experimental; str:'Hint Experimental'),
  1028. (mask:sp_has_overloaded; str:'Has overloaded'),
  1029. (mask:sp_internal; str:'Internal'),
  1030. (mask:sp_implicitrename; str:'Implicit Rename'),
  1031. (mask:sp_generic_para; str:'Generic Parameter'),
  1032. (mask:sp_has_deprecated_msg; str:'Has Deprecated Message'),
  1033. (mask:sp_generic_dummy; str:'Generic Dummy'),
  1034. (mask:sp_explicitrename; str:'Explicit Rename')
  1035. );
  1036. var
  1037. symoptions : tsymoptions;
  1038. i : longint;
  1039. first : boolean;
  1040. begin
  1041. ppufile.getsmallset(symoptions);
  1042. if symoptions<>[] then
  1043. begin
  1044. first:=true;
  1045. for i:=1to symopts do
  1046. if (symopt[i].mask in symoptions) then
  1047. begin
  1048. if first then
  1049. first:=false
  1050. else
  1051. write(', ');
  1052. write(symopt[i].str);
  1053. end;
  1054. end;
  1055. writeln;
  1056. if sp_has_deprecated_msg in symoptions then
  1057. writeln(space,'Deprecated : ', ppufile.getstring);
  1058. end;
  1059. procedure readcommonsym(const s:string);
  1060. begin
  1061. writeln(space,'** Symbol Id ',ppufile.getlongint,' **');
  1062. writeln(space,s,ppufile.getstring);
  1063. write (space,' File Pos : ');
  1064. readposinfo;
  1065. writeln(space,' Visibility : ',Visibility2Str(ppufile.getbyte));
  1066. write (space,' SymOptions : ');
  1067. readsymoptions(space+' ');
  1068. end;
  1069. var
  1070. { needed during tobjectdef parsing... }
  1071. current_defoptions : tdefoptions;
  1072. current_objectoptions : tobjectoptions;
  1073. procedure readcommondef(const s:string; out defoptions: tdefoptions);
  1074. type
  1075. tdefopt=record
  1076. mask : tdefoption;
  1077. str : string[30];
  1078. end;
  1079. tdefstateinfo=record
  1080. mask : tdefstate;
  1081. str : string[30];
  1082. end;
  1083. ptoken=^ttoken;
  1084. pmsgstate =^tmsgstate;
  1085. const
  1086. defopt : array[1..ord(high(tdefoption))] of tdefopt=(
  1087. (mask:df_unique; str:'Unique Type'),
  1088. (mask:df_generic; str:'Generic'),
  1089. (mask:df_specialization; str:'Specialization'),
  1090. (mask:df_copied_def; str:'Copied Typedef'),
  1091. (mask:df_genconstraint; str:'Generic Constraint')
  1092. );
  1093. defstate : array[1..ord(high(tdefstate))] of tdefstateinfo=(
  1094. (mask:ds_vmt_written; str:'VMT Written'),
  1095. (mask:ds_rtti_table_used; str:'RTTITable Used'),
  1096. (mask:ds_init_table_used; str:'InitTable Used'),
  1097. (mask:ds_rtti_table_written; str:'RTTITable Written'),
  1098. (mask:ds_init_table_written; str:'InitTable Written'),
  1099. (mask:ds_dwarf_dbg_info_used; str:'Dwarf DbgInfo Used'),
  1100. (mask:ds_dwarf_dbg_info_written;str:'Dwarf DbgInfo Written')
  1101. );
  1102. var
  1103. defstates : tdefstates;
  1104. i, nb, msgvalue, mesgnb : longint;
  1105. first : boolean;
  1106. copy_size, min_size, tokenbufsize : longint;
  1107. tokenbuf : pbyte;
  1108. idtoken,
  1109. token : ttoken;
  1110. state : tmsgstate;
  1111. new_settings : Tsettings;
  1112. len : sizeint;
  1113. wstring : widestring;
  1114. astring : ansistring;
  1115. function readtoken: ttoken;
  1116. var
  1117. b,b2 : byte;
  1118. begin
  1119. b:=tokenbuf[i];
  1120. inc(i);
  1121. if (b and $80)<>0 then
  1122. begin
  1123. b2:=tokenbuf[i];
  1124. inc(i);
  1125. result:=ttoken(((b and $7f) shl 8) or b2);
  1126. end
  1127. else
  1128. result:=ttoken(b);
  1129. end;
  1130. function gettokenbufdword : dword;
  1131. var
  1132. var32 : dword;
  1133. begin
  1134. var32:=pdword(@tokenbuf[i])^;
  1135. inc(i,sizeof(dword));
  1136. if ppufile.change_endian then
  1137. var32:=swapendian(var32);
  1138. result:=var32;
  1139. end;
  1140. function gettokenbufword : word;
  1141. var
  1142. var16 : word;
  1143. begin
  1144. var16:=pword(@tokenbuf[i])^;
  1145. inc(i,sizeof(word));
  1146. if ppufile.change_endian then
  1147. var16:=swapendian(var16);
  1148. result:=var16;
  1149. end;
  1150. function gettokenbufsizeint : int64;
  1151. var
  1152. var64 : int64;
  1153. var32 : longint;
  1154. var16 : smallint;
  1155. begin
  1156. if CpuAddrBitSize[cpu]=64 then
  1157. begin
  1158. var64:=pint64(@tokenbuf[i])^;
  1159. inc(i,sizeof(int64));
  1160. if ppufile.change_endian then
  1161. var64:=swapendian(var64);
  1162. result:=var64;
  1163. end
  1164. else if CpuAddrBitSize[cpu]=32 then
  1165. begin
  1166. var32:=plongint(@tokenbuf[i])^;
  1167. inc(i,sizeof(longint));
  1168. if ppufile.change_endian then
  1169. var32:=swapendian(var32);
  1170. result:=var32;
  1171. end
  1172. else if CpuAddrBitSize[cpu]=16 then
  1173. begin
  1174. var16:=psmallint(@tokenbuf[i])^;
  1175. inc(i,sizeof(smallint));
  1176. if ppufile.change_endian then
  1177. var16:=swapendian(var16);
  1178. result:=var16;
  1179. end
  1180. else
  1181. begin
  1182. WriteError('Wrong CpuAddrBitSize');
  1183. result:=0;
  1184. end;
  1185. end;
  1186. begin
  1187. writeln(space,'** Definition Id ',ppufile.getlongint,' **');
  1188. writeln(space,s);
  1189. write (space,' Type symbol : ');
  1190. readderef('');
  1191. write (space,' DefOptions : ');
  1192. ppufile.getsmallset(defoptions);
  1193. if defoptions<>[] then
  1194. begin
  1195. first:=true;
  1196. for i:=1to high(defopt) do
  1197. if (defopt[i].mask in defoptions) then
  1198. begin
  1199. if first then
  1200. first:=false
  1201. else
  1202. write(', ');
  1203. write(defopt[i].str);
  1204. end;
  1205. end;
  1206. writeln;
  1207. write (space,' DefStates : ');
  1208. ppufile.getsmallset(defstates);
  1209. if defstates<>[] then
  1210. begin
  1211. first:=true;
  1212. for i:=1 to high(defstate) do
  1213. if (defstate[i].mask in defstates) then
  1214. begin
  1215. if first then
  1216. first:=false
  1217. else
  1218. write(', ');
  1219. write(defstate[i].str);
  1220. end;
  1221. end;
  1222. writeln;
  1223. if df_generic in defoptions then
  1224. begin
  1225. tokenbufsize:=ppufile.getlongint;
  1226. writeln(space,' Tokenbuffer size : ',tokenbufsize);
  1227. tokenbuf:=allocmem(tokenbufsize);
  1228. ppufile.getdata(tokenbuf^,tokenbufsize);
  1229. i:=0;
  1230. write(space,' Tokens: ');
  1231. while i<tokenbufsize do
  1232. begin
  1233. token:=readtoken;
  1234. if token<>_GENERICSPECIALTOKEN then
  1235. begin
  1236. if token <= high(ttoken) then
  1237. write(arraytokeninfo[token].str)
  1238. else
  1239. begin
  1240. HasMoreInfos;
  1241. write('Error in Token List');
  1242. break;
  1243. end;
  1244. idtoken:=readtoken;
  1245. end;
  1246. case token of
  1247. _CWCHAR,
  1248. _CWSTRING :
  1249. begin
  1250. len:=gettokenbufsizeint;
  1251. setlength(wstring,len);
  1252. move(tokenbuf[i],wstring[1],len*2);
  1253. write(' ',wstring);
  1254. inc(i,len*2);
  1255. end;
  1256. _CSTRING:
  1257. begin
  1258. len:=gettokenbufsizeint;
  1259. setlength(astring,len);
  1260. move(tokenbuf[i],astring[1],len);
  1261. write(' ',astring);
  1262. inc(i,len);
  1263. end;
  1264. _CCHAR,
  1265. _INTCONST,
  1266. _REALNUMBER :
  1267. begin
  1268. write(' ',pshortstring(@tokenbuf[i])^);
  1269. inc(i,tokenbuf[i]+1);
  1270. end;
  1271. _ID :
  1272. begin
  1273. write(' ',pshortstring(@tokenbuf[i])^);
  1274. inc(i,tokenbuf[i]+1);
  1275. end;
  1276. _GENERICSPECIALTOKEN:
  1277. begin
  1278. { Short version of column change,
  1279. byte or $80 used }
  1280. if (tokenbuf[i] and $80)<>0 then
  1281. begin
  1282. write('Col: ',tokenbuf[i] and $7f);
  1283. inc(i);
  1284. end
  1285. else
  1286. case tspecialgenerictoken(tokenbuf[i]) of
  1287. ST_LOADSETTINGS:
  1288. begin
  1289. inc(i);
  1290. write('Settings');
  1291. { This does not load pmessage pointer }
  1292. new_settings.pmessage:=nil;
  1293. { TSettings size depends in target...
  1294. We first read the size of the copied part }
  1295. { Still not cross endian ready :( }
  1296. copy_size:=gettokenbufsizeint;
  1297. if copy_size < sizeof(tsettings)-sizeof(pointer) then
  1298. min_size:=copy_size
  1299. else
  1300. min_size:= sizeof(tsettings)-sizeof(pointer);
  1301. move(tokenbuf[i],new_settings, min_size);
  1302. inc(i,copy_size);
  1303. end;
  1304. ST_LOADMESSAGES:
  1305. begin
  1306. inc(i);
  1307. write('Messages:');
  1308. mesgnb:=tokenbuf[i];
  1309. inc(i);
  1310. for nb:=1 to mesgnb do
  1311. begin
  1312. msgvalue:=gettokenbufsizeint;
  1313. inc(i,sizeof(sizeint));
  1314. state:=tmsgstate(gettokenbufsizeint);
  1315. end;
  1316. end;
  1317. ST_LINE:
  1318. begin
  1319. inc(i);
  1320. write('Line: ',gettokenbufdword);
  1321. end;
  1322. ST_COLUMN:
  1323. begin
  1324. inc(i);
  1325. write('Col: ',gettokenbufword);
  1326. end;
  1327. ST_FILEINDEX:
  1328. begin
  1329. inc(i);
  1330. write('File: ',gettokenbufword);
  1331. end;
  1332. end;
  1333. end;
  1334. end;
  1335. if i<tokenbufsize then
  1336. write(',');
  1337. end;
  1338. writeln;
  1339. freemem(tokenbuf);
  1340. end;
  1341. if df_specialization in defoptions then
  1342. begin
  1343. write (space,' Orig. GenericDef : ');
  1344. readderef('');
  1345. end;
  1346. current_defoptions:=defoptions;
  1347. end;
  1348. { Read abstract procdef and return if inline procdef }
  1349. { type tproccalloption is in globtype unit }
  1350. { type tproctypeoption is in globtype unit }
  1351. { type tprocoption is in globtype unit }
  1352. procedure read_abstract_proc_def(var proccalloption:tproccalloption;var procoptions:tprocoptions);
  1353. type
  1354. tproccallopt=record
  1355. mask : tproccalloption;
  1356. str : string[30];
  1357. end;
  1358. tproctypeopt=record
  1359. mask : tproctypeoption;
  1360. str : string[30];
  1361. end;
  1362. tprocopt=record
  1363. mask : tprocoption;
  1364. str : string[31];
  1365. end;
  1366. const
  1367. {proccalloptionStr is also in globtype unit }
  1368. proctypeopt : array[1..ord(high(tproctypeoption))] of tproctypeopt=(
  1369. (mask:potype_proginit; str:'ProgInit'),
  1370. (mask:potype_unitinit; str:'UnitInit'),
  1371. (mask:potype_unitfinalize; str:'UnitFinalize'),
  1372. (mask:potype_constructor; str:'Constructor'),
  1373. (mask:potype_destructor; str:'Destructor'),
  1374. (mask:potype_operator; str:'Operator'),
  1375. (mask:potype_procedure; str:'Procedure'),
  1376. (mask:potype_function; str:'Function'),
  1377. (mask:potype_class_constructor; str:'Class Constructor'),
  1378. (mask:potype_class_destructor; str:'Class Destructor'),
  1379. { Dispinterface property accessors }
  1380. (mask:potype_propgetter; str:'Property Getter'),
  1381. (mask:potype_propsetter; str:'Property Setter'),
  1382. (mask:potype_exceptfilter; str:'SEH filter')
  1383. );
  1384. procopt : array[1..ord(high(tprocoption))] of tprocopt=(
  1385. (mask:po_classmethod; str:'ClassMethod'),
  1386. (mask:po_virtualmethod; str:'VirtualMethod'),
  1387. (mask:po_abstractmethod; str:'AbstractMethod'),
  1388. (mask:po_finalmethod; str:'FinalMethod'),
  1389. (mask:po_staticmethod; str:'StaticMethod'),
  1390. (mask:po_overridingmethod;str:'OverridingMethod'),
  1391. (mask:po_methodpointer; str:'MethodPointer'),
  1392. (mask:po_interrupt; str:'Interrupt'),
  1393. (mask:po_iocheck; str:'IOCheck'),
  1394. (mask:po_assembler; str:'Assembler'),
  1395. (mask:po_msgstr; str:'MsgStr'),
  1396. (mask:po_msgint; str:'MsgInt'),
  1397. (mask:po_exports; str:'Exports'),
  1398. (mask:po_external; str:'External'),
  1399. (mask:po_overload; str:'Overload'),
  1400. (mask:po_varargs; str:'VarArgs'),
  1401. (mask:po_internconst; str:'InternConst'),
  1402. (mask:po_addressonly; str:'AddressOnly'),
  1403. (mask:po_public; str:'Public'),
  1404. (mask:po_hascallingconvention;str:'HasCallingConvention'),
  1405. (mask:po_reintroduce; str:'ReIntroduce'),
  1406. (mask:po_explicitparaloc; str:'ExplicitParaloc'),
  1407. (mask:po_nostackframe; str:'NoStackFrame'),
  1408. (mask:po_has_mangledname; str:'HasMangledName'),
  1409. (mask:po_has_public_name; str:'HasPublicName'),
  1410. (mask:po_forward; str:'Forward'),
  1411. (mask:po_global; str:'Global'),
  1412. (mask:po_has_inlininginfo;str:'HasInliningInfo'),
  1413. (mask:po_syscall_legacy; str:'SyscallLegacy'),
  1414. (mask:po_syscall_sysv; str:'SyscallSysV'),
  1415. (mask:po_syscall_basesysv;str:'SyscallBaseSysV'),
  1416. (mask:po_syscall_sysvbase;str:'SyscallSysVBase'),
  1417. (mask:po_syscall_r12base; str:'SyscallR12Base'),
  1418. (mask:po_inline; str:'Inline'),
  1419. (mask:po_compilerproc; str:'CompilerProc'),
  1420. (mask:po_has_importdll; str:'HasImportDLL'),
  1421. (mask:po_has_importname; str:'HasImportName'),
  1422. (mask:po_kylixlocal; str:'KylixLocal'),
  1423. (mask:po_dispid; str:'DispId'),
  1424. (mask:po_weakexternal; str:'WeakExternal'),
  1425. (mask:po_objc; str:'ObjC'),
  1426. (mask:po_enumerator_movenext; str:'EnumeratorMoveNext'),
  1427. (mask:po_optional; str: 'Optional'),
  1428. (mask:po_delphi_nested_cc;str: 'Delphi-style nested frameptr'),
  1429. (mask:po_java_nonvirtual; str: 'Java non-virtual method'),
  1430. (mask:po_ignore_for_overload_resolution;str: 'Ignored for overload resolution'),
  1431. (mask:po_rtlproc; str: 'RTL procedure'),
  1432. (mask:po_auto_raised_visibility; str: 'Visibility raised by compiler')
  1433. );
  1434. var
  1435. proctypeoption : tproctypeoption;
  1436. i : longint;
  1437. first : boolean;
  1438. tempbuf : array[0..255] of byte;
  1439. begin
  1440. write(space,' Return type : ');
  1441. readderef('');
  1442. writeln(space,' Fpu used : ',ppufile.getbyte);
  1443. proctypeoption:=tproctypeoption(ppufile.getbyte);
  1444. write(space,' TypeOption : ');
  1445. first:=true;
  1446. for i:=1 to high(proctypeopt) do
  1447. if (proctypeopt[i].mask=proctypeoption) then
  1448. begin
  1449. if first then
  1450. first:=false
  1451. else
  1452. write(', ');
  1453. write(proctypeopt[i].str);
  1454. end;
  1455. writeln;
  1456. proccalloption:=tproccalloption(ppufile.getbyte);
  1457. writeln(space,' CallOption : ',proccalloptionStr[proccalloption]);
  1458. ppufile.getnormalset(procoptions);
  1459. if procoptions<>[] then
  1460. begin
  1461. write(space,' Options : ');
  1462. first:=true;
  1463. for i:=1 to high(procopt) do
  1464. if (procopt[i].mask in procoptions) then
  1465. begin
  1466. if first then
  1467. first:=false
  1468. else
  1469. write(', ');
  1470. write(procopt[i].str);
  1471. end;
  1472. writeln;
  1473. end;
  1474. if (po_explicitparaloc in procoptions) then
  1475. begin
  1476. i:=ppufile.getbyte;
  1477. ppufile.getdata(tempbuf,i);
  1478. end;
  1479. end;
  1480. { type tvaroption is in unit symconst }
  1481. { register variable }
  1482. { type tvarregable is in unit symconst }
  1483. procedure readabstractvarsym(const s:string;var varoptions:tvaroptions);
  1484. type
  1485. tvaropt=record
  1486. mask : tvaroption;
  1487. str : string[30];
  1488. end;
  1489. const
  1490. varopt : array[1..ord(high(tvaroption))] of tvaropt=(
  1491. (mask:vo_is_external; str:'External'),
  1492. (mask:vo_is_dll_var; str:'DLLVar'),
  1493. (mask:vo_is_thread_var; str:'ThreadVar'),
  1494. (mask:vo_has_local_copy; str:'HasLocalCopy'),
  1495. (mask:vo_is_const; str:'Constant'),
  1496. (mask:vo_is_public; str:'Public'),
  1497. (mask:vo_is_high_para; str:'HighValue'),
  1498. (mask:vo_is_funcret; str:'Funcret'),
  1499. (mask:vo_is_self; str:'Self'),
  1500. (mask:vo_is_vmt; str:'VMT'),
  1501. (mask:vo_is_result; str:'Result'),
  1502. (mask:vo_is_parentfp; str:'ParentFP'),
  1503. (mask:vo_is_loop_counter; str:'LoopCounter'),
  1504. (mask:vo_is_hidden_para; str:'Hidden'),
  1505. (mask:vo_has_explicit_paraloc;str:'ExplicitParaloc'),
  1506. (mask:vo_is_syscall_lib; str:'SysCallLib'),
  1507. (mask:vo_has_mangledname; str:'HasMangledName'),
  1508. (mask:vo_is_typed_const; str:'TypedConst'),
  1509. (mask:vo_is_range_check; str:'RangeCheckSwitch'),
  1510. (mask:vo_is_overflow_check; str:'OverflowCheckSwitch'),
  1511. (mask:vo_is_typinfo_para; str:'TypeInfo'),
  1512. (mask:vo_is_msgsel;str:'MsgSel'),
  1513. (mask:vo_is_weak_external;str:'WeakExternal'),
  1514. (mask:vo_is_first_field;str:'IsFirstField'),
  1515. (mask:vo_volatile; str:'Volatile'),
  1516. (mask:vo_has_section; str:'HasSection'),
  1517. (mask:vo_force_finalize; str:'ForceFinalize'),
  1518. (mask:vo_is_default_var; str:'DefaultIntrinsicVar')
  1519. );
  1520. var
  1521. i : longint;
  1522. first : boolean;
  1523. begin
  1524. readcommonsym(s);
  1525. writeln(space,' Spez : ',Varspez2Str(ppufile.getbyte));
  1526. writeln(space,' Regable : ',Varregable2Str(ppufile.getbyte));
  1527. writeln(space,' Addr Taken : ',(ppufile.getbyte<>0));
  1528. write (space,' Var Type : ');
  1529. readderef('');
  1530. ppufile.getsmallset(varoptions);
  1531. if varoptions<>[] then
  1532. begin
  1533. write(space,' Options : ');
  1534. first:=true;
  1535. for i:=1 to high(varopt) do
  1536. if (varopt[i].mask in varoptions) then
  1537. begin
  1538. if first then
  1539. first:=false
  1540. else
  1541. write(', ');
  1542. write(varopt[i].str);
  1543. if varopt[i].mask = vo_has_section then
  1544. writeln('Section name:',ppufile.getansistring);
  1545. end;
  1546. writeln;
  1547. end;
  1548. end;
  1549. procedure readobjectdefoptions;
  1550. type
  1551. tsymopt=record
  1552. mask : tobjectoption;
  1553. str : string[30];
  1554. end;
  1555. const
  1556. symopt : array[1..ord(high(tobjectoption))] of tsymopt=(
  1557. (mask:oo_is_forward; str:'IsForward'),
  1558. (mask:oo_is_abstract; str:'IsAbstract'),
  1559. (mask:oo_is_sealed; str:'IsSealed'),
  1560. (mask:oo_has_virtual; str:'HasVirtual'),
  1561. (mask:oo_has_private; str:'HasPrivate'),
  1562. (mask:oo_has_protected; str:'HasProtected'),
  1563. (mask:oo_has_strictprivate; str:'HasStrictPrivate'),
  1564. (mask:oo_has_strictprotected;str:'HasStrictProtected'),
  1565. (mask:oo_has_constructor; str:'HasConstructor'),
  1566. (mask:oo_has_destructor; str:'HasDestructor'),
  1567. (mask:oo_has_vmt; str:'HasVMT'),
  1568. (mask:oo_has_msgstr; str:'HasMsgStr'),
  1569. (mask:oo_has_msgint; str:'HasMsgInt'),
  1570. (mask:oo_can_have_published; str:'CanHavePublished'),
  1571. (mask:oo_has_default_property;str:'HasDefaultProperty'),
  1572. (mask:oo_has_valid_guid; str:'HasValidGUID'),
  1573. (mask:oo_has_enumerator_movenext; str:'HasEnumeratorMoveNext'),
  1574. (mask:oo_has_enumerator_current; str:'HasEnumeratorCurrent'),
  1575. (mask:oo_is_external; str:'External'),
  1576. (mask:oo_is_formal; str:'Formal'),
  1577. (mask:oo_is_classhelper; str:'Class Helper/Category'),
  1578. (mask:oo_has_class_constructor; str:'HasClassConstructor'),
  1579. (mask:oo_has_class_destructor; str:'HasClassDestructor'),
  1580. (mask:oo_is_enum_class; str:'JvmEnumClass'),
  1581. (mask:oo_has_new_destructor; str:'HasNewDestructor')
  1582. );
  1583. var
  1584. i : longint;
  1585. first : boolean;
  1586. begin
  1587. ppufile.getsmallset(current_objectoptions);
  1588. if current_objectoptions<>[] then
  1589. begin
  1590. first:=true;
  1591. for i:=1 to high(symopt) do
  1592. if (symopt[i].mask in current_objectoptions) then
  1593. begin
  1594. if first then
  1595. first:=false
  1596. else
  1597. write(', ');
  1598. write(symopt[i].str);
  1599. end;
  1600. end;
  1601. writeln;
  1602. end;
  1603. procedure readarraydefoptions;
  1604. { type tarraydefoption is in unit symconst }
  1605. type
  1606. tsymopt=record
  1607. mask : tarraydefoption;
  1608. str : string[30];
  1609. end;
  1610. const
  1611. symopt : array[1..ord(high(tarraydefoption))] of tsymopt=(
  1612. (mask:ado_IsConvertedPointer;str:'ConvertedPointer'),
  1613. (mask:ado_IsDynamicArray; str:'IsDynamicArray'),
  1614. (mask:ado_IsVariant; str:'IsVariant'),
  1615. (mask:ado_IsConstructor; str:'IsConstructor'),
  1616. (mask:ado_IsArrayOfConst; str:'ArrayOfConst'),
  1617. (mask:ado_IsConstString; str:'ConstString'),
  1618. (mask:ado_IsBitPacked; str:'BitPacked')
  1619. );
  1620. var
  1621. symoptions : tarraydefoptions;
  1622. i : longint;
  1623. first : boolean;
  1624. begin
  1625. ppufile.getsmallset(symoptions);
  1626. if symoptions<>[] then
  1627. begin
  1628. first:=true;
  1629. for i:=1 to high(symopt) do
  1630. if (symopt[i].mask in symoptions) then
  1631. begin
  1632. if first then
  1633. first:=false
  1634. else
  1635. write(', ');
  1636. write(symopt[i].str);
  1637. end;
  1638. end;
  1639. writeln;
  1640. end;
  1641. (* options for properties
  1642. tpropertyoption=(ppo_none,
  1643. ppo_indexed,
  1644. ppo_defaultproperty,
  1645. ppo_stored,
  1646. ppo_hasparameters,
  1647. ppo_implements,
  1648. ppo_enumerator_current,
  1649. ppo_overrides,
  1650. ppo_dispid_write { no longer used }
  1651. );
  1652. tpropertyoptions=set of tpropertyoption;
  1653. *)
  1654. function readpropertyoptions:tpropertyoptions;
  1655. { type tarraydefoption is in unit symconst }
  1656. type
  1657. tpropopt=record
  1658. mask : tpropertyoption;
  1659. str : string[30];
  1660. end;
  1661. const
  1662. symopt : array[1..ord(high(tpropertyoption))] of tpropopt=(
  1663. (mask:ppo_indexed;str:'indexed'),
  1664. (mask:ppo_defaultproperty;str:'default'),
  1665. (mask:ppo_stored;str:'stored'),
  1666. (mask:ppo_hasparameters;str:'has parameters'),
  1667. (mask:ppo_implements;str:'implements'),
  1668. (mask:ppo_enumerator_current;str:'enumerator current'),
  1669. (mask:ppo_overrides;str:'overrides'),
  1670. (mask:ppo_dispid_write;str:'dispid write') { no longer used }
  1671. );
  1672. var
  1673. i : longint;
  1674. first : boolean;
  1675. begin
  1676. ppufile.getsmallset(result);
  1677. if result<>[] then
  1678. begin
  1679. first:=true;
  1680. for i:=1 to high(symopt) do
  1681. if (symopt[i].mask in result) then
  1682. begin
  1683. if first then
  1684. first:=false
  1685. else
  1686. write(', ');
  1687. write(symopt[i].str);
  1688. end;
  1689. end;
  1690. writeln;
  1691. end;
  1692. procedure readnodetree;
  1693. var
  1694. l : longint;
  1695. p : pointer;
  1696. begin
  1697. with ppufile do
  1698. begin
  1699. if space<>'' then
  1700. Writeln(space,'------ nodetree ------');
  1701. if readentry=ibnodetree then
  1702. begin
  1703. l:=entrysize;
  1704. Writeln(space,'Tree size : ',l);
  1705. { Read data to prevent error that entry is not completly read }
  1706. getmem(p,l);
  1707. getdata(p^,l);
  1708. freemem(p);
  1709. end
  1710. else
  1711. begin
  1712. WriteError('!! ibnodetree not found');
  1713. end;
  1714. end;
  1715. end;
  1716. procedure ReadCreatedObjTypes;
  1717. var
  1718. i,j,
  1719. len,
  1720. bssize: longint;
  1721. bs: pbyte;
  1722. begin
  1723. if ppufile.readentry<>ibcreatedobjtypes then
  1724. begin
  1725. writeln('!! ibcreatedobjtypes entry not found');
  1726. ppufile.skipdata(ppufile.entrysize);
  1727. SetHasErrors;
  1728. exit
  1729. end;
  1730. writeln;
  1731. writeln(space,'WPO info');
  1732. writeln(space,'--------');
  1733. len:=ppufile.getlongint;
  1734. writeln(space,'** Instantiated Object/Class types: ',len,' **');
  1735. space:=space+' ';
  1736. for i:=0 to len-1 do
  1737. readderef(space);
  1738. setlength(space,length(space)-2);
  1739. len:=ppufile.getlongint;
  1740. writeln(space,'** Instantiated ClassRef types: ',len,' **');
  1741. space:=space+' ';
  1742. for i:=0 to len-1 do
  1743. readderef(space);
  1744. setlength(space,length(space)-2);
  1745. len:=ppufile.getlongint;
  1746. writeln(space,'** Possibly instantiated ClassRef types : ',len,' **');
  1747. space:=space+' ';
  1748. for i:=0 to len-1 do
  1749. readderef(space);
  1750. setlength(space,length(space)-2);
  1751. len:=ppufile.getlongint;
  1752. writeln(space,'** Class types with called virtual methods info : ',len,' **');
  1753. space:=space+' ';
  1754. for i:=0 to len-1 do
  1755. begin
  1756. write(space,'Class def : ');
  1757. readderef('');
  1758. write(space+' ','Called vmtentries : ');
  1759. bssize:=ppufile.getlongint;
  1760. getmem(bs,bssize);
  1761. ppufile.readdata(bs^,bssize);
  1762. for j:=0 to bssize*8-1 do
  1763. if (((bs+j shr 3)^ shr (j and 7)) and 1) <> 0 then
  1764. write(j,', ');
  1765. writeln;
  1766. freemem(bs);
  1767. end;
  1768. setlength(space,length(space)-2);
  1769. end;
  1770. {****************************************************************************
  1771. Read Symbols Part
  1772. ****************************************************************************}
  1773. procedure readsymbols(const s:string);
  1774. type
  1775. pguid = ^tguid;
  1776. tguid = packed record
  1777. D1: LongWord;
  1778. D2: Word;
  1779. D3: Word;
  1780. D4: array[0..7] of Byte;
  1781. end;
  1782. var
  1783. b : byte;
  1784. pc : pchar;
  1785. ch : dword;
  1786. startnewline : boolean;
  1787. i,j,len : longint;
  1788. prettyname : ansistring;
  1789. guid : tguid;
  1790. realvalue : ppureal;
  1791. doublevalue : double;
  1792. singlevalue : single;
  1793. extended : TSplit80bitReal;
  1794. tempbuf : array[0..127] of char;
  1795. pw : pcompilerwidestring;
  1796. varoptions : tvaroptions;
  1797. propoptions : tpropertyoptions;
  1798. begin
  1799. with ppufile do
  1800. begin
  1801. if space<>'' then
  1802. Writeln(space,'------ ',s,' ------');
  1803. if readentry=ibstartsyms then
  1804. begin
  1805. Writeln(space,'Symtable datasize : ',getlongint);
  1806. Writeln(space,'Symtable alignment: ',getlongint);
  1807. end
  1808. else
  1809. Writeln('!! ibstartsym not found');
  1810. repeat
  1811. b:=readentry;
  1812. case b of
  1813. ibunitsym :
  1814. readcommonsym('Unit symbol ');
  1815. ibnamespacesym :
  1816. begin
  1817. readcommonsym('NameSpace symbol ');
  1818. write(space,' Hidden Unit : ');
  1819. readderef('');
  1820. end;
  1821. iblabelsym :
  1822. readcommonsym('Label symbol ');
  1823. ibtypesym :
  1824. begin
  1825. readcommonsym('Type symbol ');
  1826. write(space,' Result Type : ');
  1827. readderef('');
  1828. prettyname:=getansistring;
  1829. if prettyname<>'' then
  1830. begin
  1831. write(space,' Pretty Name : ');
  1832. Writeln(prettyname);
  1833. end;
  1834. end;
  1835. ibprocsym :
  1836. begin
  1837. readcommonsym('Procedure symbol ');
  1838. len:=ppufile.getword;
  1839. for i:=1 to len do
  1840. begin
  1841. write(space,' Definition : ');
  1842. readderef('');
  1843. end;
  1844. end;
  1845. ibconstsym :
  1846. begin
  1847. readcommonsym('Constant symbol ');
  1848. b:=getbyte;
  1849. case tconsttyp(b) of
  1850. constord :
  1851. begin
  1852. write (space,' OrdinalType : ');
  1853. readderef('');
  1854. writeln(space,' Value : ',constexp.tostr(getexprint));
  1855. end;
  1856. constpointer :
  1857. begin
  1858. write (space,' PointerType : ');
  1859. readderef('');
  1860. writeln(space,' Value : ',getaint)
  1861. end;
  1862. conststring,
  1863. constresourcestring :
  1864. begin
  1865. len:=getlongint;
  1866. getmem(pc,len+1);
  1867. getdata(pc^,len);
  1868. (pc+len)^:= #0;
  1869. writeln(space,' Length : ',len);
  1870. writeln(space,' Value : "',pc,'"');
  1871. freemem(pc,len+1);
  1872. end;
  1873. constreal :
  1874. begin
  1875. write (space,' RealType : ');
  1876. readderef('');
  1877. write(space,' Value : ');
  1878. if entryleft=sizeof(ppureal) then
  1879. begin
  1880. realvalue:=getrealsize(sizeof(ppureal));
  1881. writeln(realvalue);
  1882. end
  1883. else if entryleft=sizeof(double) then
  1884. begin
  1885. doublevalue:=getrealsize(sizeof(double));
  1886. writeln(doublevalue);
  1887. end
  1888. else if entryleft=sizeof(single) then
  1889. begin
  1890. singlevalue:=getrealsize(sizeof(single));
  1891. writeln(singlevalue);
  1892. end
  1893. else if entryleft=10 then
  1894. begin
  1895. getdata(extended,entryleft);
  1896. writeln(Real80bitToStr(extended));
  1897. end
  1898. else
  1899. begin
  1900. realvalue:=0.0;
  1901. writeln(realvalue,' Error reading real value');
  1902. SetHasErrors;
  1903. end;
  1904. end;
  1905. constset :
  1906. begin
  1907. write (space,' Set Type : ');
  1908. readderef('');
  1909. for i:=1to 4 do
  1910. begin
  1911. write (space,' Value : ');
  1912. for j:=1to 8 do
  1913. begin
  1914. if j>1 then
  1915. write(',');
  1916. write(hexstr(getbyte,2));
  1917. end;
  1918. writeln;
  1919. end;
  1920. end;
  1921. constnil:
  1922. writeln(space,' NIL pointer.');
  1923. constwstring :
  1924. begin
  1925. initwidestring(pw);
  1926. setlengthwidestring(pw,getlongint);
  1927. if widecharsize=2 then
  1928. { don't use getdata, because the compilerwidechars may have to
  1929. be byteswapped
  1930. }
  1931. begin
  1932. for i:=0 to pw^.len-1 do
  1933. pw^.data[i]:=ppufile.getword;
  1934. end
  1935. else if widecharsize=4 then
  1936. begin
  1937. for i:=0 to pw^.len-1 do
  1938. pw^.data[i]:=cardinal(ppufile.getlongint);
  1939. end
  1940. else
  1941. begin
  1942. WriteError('Unsupported tcompilerwidechar size');
  1943. end;
  1944. Writeln(space,'Wide string type');
  1945. startnewline:=true;
  1946. for i:=0 to pw^.len-1 do
  1947. begin
  1948. if startnewline then
  1949. begin
  1950. write(space);
  1951. startnewline:=false;
  1952. end;
  1953. ch:=pw^.data[i];
  1954. if widecharsize=2 then
  1955. write(hexstr(ch,4))
  1956. else
  1957. write(hexstr(ch,8));
  1958. if (i mod 8)= 0 then
  1959. startnewline:=true
  1960. else
  1961. write(', ');
  1962. end;
  1963. donewidestring(pw);
  1964. end;
  1965. constguid:
  1966. begin
  1967. getdata(guid,sizeof(guid));
  1968. write (space,' IID String: {',hexstr(guid.d1,8),'-',hexstr(guid.d2,4),'-',hexstr(guid.d3,4),'-');
  1969. for i:=0 to 7 do
  1970. begin
  1971. write(hexstr(guid.d4[i],2));
  1972. if i=1 then write('-');
  1973. end;
  1974. writeln('}');
  1975. end
  1976. else
  1977. Writeln ('!! Invalid unit format : Invalid const type encountered: ',b);
  1978. end;
  1979. end;
  1980. ibabsolutevarsym :
  1981. begin
  1982. readabstractvarsym('Absolute variable symbol ',varoptions);
  1983. Write (space,' Relocated to ');
  1984. b:=getbyte;
  1985. case absolutetyp(b) of
  1986. tovar :
  1987. readpropaccesslist(space+' Sym : ');
  1988. toasm :
  1989. Writeln('Assembler name : ',getstring);
  1990. toaddr :
  1991. begin
  1992. Write('Address : ',getlongint);
  1993. if tsystemcpu(ppufile.header.cpu)=cpu_i386 then
  1994. WriteLn(' (Far: ',getbyte<>0,')');
  1995. end;
  1996. else
  1997. Writeln ('!! Invalid unit format : Invalid absolute type encountered: ',b);
  1998. end;
  1999. end;
  2000. ibfieldvarsym :
  2001. begin
  2002. readabstractvarsym('Field Variable symbol ',varoptions);
  2003. writeln(space,' Address : ',getaint);
  2004. end;
  2005. ibstaticvarsym :
  2006. begin
  2007. readabstractvarsym('Global Variable symbol ',varoptions);
  2008. write (space,' DefaultConst : ');
  2009. readderef('');
  2010. if (vo_has_mangledname in varoptions) then
  2011. {$ifdef symansistr}
  2012. writeln(space,' Mangledname : ',getansistring);
  2013. {$else symansistr}
  2014. writeln(space,' Mangledname : ',getstring);
  2015. {$endif symansistr}
  2016. end;
  2017. iblocalvarsym :
  2018. begin
  2019. readabstractvarsym('Local Variable symbol ',varoptions);
  2020. write (space,' DefaultConst : ');
  2021. readderef('');
  2022. end;
  2023. ibparavarsym :
  2024. begin
  2025. readabstractvarsym('Parameter Variable symbol ',varoptions);
  2026. write (space,' DefaultConst : ');
  2027. readderef('');
  2028. writeln(space,' ParaNr : ',getword);
  2029. writeln(space,' Univ : ',boolean(getbyte));
  2030. writeln(space,' VarState : ',getbyte);
  2031. writeln(space,' Refs : ',getbyte);
  2032. if (vo_has_explicit_paraloc in varoptions) then
  2033. begin
  2034. i:=getbyte;
  2035. getdata(tempbuf,i);
  2036. end;
  2037. end;
  2038. ibenumsym :
  2039. begin
  2040. readcommonsym('Enumeration symbol ');
  2041. write (space,' Definition : ');
  2042. readderef('');
  2043. writeln(space,' Value : ',getlongint);
  2044. end;
  2045. ibsyssym :
  2046. begin
  2047. readcommonsym('Internal system symbol ');
  2048. writeln(space,' Internal Nr : ',getlongint);
  2049. end;
  2050. ibmacrosym :
  2051. begin
  2052. readcommonsym('Macro symbol ');
  2053. writeln(space,' Name: ',getstring);
  2054. writeln(space,' Defined: ',getbyte);
  2055. writeln(space,' Compiler var: ',getbyte);
  2056. len:=getlongint;
  2057. writeln(space,' Value length: ',len);
  2058. if len > 0 then
  2059. begin
  2060. getmem(pc,len+1);
  2061. getdata(pc^,len);
  2062. (pc+len)^:= #0;
  2063. writeln(space,' Value: "',pc,'"');
  2064. freemem(pc,len+1);
  2065. end;
  2066. end;
  2067. ibpropertysym :
  2068. begin
  2069. readcommonsym('Property ');
  2070. propoptions:=readpropertyoptions;
  2071. if ppo_overrides in propoptions then
  2072. begin
  2073. write (space,' OverrideProp : ');
  2074. readderef('');
  2075. end;
  2076. write (space,' Prop Type : ');
  2077. readderef('');
  2078. writeln(space,' Index : ',getlongint);
  2079. writeln(space,' Default : ',getlongint);
  2080. write (space,' Index Type : ');
  2081. readderef('');
  2082. { palt_none }
  2083. readpropaccesslist('');
  2084. write (space,' Readaccess : ');
  2085. readpropaccesslist(space+' Sym: ');
  2086. write (space,' Writeaccess : ');
  2087. readpropaccesslist(space+' Sym: ');
  2088. write (space,' Storedaccess : ');
  2089. readpropaccesslist(space+' Sym: ');
  2090. if [ppo_hasparameters,ppo_overrides]*propoptions=[ppo_hasparameters] then
  2091. begin
  2092. space:=' '+space;
  2093. readsymtable('parast');
  2094. delete(space,1,4);
  2095. end;
  2096. end;
  2097. iberror :
  2098. begin
  2099. WriteError('!! Error in PPU');
  2100. exit;
  2101. end;
  2102. ibendsyms :
  2103. break;
  2104. else
  2105. begin
  2106. WriteLn('!! Skipping unsupported PPU Entry in Symbols: ',b);
  2107. SetHasErrors;
  2108. end;
  2109. end;
  2110. if not EndOfEntry then
  2111. HasMoreInfos;
  2112. until false;
  2113. end;
  2114. end;
  2115. {****************************************************************************
  2116. Read defintions Part
  2117. ****************************************************************************}
  2118. procedure readdefinitions(const s:string);
  2119. { type tordtype is in symconst unit }
  2120. {
  2121. uvoid,
  2122. u8bit,u16bit,u32bit,u64bit,
  2123. s8bit,s16bit,s32bit,s64bit,
  2124. bool8bit,bool16bit,bool32bit,bool64bit,
  2125. uchar,uwidechar,scurrency
  2126. ); }
  2127. { type tobjecttyp is in symconst unit }
  2128. { type tvarianttype is in symconst unit }
  2129. var
  2130. b : byte;
  2131. l,j : longint;
  2132. calloption : tproccalloption;
  2133. procoptions : tprocoptions;
  2134. defoptions: tdefoptions;
  2135. begin
  2136. with ppufile do
  2137. begin
  2138. if space<>'' then
  2139. Writeln(space,'------ ',s,' ------');
  2140. if readentry<>ibstartdefs then
  2141. Writeln('!! ibstartdefs not found');
  2142. repeat
  2143. b:=readentry;
  2144. case b of
  2145. ibpointerdef :
  2146. begin
  2147. readcommondef('Pointer definition',defoptions);
  2148. write (space,' Pointed Type : ');
  2149. readderef('');
  2150. writeln(space,' Is Far : ',(getbyte<>0));
  2151. writeln(space,' Has Pointer Math : ',(getbyte<>0));
  2152. end;
  2153. iborddef :
  2154. begin
  2155. readcommondef('Ordinal definition',defoptions);
  2156. write (space,' Base type : ');
  2157. b:=getbyte;
  2158. case tordtype(b) of
  2159. uvoid : writeln('uvoid');
  2160. u8bit : writeln('u8bit');
  2161. u16bit : writeln('u16bit');
  2162. u32bit : writeln('s32bit');
  2163. u64bit : writeln('u64bit');
  2164. s8bit : writeln('s8bit');
  2165. s16bit : writeln('s16bit');
  2166. s32bit : writeln('s32bit');
  2167. s64bit : writeln('s64bit');
  2168. bool8bit : writeln('bool8bit');
  2169. bool16bit : writeln('bool16bit');
  2170. bool32bit : writeln('bool32bit');
  2171. bool64bit : writeln('bool64bit');
  2172. uchar : writeln('uchar');
  2173. uwidechar : writeln('uwidechar');
  2174. scurrency : writeln('ucurrency');
  2175. else writeln('!! Warning: Invalid base type ',b);
  2176. end;
  2177. writeln(space,' Range : ',constexp.tostr(getexprint),' to ',constexp.tostr(getexprint));
  2178. end;
  2179. ibfloatdef :
  2180. begin
  2181. readcommondef('Float definition',defoptions);
  2182. writeln(space,' Float type : ',getbyte);
  2183. end;
  2184. ibarraydef :
  2185. begin
  2186. readcommondef('Array definition',defoptions);
  2187. write (space,' Element type : ');
  2188. readderef('');
  2189. write (space,' Range Type : ');
  2190. readderef('');
  2191. writeln(space,' Range : ',getaint,' to ',getaint);
  2192. write (space,' Options : ');
  2193. readarraydefoptions;
  2194. readsymtable('symbols');
  2195. end;
  2196. ibprocdef :
  2197. begin
  2198. readcommondef('Procedure definition',defoptions);
  2199. read_abstract_proc_def(calloption,procoptions);
  2200. if (po_has_mangledname in procoptions) then
  2201. {$ifdef symansistr}
  2202. writeln(space,' Mangled name : ',getansistring);
  2203. {$else symansistr}
  2204. writeln(space,' Mangled name : ',getstring);
  2205. {$endif symansistr}
  2206. writeln(space,' Number : ',getword);
  2207. writeln(space,' Level : ',getbyte);
  2208. write (space,' Class : ');
  2209. readderef('');
  2210. write (space,' Procsym : ');
  2211. readderef('');
  2212. write (space,' File Pos : ');
  2213. readposinfo;
  2214. writeln(space,' Visibility : ',Visibility2Str(ppufile.getbyte));
  2215. write (space,' SymOptions : ');
  2216. readsymoptions(space+' ');
  2217. write (space,' Synthetic kind : ',Synthetic2Str(ppufile.getbyte));
  2218. if tsystemcpu(ppufile.header.cpu)=cpu_powerpc then
  2219. begin
  2220. { library symbol for AmigaOS/MorphOS }
  2221. write (space,' Library symbol : ');
  2222. readderef('');
  2223. end;
  2224. if (po_has_importdll in procoptions) then
  2225. writeln(space,' Import DLL : ',getstring);
  2226. if (po_has_importname in procoptions) then
  2227. writeln(space,' Import Name : ',getstring);
  2228. writeln(space,' Import Nr : ',getword);
  2229. if (po_msgint in procoptions) then
  2230. writeln(space,' MsgInt : ',getlongint);
  2231. if (po_msgstr in procoptions) then
  2232. writeln(space,' MsgStr : ',getstring);
  2233. if (po_dispid in procoptions) then
  2234. writeln(space,' DispID: ',ppufile.getlongint);
  2235. if (po_has_inlininginfo in procoptions) then
  2236. begin
  2237. write (space,' FuncretSym : ');
  2238. readderef('');
  2239. readprocinfooptions(space);
  2240. end;
  2241. b:=ppufile.getbyte;
  2242. if b<>0 then
  2243. begin
  2244. write (space,' Alias names : ');
  2245. for j:=1 to b do
  2246. begin
  2247. write(ppufile.getstring);
  2248. if j<b then
  2249. write(', ');
  2250. end;
  2251. writeln;
  2252. end;
  2253. writeln(space,' Empty : ',getbyte<>0);
  2254. if not EndOfEntry then
  2255. HasMoreInfos;
  2256. space:=' '+space;
  2257. { parast }
  2258. readsymtable('parast');
  2259. { localst }
  2260. if (po_has_inlininginfo in procoptions) then
  2261. readsymtable('localst');
  2262. if (po_has_inlininginfo in procoptions) then
  2263. readnodetree;
  2264. delete(space,1,4);
  2265. end;
  2266. ibprocvardef :
  2267. begin
  2268. readcommondef('Procedural type (ProcVar) definition',defoptions);
  2269. read_abstract_proc_def(calloption,procoptions);
  2270. writeln(space,' Symtable level :',ppufile.getbyte);
  2271. if not EndOfEntry then
  2272. HasMoreInfos;
  2273. space:=' '+space;
  2274. { parast }
  2275. readsymtable('parast');
  2276. delete(space,1,4);
  2277. end;
  2278. ibshortstringdef :
  2279. begin
  2280. readcommondef('ShortString definition',defoptions);
  2281. writeln(space,' Length : ',getbyte);
  2282. end;
  2283. ibwidestringdef :
  2284. begin
  2285. readcommondef('WideString definition',defoptions);
  2286. writeln(space,' Length : ',getaint);
  2287. end;
  2288. ibunicodestringdef :
  2289. begin
  2290. readcommondef('UnicodeString definition',defoptions);
  2291. writeln(space,' Length : ',getaint);
  2292. end;
  2293. ibansistringdef :
  2294. begin
  2295. readcommondef('AnsiString definition',defoptions);
  2296. writeln(space,' Length : ',getaint);
  2297. end;
  2298. iblongstringdef :
  2299. begin
  2300. readcommondef('Longstring definition',defoptions);
  2301. writeln(space,' Length : ',getaint);
  2302. end;
  2303. ibrecorddef :
  2304. begin
  2305. readcommondef('Record definition',defoptions);
  2306. writeln(space,' Name of Record : ',getstring);
  2307. writeln(space,' Import lib/pkg : ',getstring);
  2308. write (space,' Options : ');
  2309. readobjectdefoptions;
  2310. if (df_copied_def in defoptions) then
  2311. begin
  2312. write(space,' Copied from : ');
  2313. readderef('');
  2314. end
  2315. else
  2316. begin
  2317. writeln(space,' FieldAlign : ',shortint(getbyte));
  2318. writeln(space,' RecordAlign : ',shortint(getbyte));
  2319. writeln(space,' PadAlign : ',shortint(getbyte));
  2320. writeln(space,'UseFieldAlignment : ',shortint(getbyte));
  2321. writeln(space,' DataSize : ',getasizeint);
  2322. writeln(space,' PaddingSize : ',getword);
  2323. end;
  2324. if not EndOfEntry then
  2325. HasMoreInfos;
  2326. {read the record definitions and symbols}
  2327. if not(df_copied_def in current_defoptions) then
  2328. begin
  2329. space:=' '+space;
  2330. readrecsymtableoptions;
  2331. readsymtable('fields');
  2332. Delete(space,1,4);
  2333. end;
  2334. end;
  2335. ibobjectdef :
  2336. begin
  2337. readcommondef('Object/Class definition',defoptions);
  2338. writeln(space,' Name of Class : ',getstring);
  2339. writeln(space,' Import lib/pkg : ',getstring);
  2340. write (space,' Options : ');
  2341. readobjectdefoptions;
  2342. b:=getbyte;
  2343. write (space,' Type : ');
  2344. case tobjecttyp(b) of
  2345. odt_class : writeln('class');
  2346. odt_object : writeln('object');
  2347. odt_interfacecom : writeln('interfacecom');
  2348. odt_interfacecorba : writeln('interfacecorba');
  2349. odt_cppclass : writeln('cppclass');
  2350. odt_dispinterface : writeln('dispinterface');
  2351. odt_objcclass : writeln('objcclass');
  2352. odt_objcprotocol : writeln('objcprotocol');
  2353. odt_helper : writeln('helper');
  2354. odt_objccategory : writeln('objccategory');
  2355. odt_javaclass : writeln('Java class');
  2356. odt_interfacejava : writeln('Java interface');
  2357. else writeln('!! Warning: Invalid object type ',b);
  2358. end;
  2359. writeln(space,' External name : ',getstring);
  2360. writeln(space,' DataSize : ',getasizeint);
  2361. writeln(space,' PaddingSize : ',getword);
  2362. writeln(space,' FieldAlign : ',shortint(getbyte));
  2363. writeln(space,' RecordAlign : ',shortint(getbyte));
  2364. writeln(space,' Vmt offset : ',getlongint);
  2365. write (space, ' Ancestor Class : ');
  2366. readderef('');
  2367. if tobjecttyp(b) in [odt_interfacecom,odt_interfacecorba,odt_dispinterface] then
  2368. begin
  2369. { IIDGUID }
  2370. for j:=1to 16 do
  2371. getbyte;
  2372. writeln(space,' IID String : ',getstring);
  2373. end;
  2374. writeln(space,' Abstract methods : ',getlongint);
  2375. if (tobjecttyp(b)=odt_helper) or
  2376. (oo_is_classhelper in current_objectoptions) then
  2377. begin
  2378. write(space,' Helper parent : ');
  2379. readderef('');
  2380. end;
  2381. l:=getlongint;
  2382. writeln(space,' VMT entries: ',l);
  2383. for j:=1 to l do
  2384. begin
  2385. write(space,' ');
  2386. readderef('');
  2387. writeln(space,' Visibility: ',Visibility2Str(getbyte));
  2388. end;
  2389. if tobjecttyp(b) in [odt_class,odt_interfacecorba,odt_objcclass,odt_objcprotocol,odt_javaclass,odt_interfacejava] then
  2390. begin
  2391. l:=getlongint;
  2392. writeln(space,' Impl Intf Count : ',l);
  2393. for j:=1 to l do
  2394. begin
  2395. write (space,' - Definition : ');
  2396. readderef('');
  2397. writeln(space,' IOffset : ',getlongint);
  2398. end;
  2399. end;
  2400. if df_copied_def in current_defoptions then
  2401. begin
  2402. writeln(' Copy of def: ');
  2403. readderef('');
  2404. end;
  2405. if not EndOfEntry then
  2406. HasMoreInfos;
  2407. if not(df_copied_def in current_defoptions) then
  2408. begin
  2409. {read the record definitions and symbols}
  2410. space:=' '+space;
  2411. readrecsymtableoptions;
  2412. readsymtable('fields');
  2413. Delete(space,1,4);
  2414. end;
  2415. end;
  2416. ibfiledef :
  2417. begin
  2418. ReadCommonDef('File definition',defoptions);
  2419. write (space,' Type : ');
  2420. case getbyte of
  2421. 0 : writeln('Text');
  2422. 1 : begin
  2423. writeln('Typed');
  2424. write (space,' File of Type : ');
  2425. readderef('');
  2426. end;
  2427. 2 : writeln('Untyped');
  2428. end;
  2429. end;
  2430. ibformaldef :
  2431. begin
  2432. readcommondef('Generic definition (void-typ)',defoptions);
  2433. writeln(space,' Is Typed : ',(getbyte<>0));
  2434. end;
  2435. ibundefineddef :
  2436. readcommondef('Undefined definition (generic parameter)',defoptions);
  2437. ibenumdef :
  2438. begin
  2439. readcommondef('Enumeration type definition',defoptions);
  2440. writeln(space,' Smallest element : ',getaint);
  2441. writeln(space,' Largest element : ',getaint);
  2442. writeln(space,' Size : ',getaint);
  2443. {$ifdef jvm}
  2444. write(space,' Class def : ');
  2445. readderef('');
  2446. {$endif}
  2447. if df_copied_def in defoptions then
  2448. begin
  2449. write(space,'Base enumeration type : ');
  2450. readderef('');
  2451. end
  2452. else
  2453. begin
  2454. space:=' '+space;
  2455. readsymtable('elements');
  2456. delete(space,1,4);
  2457. end;
  2458. end;
  2459. ibclassrefdef :
  2460. begin
  2461. readcommondef('Class reference definition',defoptions);
  2462. write (space,' Pointed Type : ');
  2463. readderef('');
  2464. end;
  2465. ibsetdef :
  2466. begin
  2467. readcommondef('Set definition',defoptions);
  2468. write (space,' Element type : ');
  2469. readderef('');
  2470. writeln(space,' Size : ',getaint);
  2471. writeln(space,' Set Base : ',getaint);
  2472. writeln(space,' Set Max : ',getaint);
  2473. end;
  2474. ibvariantdef :
  2475. begin
  2476. readcommondef('Variant definition',defoptions);
  2477. write (space,' Varianttype : ');
  2478. b:=getbyte;
  2479. case tvarianttype(b) of
  2480. vt_normalvariant :
  2481. writeln('Normal');
  2482. vt_olevariant :
  2483. writeln('OLE');
  2484. else
  2485. writeln('!! Warning: Invalid varianttype ',b);
  2486. end;
  2487. end;
  2488. iberror :
  2489. begin
  2490. WriteError('!! Error in PPU');
  2491. exit;
  2492. end;
  2493. ibenddefs :
  2494. break;
  2495. else
  2496. begin
  2497. WriteLn('!! Skipping unsupported PPU Entry in definitions: ',b);
  2498. SetHasErrors;
  2499. end;
  2500. end;
  2501. if not EndOfEntry then
  2502. HasMoreInfos;
  2503. until false;
  2504. end;
  2505. end;
  2506. procedure readmoduleoptions(space : string);
  2507. type
  2508. { tmoduleoption type is in unit fmodule }
  2509. tmoduleoption = (mo_none,
  2510. mo_hint_deprecated,
  2511. mo_hint_platform,
  2512. mo_hint_library,
  2513. mo_hint_unimplemented,
  2514. mo_hint_experimental,
  2515. mo_has_deprecated_msg
  2516. );
  2517. tmoduleoptions = set of tmoduleoption;
  2518. tmoduleopt=record
  2519. mask : tmoduleoption;
  2520. str : string[30];
  2521. end;
  2522. const
  2523. moduleopts=ord(high(tmoduleoption));
  2524. moduleopt : array[1..moduleopts] of tmoduleopt=(
  2525. (mask:mo_hint_deprecated; str:'Hint Deprecated'),
  2526. (mask:mo_hint_platform; str:'Hint Platform'),
  2527. (mask:mo_hint_library; str:'Hint Library'),
  2528. (mask:mo_hint_unimplemented; str:'Hint Unimplemented'),
  2529. (mask:mo_hint_experimental; str:'Hint Experimental'),
  2530. (mask:mo_has_deprecated_msg; str:'Has Deprecated Message')
  2531. );
  2532. var
  2533. moduleoptions : tmoduleoptions;
  2534. i : longint;
  2535. first : boolean;
  2536. begin
  2537. ppufile.getsmallset(moduleoptions);
  2538. if moduleoptions<>[] then
  2539. begin
  2540. first:=true;
  2541. for i:=1to moduleopts do
  2542. if (moduleopt[i].mask in moduleoptions) then
  2543. begin
  2544. if first then
  2545. first:=false
  2546. else
  2547. write(', ');
  2548. write(moduleopt[i].str);
  2549. end;
  2550. end;
  2551. writeln;
  2552. if mo_has_deprecated_msg in moduleoptions then
  2553. writeln(space,'Deprecated : ', ppufile.getstring);
  2554. end;
  2555. {****************************************************************************
  2556. Read General Part
  2557. ****************************************************************************}
  2558. procedure readinterface;
  2559. var
  2560. b : byte;
  2561. sourcenumber : longint;
  2562. begin
  2563. with ppufile do
  2564. begin
  2565. repeat
  2566. b:=readentry;
  2567. case b of
  2568. ibmodulename :
  2569. Writeln('Module Name: ',getstring);
  2570. ibmoduleoptions:
  2571. readmoduleoptions(' ');
  2572. ibsourcefiles :
  2573. begin
  2574. sourcenumber:=1;
  2575. while not EndOfEntry do
  2576. begin
  2577. Writeln('Source file ',sourcenumber,' : ',getstring,' ',filetimestring(getlongint));
  2578. inc(sourcenumber);
  2579. end;
  2580. end;
  2581. {$IFDEF MACRO_DIFF_HINT}
  2582. ibusedmacros :
  2583. begin
  2584. while not EndOfEntry do
  2585. begin
  2586. Write('Conditional ',getstring);
  2587. b:=getbyte;
  2588. if boolean(b)=true then
  2589. write(' defined at startup')
  2590. else
  2591. write(' not defined at startup');
  2592. b:=getbyte;
  2593. if boolean(b)=true then
  2594. writeln(' was used')
  2595. else
  2596. writeln;
  2597. end;
  2598. end;
  2599. {$ENDIF}
  2600. ibloadunit :
  2601. ReadLoadUnit;
  2602. iblinkunitofiles :
  2603. ReadLinkContainer('Link unit object file: ');
  2604. iblinkunitstaticlibs :
  2605. ReadLinkContainer('Link unit static lib: ');
  2606. iblinkunitsharedlibs :
  2607. ReadLinkContainer('Link unit shared lib: ');
  2608. iblinkotherofiles :
  2609. ReadLinkContainer('Link other object file: ');
  2610. iblinkotherstaticlibs :
  2611. ReadLinkContainer('Link other static lib: ');
  2612. iblinkothersharedlibs :
  2613. ReadLinkContainer('Link other shared lib: ');
  2614. iblinkotherframeworks:
  2615. ReadLinkContainer('Link framework: ');
  2616. ibmainname:
  2617. Writeln('Specified main program symbol name: ',getstring);
  2618. ibImportSymbols :
  2619. ReadImportSymbols;
  2620. ibderefdata :
  2621. ReadDerefData;
  2622. ibderefmap :
  2623. ReadDerefMap;
  2624. ibwpofile :
  2625. ReadWpoFileInfo;
  2626. ibresources :
  2627. ReadLinkContainer('Resource file: ');
  2628. iberror :
  2629. begin
  2630. WriteError('Error in PPU');
  2631. exit;
  2632. end;
  2633. ibendinterface :
  2634. break;
  2635. else
  2636. begin
  2637. WriteLn('!! Skipping unsupported PPU Entry in General Part: ',b);
  2638. SetHasErrors;
  2639. end;
  2640. end;
  2641. until false;
  2642. end;
  2643. end;
  2644. {****************************************************************************
  2645. Read Implementation Part
  2646. ****************************************************************************}
  2647. procedure readimplementation;
  2648. var
  2649. b : byte;
  2650. begin
  2651. with ppufile do
  2652. begin
  2653. repeat
  2654. b:=readentry;
  2655. case b of
  2656. ibasmsymbols :
  2657. ReadAsmSymbols;
  2658. ibloadunit :
  2659. ReadLoadUnit;
  2660. iberror :
  2661. begin
  2662. WriteError('Error in PPU');
  2663. exit;
  2664. end;
  2665. ibendimplementation :
  2666. break;
  2667. else
  2668. begin
  2669. WriteLn('!! Skipping unsupported PPU Entry in Implementation: ',b);
  2670. SetHasErrors;
  2671. end;
  2672. end;
  2673. until false;
  2674. end;
  2675. end;
  2676. procedure dofile (filename : string);
  2677. begin
  2678. { reset }
  2679. space:='';
  2680. { fix filename }
  2681. if pos('.',filename)=0 then
  2682. filename:=filename+'.ppu';
  2683. ppufile:=tppufile.create(filename);
  2684. if not ppufile.openfile then
  2685. begin
  2686. WriteError('IO-Error when opening : '+filename+', Skipping');
  2687. exit;
  2688. end;
  2689. { PPU File is open, check for PPU Id }
  2690. if not ppufile.CheckPPUID then
  2691. begin
  2692. writeln(Filename,' : Not a valid PPU file, Skipping');
  2693. SetHasErrors;
  2694. exit;
  2695. end;
  2696. { Check PPU Version }
  2697. ppuversion:=ppufile.GetPPUVersion;
  2698. Writeln('Analyzing ',filename,' (v',PPUVersion,')');
  2699. if PPUVersion<16 then
  2700. begin
  2701. writeln(Filename,' : Old PPU Formats (<v16) are not supported, Skipping');
  2702. SetHasErrors;
  2703. exit;
  2704. end;
  2705. { Write PPU Header Information }
  2706. if (verbose and v_header)<>0 then
  2707. begin
  2708. Writeln;
  2709. Writeln('Header');
  2710. Writeln('-------');
  2711. with ppufile.header do
  2712. begin
  2713. Writeln('Compiler version : ',ppufile.header.compiler shr 14,'.',
  2714. (ppufile.header.compiler shr 7) and $7f,'.',
  2715. ppufile.header.compiler and $7f);
  2716. WriteLn('Target processor : ',Cpu2Str(cpu));
  2717. WriteLn('Target operating system : ',Target2Str(target));
  2718. Writeln('Unit flags : ',PPUFlags2Str(flags));
  2719. Writeln('FileSize (w/o header) : ',size);
  2720. Writeln('Checksum : ',hexstr(checksum,8));
  2721. Writeln('Interface Checksum : ',hexstr(interface_checksum,8));
  2722. Writeln('Indirect Checksum : ',hexstr(indirect_checksum,8));
  2723. Writeln('Definitions stored : ',tostr(deflistsize));
  2724. Writeln('Symbols stored : ',tostr(symlistsize));
  2725. end;
  2726. end;
  2727. {read the general stuff}
  2728. if (verbose and v_interface)<>0 then
  2729. begin
  2730. Writeln;
  2731. Writeln('Interface section');
  2732. Writeln('------------------');
  2733. readinterface;
  2734. end
  2735. else
  2736. ppufile.skipuntilentry(ibendinterface);
  2737. Writeln;
  2738. Writeln('Interface symtable');
  2739. Writeln('----------------------');
  2740. readsymtableoptions('interface');
  2741. {read the definitions}
  2742. if (verbose and v_defs)<>0 then
  2743. begin
  2744. Writeln;
  2745. Writeln('Interface definitions');
  2746. Writeln('----------------------');
  2747. readdefinitions('interface');
  2748. end
  2749. else
  2750. ppufile.skipuntilentry(ibenddefs);
  2751. {read the symbols}
  2752. if (verbose and v_syms)<>0 then
  2753. begin
  2754. Writeln;
  2755. Writeln('Interface Symbols');
  2756. Writeln('------------------');
  2757. readsymbols('interface');
  2758. end
  2759. else
  2760. ppufile.skipuntilentry(ibendsyms);
  2761. {read the macro symbols}
  2762. if (verbose and v_syms)<>0 then
  2763. begin
  2764. Writeln;
  2765. Writeln('Interface Macro Symbols');
  2766. Writeln('-----------------------');
  2767. end;
  2768. if ppufile.readentry<>ibexportedmacros then
  2769. begin
  2770. WriteError('!! Error in PPU');
  2771. exit;
  2772. end;
  2773. if boolean(ppufile.getbyte) then
  2774. begin
  2775. readsymtableoptions('interface macro');
  2776. {skip the definition section for macros (since they are never used) }
  2777. ppufile.skipuntilentry(ibenddefs);
  2778. {read the macro symbols}
  2779. if (verbose and v_syms)<>0 then
  2780. readsymbols('interface macro')
  2781. else
  2782. ppufile.skipuntilentry(ibendsyms);
  2783. end
  2784. else
  2785. Writeln('(no exported macros)');
  2786. {read the implementation stuff}
  2787. if (verbose and v_implementation)<>0 then
  2788. begin
  2789. Writeln;
  2790. Writeln('Implementation section');
  2791. Writeln('-----------------------');
  2792. readimplementation;
  2793. end
  2794. else
  2795. ppufile.skipuntilentry(ibendimplementation);
  2796. {read the static symtable}
  2797. Writeln;
  2798. Writeln('Implementation symtable');
  2799. Writeln('----------------------');
  2800. readsymtableoptions('implementation');
  2801. if (ppufile.header.flags and uf_local_symtable)<>0 then
  2802. begin
  2803. if (verbose and v_defs)<>0 then
  2804. begin
  2805. Writeln;
  2806. Writeln('Static definitions');
  2807. Writeln('----------------------');
  2808. readdefinitions('implementation');
  2809. end
  2810. else
  2811. ppufile.skipuntilentry(ibenddefs);
  2812. {read the symbols}
  2813. if (verbose and v_syms)<>0 then
  2814. begin
  2815. Writeln;
  2816. Writeln('Static Symbols');
  2817. Writeln('------------------');
  2818. readsymbols('implementation');
  2819. end
  2820. else
  2821. ppufile.skipuntilentry(ibendsyms);
  2822. end;
  2823. ReadCreatedObjTypes;
  2824. FreeDerefdata;
  2825. {shutdown ppufile}
  2826. ppufile.closefile;
  2827. ppufile.free;
  2828. Writeln;
  2829. end;
  2830. procedure help;
  2831. begin
  2832. writeln('usage: ppudump [options] <filename1> <filename2>...');
  2833. writeln;
  2834. writeln('[options] can be:');
  2835. writeln(' -M Exit with ExitCode=2 if more information is available');
  2836. writeln(' -V<verbose> Set verbosity to <verbose>');
  2837. writeln(' H - Show header info');
  2838. writeln(' I - Show interface');
  2839. writeln(' M - Show implementation');
  2840. writeln(' S - Show interface symbols');
  2841. writeln(' D - Show interface definitions');
  2842. // writeln(' B - Show browser info');
  2843. writeln(' A - Show all');
  2844. writeln(' -h, -? This helpscreen');
  2845. halt;
  2846. end;
  2847. var
  2848. startpara,
  2849. nrfile,i : longint;
  2850. para : string;
  2851. const
  2852. error_on_more : boolean = false;
  2853. begin
  2854. writeln(Title+' '+Version);
  2855. writeln(Copyright);
  2856. writeln;
  2857. if paramcount<1 then
  2858. begin
  2859. writeln('usage: dumpppu [options] <filename1> <filename2>...');
  2860. halt(1);
  2861. end;
  2862. { turn verbose on by default }
  2863. verbose:=v_all;
  2864. { read options }
  2865. startpara:=1;
  2866. while copy(paramstr(startpara),1,1)='-' do
  2867. begin
  2868. para:=paramstr(startpara);
  2869. case upcase(para[2]) of
  2870. 'M' : error_on_more:=true;
  2871. 'V' : begin
  2872. verbose:=0;
  2873. for i:=3 to length(para) do
  2874. case upcase(para[i]) of
  2875. 'H' : verbose:=verbose or v_header;
  2876. 'I' : verbose:=verbose or v_interface;
  2877. 'M' : verbose:=verbose or v_implementation;
  2878. 'D' : verbose:=verbose or v_defs;
  2879. 'S' : verbose:=verbose or v_syms;
  2880. 'A' : verbose:=verbose or v_all;
  2881. end;
  2882. end;
  2883. 'H' : help;
  2884. '?' : help;
  2885. end;
  2886. inc(startpara);
  2887. end;
  2888. { process files }
  2889. for nrfile:=startpara to paramcount do
  2890. dofile (paramstr(nrfile));
  2891. if has_errors then
  2892. Halt(1);
  2893. if error_on_more and has_more_infos then
  2894. Halt(2);
  2895. end.