symdef.inc 80 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 by Florian Klaempfl, Pierre Muller
  4. Symbol table implementation for the defenitions
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. {*************************************************************************************************************************
  19. TDEF (base class for definitions)
  20. ****************************************************************************}
  21. const
  22. { if you change one of the following contants, }
  23. { you have also to change the typinfo unit }
  24. tkUnknown = 0;
  25. tkInteger = 1;
  26. tkChar = 2;
  27. tkEnumeration = 3;
  28. tkFloat = 4;
  29. tkSet = 6;
  30. tkMethod = 7;
  31. tkSString = 8;
  32. tkString = tkSString;
  33. tkLString = 9;
  34. tkAString = 10;
  35. tkWString = 11;
  36. tkVariant = 12;
  37. tkArray = 13;
  38. tkRecord = 14;
  39. tkInterface = 15;
  40. tkClass = 16;
  41. tkObject = 17;
  42. tkWChar = 18;
  43. otSByte = 0;
  44. otUByte = 1;
  45. otSWord = 2;
  46. otUWord = 3;
  47. otSLong = 4;
  48. otULong = 5;
  49. ftSingle = 0;
  50. ftDouble = 1;
  51. ftExtended = 2;
  52. ftComp = 3;
  53. ftCurr = 4;
  54. ftFixed16 = 5;
  55. ftFixed32 = 6;
  56. constructor tdef.init;
  57. begin
  58. deftype:=abstractdef;
  59. owner := nil;
  60. next := nil;
  61. sym := nil;
  62. indexnb := 0;
  63. if registerdef then
  64. symtablestack^.registerdef(@self);
  65. has_rtti:=false;
  66. has_inittable:=false;
  67. {$ifdef GDB}
  68. is_def_stab_written := false;
  69. globalnb := 0;
  70. if assigned(lastglobaldef) then
  71. begin
  72. lastglobaldef^.nextglobal := @self;
  73. previousglobal:=lastglobaldef;
  74. end
  75. else
  76. begin
  77. firstglobaldef := @self;
  78. previousglobal := nil;
  79. end;
  80. lastglobaldef := @self;
  81. nextglobal := nil;
  82. {$endif GDB}
  83. end;
  84. constructor tdef.load;
  85. begin
  86. deftype:=abstractdef;
  87. indexnb := 0;
  88. sym := nil;
  89. owner := nil;
  90. next := nil;
  91. has_rtti:=false;
  92. has_inittable:=false;
  93. {$ifdef GDB}
  94. is_def_stab_written := false;
  95. globalnb := 0;
  96. if assigned(lastglobaldef) then
  97. begin
  98. lastglobaldef^.nextglobal := @self;
  99. previousglobal:=lastglobaldef;
  100. end
  101. else
  102. begin
  103. firstglobaldef := @self;
  104. previousglobal:=nil;
  105. end;
  106. lastglobaldef := @self;
  107. nextglobal := nil;
  108. {$endif GDB}
  109. end;
  110. destructor tdef.done;
  111. begin
  112. {$ifdef GDB}
  113. { first element ? }
  114. if not(assigned(previousglobal)) then
  115. begin
  116. firstglobaldef := nextglobal;
  117. if assigned(firstglobaldef) then
  118. firstglobaldef^.previousglobal:=nil;
  119. end
  120. else
  121. begin
  122. { remove reference in the element before }
  123. previousglobal^.nextglobal:=nextglobal;
  124. end;
  125. { last element ? }
  126. if not(assigned(nextglobal)) then
  127. begin
  128. lastglobaldef := previousglobal;
  129. if assigned(lastglobaldef) then
  130. lastglobaldef^.nextglobal:=nil;
  131. end
  132. else
  133. nextglobal^.previousglobal:=previousglobal;
  134. previousglobal:=nil;
  135. nextglobal:=nil;
  136. {$endif GDB}
  137. end;
  138. procedure tdef.write;
  139. begin
  140. {$ifdef GDB}
  141. if globalnb = 0 then
  142. begin
  143. if assigned(owner) then
  144. globalnb := owner^.getnewtypecount
  145. else
  146. begin
  147. globalnb := PGlobalTypeCount^;
  148. Inc(PGlobalTypeCount^);
  149. end;
  150. end;
  151. {$endif GDB}
  152. end;
  153. function tdef.size : longint;
  154. begin
  155. size:=savesize;
  156. end;
  157. {$ifdef GDB}
  158. procedure tdef.set_globalnb;
  159. begin
  160. globalnb :=PGlobalTypeCount^;
  161. inc(PglobalTypeCount^);
  162. end;
  163. function tdef.stabstring : pchar;
  164. begin
  165. stabstring := strpnew('t'+numberstring+';');
  166. end;
  167. function tdef.numberstring : string;
  168. var table : psymtable;
  169. begin
  170. {formal def have no type !}
  171. if deftype = formaldef then
  172. begin
  173. numberstring := voiddef^.numberstring;
  174. exit;
  175. end;
  176. if (not assigned(sym)) or (not sym^.isusedinstab) then
  177. begin
  178. {set even if debuglist is not defined}
  179. if assigned(sym) then
  180. sym^.isusedinstab := true;
  181. if assigned(debuglist) and not is_def_stab_written then
  182. concatstabto(debuglist);
  183. end;
  184. if not use_dbx then
  185. begin
  186. if globalnb = 0 then
  187. set_globalnb;
  188. numberstring := tostr(globalnb);
  189. end
  190. else
  191. begin
  192. if globalnb = 0 then
  193. begin
  194. if assigned(owner) then
  195. globalnb := owner^.getnewtypecount
  196. else
  197. begin
  198. globalnb := PGlobalTypeCount^;
  199. Inc(PGlobalTypeCount^);
  200. end;
  201. end;
  202. if assigned(sym) then
  203. begin
  204. table := sym^.owner;
  205. if table^.unitid > 0 then
  206. numberstring := '('+tostr(table^.unitid)+','
  207. +tostr(sym^.definition^.globalnb)+')'
  208. else
  209. numberstring := tostr(globalnb);
  210. exit;
  211. end;
  212. numberstring := tostr(globalnb);
  213. end;
  214. end;
  215. function tdef.allstabstring : pchar;
  216. var stabchar : string[2];
  217. ss,st : pchar;
  218. name : string;
  219. sym_line_no : longint;
  220. begin
  221. ss := stabstring;
  222. getmem(st,strlen(ss)+512);
  223. stabchar := 't';
  224. if deftype in tagtypes then
  225. stabchar := 'Tt';
  226. if assigned(sym) then
  227. begin
  228. name := sym^.name;
  229. sym_line_no:=sym^.fileinfo.line;
  230. end
  231. else
  232. begin
  233. name := ' ';
  234. sym_line_no:=0;
  235. end;
  236. strpcopy(st,'"'+name+':'+stabchar+numberstring+'=');
  237. strpcopy(strecopy(strend(st),ss),'",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0');
  238. allstabstring := strnew(st);
  239. freemem(st,strlen(ss)+512);
  240. strdispose(ss);
  241. end;
  242. procedure tdef.concatstabto(asmlist : paasmoutput);
  243. var stab_str : pchar;
  244. begin
  245. if ((sym = nil) or sym^.isusedinstab or use_dbx)
  246. and not is_def_stab_written then
  247. begin
  248. If use_dbx then
  249. begin
  250. { otherwise you get two of each def }
  251. If assigned(sym) then
  252. begin
  253. if sym^.typ=typesym then
  254. sym^.isusedinstab:=true;
  255. if (sym^.owner = nil) or
  256. ((sym^.owner^.symtabletype = unitsymtable) and
  257. punitsymtable(sym^.owner)^.dbx_count_ok) then
  258. begin
  259. {with DBX we get the definition from the other objects }
  260. is_def_stab_written := true;
  261. exit;
  262. end;
  263. end;
  264. end;
  265. { to avoid infinite loops }
  266. is_def_stab_written := true;
  267. stab_str := allstabstring;
  268. if asmlist = debuglist then do_count_dbx := true;
  269. { count_dbx(stab_str); moved to GDB.PAS}
  270. asmlist^.concat(new(pai_stabs,init(stab_str)));
  271. end;
  272. end;
  273. {$endif GDB}
  274. procedure tdef.deref;
  275. begin
  276. end;
  277. { rtti generation }
  278. procedure tdef.generate_rtti;
  279. begin
  280. has_rtti:=true;
  281. getlabel(rtti_label);
  282. write_child_rtti_data;
  283. rttilist^.concat(new(pai_label,init(rtti_label)));
  284. write_rtti_data;
  285. end;
  286. function tdef.get_rtti_label : plabel;
  287. begin
  288. if not(has_rtti) then
  289. generate_rtti;
  290. get_rtti_label:=rtti_label;
  291. end;
  292. { init table handling }
  293. function tdef.needs_inittable : boolean;
  294. begin
  295. needs_inittable:=false;
  296. end;
  297. procedure tdef.generate_inittable;
  298. begin
  299. has_inittable:=true;
  300. getlabel(inittable_label);
  301. write_child_init_data;
  302. rttilist^.concat(new(pai_label,init(inittable_label)));
  303. write_init_data;
  304. end;
  305. procedure tdef.write_init_data;
  306. begin
  307. write_rtti_data;
  308. end;
  309. procedure tdef.write_child_init_data;
  310. begin
  311. write_child_rtti_data;
  312. end;
  313. function tdef.get_inittable_label : plabel;
  314. begin
  315. if not(has_inittable) then
  316. generate_inittable;
  317. get_inittable_label:=inittable_label;
  318. end;
  319. procedure tdef.writename;
  320. var
  321. str : string;
  322. begin
  323. { name }
  324. if assigned(sym) then
  325. begin
  326. str:=sym^.name;
  327. rttilist^.concat(new(pai_string,init(chr(length(str))+str)));
  328. end
  329. else
  330. rttilist^.concat(new(pai_string,init(#0)))
  331. end;
  332. { returns true, if the definition can be published }
  333. function tdef.is_publishable : boolean;
  334. begin
  335. is_publishable:=false;
  336. end;
  337. procedure tdef.write_rtti_data;
  338. begin
  339. end;
  340. procedure tdef.write_child_rtti_data;
  341. begin
  342. end;
  343. {*************************************************************************************************************************
  344. TSTRINGDEF
  345. ****************************************************************************}
  346. constructor tstringdef.init(l : byte);
  347. begin
  348. tdef.init;
  349. string_typ:=st_shortstring;
  350. deftype:=stringdef;
  351. len:=l;
  352. savesize:=len+1;
  353. end;
  354. constructor tstringdef.load;
  355. begin
  356. tdef.load;
  357. string_typ:=st_shortstring;
  358. deftype:=stringdef;
  359. len:=readbyte;
  360. savesize:=len+1;
  361. end;
  362. constructor tstringdef.longinit(l : longint);
  363. begin
  364. tdef.init;
  365. string_typ:=st_longstring;
  366. deftype:=stringdef;
  367. len:=l;
  368. savesize:=Sizeof(pointer);
  369. end;
  370. constructor tstringdef.longload;
  371. begin
  372. tdef.load;
  373. deftype:=stringdef;
  374. string_typ:=st_longstring;
  375. len:=readlong;
  376. savesize:=Sizeof(pointer);
  377. end;
  378. constructor tstringdef.ansiinit(l : longint);
  379. begin
  380. tdef.init;
  381. string_typ:=st_ansistring;
  382. deftype:=stringdef;
  383. len:=l;
  384. savesize:=sizeof(pointer);
  385. end;
  386. constructor tstringdef.ansiload;
  387. begin
  388. tdef.load;
  389. deftype:=stringdef;
  390. string_typ:=st_ansistring;
  391. len:=readlong;
  392. savesize:=sizeof(pointer);
  393. end;
  394. constructor tstringdef.wideinit(l : longint);
  395. begin
  396. tdef.init;
  397. string_typ:=st_widestring;
  398. deftype:=stringdef;
  399. len:=l;
  400. savesize:=sizeof(pointer);
  401. end;
  402. constructor tstringdef.wideload;
  403. begin
  404. tdef.load;
  405. deftype:=stringdef;
  406. string_typ:=st_ansistring;
  407. len:=readlong;
  408. savesize:=sizeof(pointer);
  409. end;
  410. function tstringdef.size : longint;
  411. begin
  412. size:=savesize;
  413. end;
  414. procedure tstringdef.write;
  415. begin
  416. tdef.write;
  417. if string_typ=st_shortstring then
  418. writebyte(len)
  419. else
  420. writelong(len);
  421. case string_typ of
  422. st_shortstring : current_ppu^.writeentry(ibstringdef);
  423. st_longstring : current_ppu^.writeentry(iblongstringdef);
  424. st_ansistring : current_ppu^.writeentry(ibansistringdef);
  425. st_widestring : current_ppu^.writeentry(ibwidestringdef);
  426. end;
  427. end;
  428. {$ifdef GDB}
  429. function tstringdef.stabstring : pchar;
  430. var
  431. bytest,charst,longst : string;
  432. begin
  433. case string_typ of
  434. st_shortstring:
  435. begin
  436. charst := typeglobalnumber('char');
  437. { this is what I found in stabs.texinfo but
  438. gdb 4.12 for go32 doesn't understand that !! }
  439. {$IfDef GDBknowsstrings}
  440. stabstring := strpnew('n'+charst+';'+tostr(len));
  441. {$else}
  442. bytest := typeglobalnumber('byte');
  443. stabstring := strpnew('s'+tostr(len+1)+'length:'+bytest
  444. +',0,8;st:ar'+bytest
  445. +';1;'+tostr(len)+';'+charst+',8,'+tostr(len*8)+';;');
  446. {$EndIf}
  447. end;
  448. st_longstring:
  449. begin
  450. charst := typeglobalnumber('char');
  451. { this is what I found in stabs.texinfo but
  452. gdb 4.12 for go32 doesn't understand that !! }
  453. {$IfDef GDBknowsstrings}
  454. stabstring := strpnew('n'+charst+';'+tostr(len));
  455. {$else}
  456. bytest := typeglobalnumber('byte');
  457. longst := typeglobalnumber('longint');
  458. stabstring := strpnew('s'+tostr(len+5)+'length:'+longst
  459. +',0,32;dummy:'+bytest+',32,8;st:ar'+bytest
  460. +';1;'+tostr(len)+';'+charst+',40,'+tostr(len*8)+';;');
  461. {$EndIf}
  462. end;
  463. st_ansistring:
  464. begin
  465. { an ansi string looks like a pchar easy !! }
  466. stabstring:=strpnew('*'+typeglobalnumber('char'));
  467. end;
  468. st_widestring:
  469. begin
  470. { an ansi string looks like a pchar easy !! }
  471. stabstring:=strpnew('*'+typeglobalnumber('char'));
  472. end;
  473. end;
  474. end;
  475. procedure tstringdef.concatstabto(asmlist : paasmoutput);
  476. begin
  477. inherited concatstabto(asmlist);
  478. end;
  479. {$endif GDB}
  480. function tstringdef.needs_inittable : boolean;
  481. begin
  482. needs_inittable:=string_typ in [st_ansistring,st_widestring];
  483. end;
  484. procedure tstringdef.write_rtti_data;
  485. begin
  486. case string_typ of
  487. st_ansistring:
  488. begin
  489. rttilist^.concat(new(pai_const,init_8bit(tkAString)));
  490. end;
  491. st_widestring:
  492. begin
  493. rttilist^.concat(new(pai_const,init_8bit(tkWString)));
  494. end;
  495. st_longstring:
  496. begin
  497. rttilist^.concat(new(pai_const,init_8bit(tkLString)));
  498. end;
  499. st_shortstring:
  500. begin
  501. rttilist^.concat(new(pai_const,init_8bit(tkSString)));
  502. rttilist^.concat(new(pai_const,init_8bit(len)));
  503. end;
  504. end;
  505. end;
  506. {*************************************************************************************************************************
  507. TENUMDEF
  508. ****************************************************************************}
  509. constructor tenumdef.init;
  510. begin
  511. tdef.init;
  512. deftype:=enumdef;
  513. minval:=0;
  514. maxval:=0;
  515. calcsavesize;
  516. has_jumps:=false;
  517. basedef:=nil;
  518. first:=nil;
  519. end;
  520. constructor tenumdef.init_subrange(_basedef:penumdef;_min,_max:longint);
  521. begin
  522. tdef.init;
  523. deftype:=enumdef;
  524. minval:=_min;
  525. maxval:=_max;
  526. basedef:=_basedef;
  527. calcsavesize;
  528. has_jumps:=false;
  529. first:=nil;
  530. end;
  531. constructor tenumdef.load;
  532. begin
  533. tdef.load;
  534. deftype:=enumdef;
  535. basedef:=penumdef(readdefref);
  536. minval:=readlong;
  537. maxval:=readlong;
  538. savesize:=readlong;
  539. has_jumps:=false;
  540. first:=Nil;
  541. end;
  542. procedure tenumdef.calcsavesize;
  543. begin
  544. if (aktpackenum=4) or (max>65535) then
  545. savesize:=4
  546. else
  547. if (aktpackenum=2) or (max>255) then
  548. savesize:=2
  549. else
  550. savesize:=1;
  551. end;
  552. procedure tenumdef.setmax(_max:longint);
  553. begin
  554. maxval:=_max;
  555. calcsavesize;
  556. end;
  557. procedure tenumdef.setmin(_min:longint);
  558. begin
  559. minval:=_min;
  560. calcsavesize;
  561. end;
  562. function tenumdef.min:longint;
  563. begin
  564. min:=minval;
  565. end;
  566. function tenumdef.max:longint;
  567. begin
  568. max:=maxval;
  569. end;
  570. procedure tenumdef.deref;
  571. begin
  572. resolvedef(pdef(basedef));
  573. end;
  574. destructor tenumdef.done;
  575. begin
  576. inherited done;
  577. end;
  578. procedure tenumdef.write;
  579. begin
  580. tdef.write;
  581. writedefref(basedef);
  582. writelong(min);
  583. writelong(max);
  584. writelong(savesize);
  585. current_ppu^.writeentry(ibenumdef);
  586. end;
  587. {$ifdef GDB}
  588. function tenumdef.stabstring : pchar;
  589. var st,st2 : pchar;
  590. p : penumsym;
  591. s : string;
  592. memsize : word;
  593. begin
  594. memsize := memsizeinc;
  595. getmem(st,memsize);
  596. strpcopy(st,'e');
  597. p := first;
  598. while assigned(p) do
  599. begin
  600. s :=p^.name+':'+tostr(p^.value)+',';
  601. { place for the ending ';' also }
  602. if (strlen(st)+length(s)+1<memsize) then
  603. strpcopy(strend(st),s)
  604. else
  605. begin
  606. getmem(st2,memsize+memsizeinc);
  607. strcopy(st2,st);
  608. freemem(st,memsize);
  609. st := st2;
  610. memsize := memsize+memsizeinc;
  611. strpcopy(strend(st),s);
  612. end;
  613. p := p^.next;
  614. end;
  615. strpcopy(strend(st),';');
  616. stabstring := strnew(st);
  617. freemem(st,memsize);
  618. end;
  619. {$endif GDB}
  620. procedure tenumdef.generate_rtti;
  621. begin
  622. inherited generate_rtti;
  623. rttilist^.concat(new(pai_const,init_8bit(tkEnumeration)));
  624. rttilist^.concat(new(pai_const,init_8bit(0)));
  625. end;
  626. {*************************************************************************************************************************
  627. TORDDEF
  628. ****************************************************************************}
  629. constructor torddef.init(t : tbasetype;v,b : longint);
  630. begin
  631. inherited init;
  632. deftype:=orddef;
  633. low:=v;
  634. high:=b;
  635. typ:=t;
  636. setsize;
  637. end;
  638. constructor torddef.load;
  639. begin
  640. inherited load;
  641. deftype:=orddef;
  642. typ:=tbasetype(readbyte);
  643. low:=readlong;
  644. high:=readlong;
  645. rangenr:=0;
  646. setsize;
  647. end;
  648. procedure torddef.setsize;
  649. begin
  650. if typ=uauto then
  651. begin
  652. { generate a unsigned range if high<0 and low>=0 }
  653. if (low>=0) and (high<0) then
  654. begin
  655. savesize:=4;
  656. typ:=u32bit;
  657. end
  658. else if (low>=0) and (high<=255) then
  659. begin
  660. savesize:=1;
  661. typ:=u8bit;
  662. end
  663. else if (low>=-128) and (high<=127) then
  664. begin
  665. savesize:=1;
  666. typ:=s8bit;
  667. end
  668. else if (low>=0) and (high<=65536) then
  669. begin
  670. savesize:=2;
  671. typ:=u16bit;
  672. end
  673. else if (low>=-32768) and (high<=32767) then
  674. begin
  675. savesize:=2;
  676. typ:=s16bit;
  677. end
  678. else
  679. begin
  680. savesize:=4;
  681. typ:=s32bit;
  682. end;
  683. end
  684. else
  685. begin
  686. case typ of
  687. u8bit,s8bit,
  688. uchar,bool8bit : savesize:=1;
  689. u16bit,s16bit,
  690. bool16bit : savesize:=2;
  691. s32bit,u32bit,
  692. bool32bit : savesize:=4;
  693. else
  694. savesize:=0;
  695. end;
  696. end;
  697. { there are no entrys for range checking }
  698. rangenr:=0;
  699. end;
  700. procedure torddef.genrangecheck;
  701. begin
  702. if rangenr=0 then
  703. begin
  704. { generate two constant for bounds }
  705. getlabelnr(rangenr);
  706. if (cs_smartlink in aktmoduleswitches) then
  707. datasegment^.concat(new(pai_symbol,init_global('R_'+current_module^.modulename^+tostr(rangenr))))
  708. else
  709. datasegment^.concat(new(pai_symbol,init('R_'+tostr(rangenr))));
  710. if low<=high then
  711. begin
  712. datasegment^.concat(new(pai_const,init_32bit(low)));
  713. datasegment^.concat(new(pai_const,init_32bit(high)));
  714. end
  715. { for u32bit we need two bounds }
  716. else
  717. begin
  718. datasegment^.concat(new(pai_const,init_32bit(low)));
  719. datasegment^.concat(new(pai_const,init_32bit($7fffffff)));
  720. inc(nextlabelnr);
  721. if (cs_smartlink in aktmoduleswitches) then
  722. datasegment^.concat(new(pai_symbol,init_global('R_'+current_module^.modulename^+tostr(rangenr+1))))
  723. else
  724. datasegment^.concat(new(pai_symbol,init('R_'+tostr(rangenr+1))));
  725. datasegment^.concat(new(pai_const,init_32bit($80000000)));
  726. datasegment^.concat(new(pai_const,init_32bit(high)));
  727. end;
  728. end;
  729. end;
  730. procedure torddef.write;
  731. begin
  732. tdef.write;
  733. writebyte(byte(typ));
  734. writelong(low);
  735. writelong(high);
  736. current_ppu^.writeentry(iborddef);
  737. end;
  738. {$ifdef GDB}
  739. function torddef.stabstring : pchar;
  740. begin
  741. case typ of
  742. uvoid : stabstring := strpnew(numberstring+';');
  743. {GDB 4.12 for go32 doesn't like boolean as range for 0 to 1 !!!}
  744. bool8bit,
  745. bool16bit,
  746. bool32bit : stabstring := strpnew('r'+numberstring+';0;255;');
  747. { u32bit : stabstring := strpnew('r'+
  748. s32bitdef^.numberstring+';0;-1;'); }
  749. else
  750. stabstring := strpnew('r'+s32bitdef^.numberstring+';'+tostr(low)+';'+tostr(high)+';');
  751. end;
  752. end;
  753. {$endif GDB}
  754. procedure torddef.write_rtti_data;
  755. begin
  756. rttilist^.concat(new(pai_const,init_8bit(255)));
  757. end;
  758. {*************************************************************************************************************************
  759. TFLOATDEF
  760. ****************************************************************************}
  761. constructor tfloatdef.init(t : tfloattype);
  762. begin
  763. tdef.init;
  764. deftype:=floatdef;
  765. typ:=t;
  766. setsize;
  767. end;
  768. constructor tfloatdef.load;
  769. begin
  770. tdef.load;
  771. deftype:=floatdef;
  772. typ:=tfloattype(readbyte);
  773. setsize;
  774. end;
  775. procedure tfloatdef.setsize;
  776. begin
  777. case typ of
  778. f16bit:
  779. savesize:=2;
  780. f32bit,s32real:
  781. savesize:=4;
  782. s64real:
  783. savesize:=8;
  784. s64bit:
  785. savesize:=8;
  786. s80real:
  787. savesize:=extended_size;
  788. else savesize:=0;
  789. end;
  790. end;
  791. procedure tfloatdef.write;
  792. begin
  793. tdef.write;
  794. writebyte(byte(typ));
  795. current_ppu^.writeentry(ibfloatdef);
  796. end;
  797. {$ifdef GDB}
  798. function tfloatdef.stabstring : pchar;
  799. begin
  800. case typ of
  801. s32real,
  802. s64real : stabstring := strpnew('r'+
  803. s32bitdef^.numberstring+';'+tostr(savesize)+';0;');
  804. { for fixed real use longint instead to be able to }
  805. { debug something at least }
  806. f32bit:
  807. stabstring := s32bitdef^.stabstring;
  808. f16bit:
  809. stabstring := strpnew('r'+s32bitdef^.numberstring+';0;'+
  810. tostr($ffff)+';');
  811. { found this solution in stabsread.c from GDB v4.16 }
  812. s64bit : stabstring := strpnew('r'+
  813. s32bitdef^.numberstring+';-'+tostr(savesize)+';0;');
  814. {$ifdef i386}
  815. { under dos at least you must give a size of twelve instead of 10 !! }
  816. { this is probably do to the fact that in gcc all is pushed in 4 bytes size }
  817. s80real : stabstring := strpnew('r'+s32bitdef^.numberstring+';12;0;');
  818. {$endif i386}
  819. else
  820. internalerror(10005);
  821. end;
  822. end;
  823. {$endif GDB}
  824. procedure tfloatdef.write_rtti_data;
  825. const
  826. translate : array[tfloattype] of byte =
  827. (ftFixed32,ftSingle,ftDouble,ftExtended,ftComp,ftFixed16);
  828. begin
  829. rttilist^.concat(new(pai_const,init_8bit(tkFloat)));
  830. rttilist^.concat(new(pai_const,init_8bit(translate[typ])));
  831. end;
  832. {*************************************************************************************************************************
  833. TFILEDEF
  834. ****************************************************************************}
  835. constructor tfiledef.init(ft : tfiletype;tas : pdef);
  836. begin
  837. inherited init;
  838. deftype:=filedef;
  839. filetype:=ft;
  840. typed_as:=tas;
  841. setsize;
  842. end;
  843. constructor tfiledef.load;
  844. begin
  845. tdef.load;
  846. deftype:=filedef;
  847. filetype:=tfiletype(readbyte);
  848. if filetype=ft_typed then
  849. typed_as:=readdefref
  850. else
  851. typed_as:=nil;
  852. setsize;
  853. end;
  854. procedure tfiledef.deref;
  855. begin
  856. if filetype=ft_typed then
  857. resolvedef(typed_as);
  858. end;
  859. procedure tfiledef.setsize;
  860. begin
  861. {$ifdef i386}
  862. case target_info.target of
  863. target_LINUX : begin
  864. case filetype of
  865. ft_text : savesize:=432;
  866. ft_typed,
  867. ft_untyped : savesize:=304;
  868. end;
  869. end;
  870. target_Win32 : begin
  871. case filetype of
  872. ft_text : savesize:=434;
  873. ft_typed,
  874. ft_untyped : savesize:=306;
  875. end;
  876. end;
  877. else
  878. begin
  879. case filetype of
  880. ft_text : savesize:=256;
  881. ft_typed,ft_untyped : savesize:=128;
  882. end;
  883. end;
  884. end;
  885. {$endif}
  886. {$ifdef m68k}
  887. case target_info.target of
  888. target_Amiga,
  889. target_Mac68k : begin
  890. case filetype of
  891. ft_text : savesize:=434;
  892. ft_typed,
  893. ft_untyped : savesize:=306;
  894. end;
  895. end;
  896. else
  897. begin
  898. case filetype of
  899. ft_text : savesize:=256;
  900. ft_typed,ft_untyped : savesize:=128;
  901. end;
  902. end;
  903. end;
  904. {$endif}
  905. end;
  906. procedure tfiledef.write;
  907. begin
  908. tdef.write;
  909. writebyte(byte(filetype));
  910. if filetype=ft_typed then
  911. writedefref(typed_as);
  912. current_ppu^.writeentry(ibfiledef);
  913. end;
  914. {$ifdef GDB}
  915. function tfiledef.stabstring : pchar;
  916. var Handlebitsize,namesize : longint;
  917. Handledef :string;
  918. begin
  919. {$IfDef GDBknowsfiles}
  920. case filetyp of
  921. ft_typed : stabstring := strpnew('d'+typed_as^.numberstring{+';'});
  922. ft_untyped : stabstring := strpnew('d'+voiddef^.numberstring{+';'});
  923. ft_text : stabstring := strpnew('d'+cchardef^.numberstring{+';'});
  924. end;
  925. {$Else }
  926. {based on
  927. filerec = record
  928. handle : word;
  929. mode : word;
  930. recsize : word;
  931. _private : array[1..26] of byte;
  932. userdata : array[1..16] of byte;
  933. name : string[79 or 255 for linux]; }
  934. {$ifdef i386}
  935. if (target_info.target=target_GO32V1) or
  936. (target_info.target=target_GO32V2) then
  937. namesize:=79
  938. else
  939. namesize:=255;
  940. if (target_info.target=target_Win32) then
  941. begin
  942. Handledef:='longint';
  943. Handlebitsize:=32;
  944. end
  945. else
  946. begin
  947. Handledef:='word';
  948. HandleBitSize:=16;
  949. end;
  950. {$endif}
  951. {$ifdef m68k}
  952. namesize:=79;
  953. Handledef:='word';
  954. HandleBitSize:=16;
  955. {$endif}
  956. { the buffer part is still missing !! (PM) }
  957. { but the string could become too long !! }
  958. stabstring := strpnew('s'+tostr(savesize)+
  959. 'HANDLE:'+typeglobalnumber(Handledef)+',0,'+tostr(HandleBitSize)+';'+
  960. 'MODE:'+typeglobalnumber('word')+','+tostr(HandleBitSize)+',16;'+
  961. 'RECSIZE:'+typeglobalnumber('word')+','+tostr(HandleBitSize+16)+',16;'+
  962. '_PRIVATE:ar'+typeglobalnumber('word')+';1;26;'+typeglobalnumber('byte')
  963. +','+tostr(HandleBitSize+32)+',208;'+
  964. 'USERDATA:ar'+typeglobalnumber('word')+';1;16;'+typeglobalnumber('byte')
  965. +','+tostr(HandleBitSize+240)+',128;'+
  966. { 'NAME:s'+tostr(namesize+1)+
  967. 'length:'+typeglobalnumber('byte')+',0,8;'+
  968. 'st:ar'+typeglobalnumber('word')+';1;'
  969. +tostr(namesize)+';'+typeglobalnumber('char')+',8,'+tostr(8*namesize)+';;'+}
  970. 'NAME:ar'+typeglobalnumber('word')+';0;'
  971. +tostr(namesize)+';'+typeglobalnumber('char')+
  972. ','+tostr(HandleBitSize+368)+','+tostr(8*(namesize+1))+';;');
  973. {$EndIf}
  974. end;
  975. procedure tfiledef.concatstabto(asmlist : paasmoutput);
  976. begin
  977. { most file defs are unnamed !!! }
  978. if ((sym = nil) or sym^.isusedinstab or use_dbx) and not is_def_stab_written then
  979. begin
  980. if assigned(typed_as) then forcestabto(asmlist,typed_as);
  981. inherited concatstabto(asmlist);
  982. end;
  983. end;
  984. {$endif GDB}
  985. {*************************************************************************************************************************
  986. TPOINTERDEF
  987. ****************************************************************************}
  988. constructor tpointerdef.init(def : pdef);
  989. begin
  990. inherited init;
  991. deftype:=pointerdef;
  992. definition:=def;
  993. savesize:=Sizeof(pointer);
  994. end;
  995. constructor tpointerdef.load;
  996. begin
  997. tdef.load;
  998. deftype:=pointerdef;
  999. { the real address in memory is calculated later (deref) }
  1000. definition:=readdefref;
  1001. savesize:=Sizeof(pointer);
  1002. end;
  1003. procedure tpointerdef.deref;
  1004. begin
  1005. resolvedef(definition);
  1006. end;
  1007. procedure tpointerdef.write;
  1008. begin
  1009. tdef.write;
  1010. writedefref(definition);
  1011. current_ppu^.writeentry(ibpointerdef);
  1012. end;
  1013. {$ifdef GDB}
  1014. function tpointerdef.stabstring : pchar;
  1015. begin
  1016. stabstring := strpnew('*'+definition^.numberstring);
  1017. end;
  1018. procedure tpointerdef.concatstabto(asmlist : paasmoutput);
  1019. var st,nb : string;
  1020. sym_line_no : longint;
  1021. begin
  1022. if ( (sym=nil) or sym^.isusedinstab or use_dbx) and not is_def_stab_written then
  1023. begin
  1024. if assigned(definition) then
  1025. if definition^.deftype in [recorddef,objectdef] then
  1026. begin
  1027. is_def_stab_written := true;
  1028. {to avoid infinite recursion in record with next-like fields }
  1029. nb := definition^.numberstring;
  1030. is_def_stab_written := false;
  1031. if not definition^.is_def_stab_written then
  1032. begin
  1033. if assigned(definition^.sym) then
  1034. begin
  1035. if assigned(sym) then
  1036. begin
  1037. st := sym^.name;
  1038. sym_line_no:=sym^.fileinfo.line;
  1039. end
  1040. else
  1041. begin
  1042. st := ' ';
  1043. sym_line_no:=0;
  1044. end;
  1045. st := '"'+st+':t'+numberstring+'=*'+definition^.numberstring
  1046. +'=xs'+definition^.sym^.name+':",'+tostr(N_LSYM)+',0,'+tostr(sym_line_no)+',0';
  1047. if asmlist = debuglist then do_count_dbx := true;
  1048. asmlist^.concat(new(pai_stabs,init(strpnew(st))));
  1049. end;
  1050. end else inherited concatstabto(asmlist);
  1051. is_def_stab_written := true;
  1052. end else
  1053. begin
  1054. forcestabto(asmlist,definition);
  1055. inherited concatstabto(asmlist);
  1056. end;
  1057. end;
  1058. end;
  1059. {$endif GDB}
  1060. {*************************************************************************************************************************
  1061. TCLASSREFDEF
  1062. ****************************************************************************}
  1063. constructor tclassrefdef.init(def : pdef);
  1064. begin
  1065. inherited init(def);
  1066. deftype:=classrefdef;
  1067. definition:=def;
  1068. savesize:=Sizeof(pointer);
  1069. end;
  1070. constructor tclassrefdef.load;
  1071. begin
  1072. inherited load;
  1073. deftype:=classrefdef;
  1074. end;
  1075. procedure tclassrefdef.write;
  1076. begin
  1077. tdef.write;
  1078. writedefref(definition);
  1079. current_ppu^.writeentry(ibclassrefdef);
  1080. end;
  1081. {$ifdef GDB}
  1082. function tclassrefdef.stabstring : pchar;
  1083. begin
  1084. stabstring:=strpnew('');
  1085. end;
  1086. procedure tclassrefdef.concatstabto(asmlist : paasmoutput);
  1087. begin
  1088. end;
  1089. {$endif GDB}
  1090. {***********************************************************************************
  1091. TSETDEF
  1092. ***************************************************************************}
  1093. constructor tsetdef.init(s : pdef;high : longint);
  1094. begin
  1095. inherited init;
  1096. deftype:=setdef;
  1097. setof:=s;
  1098. if high<32 then
  1099. begin
  1100. settype:=smallset;
  1101. savesize:=Sizeof(longint);
  1102. end
  1103. else
  1104. if high<256 then
  1105. begin
  1106. settype:=normset;
  1107. savesize:=32;
  1108. end
  1109. else
  1110. {$ifdef testvarsets}
  1111. if high<$10000 then
  1112. begin
  1113. settype:=varset;
  1114. savesize:=4*((high+31) div 32);
  1115. end
  1116. else
  1117. {$endif testvarsets}
  1118. Message(sym_e_ill_type_decl_set);
  1119. end;
  1120. constructor tsetdef.load;
  1121. begin
  1122. tdef.load;
  1123. deftype:=setdef;
  1124. setof:=readdefref;
  1125. settype:=tsettype(readbyte);
  1126. case settype of
  1127. normset : savesize:=32;
  1128. varset : savesize:=readlong;
  1129. smallset : savesize:=Sizeof(longint);
  1130. end;
  1131. end;
  1132. procedure tsetdef.write;
  1133. begin
  1134. tdef.write;
  1135. writedefref(setof);
  1136. writebyte(byte(settype));
  1137. if settype=varset then
  1138. writelong(savesize);
  1139. current_ppu^.writeentry(ibsetdef);
  1140. end;
  1141. {$ifdef GDB}
  1142. function tsetdef.stabstring : pchar;
  1143. begin
  1144. stabstring := strpnew('S'+setof^.numberstring);
  1145. end;
  1146. procedure tsetdef.concatstabto(asmlist : paasmoutput);
  1147. begin
  1148. if ( not assigned(sym) or sym^.isusedinstab or use_dbx) and
  1149. not is_def_stab_written then
  1150. begin
  1151. if assigned(setof) then
  1152. forcestabto(asmlist,setof);
  1153. inherited concatstabto(asmlist);
  1154. end;
  1155. end;
  1156. {$endif GDB}
  1157. procedure tsetdef.deref;
  1158. begin
  1159. resolvedef(setof);
  1160. end;
  1161. procedure tsetdef.generate_rtti;
  1162. begin
  1163. inherited generate_rtti;
  1164. rttilist^.concat(new(pai_const,init_8bit(255)));
  1165. end;
  1166. {***********************************************************************************
  1167. TFORMALDEF
  1168. ***************************************************************************}
  1169. constructor tformaldef.init;
  1170. begin
  1171. inherited init;
  1172. deftype:=formaldef;
  1173. savesize:=Sizeof(pointer);
  1174. end;
  1175. constructor tformaldef.load;
  1176. begin
  1177. tdef.load;
  1178. deftype:=formaldef;
  1179. savesize:=Sizeof(pointer);
  1180. end;
  1181. procedure tformaldef.write;
  1182. begin
  1183. tdef.write;
  1184. current_ppu^.writeentry(ibformaldef);
  1185. end;
  1186. {$ifdef GDB}
  1187. function tformaldef.stabstring : pchar;
  1188. begin
  1189. stabstring := strpnew('formal'+numberstring+';');
  1190. end;
  1191. procedure tformaldef.concatstabto(asmlist : paasmoutput);
  1192. begin
  1193. { formaldef can't be stab'ed !}
  1194. end;
  1195. {$endif GDB}
  1196. {***********************************************************************************
  1197. TARRAYDEF
  1198. ***************************************************************************}
  1199. constructor tarraydef.init(l,h : longint;rd : pdef);
  1200. begin
  1201. tdef.init;
  1202. deftype:=arraydef;
  1203. lowrange:=l;
  1204. highrange:=h;
  1205. rangedef:=rd;
  1206. rangenr:=0;
  1207. definition:=nil;
  1208. end;
  1209. constructor tarraydef.load;
  1210. begin
  1211. tdef.load;
  1212. deftype:=arraydef;
  1213. { the addresses are calculated later }
  1214. definition:=readdefref;
  1215. rangedef:=readdefref;
  1216. lowrange:=readlong;
  1217. highrange:=readlong;
  1218. rangenr:=0;
  1219. end;
  1220. procedure tarraydef.genrangecheck;
  1221. begin
  1222. if rangenr=0 then
  1223. begin
  1224. { generates the data for range checking }
  1225. getlabelnr(rangenr);
  1226. datasegment^.concat(new(pai_symbol,init('R_'+tostr(rangenr))));
  1227. datasegment^.concat(new(pai_const,init_32bit(lowrange)));
  1228. datasegment^.concat(new(pai_const,init_32bit(highrange)));
  1229. end;
  1230. end;
  1231. procedure tarraydef.deref;
  1232. begin
  1233. resolvedef(definition);
  1234. resolvedef(rangedef);
  1235. end;
  1236. procedure tarraydef.write;
  1237. begin
  1238. tdef.write;
  1239. writedefref(definition);
  1240. writedefref(rangedef);
  1241. writelong(lowrange);
  1242. writelong(highrange);
  1243. current_ppu^.writeentry(ibarraydef);
  1244. end;
  1245. {$ifdef GDB}
  1246. function tarraydef.stabstring : pchar;
  1247. begin
  1248. stabstring := strpnew('ar'+rangedef^.numberstring+';'
  1249. +tostr(lowrange)+';'+tostr(highrange)+';'+definition^.numberstring);
  1250. end;
  1251. procedure tarraydef.concatstabto(asmlist : paasmoutput);
  1252. begin
  1253. if (not assigned(sym) or sym^.isusedinstab or use_dbx)
  1254. and not is_def_stab_written then
  1255. begin
  1256. {when array are inserted they have no definition yet !!}
  1257. if assigned(definition) then
  1258. inherited concatstabto(asmlist);
  1259. end;
  1260. end;
  1261. {$endif GDB}
  1262. function tarraydef.elesize : longint;
  1263. begin
  1264. elesize:=definition^.size;
  1265. end;
  1266. function tarraydef.size : longint;
  1267. begin
  1268. size:=(highrange-lowrange+1)*elesize;
  1269. end;
  1270. function tarraydef.needs_inittable : boolean;
  1271. begin
  1272. needs_inittable:=definition^.needs_inittable;
  1273. end;
  1274. procedure tarraydef.write_child_rtti_table;
  1275. begin
  1276. definition^.generate_rtti;
  1277. end;
  1278. procedure tarraydef.write_rtti_data;
  1279. begin
  1280. rttilist^.concat(new(pai_const,init_8bit(13)));
  1281. writename;
  1282. { size of elements }
  1283. rttilist^.concat(new(pai_const,init_32bit(definition^.size)));
  1284. { count of elements }
  1285. rttilist^.concat(new(pai_const,init_32bit(highrange-lowrange+1)));
  1286. { element type }
  1287. rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(definition^.get_inittable_label)))));
  1288. end;
  1289. {***********************************************************************************
  1290. TRECDEF
  1291. ***************************************************************************}
  1292. constructor trecdef.init(p : psymtable);
  1293. begin
  1294. tdef.init;
  1295. deftype:=recorddef;
  1296. symtable:=p;
  1297. savesize:=symtable^.datasize;
  1298. symtable^.defowner := @self;
  1299. end;
  1300. constructor trecdef.load;
  1301. var
  1302. oldread_member : boolean;
  1303. begin
  1304. tdef.load;
  1305. deftype:=recorddef;
  1306. savesize:=readlong;
  1307. oldread_member:=read_member;
  1308. read_member:=true;
  1309. symtable:=new(psymtable,loadasstruct(recordsymtable));
  1310. read_member:=oldread_member;
  1311. symtable^.defowner := @self;
  1312. end;
  1313. destructor trecdef.done;
  1314. begin
  1315. if assigned(symtable) then dispose(symtable,done);
  1316. inherited done;
  1317. end;
  1318. var
  1319. binittable : boolean;
  1320. procedure check_rec_inittable(s : psym);
  1321. begin
  1322. if (s^.typ=varsym) and (pvarsym(s)^.definition^.needs_inittable) then
  1323. binittable:=true;
  1324. end;
  1325. function trecdef.needs_inittable : boolean;
  1326. var
  1327. oldb : boolean;
  1328. begin
  1329. { there are recursive calls to needs_rtti possible, }
  1330. { so we have to change to old value how else should }
  1331. { we do that ? check_rec_rtti can't be a nested }
  1332. { procedure of needs_rtti ! }
  1333. oldb:=binittable;
  1334. binittable:=false;
  1335. symtable^.foreach(check_rec_inittable);
  1336. needs_inittable:=binittable;
  1337. binittable:=oldb;
  1338. end;
  1339. procedure trecdef.deref;
  1340. var
  1341. hp : pdef;
  1342. oldrecsyms : psymtable;
  1343. begin
  1344. oldrecsyms:=aktrecordsymtable;
  1345. aktrecordsymtable:=symtable;
  1346. { now dereference the definitions }
  1347. hp:=symtable^.rootdef;
  1348. while assigned(hp) do
  1349. begin
  1350. hp^.deref;
  1351. { set owner }
  1352. hp^.owner:=symtable;
  1353. hp:=hp^.next;
  1354. end;
  1355. {$ifdef tp}
  1356. symtable^.foreach(derefsym);
  1357. {$else}
  1358. symtable^.foreach(@derefsym);
  1359. {$endif}
  1360. aktrecordsymtable:=oldrecsyms;
  1361. end;
  1362. procedure trecdef.write;
  1363. var
  1364. oldread_member : boolean;
  1365. begin
  1366. oldread_member:=read_member;
  1367. read_member:=true;
  1368. tdef.write;
  1369. writelong(savesize);
  1370. current_ppu^.writeentry(ibrecorddef);
  1371. self.symtable^.writeasstruct;
  1372. read_member:=oldread_member;
  1373. end;
  1374. {$ifdef GDB}
  1375. Const StabRecString : pchar = Nil;
  1376. StabRecSize : longint = 0;
  1377. RecOffset : Longint = 0;
  1378. procedure addname(p : psym);
  1379. var
  1380. news, newrec : pchar;
  1381. begin
  1382. { static variables from objects are like global objects }
  1383. if ((p^.properties and sp_static)<>0) then
  1384. exit;
  1385. If p^.typ = varsym then
  1386. begin
  1387. newrec := strpnew(p^.name+':'+pvarsym(p)^.definition^.numberstring
  1388. +','+tostr(pvarsym(p)^.address*8)+','
  1389. +tostr(pvarsym(p)^.definition^.size*8)+';');
  1390. if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
  1391. begin
  1392. getmem(news,stabrecsize+memsizeinc);
  1393. strcopy(news,stabrecstring);
  1394. freemem(stabrecstring,stabrecsize);
  1395. stabrecsize:=stabrecsize+memsizeinc;
  1396. stabrecstring:=news;
  1397. end;
  1398. strcat(StabRecstring,newrec);
  1399. strdispose(newrec);
  1400. {This should be used for case !!}
  1401. RecOffset := RecOffset + pvarsym(p)^.definition^.size;
  1402. end;
  1403. end;
  1404. function trecdef.stabstring : pchar;
  1405. Var oldrec : pchar;
  1406. oldsize : longint;
  1407. begin
  1408. oldrec := stabrecstring;
  1409. oldsize:=stabrecsize;
  1410. GetMem(stabrecstring,memsizeinc);
  1411. stabrecsize:=memsizeinc;
  1412. strpcopy(stabRecString,'s'+tostr(savesize));
  1413. RecOffset := 0;
  1414. {$ifdef tp}
  1415. symtable^.foreach(addname);
  1416. {$else}
  1417. symtable^.foreach(@addname);
  1418. {$endif}
  1419. { FPC doesn't want to convert a char to a pchar}
  1420. { is this a bug ? }
  1421. strpcopy(strend(StabRecString),';');
  1422. stabstring := strnew(StabRecString);
  1423. Freemem(stabrecstring,stabrecsize);
  1424. stabrecstring := oldrec;
  1425. stabrecsize:=oldsize;
  1426. end;
  1427. procedure trecdef.concatstabto(asmlist : paasmoutput);
  1428. begin
  1429. if (not assigned(sym) or sym^.isusedinstab or use_dbx) and
  1430. (not is_def_stab_written) then
  1431. inherited concatstabto(asmlist);
  1432. end;
  1433. {$endif GDB}
  1434. var
  1435. count : longint;
  1436. procedure count_inittable_fields(sym : psym);{$ifndef fpc}far;{$endif}
  1437. begin
  1438. if pvarsym(sym)^.definition^.needs_inittable then
  1439. inc(count);
  1440. end;
  1441. procedure count_fields(sym : psym);{$ifndef fpc}far;{$endif}
  1442. begin
  1443. inc(count);
  1444. end;
  1445. procedure write_field_inittable(sym : psym);{$ifndef fpc}far;{$endif}
  1446. begin
  1447. if pvarsym(sym)^.definition^.needs_inittable then
  1448. begin
  1449. rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(pvarsym(sym)^.definition^.get_inittable_label)))));
  1450. rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
  1451. end;
  1452. end;
  1453. procedure write_field_rtti(sym : psym);{$ifndef fpc}far;{$endif}
  1454. begin
  1455. rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(pvarsym(sym)^.definition^.get_rtti_label)))));
  1456. rttilist^.concat(new(pai_const,init_32bit(pvarsym(sym)^.address)));
  1457. end;
  1458. procedure generate_child_inittable(sym : psym);{$ifndef fpc}far;{$endif}
  1459. begin
  1460. if (sym^.typ=varsym) and pvarsym(sym)^.definition^.needs_inittable then
  1461. { force inittable generation }
  1462. pvarsym(sym)^.definition^.get_inittable_label;
  1463. end;
  1464. procedure generate_child_rtti(sym : psym);{$ifndef fpc}far;{$endif}
  1465. begin
  1466. pvarsym(sym)^.definition^.get_rtti_label;
  1467. end;
  1468. procedure trecdef.write_child_rtti_data;
  1469. begin
  1470. symtable^.foreach(generate_child_rtti);
  1471. end;
  1472. procedure trecdef.write_child_init_data;
  1473. begin
  1474. symtable^.foreach(generate_child_inittable);
  1475. end;
  1476. procedure trecdef.write_rtti_data;
  1477. begin
  1478. rttilist^.concat(new(pai_const,init_8bit(14)));
  1479. writename;
  1480. rttilist^.concat(new(pai_const,init_32bit(size)));
  1481. count:=0;
  1482. symtable^.foreach(count_fields);
  1483. rttilist^.concat(new(pai_const,init_32bit(count)));
  1484. symtable^.foreach(write_field_rtti);
  1485. end;
  1486. procedure trecdef.write_init_data;
  1487. begin
  1488. rttilist^.concat(new(pai_const,init_8bit(14)));
  1489. writename;
  1490. rttilist^.concat(new(pai_const,init_32bit(size)));
  1491. count:=0;
  1492. symtable^.foreach(count_inittable_fields);
  1493. rttilist^.concat(new(pai_const,init_32bit(count)));
  1494. symtable^.foreach(write_field_inittable);
  1495. end;
  1496. {***********************************************************************************
  1497. TABSTRACTPROCDEF
  1498. ***************************************************************************}
  1499. constructor tabstractprocdef.init;
  1500. begin
  1501. inherited init;
  1502. para1:=nil;
  1503. {$ifdef StoreFPULevel}
  1504. fpu_used:=255;
  1505. {$endif StoreFPULevel}
  1506. options:=0;
  1507. retdef:=voiddef;
  1508. savesize:=Sizeof(pointer);
  1509. end;
  1510. destructor tabstractprocdef.done;
  1511. var
  1512. hp : pdefcoll;
  1513. begin
  1514. hp:=para1;
  1515. while assigned(hp) do
  1516. begin
  1517. para1:=hp^.next;
  1518. dispose(hp);
  1519. hp:=para1;
  1520. end;
  1521. inherited done;
  1522. end;
  1523. procedure tabstractprocdef.concatdef(p : pdef;vsp : tvarspez);
  1524. var
  1525. hp : pdefcoll;
  1526. begin
  1527. new(hp);
  1528. hp^.paratyp:=vsp;
  1529. hp^.data:=p;
  1530. hp^.next:=para1;
  1531. para1:=hp;
  1532. end;
  1533. procedure tabstractprocdef.deref;
  1534. var
  1535. hp : pdefcoll;
  1536. begin
  1537. inherited deref;
  1538. resolvedef(retdef);
  1539. hp:=para1;
  1540. while assigned(hp) do
  1541. begin
  1542. resolvedef(hp^.data);
  1543. hp:=hp^.next;
  1544. end;
  1545. end;
  1546. constructor tabstractprocdef.load;
  1547. var
  1548. last,hp : pdefcoll;
  1549. count,i : word;
  1550. begin
  1551. tdef.load;
  1552. retdef:=readdefref;
  1553. {$ifdef StoreFPULevel}
  1554. fpu_used:=readbyte;
  1555. {$endif StoreFPULevel}
  1556. options:=readlong;
  1557. count:=readword;
  1558. para1:=nil;
  1559. savesize:=Sizeof(pointer);
  1560. for i:=1 to count do
  1561. begin
  1562. new(hp);
  1563. hp^.paratyp:=tvarspez(readbyte);
  1564. hp^.data:=readdefref;
  1565. hp^.next:=nil;
  1566. if para1=nil then
  1567. para1:=hp
  1568. else
  1569. last^.next:=hp;
  1570. last:=hp;
  1571. end;
  1572. end;
  1573. function tabstractprocdef.para_size : longint;
  1574. var
  1575. pdc : pdefcoll;
  1576. l : longint;
  1577. begin
  1578. l:=0;
  1579. pdc:=para1;
  1580. while assigned(pdc) do
  1581. begin
  1582. case pdc^.paratyp of
  1583. vs_value :
  1584. l:=l+pdc^.data^.size+(pdc^.data^.size mod 2);
  1585. vs_var :
  1586. l:=l+sizeof(pointer);
  1587. vs_const :
  1588. if dont_copy_const_param(pdc^.data) then
  1589. l:=l+sizeof(pointer)
  1590. else
  1591. l:=l+pdc^.data^.size+(pdc^.data^.size mod 2);
  1592. end;
  1593. pdc:=pdc^.next;
  1594. end;
  1595. para_size:=l;
  1596. end;
  1597. procedure tabstractprocdef.write;
  1598. var
  1599. count : word;
  1600. hp : pdefcoll;
  1601. begin
  1602. tdef.write;
  1603. writedefref(retdef);
  1604. {$ifdef StoreFPULevel}
  1605. writebyte(fpu_used);
  1606. {$endif StoreFPULevel}
  1607. writelong(options);
  1608. hp:=para1;
  1609. count:=0;
  1610. while assigned(hp) do
  1611. begin
  1612. inc(count);
  1613. hp:=hp^.next;
  1614. end;
  1615. writeword(count);
  1616. hp:=para1;
  1617. while assigned(hp) do
  1618. begin
  1619. writebyte(byte(hp^.paratyp));
  1620. writedefref(hp^.data);
  1621. hp:=hp^.next;
  1622. end;
  1623. end;
  1624. function tabstractprocdef.demangled_paras : string;
  1625. var s : string;
  1626. p : pdefcoll;
  1627. begin
  1628. s:='';
  1629. p:=para1;
  1630. if assigned(p) then
  1631. begin
  1632. s:=s+'(';
  1633. while assigned(p) do
  1634. begin
  1635. if assigned(p^.data^.sym) then
  1636. s:=s+p^.data^.sym^.name
  1637. else if p^.paratyp=vs_var then
  1638. s:=s+'var'
  1639. else if p^.paratyp=vs_const then
  1640. s:=s+'const';
  1641. p:=p^.next;
  1642. if assigned(p) then
  1643. s:=s+','
  1644. else
  1645. s:=s+')';
  1646. end;
  1647. end;
  1648. demangled_paras:=s;
  1649. end;
  1650. {$ifdef GDB}
  1651. function tabstractprocdef.stabstring : pchar;
  1652. begin
  1653. stabstring := strpnew('abstractproc'+numberstring+';');
  1654. end;
  1655. procedure tabstractprocdef.concatstabto(asmlist : paasmoutput);
  1656. begin
  1657. if (not assigned(sym) or sym^.isusedinstab or use_dbx)
  1658. and not is_def_stab_written then
  1659. begin
  1660. if assigned(retdef) then forcestabto(asmlist,retdef);
  1661. inherited concatstabto(asmlist);
  1662. end;
  1663. end;
  1664. {$endif GDB}
  1665. {***********************************************************************************
  1666. TPROCDEF
  1667. ***************************************************************************}
  1668. constructor tprocdef.init;
  1669. begin
  1670. inherited init;
  1671. deftype:=procdef;
  1672. _mangledname:=nil;
  1673. nextoverloaded:=nil;
  1674. extnumber:=-1;
  1675. localst:=new(psymtable,init(localsymtable));
  1676. parast:=new(psymtable,init(parasymtable));
  1677. { this is used by insert
  1678. to check same names in parast and localst }
  1679. localst^.next:=parast;
  1680. {$ifdef UseBrowser}
  1681. defref:=nil;
  1682. lastwritten:=nil;
  1683. refcount:=0;
  1684. if (cs_browser in aktmoduleswitches) and make_ref then
  1685. begin
  1686. defref:=new(pref,init(defref,@tokenpos));
  1687. inc(refcount);
  1688. end;
  1689. lastref:=defref;
  1690. {$endif UseBrowser}
  1691. { first, we assume, that all registers are used }
  1692. {$ifdef i386}
  1693. usedregisters:=$ff;
  1694. {$endif i386}
  1695. {$ifdef m68k}
  1696. usedregisters:=$FFFF;
  1697. {$endif}
  1698. {$ifdef alpha}
  1699. usedregisters_int:=$ffffffff;
  1700. usedregisters_fpu:=$ffffffff;
  1701. {$endif alpha}
  1702. forwarddef:=true;
  1703. _class := nil;
  1704. code:=nil;
  1705. end;
  1706. constructor tprocdef.load;
  1707. var
  1708. s : string;
  1709. begin
  1710. { deftype:=procdef; this is at the wrong place !! }
  1711. inherited load;
  1712. deftype:=procdef;
  1713. {$ifdef i386}
  1714. usedregisters:=readbyte;
  1715. {$endif i386}
  1716. {$ifdef m68k}
  1717. usedregisters:=readword;
  1718. {$endif}
  1719. {$ifdef alpha}
  1720. usedregisters_int:=readlong;
  1721. usedregisters_fpu:=readlong;
  1722. {$endif alpha}
  1723. s:=readstring;
  1724. setstring(_mangledname,s);
  1725. extnumber:=readlong;
  1726. nextoverloaded:=pprocdef(readdefref);
  1727. _class := pobjectdef(readdefref);
  1728. if (cs_link_deffile in aktglobalswitches) and ((options and poexports)<>0) then
  1729. deffile.AddExport(mangledname);
  1730. parast:=nil;
  1731. localst:=nil;
  1732. forwarddef:=false;
  1733. {$ifdef UseBrowser}
  1734. lastref:=nil;
  1735. lastwritten:=nil;
  1736. defref:=nil;
  1737. refcount:=0;
  1738. {$endif UseBrowser}
  1739. end;
  1740. {$ifdef UseBrowser}
  1741. procedure tprocdef.load_references;
  1742. var
  1743. pos : tfileposinfo;
  1744. begin
  1745. while (not current_ppu^.endofentry) do
  1746. begin
  1747. readposinfo(pos);
  1748. inc(refcount);
  1749. lastref:=new(pref,init(lastref,@pos));
  1750. if refcount=1 then
  1751. defref:=lastref;
  1752. end;
  1753. end;
  1754. procedure tprocdef.write_references;
  1755. var
  1756. ref : pref;
  1757. begin
  1758. if lastwritten=lastref then
  1759. exit;
  1760. { write address of this symbol }
  1761. writedefref(@self);
  1762. { write refs }
  1763. if assigned(lastwritten) then
  1764. ref:=lastwritten
  1765. else
  1766. ref:=defref;
  1767. while assigned(ref) do
  1768. begin
  1769. writeposinfo(ref^.posinfo);
  1770. ref:=ref^.nextref;
  1771. end;
  1772. current_ppu^.writeentry(ibdefref);
  1773. lastwritten:=lastref;
  1774. end;
  1775. procedure tprocdef.add_to_browserlog;
  1776. begin
  1777. if assigned(defref) then
  1778. begin
  1779. Browse.AddLog('***'+mangledname);
  1780. Browse.AddLogRefs(defref);
  1781. if assigned(parast) then
  1782. parast^.writebrowserlog;
  1783. if assigned(localst) then
  1784. localst^.writebrowserlog;
  1785. end;
  1786. end;
  1787. {$endif UseBrowser}
  1788. destructor tprocdef.done;
  1789. begin
  1790. {$ifdef UseBrowser}
  1791. if assigned(defref) then
  1792. dispose(defref,done);
  1793. {$endif UseBrowser}
  1794. if assigned(parast) then
  1795. dispose(parast,done);
  1796. if assigned(localst) then
  1797. dispose(localst,done);
  1798. if
  1799. {$ifdef tp}
  1800. not(use_big) and
  1801. {$endif}
  1802. assigned(_mangledname) then
  1803. strdispose(_mangledname);
  1804. inherited done;
  1805. end;
  1806. procedure tprocdef.write;
  1807. begin
  1808. inherited write;
  1809. {$ifdef i386}
  1810. writebyte(usedregisters);
  1811. {$endif i386}
  1812. {$ifdef m68k}
  1813. writeword(usedregisters);
  1814. {$endif}
  1815. {$ifdef alpha}
  1816. writelong(usedregisters_int);
  1817. writelong(usedregisters_fpu);
  1818. {$endif alpha}
  1819. writestring(mangledname);
  1820. writelong(extnumber);
  1821. if (options and pooperator) = 0 then
  1822. writedefref(nextoverloaded)
  1823. else
  1824. begin
  1825. { only write the overloads from the same unit }
  1826. if nextoverloaded^.owner=owner then
  1827. writedefref(nextoverloaded)
  1828. else
  1829. writedefref(nil);
  1830. end;
  1831. writedefref(_class);
  1832. if (options and poinline) <> 0 then
  1833. begin
  1834. { we need to save
  1835. - the para and the local symtable
  1836. - the code ptree !! PM
  1837. writesymtable(parast);
  1838. writesymtable(localst);
  1839. writeptree(ptree(code));
  1840. }
  1841. end;
  1842. current_ppu^.writeentry(ibprocdef);
  1843. end;
  1844. {$ifdef GDB}
  1845. procedure addparaname(p : psym);
  1846. var vs : char;
  1847. begin
  1848. if pvarsym(p)^.varspez = vs_value then vs := '1'
  1849. else vs := '0';
  1850. strpcopy(strend(StabRecString),p^.name+':'+pvarsym(p)^.definition^.numberstring+','+vs+';');
  1851. end;
  1852. function tprocdef.stabstring : pchar;
  1853. var param : pdefcoll;
  1854. i : word;
  1855. vartyp : char;
  1856. oldrec : pchar;
  1857. begin
  1858. oldrec := stabrecstring;
  1859. getmem(StabRecString,1024);
  1860. param := para1;
  1861. i := 0;
  1862. while assigned(param) do
  1863. begin
  1864. inc(i);
  1865. param := param^.next;
  1866. end;
  1867. strpcopy(StabRecString,'f'+retdef^.numberstring);
  1868. if i>0 then
  1869. begin
  1870. strpcopy(strend(StabRecString),','+tostr(i)+';');
  1871. if assigned(parast) then
  1872. {$IfDef TP}
  1873. parast^.foreach(addparaname)
  1874. {$Else}
  1875. parast^.foreach(@addparaname)
  1876. {$EndIf}
  1877. else
  1878. begin
  1879. param := para1;
  1880. i := 0;
  1881. while assigned(param) do
  1882. begin
  1883. inc(i);
  1884. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  1885. {Here we have lost the parameter names !!}
  1886. {using lower case parameters }
  1887. strpcopy(strend(stabrecstring),'p'+tostr(i)
  1888. +':'+param^.data^.numberstring+','+vartyp+';');
  1889. param := param^.next;
  1890. end;
  1891. end;
  1892. {strpcopy(strend(StabRecString),';');}
  1893. end;
  1894. stabstring := strnew(stabrecstring);
  1895. freemem(stabrecstring,1024);
  1896. stabrecstring := oldrec;
  1897. end;
  1898. procedure tprocdef.concatstabto(asmlist : paasmoutput);
  1899. begin
  1900. end;
  1901. {$endif GDB}
  1902. procedure tprocdef.deref;
  1903. begin
  1904. inherited deref;
  1905. resolvedef(pdef(nextoverloaded));
  1906. resolvedef(pdef(_class));
  1907. end;
  1908. function tprocdef.mangledname : string;
  1909. {$ifdef tp}
  1910. var
  1911. oldpos : longint;
  1912. s : string;
  1913. b : byte;
  1914. {$endif tp}
  1915. begin
  1916. {$ifdef tp}
  1917. if use_big then
  1918. begin
  1919. symbolstream.seek(longint(_mangledname));
  1920. symbolstream.read(b,1);
  1921. symbolstream.read(s[1],b);
  1922. s[0]:=chr(b);
  1923. mangledname:=s;
  1924. end
  1925. else
  1926. {$endif}
  1927. mangledname:=strpas(_mangledname);
  1928. end;
  1929. {$IfDef GDB}
  1930. function tprocdef.cplusplusmangledname : string;
  1931. var
  1932. s,s2 : string;
  1933. param : pdefcoll;
  1934. begin
  1935. s := sym^.name;
  1936. if _class <> nil then
  1937. begin
  1938. s2 := _class^.name^;
  1939. s := s+'__'+tostr(length(s2))+s2;
  1940. end else s := s + '_';
  1941. param := para1;
  1942. while assigned(param) do
  1943. begin
  1944. s2 := param^.data^.sym^.name;
  1945. s := s+tostr(length(s2))+s2;
  1946. param := param^.next;
  1947. end;
  1948. cplusplusmangledname:=s;
  1949. end;
  1950. {$EndIf GDB}
  1951. procedure tprocdef.setmangledname(const s : string);
  1952. begin
  1953. if {$ifdef tp}not(use_big) and{$endif} (assigned(_mangledname)) then
  1954. strdispose(_mangledname);
  1955. setstring(_mangledname,s);
  1956. {$ifdef UseBrowser}
  1957. if assigned(parast) then
  1958. begin
  1959. stringdispose(parast^.name);
  1960. parast^.name:=stringdup('args of '+s);
  1961. end;
  1962. if assigned(localst) then
  1963. begin
  1964. stringdispose(localst^.name);
  1965. localst^.name:=stringdup('locals of '+s);
  1966. end;
  1967. {$endif UseBrowser}
  1968. end;
  1969. procedure tprocdef.write_rtti_data;
  1970. begin
  1971. end;
  1972. {***********************************************************************************
  1973. TPROCVARDEF
  1974. ***************************************************************************}
  1975. constructor tprocvardef.init;
  1976. begin
  1977. inherited init;
  1978. deftype:=procvardef;
  1979. end;
  1980. constructor tprocvardef.load;
  1981. begin
  1982. inherited load;
  1983. deftype:=procvardef;
  1984. end;
  1985. procedure tprocvardef.write;
  1986. begin
  1987. { here we cannot get a real good value so just give something }
  1988. { plausible (PM) }
  1989. {$ifdef StoreFPULevel}
  1990. if is_fpu(retdef) then
  1991. fpu_used:=2
  1992. else
  1993. fpu_used:=0;
  1994. {$endif StoreFPULevel}
  1995. inherited write;
  1996. current_ppu^.writeentry(ibprocvardef);
  1997. end;
  1998. function tprocvardef.size : longint;
  1999. begin
  2000. if (options and pomethodpointer)=0 then
  2001. size:=sizeof(pointer)
  2002. else
  2003. size:=2*sizeof(pointer);
  2004. end;
  2005. {$ifdef GDB}
  2006. function tprocvardef.stabstring : pchar;
  2007. var
  2008. nss : pchar;
  2009. i : word;
  2010. vartyp : char;
  2011. pst : pchar;
  2012. param : pdefcoll;
  2013. begin
  2014. i := 0;
  2015. param := para1;
  2016. while assigned(param) do
  2017. begin
  2018. inc(i);
  2019. param := param^.next;
  2020. end;
  2021. getmem(nss,1024);
  2022. strpcopy(nss,'f'+retdef^.numberstring+','+tostr(i)+';');
  2023. param := para1;
  2024. i := 0;
  2025. while assigned(param) do
  2026. begin
  2027. inc(i);
  2028. if param^.paratyp = vs_value then vartyp := '1' else vartyp := '0';
  2029. {Here we have lost the parameter names !!}
  2030. pst := strpnew('p'+tostr(i)+':'+param^.data^.numberstring+','+vartyp+';');
  2031. strcat(nss,pst);
  2032. strdispose(pst);
  2033. param := param^.next;
  2034. end;
  2035. {strpcopy(strend(nss),';');}
  2036. stabstring := strnew(nss);
  2037. freemem(nss,1024);
  2038. end;
  2039. procedure tprocvardef.concatstabto(asmlist : paasmoutput);
  2040. begin
  2041. if ( not assigned(sym) or sym^.isusedinstab or use_dbx)
  2042. and not is_def_stab_written then
  2043. inherited concatstabto(asmlist);
  2044. is_def_stab_written:=true;
  2045. end;
  2046. {$endif GDB}
  2047. {***************************************************************************
  2048. TOBJECTDEF
  2049. ***************************************************************************}
  2050. {$ifdef GDB}
  2051. const
  2052. vtabletype : word = 0;
  2053. vtableassigned : boolean = false;
  2054. {$endif GDB}
  2055. constructor tobjectdef.init(const n : string;c : pobjectdef);
  2056. begin
  2057. tdef.init;
  2058. deftype:=objectdef;
  2059. childof:=c;
  2060. options:=0;
  2061. { privatesyms:=new(psymtable,init(objectsymtable));
  2062. protectedsyms:=new(psymtable,init(objectsymtable)); }
  2063. publicsyms:=new(psymtable,init(objectsymtable));
  2064. publicsyms^.name := stringdup(n);
  2065. { add the data of the anchestor class }
  2066. if assigned(childof) then
  2067. begin
  2068. publicsyms^.datasize:=
  2069. publicsyms^.datasize-4+childof^.publicsyms^.datasize;
  2070. end;
  2071. name:=stringdup(n);
  2072. savesize := publicsyms^.datasize;
  2073. publicsyms^.defowner:=@self;
  2074. end;
  2075. constructor tobjectdef.load;
  2076. var
  2077. oldread_member : boolean;
  2078. begin
  2079. tdef.load;
  2080. deftype:=objectdef;
  2081. savesize:=readlong;
  2082. name:=stringdup(readstring);
  2083. childof:=pobjectdef(readdefref);
  2084. options:=readlong;
  2085. oldread_member:=read_member;
  2086. read_member:=true;
  2087. object_options:=true;
  2088. publicsyms:=new(psymtable,loadasstruct(objectsymtable));
  2089. object_options:=false;
  2090. read_member:=oldread_member;
  2091. publicsyms^.defowner:=@self;
  2092. publicsyms^.datasize:=savesize;
  2093. publicsyms^.name := stringdup(name^);
  2094. { handles the predefined class tobject }
  2095. { the last TOBJECT which is loaded gets }
  2096. { it ! }
  2097. if (name^='TOBJECT') and not(cs_compilesystem in aktmoduleswitches) and
  2098. isclass and (childof=pointer($ffffffff)) then
  2099. class_tobject:=@self;
  2100. end;
  2101. procedure tobjectdef.check_forwards;
  2102. begin
  2103. publicsyms^.check_forwards;
  2104. if (options and oo_isforward)<>0 then
  2105. begin
  2106. { ok, in future, the forward can be resolved }
  2107. Message1(sym_e_class_forward_not_resolved,name^);
  2108. options:=options and not(oo_isforward);
  2109. end;
  2110. end;
  2111. destructor tobjectdef.done;
  2112. begin
  2113. {!!!!
  2114. if assigned(privatesyms) then
  2115. dispose(privatesyms,done);
  2116. if assigned(protectedsyms) then
  2117. dispose(protectedsyms,done); }
  2118. if assigned(publicsyms) then
  2119. dispose(publicsyms,done);
  2120. if (options and oo_isforward)<>0 then
  2121. Message1(sym_e_class_forward_not_resolved,name^);
  2122. stringdispose(name);
  2123. tdef.done;
  2124. end;
  2125. { true, if self inherits from d (or if they are equal) }
  2126. function tobjectdef.isrelated(d : pobjectdef) : boolean;
  2127. var
  2128. hp : pobjectdef;
  2129. begin
  2130. hp:=@self;
  2131. while assigned(hp) do
  2132. begin
  2133. if hp=d then
  2134. begin
  2135. isrelated:=true;
  2136. exit;
  2137. end;
  2138. hp:=hp^.childof;
  2139. end;
  2140. isrelated:=false;
  2141. end;
  2142. function tobjectdef.size : longint;
  2143. begin
  2144. if (options and oois_class)<>0 then
  2145. size:=sizeof(pointer)
  2146. else
  2147. size:=publicsyms^.datasize;
  2148. end;
  2149. procedure tobjectdef.deref;
  2150. var
  2151. hp : pdef;
  2152. oldrecsyms : psymtable;
  2153. begin
  2154. resolvedef(pdef(childof));
  2155. oldrecsyms:=aktrecordsymtable;
  2156. aktrecordsymtable:=publicsyms;
  2157. { nun die Definitionen dereferenzieren }
  2158. hp:=publicsyms^.rootdef;
  2159. while assigned(hp) do
  2160. begin
  2161. hp^.deref;
  2162. { set owner }
  2163. hp^.owner:=publicsyms;
  2164. hp:=hp^.next;
  2165. end;
  2166. {$ifdef tp}
  2167. publicsyms^.foreach(derefsym);
  2168. {$else}
  2169. publicsyms^.foreach(@derefsym);
  2170. {$endif}
  2171. aktrecordsymtable:=oldrecsyms;
  2172. end;
  2173. function tobjectdef.vmt_mangledname : string;
  2174. {DM: I get a nil pointer on the owner name. I don't know if this
  2175. mayhappen, and I have therefore fixed the problem by doing nil pointer
  2176. checks.}
  2177. var s1,s2:string;
  2178. begin
  2179. if owner^.name=nil then
  2180. s1:=''
  2181. else
  2182. s1:=owner^.name^;
  2183. if name=nil then
  2184. s2:=''
  2185. else
  2186. s2:=name^;
  2187. vmt_mangledname:='VMT_'+s1+'$_'+s2;
  2188. end;
  2189. function tobjectdef.isclass : boolean;
  2190. begin
  2191. isclass:=(options and oois_class)<>0;
  2192. end;
  2193. procedure tobjectdef.write;
  2194. var
  2195. oldread_member : boolean;
  2196. begin
  2197. tdef.write;
  2198. writelong(size);
  2199. writestring(name^);
  2200. writedefref(childof);
  2201. writelong(options);
  2202. current_ppu^.writeentry(ibobjectdef);
  2203. oldread_member:=read_member;
  2204. read_member:=true;
  2205. object_options:=true;
  2206. publicsyms^.writeasstruct;
  2207. object_options:=false;
  2208. read_member:=oldread_member;
  2209. end;
  2210. {$ifdef GDB}
  2211. procedure addprocname(p :psym);
  2212. var virtualind,argnames : string;
  2213. news, newrec : pchar;
  2214. pd,ipd : pprocdef;
  2215. lindex : longint;
  2216. para : pdefcoll;
  2217. arglength : byte;
  2218. sp : char;
  2219. begin
  2220. If p^.typ = procsym then
  2221. begin
  2222. pd := pprocsym(p)^.definition;
  2223. { this will be used for full implementation of object stabs
  2224. not yet done }
  2225. ipd := pd;
  2226. while assigned(ipd^.nextoverloaded) do ipd := ipd^.nextoverloaded;
  2227. if (pd^.options and povirtualmethod) <> 0 then
  2228. begin
  2229. lindex := pd^.extnumber;
  2230. {doesnt seem to be necessary
  2231. lindex := lindex or $80000000;}
  2232. virtualind := '*'+tostr(lindex)+';'+ipd^._class^.numberstring+';'
  2233. end else virtualind := '.';
  2234. { arguments are not listed here }
  2235. {we don't need another definition}
  2236. para := pd^.para1;
  2237. argnames := '';
  2238. while assigned(para) do
  2239. begin
  2240. if para^.data^.deftype = formaldef then
  2241. begin
  2242. if para^.paratyp=vs_var then
  2243. argnames := argnames+'3var'
  2244. else if para^.paratyp=vs_const then
  2245. argnames:=argnames+'5const';
  2246. end
  2247. else
  2248. begin
  2249. { if the arg definition is like (v: ^byte;..
  2250. there is no sym attached to data !!! }
  2251. if assigned(para^.data^.sym) then
  2252. begin
  2253. arglength := length(para^.data^.sym^.name);
  2254. argnames := argnames + tostr(arglength)+para^.data^.sym^.name;
  2255. end
  2256. else
  2257. begin
  2258. argnames:=argnames+'11unnamedtype';
  2259. end;
  2260. end;
  2261. para := para^.next;
  2262. end;
  2263. ipd^.is_def_stab_written := true;
  2264. { here 2A must be changed for private and protected }
  2265. { 0 is private 1 protected and 2 public }
  2266. if (p^.properties and sp_private)<>0 then sp:='0'
  2267. else if (p^.properties and sp_protected)<>0 then sp:='1'
  2268. else sp:='2';
  2269. newrec := strpnew(p^.name+'::'+ipd^.numberstring
  2270. +'=##'+pd^.retdef^.numberstring+';:'+argnames+';'+sp+'A'
  2271. +virtualind+';');
  2272. { get spare place for a string at the end }
  2273. if strlen(StabRecString) + strlen(newrec) >= StabRecSize-256 then
  2274. begin
  2275. getmem(news,stabrecsize+memsizeinc);
  2276. strcopy(news,stabrecstring);
  2277. freemem(stabrecstring,stabrecsize);
  2278. stabrecsize:=stabrecsize+memsizeinc;
  2279. stabrecstring:=news;
  2280. end;
  2281. strcat(StabRecstring,newrec);
  2282. {freemem(newrec,memsizeinc); }
  2283. strdispose(newrec);
  2284. {This should be used for case !!}
  2285. RecOffset := RecOffset + pd^.size;
  2286. end;
  2287. end;
  2288. function tobjectdef.stabstring : pchar;
  2289. var anc : pobjectdef;
  2290. oldrec : pchar;
  2291. oldrecsize : longint;
  2292. str_end : string;
  2293. begin
  2294. oldrec := stabrecstring;
  2295. oldrecsize:=stabrecsize;
  2296. stabrecsize:=memsizeinc;
  2297. GetMem(stabrecstring,stabrecsize);
  2298. strpcopy(stabRecString,'s'+tostr(size));
  2299. if assigned(childof) then
  2300. {only one ancestor not virtual, public, at base offset 0 }
  2301. { !1 , 0 2 0 , }
  2302. strpcopy(strend(stabrecstring),'!1,020,'+childof^.numberstring+';');
  2303. {virtual table to implement yet}
  2304. RecOffset := 0;
  2305. {$ifdef tp}
  2306. publicsyms^.foreach(addname);
  2307. {$else}
  2308. publicsyms^.foreach(@addname);
  2309. {$endif tp}
  2310. if (options and oo_hasvirtual) <> 0 then
  2311. if not assigned(childof) or ((childof^.options and oo_hasvirtual) = 0) then
  2312. begin
  2313. str_end:='$vf'+numberstring+':'+typeglobalnumber('vtblarray')+',0;';
  2314. strpcopy(strend(stabrecstring),'$vf'+numberstring+':'+typeglobalnumber('vtblarray')+',0;');
  2315. end;
  2316. {$ifdef tp}
  2317. publicsyms^.foreach(addprocname);
  2318. {$else}
  2319. publicsyms^.foreach(@addprocname);
  2320. {$endif tp }
  2321. if (options and oo_hasvirtual) <> 0 then
  2322. begin
  2323. anc := @self;
  2324. while assigned(anc^.childof) and ((anc^.childof^.options and oo_hasvirtual) <> 0) do
  2325. anc := anc^.childof;
  2326. str_end:=';~%'+anc^.numberstring+';';
  2327. end
  2328. else
  2329. str_end:=';';
  2330. strpcopy(strend(stabrecstring),str_end);
  2331. stabstring := strnew(StabRecString);
  2332. freemem(stabrecstring,stabrecsize);
  2333. stabrecstring := oldrec;
  2334. stabrecsize:=oldrecsize;
  2335. end;
  2336. {$endif GDB}
  2337. procedure tobjectdef.write_child_init_data;
  2338. begin
  2339. end;
  2340. procedure tobjectdef.write_init_data;
  2341. begin
  2342. if isclass then
  2343. rttilist^.concat(new(pai_const,init_8bit(tkclass)))
  2344. else
  2345. rttilist^.concat(new(pai_const,init_8bit(tkobject)));
  2346. { generate the name }
  2347. rttilist^.concat(new(pai_const,init_8bit(length(name^))));
  2348. rttilist^.concat(new(pai_string,init(name^)));
  2349. rttilist^.concat(new(pai_const,init_32bit(size)));
  2350. count:=0;
  2351. publicsyms^.foreach(count_inittable_fields);
  2352. rttilist^.concat(new(pai_const,init_32bit(count)));
  2353. publicsyms^.foreach(write_field_inittable);
  2354. end;
  2355. function tobjectdef.needs_inittable : boolean;
  2356. var
  2357. oldb : boolean;
  2358. begin
  2359. { there are recursive calls to needs_inittable possible, }
  2360. { so we have to change to old value how else should }
  2361. { we do that ? check_rec_rtti can't be a nested }
  2362. { procedure of needs_rtti ! }
  2363. oldb:=binittable;
  2364. binittable:=false;
  2365. publicsyms^.foreach(check_rec_inittable);
  2366. needs_inittable:=binittable;
  2367. binittable:=oldb;
  2368. end;
  2369. procedure count_published_properties(sym : psym);{$ifndef fpc}far;{$endif}
  2370. begin
  2371. if (sym^.properties and sp_published)<>0 then
  2372. inc(count);
  2373. end;
  2374. procedure write_property_info(sym : psym);{$ifndef fpc}far;{$endif}
  2375. begin
  2376. end;
  2377. procedure generate_published_child_rtti(sym : psym);{$ifndef fpc}far;{$endif}
  2378. begin
  2379. end;
  2380. procedure tobjectdef.write_child_rtti_data;
  2381. begin
  2382. if assigned(childof) then
  2383. childof^.get_rtti_label;
  2384. publicsyms^.foreach(generate_published_child_rtti);
  2385. end;
  2386. procedure tobjectdef.write_rtti_data;
  2387. begin
  2388. if isclass then
  2389. rttilist^.concat(new(pai_const,init_8bit(tkclass)))
  2390. else
  2391. rttilist^.concat(new(pai_const,init_8bit(tkobject)));
  2392. { generate the name }
  2393. rttilist^.concat(new(pai_const,init_8bit(length(name^))));
  2394. rttilist^.concat(new(pai_string,init(name^)));
  2395. { write class type }
  2396. rttilist^.concat(new(pai_const,init_symbol(strpnew(vmt_mangledname))));
  2397. { write owner typeinfo }
  2398. if assigned(childof) then
  2399. rttilist^.concat(new(pai_const,init_symbol(strpnew(lab2str(childof^.get_rtti_label)))))
  2400. else
  2401. rttilist^.concat(new(pai_const,init_32bit(0)));
  2402. { write published properties count }
  2403. count:=0;
  2404. publicsyms^.foreach(count_published_properties);
  2405. rttilist^.concat(new(pai_const,init_16bit(count)));
  2406. { write unit name }
  2407. if assigned(owner^.name) then
  2408. begin
  2409. rttilist^.concat(new(pai_const,init_8bit(length(owner^.name^))));
  2410. rttilist^.concat(new(pai_string,init(owner^.name^)));
  2411. end
  2412. else
  2413. rttilist^.concat(new(pai_const,init_8bit(0)));
  2414. publicsyms^.foreach(write_property_info);
  2415. end;
  2416. {****************************************************************************
  2417. TERRORDEF
  2418. ****************************************************************************}
  2419. constructor terrordef.init;
  2420. begin
  2421. tdef.init;
  2422. deftype:=errordef;
  2423. end;
  2424. {$ifdef GDB}
  2425. function terrordef.stabstring : pchar;
  2426. begin
  2427. stabstring:=strpnew('error'+numberstring);
  2428. end;
  2429. {$endif GDB}
  2430. {
  2431. $Log$
  2432. Revision 1.32 1998-09-03 16:03:20 florian
  2433. + rtti generation
  2434. * init table generation changed
  2435. Revision 1.31 1998/09/02 15:14:28 peter
  2436. * enum packing changed from len to max
  2437. Revision 1.30 1998/09/01 17:37:29 peter
  2438. * removed debug writeln :(
  2439. Revision 1.29 1998/09/01 12:53:25 peter
  2440. + aktpackenum
  2441. Revision 1.28 1998/09/01 07:54:22 pierre
  2442. * UseBrowser a little updated (might still be buggy !!)
  2443. * bug in psub.pas in function specifier removed
  2444. * stdcall allowed in interface and in implementation
  2445. (FPC will not yet complain if it is missing in either part
  2446. because stdcall is only a dummy !!)
  2447. Revision 1.27 1998/08/28 12:51:43 florian
  2448. + ansistring to pchar type cast fixed
  2449. Revision 1.26 1998/08/25 12:42:44 pierre
  2450. * CDECL changed to CVAR for variables
  2451. specifications are read in structures also
  2452. + started adding GPC compatibility mode ( option -Sp)
  2453. * names changed to lowercase
  2454. Revision 1.25 1998/08/23 21:04:38 florian
  2455. + rtti generation for classes added
  2456. + new/dispose do now also a call to INITIALIZE/FINALIZE, if necessaray
  2457. Revision 1.24 1998/08/20 12:53:26 peter
  2458. * object_options are always written for object syms
  2459. Revision 1.23 1998/08/19 00:42:42 peter
  2460. + subrange types for enums
  2461. + checking for bounds type with ranges
  2462. Revision 1.22 1998/08/17 10:10:10 peter
  2463. - removed OLDPPU
  2464. Revision 1.21 1998/08/10 14:50:28 peter
  2465. + localswitches, moduleswitches, globalswitches splitting
  2466. Revision 1.20 1998/07/18 22:54:30 florian
  2467. * some ansi/wide/longstring support fixed:
  2468. o parameter passing
  2469. o returning as result from functions
  2470. Revision 1.19 1998/07/14 14:47:05 peter
  2471. * released NEWINPUT
  2472. Revision 1.18 1998/07/10 10:51:04 peter
  2473. * m68k updates
  2474. Revision 1.16 1998/07/07 11:20:13 peter
  2475. + NEWINPUT for a better inputfile and scanner object
  2476. Revision 1.15 1998/06/24 14:48:37 peter
  2477. * ifdef newppu -> ifndef oldppu
  2478. Revision 1.14 1998/06/16 08:56:31 peter
  2479. + targetcpu
  2480. * cleaner pmodules for newppu
  2481. Revision 1.13 1998/06/15 15:38:09 pierre
  2482. * small bug in systems.pas corrected
  2483. + operators in different units better hanlded
  2484. Revision 1.12 1998/06/15 14:30:12 daniel
  2485. * Reverted my changes.
  2486. Revision 1.10 1998/06/13 00:10:16 peter
  2487. * working browser and newppu
  2488. * some small fixes against crashes which occured in bp7 (but not in
  2489. fpc?!)
  2490. Revision 1.9 1998/06/12 14:10:37 michael
  2491. * Fixed wrong code for ansistring
  2492. Revision 1.8 1998/06/11 10:11:58 peter
  2493. * -gb works again
  2494. Revision 1.7 1998/06/07 15:30:25 florian
  2495. + first working rtti
  2496. + data init/final. for local variables
  2497. Revision 1.6 1998/06/05 14:37:37 pierre
  2498. * fixes for inline for operators
  2499. * inline procedure more correctly restricted
  2500. Revision 1.5 1998/06/04 23:52:01 peter
  2501. * m68k compiles
  2502. + .def file creation moved to gendef.pas so it could also be used
  2503. for win32
  2504. Revision 1.4 1998/06/04 09:55:45 pierre
  2505. * demangled name of procsym reworked to become independant of the mangling
  2506. scheme
  2507. Revision 1.3 1998/06/03 22:49:03 peter
  2508. + wordbool,longbool
  2509. * rename bis,von -> high,low
  2510. * moved some systemunit loading/creating to psystem.pas
  2511. Revision 1.2 1998/05/31 14:13:37 peter
  2512. * fixed call bugs with assembler readers
  2513. + OPR_SYMBOL to hold a symbol in the asm parser
  2514. * fixed staticsymtable vars which were acessed through %ebp instead of
  2515. name
  2516. Revision 1.1 1998/05/27 19:45:09 peter
  2517. * symtable.pas splitted into includefiles
  2518. * symtable adapted for $ifndef OLDPPU
  2519. }