fppu.pas 88 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564
  1. {
  2. Copyright (c) 1998-2002 by Florian Klaempfl
  3. This unit implements the first loading and searching of the modules
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit fppu;
  18. {$i fpcdefs.inc}
  19. { $define DEBUG_UNIT_CRC_CHANGES}
  20. { close ppufiles on system that are
  21. short on file handles like DOS system PM }
  22. {$ifdef GO32V2}
  23. {$define SHORT_ON_FILE_HANDLES}
  24. {$endif GO32V2}
  25. {$ifdef WATCOM}
  26. {$define SHORT_ON_FILE_HANDLES}
  27. {$endif WATCOM}
  28. interface
  29. uses
  30. cmsgs,verbose,
  31. cutils,cclasses,cstreams,
  32. globtype,globals,finput,fmodule,
  33. symbase,ppu,symtype;
  34. type
  35. { tppumodule }
  36. TAvailableUnitFile = (auPPU,auSrc);
  37. TAvailableUnitFiles = set of TAvailableUnitFile;
  38. tschedule_recompile_proc = procedure(amodule : tmodule) of object;
  39. tppumodule = class(tmodule)
  40. ppufile : tcompilerppufile; { the PPU file }
  41. sourcefn : TPathStr; { Source specified with "uses .. in '..'" }
  42. comments : TCmdStrList;
  43. nsprefix : TCmdStr; { Namespace prefix the unit was found with }
  44. reload_from : tppumodule; { from_module in case we need to reload }
  45. {$ifdef Test_Double_checksum}
  46. interface_read_crc_index,
  47. interface_write_crc_index,
  48. indirect_read_crc_index,
  49. indirect_write_crc_index,
  50. implementation_read_crc_index,
  51. implementation_write_crc_index : cardinal;
  52. interface_crc_array,
  53. indirect_crc_array,
  54. implementation_crc_array : pointer;
  55. {$endif def Test_Double_checksum}
  56. constructor create(LoadedFrom:TModule;const amodulename: string; const afilename:TPathStr;_is_unit:boolean);
  57. destructor destroy;override;
  58. procedure reset(for_recompile: boolean);override;
  59. procedure re_resolve(loadfrom: tmodule);
  60. function openppufile:boolean;
  61. function openppustream(strm:TCStream):boolean;
  62. procedure getppucrc;
  63. procedure writeppu;
  64. function loadppu(from_module : tmodule) : boolean;
  65. procedure post_load_or_compile(from_module : tmodule; second_time: boolean);
  66. procedure discardppu;
  67. function needrecompile:boolean;
  68. procedure setdefgeneration;
  69. procedure reload_flagged_units;
  70. procedure end_of_parsing;override;
  71. private
  72. unitimportsymsderefs : tfplist;
  73. { Each time a unit's defs are (re)created, its defsgeneration is
  74. set to the value of a global counter, and the global counter is
  75. increased. We only reresolve its dependent units' defs in case
  76. they have been resolved only for an older generation, in order to
  77. avoid endless resolving loops in case of cyclic dependencies. }
  78. defsgeneration : longint;
  79. function check_loadfrompackage: boolean;
  80. procedure check_reload(from_module: tmodule; var do_load: boolean);
  81. function openppu(ppufiletime:longint):boolean;
  82. procedure prepare_second_load(from_module: tmodule);
  83. procedure recompile_from_sources(from_module: tmodule);
  84. function search_unit_files(loaded_from : tmodule; onlysource:boolean):TAvailableUnitFiles;
  85. function search_unit(loaded_from : tmodule; onlysource,shortname:boolean):TAvailableUnitFiles;
  86. function loadfrompackage:boolean;
  87. procedure load_interface;
  88. procedure load_implementation;
  89. function load_usedunits : boolean;
  90. procedure printcomments;
  91. procedure queuecomment(const s:TMsgStr;v,w:longint);
  92. procedure buildderefunitimportsyms;
  93. procedure derefunitimportsyms;
  94. procedure freederefunitimportsyms;
  95. function try_load_ppufile(from_module: tmodule) : Boolean;
  96. procedure writesourcefiles;
  97. procedure writeusedunit(intf:boolean);
  98. procedure writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
  99. procedure writederefmap;
  100. procedure writederefdata;
  101. procedure writeImportSymbols;
  102. procedure writeResources;
  103. procedure writeOrderedSymbols;
  104. procedure writeunitimportsyms;
  105. procedure writeasmsyms(kind:tunitasmlisttype;list:tfphashobjectlist);
  106. procedure writeextraheader;
  107. procedure readsourcefiles;
  108. procedure readloadunit;
  109. procedure readlinkcontainer(var p:tlinkcontainer);
  110. procedure readderefmap;
  111. procedure readderefdata;
  112. procedure readImportSymbols;
  113. procedure readResources;
  114. procedure readOrderedSymbols;
  115. procedure readwpofile;
  116. procedure readunitimportsyms;
  117. procedure readasmsyms;
  118. procedure readextraheader;
  119. {$IFDEF MACRO_DIFF_HINT}
  120. procedure writeusedmacro(p:TNamedIndexItem;arg:pointer);
  121. procedure writeusedmacros;
  122. procedure readusedmacros;
  123. {$ENDIF}
  124. end;
  125. function registerunit(callermodule:tmodule;const s : TIDString;const fn:string; out is_new:boolean) : tppumodule;
  126. var
  127. { Set by task class. To avoid circular dependencies }
  128. schedule_recompile_proc : tschedule_recompile_proc;
  129. implementation
  130. uses
  131. SysUtils,
  132. cfileutl,
  133. systems,version,options,
  134. symtable, symsym,
  135. wpoinfo,
  136. scanner,
  137. aasmbase,ogbase,
  138. parser,
  139. comphook,
  140. entfile,fpkg,fpcp;
  141. var
  142. currentdefgeneration: longint;
  143. {****************************************************************************
  144. TPPUMODULE
  145. ****************************************************************************}
  146. constructor tppumodule.create(LoadedFrom:TModule;const amodulename: string; const afilename:TPathStr;_is_unit:boolean);
  147. begin
  148. inherited create(LoadedFrom,amodulename,afilename,_is_unit);
  149. ppufile:=nil;
  150. sourcefn:=afilename;
  151. unitimportsymsderefs:=tfplist.create;
  152. end;
  153. destructor tppumodule.destroy;
  154. begin
  155. discardppu;
  156. comments.free;
  157. comments:=nil;
  158. { all derefs allocated with new
  159. are dispose'd inside this method }
  160. freederefunitimportsyms;
  161. unitimportsymsderefs.free;
  162. unitimportsymsderefs:=nil;
  163. inherited Destroy;
  164. end;
  165. procedure tppumodule.reset(for_recompile : boolean);
  166. begin
  167. inc(currentdefgeneration);
  168. discardppu;
  169. freederefunitimportsyms;
  170. unitimportsymsderefs.free;
  171. unitimportsymsderefs:=tfplist.create;
  172. inherited reset(for_recompile);
  173. end;
  174. procedure tppumodule.re_resolve(loadfrom: tmodule);
  175. begin
  176. Message1(unit_u_reresolving_unit,modulename^);
  177. if tstoredsymtable(globalsymtable).is_deref_built then
  178. tstoredsymtable(globalsymtable).deref(false);
  179. if tstoredsymtable(globalsymtable).is_derefimpl_built then
  180. tstoredsymtable(globalsymtable).derefimpl(false);
  181. if assigned(localsymtable) then
  182. begin
  183. { we have only builderef(impl)'d the registered symbols of
  184. the localsymtable -> also only deref those again }
  185. if tstoredsymtable(localsymtable).is_deref_built then
  186. tstoredsymtable(localsymtable).deref(true);
  187. if tstoredsymtable(localsymtable).is_derefimpl_built then
  188. tstoredsymtable(localsymtable).derefimpl(true);
  189. end;
  190. if assigned(wpoinfo) then
  191. begin
  192. tunitwpoinfo(wpoinfo).deref;
  193. tunitwpoinfo(wpoinfo).derefimpl;
  194. end;
  195. { We have to flag the units that depend on this unit even
  196. though it didn't change, because they might also
  197. indirectly depend on the unit that did change (e.g.,
  198. in case rgobj, rgx86 and rgcpu have been compiled
  199. already, and then rgobj is recompiled for some reason
  200. -> rgx86 is re-reresolved, but the vmtentries of trgcpu
  201. must also be re-resolved, because they will also contain
  202. pointers to procdefs in the old trgobj (in case of a
  203. recompile, all old defs are freed) }
  204. flagdependent(loadfrom);
  205. reload_flagged_units;
  206. end;
  207. procedure tppumodule.queuecomment(const s:TMsgStr;v,w:longint);
  208. begin
  209. if comments = nil then
  210. comments := TCmdStrList.create;
  211. comments.insert(s);
  212. end;
  213. procedure tppumodule.printcomments;
  214. var
  215. comment: string;
  216. begin
  217. if comments = nil then
  218. exit;
  219. { comments are inserted in reverse order }
  220. repeat
  221. comment := comments.getlast;
  222. if length(comment) = 0 then
  223. exit;
  224. do_comment(v_normal, comment);
  225. until false;
  226. end;
  227. function tppumodule.openppufile:boolean;
  228. var
  229. ppufiletime : longint;
  230. begin
  231. openppufile:=false;
  232. Message1(unit_t_ppu_loading,ppufilename,@queuecomment);
  233. { Get ppufile time (also check if the file exists) }
  234. ppufiletime:=getnamedfiletime(ppufilename);
  235. if ppufiletime=-1 then
  236. exit;
  237. { Open the ppufile }
  238. Message1(unit_u_ppu_name,ppufilename);
  239. ppufile:=tcompilerppufile.create(ppufilename);
  240. if not ppufile.openfile then
  241. begin
  242. discardppu;
  243. Message(unit_u_ppu_file_too_short);
  244. exit;
  245. end;
  246. result:=openppu(ppufiletime);
  247. end;
  248. function tppumodule.openppustream(strm:TCStream):boolean;
  249. begin
  250. result:=false;
  251. { Open the ppufile }
  252. Message1(unit_u_ppu_name,ppufilename);
  253. ppufile:=tcompilerppufile.create(ppufilename);
  254. if not ppufile.openstream(strm) then
  255. begin
  256. discardppu;
  257. Message(unit_u_ppu_file_too_short);
  258. exit;
  259. end;
  260. result:=openppu(-1);
  261. end;
  262. function tppumodule.openppu(ppufiletime:longint):boolean;
  263. function checkheader: boolean;
  264. begin
  265. result:=false;
  266. { check for a valid PPU file }
  267. if not ppufile.CheckPPUId then
  268. begin
  269. Message(unit_u_ppu_invalid_header);
  270. exit;
  271. end;
  272. { check for allowed PPU versions }
  273. if not (ppufile.getversion = CurrentPPUVersion) then
  274. begin
  275. Message1(unit_u_ppu_invalid_version,tostr(ppufile.getversion),@queuecomment);
  276. exit;
  277. end;
  278. { check the target processor }
  279. if tsystemcpu(ppufile.header.common.cpu)<>target_cpu then
  280. begin
  281. Message(unit_u_ppu_invalid_processor,@queuecomment);
  282. exit;
  283. end;
  284. { check target }
  285. if tsystem(ppufile.header.common.target)<>target_info.system then
  286. begin
  287. Message(unit_u_ppu_invalid_target,@queuecomment);
  288. exit;
  289. end;
  290. {$ifdef cpufpemu}
  291. { check if floating point emulation is on?
  292. fpu emulation isn't unit levelwise because it affects calling convention }
  293. if ((ppufile.header.common.flags and uf_fpu_emulation)<>0) <>
  294. (cs_fp_emulation in current_settings.moduleswitches) then
  295. begin
  296. Message(unit_u_ppu_invalid_fpumode,@queuecomment);
  297. exit;
  298. end;
  299. {$endif cpufpemu}
  300. result:=true;
  301. end;
  302. function checkextraheader: boolean;
  303. begin
  304. result:=false;
  305. if ppufile.readentry<>ibextraheader then
  306. begin
  307. Message(unit_u_ppu_invalid_header);
  308. exit;
  309. end;
  310. readextraheader;
  311. if (longversion<>CurrentPPULongVersion) or
  312. not ppufile.EndOfEntry then
  313. begin
  314. Message(unit_u_ppu_invalid_header);
  315. exit;
  316. end;
  317. {$ifdef i8086}
  318. { check i8086 memory model flags }
  319. if (mf_i8086_far_code in moduleflags) <>
  320. (current_settings.x86memorymodel in [mm_medium,mm_large,mm_huge]) then
  321. begin
  322. Message(unit_u_ppu_invalid_memory_model,@queuecomment);
  323. exit;
  324. end;
  325. if (mf_i8086_far_data in moduleflags) <>
  326. (current_settings.x86memorymodel in [mm_compact,mm_large]) then
  327. begin
  328. Message(unit_u_ppu_invalid_memory_model,@queuecomment);
  329. exit;
  330. end;
  331. if (mf_i8086_huge_data in moduleflags) <>
  332. (current_settings.x86memorymodel=mm_huge) then
  333. begin
  334. Message(unit_u_ppu_invalid_memory_model,@queuecomment);
  335. exit;
  336. end;
  337. if (mf_i8086_cs_equals_ds in moduleflags) <>
  338. (current_settings.x86memorymodel=mm_tiny) then
  339. begin
  340. Message(unit_u_ppu_invalid_memory_model,@queuecomment);
  341. exit;
  342. end;
  343. if (mf_i8086_ss_equals_ds in moduleflags) <>
  344. (current_settings.x86memorymodel in [mm_tiny,mm_small,mm_medium]) then
  345. begin
  346. Message(unit_u_ppu_invalid_memory_model,@queuecomment);
  347. exit;
  348. end;
  349. {$endif i8086}
  350. {$ifdef wasm}
  351. { check WebAssembly exceptions mode flag }
  352. if ((mf_wasm_no_exceptions in moduleflags) <>
  353. (ts_wasm_no_exceptions in current_settings.targetswitches)) or
  354. ((mf_wasm_bf_exceptions in moduleflags) <>
  355. (ts_wasm_bf_exceptions in current_settings.targetswitches)) or
  356. ((mf_wasm_js_exceptions in moduleflags) <>
  357. (ts_wasm_js_exceptions in current_settings.targetswitches)) or
  358. ((mf_wasm_native_exceptions in moduleflags) <>
  359. (ts_wasm_native_exceptions in current_settings.targetswitches)) then
  360. begin
  361. Message(unit_u_ppu_invalid_wasm_exceptions_mode,@queuecomment);
  362. exit;
  363. end;
  364. if (mf_wasm_threads in moduleflags) <>
  365. (ts_wasm_threads in current_settings.targetswitches) then
  366. begin
  367. Message(unit_u_ppu_wasm_threads_mismatch,@queuecomment);
  368. exit;
  369. end;
  370. {$endif}
  371. if {$ifdef symansistr}not{$endif}(mf_symansistr in moduleflags) then
  372. begin
  373. Message(unit_u_ppu_symansistr_mismatch,@queuecomment);
  374. exit;
  375. end;
  376. if {$ifdef llvm}not{$endif}(mf_llvm in moduleflags) then
  377. begin
  378. Message(unit_u_ppu_llvm_mismatch,@queuecomment);
  379. exit;
  380. end;
  381. result:=true;
  382. end;
  383. begin
  384. openppu:=false;
  385. if not checkheader or
  386. not checkextraheader then
  387. begin
  388. discardppu;
  389. exit;
  390. end;
  391. { Load values to be access easier }
  392. headerflags:=ppufile.header.common.flags;
  393. crc:=ppufile.header.checksum;
  394. interface_crc:=ppufile.header.interface_checksum;
  395. indirect_crc:=ppufile.header.indirect_checksum;
  396. change_endian:=ppufile.change_endian;
  397. { Show Debug info }
  398. if ppufiletime<>-1 then
  399. Message1(unit_u_ppu_time,filetimestring(ppufiletime))
  400. else
  401. Message1(unit_u_ppu_time,'unknown');
  402. Message1(unit_u_ppu_flags,tostr(headerflags));
  403. Message1(unit_u_ppu_crc,hexstr(ppufile.header.checksum,8));
  404. Message1(unit_u_ppu_crc,hexstr(ppufile.header.interface_checksum,8)+' (intfc)');
  405. Message1(unit_u_ppu_crc,hexstr(ppufile.header.indirect_checksum,8)+' (indc)');
  406. Comment(V_used,'Number of definitions: '+tostr(ppufile.header.deflistsize));
  407. Comment(V_used,'Number of symbols: '+tostr(ppufile.header.symlistsize));
  408. openppu:=true;
  409. end;
  410. function tppumodule.search_unit_files(loaded_from : tmodule; onlysource:boolean):TAvailableUnitFiles;
  411. var
  412. found : TAvailableUnitFiles;
  413. begin
  414. found:=search_unit(loaded_from,onlysource,false);
  415. if (found=[]) and
  416. (ft83 in AllowedFilenameTransFormations) and
  417. (length(modulename^)>8) then
  418. found:=search_unit(loaded_from,onlysource,true);
  419. search_unit_files:=found;
  420. end;
  421. function tppumodule.search_unit(loaded_from : tmodule; onlysource,shortname:boolean):TAvailableUnitFiles;
  422. var
  423. singlepathstring,
  424. filename : TCmdStr;
  425. Function UnitExists(const ext:string;var foundfile:TCmdStr;const prefix:TCmdStr):boolean;
  426. var
  427. s : tcmdstr;
  428. begin
  429. if CheckVerbosity(V_Tried) then
  430. Message1(unit_t_unitsearch,Singlepathstring+filename+ext);
  431. s:=FileName+ext;
  432. if prefix<>'' then
  433. s:=prefix+'.'+s;
  434. UnitExists:=FindFile(s,Singlepathstring,true,foundfile);
  435. end;
  436. Function PPUSearchPath(const s,prefix:TCmdStr):boolean;
  437. var
  438. found : boolean;
  439. hs,
  440. newname : TCmdStr;
  441. begin
  442. Found:=false;
  443. singlepathstring:=FixPath(s,false);
  444. { Check for PPU file }
  445. Found:=UnitExists(target_info.unitext,hs,prefix);
  446. if Found then
  447. Begin
  448. SetFileName(hs,false);
  449. if prefix<>'' then
  450. begin
  451. newname:=prefix+'.'+realmodulename^;
  452. stringdispose(realmodulename);
  453. realmodulename:=stringdup(newname);
  454. stringdispose(modulename);
  455. modulename:=stringdup(upper(newname));
  456. end;
  457. Found:=openppufile;
  458. End;
  459. PPUSearchPath:=Found;
  460. end;
  461. Function SourceSearchPath(const s,prefix:TCmdStr):boolean;
  462. var
  463. found : boolean;
  464. hs,
  465. newname : TCmdStr;
  466. begin
  467. Found:=false;
  468. singlepathstring:=FixPath(s,false);
  469. { Check for Sources }
  470. ppufile:=nil;
  471. recompile_reason:=rr_noppu;
  472. {Check for .pp file}
  473. Found:=UnitExists(sourceext,hs,prefix);
  474. if not Found then
  475. begin
  476. { Check for .pas }
  477. Found:=UnitExists(pasext,hs,prefix);
  478. end;
  479. if not Found and
  480. ((m_mac in current_settings.modeswitches) or
  481. (tf_p_ext_support in target_info.flags)) then
  482. begin
  483. { Check for .p, if mode is macpas}
  484. Found:=UnitExists(pext,hs,prefix);
  485. end;
  486. mainsource:='';
  487. if Found then
  488. begin
  489. sources_avail:=true;
  490. { Load Filenames when found }
  491. mainsource:=hs;
  492. SetFileName(hs,false);
  493. if prefix<>'' then
  494. begin
  495. newname:=prefix+'.'+realmodulename^;
  496. stringdispose(realmodulename);
  497. realmodulename:=stringdup(newname);
  498. stringdispose(modulename);
  499. modulename:=stringdup(upper(newname));
  500. end;
  501. end
  502. else
  503. sources_avail:=false;
  504. SourceSearchPath:=Found;
  505. end;
  506. Function SearchPath(const s,prefix:TCmdStr):TAvailableUnitFiles;
  507. var
  508. found : TAvailableUnitFiles;
  509. begin
  510. { First check for a ppu, then for the source }
  511. found:=[];
  512. if not onlysource then
  513. if PPUSearchPath(s,prefix) then
  514. Include(found,auPPU);
  515. if found=[] then
  516. if SourceSearchPath(s,prefix) then
  517. Include(found,auSrc);
  518. SearchPath:=found;
  519. end;
  520. Function SearchPathList(list:TSearchPathList;const prefix:TCmdStr):TAvailableUnitFiles;
  521. var
  522. hp : TCmdStrListItem;
  523. found : TAvailableUnitFiles;
  524. begin
  525. found:=[];
  526. hp:=TCmdStrListItem(list.First);
  527. while assigned(hp) do
  528. begin
  529. found:=SearchPath(hp.Str,prefix);
  530. if found<>[] then
  531. break;
  532. hp:=TCmdStrListItem(hp.next);
  533. end;
  534. SearchPathList:=found;
  535. end;
  536. function SearchPPUPaths(const prefix:TCmdStr):boolean;
  537. begin
  538. result:=PPUSearchPath('.',prefix);
  539. if (not result) and (outputpath<>'') then
  540. result:=PPUSearchPath(outputpath,prefix);
  541. if (not result) and Assigned(main_module) and (main_module.Path<>'') then
  542. result:=PPUSearchPath(main_module.Path,prefix);
  543. end;
  544. function SearchSourcePaths(const prefix:TCmdStr):TAvailableUnitFiles;
  545. begin
  546. result:=[];
  547. if SourceSearchPath('.',prefix) then
  548. include(Result,auSrc);
  549. if (result=[]) and Assigned(main_module) and (main_module.Path<>'') then
  550. if SourceSearchPath(main_module.Path,prefix) then
  551. include(Result,auSrc);
  552. if (result=[]) and Assigned(loaded_from) then
  553. result:=SearchPathList(loaded_from.LocalUnitSearchPath,prefix);
  554. if (result=[]) then
  555. result:=SearchPathList(UnitSearchPath,prefix);
  556. end;
  557. function SearchNamespaceList(const prefixes:TCmdStrList): TAvailableUnitFiles;
  558. var
  559. nsitem : TCmdStrListItem;
  560. res : TAvailableUnitFiles;
  561. begin
  562. res:=[];
  563. nsitem:=TCmdStrListItem(prefixes.first);
  564. while assigned(nsitem) do
  565. begin
  566. if not onlysource then
  567. begin
  568. if SearchPPUPaths(nsitem.str) then
  569. Include(res,auPPU);
  570. if res<>[] then
  571. break;
  572. end;
  573. res:=SearchSourcePaths(nsitem.str);
  574. if res<>[] then
  575. break;
  576. nsitem:=TCmdStrListItem(nsitem.next);
  577. end;
  578. if assigned(nsitem) then
  579. nsprefix:=nsitem.str;
  580. result:=res;
  581. end;
  582. var
  583. fnd : TAvailableUnitFiles;
  584. hs : TPathStr;
  585. begin
  586. fnd:=[];
  587. if shortname then
  588. filename:=FixFileName(Copy(realmodulename^,1,8))
  589. else
  590. filename:=FixFileName(realmodulename^);
  591. { try to find unit
  592. 1. look for ppu in cwd
  593. 2. look for ppu in outputpath if set, this is tp7 compatible (PFV)
  594. 3. look for ppu in maindir
  595. 4. look for the specified source file (from the uses line)
  596. 5. look for source in cwd
  597. 6. look for source in maindir
  598. 7. local unit pathlist
  599. 8. global unit pathlist
  600. 9. for each default namespace:
  601. repeat 1 - 3 and 5 - 8 with namespace as prefix }
  602. if not onlysource then
  603. if SearchPPUPaths('') then
  604. include(fnd,auPPU);
  605. if (fnd=[]) and (sourcefn<>'') then
  606. begin
  607. { the full filename is specified so we can't use here the
  608. searchpath (PFV) }
  609. if CheckVerbosity(V_Tried) then
  610. Message1(unit_t_unitsearch,ChangeFileExt(sourcefn,sourceext));
  611. if FindFile(ChangeFileExt(sourcefn,sourceext),'',true,hs) then
  612. include(fnd,auSrc);
  613. if (fnd=[]) then
  614. begin
  615. if CheckVerbosity(V_Tried) then
  616. Message1(unit_t_unitsearch,ChangeFileExt(sourcefn,pasext));
  617. if FindFile(ChangeFileExt(sourcefn,pasext),'',true,hs) then
  618. include(fnd,auSrc);
  619. end;
  620. if (fnd=[]) and
  621. ((m_mac in current_settings.modeswitches) or
  622. (tf_p_ext_support in target_info.flags)) then
  623. begin
  624. if CheckVerbosity(V_Tried) then
  625. Message1(unit_t_unitsearch,ChangeFileExt(sourcefn,pext));
  626. if FindFile(ChangeFileExt(sourcefn,pext),'',true,hs) then
  627. include(fnd,auSrc)
  628. end;
  629. if [auSrc]=fnd then
  630. begin
  631. sources_avail:=true;
  632. state:=ms_compile;
  633. recompile_reason:=rr_noppu;
  634. mainsource:=hs;
  635. SetFileName(hs,false);
  636. end;
  637. end;
  638. if fnd=[] then
  639. begin
  640. fnd:=SearchSourcePaths('');
  641. // current_namespacelist is set to the current module's namespacelist.
  642. if (fnd=[]) and assigned(current_namespacelist) and (current_namespacelist.count>0) then
  643. fnd:=SearchNameSpaceList(current_namespacelist);
  644. if (fnd=[]) and (namespacelist.count>0) then
  645. fnd:=SearchNameSpaceList(namespacelist);
  646. end;
  647. search_unit:=fnd;
  648. end;
  649. function tppumodule.loadfrompackage: boolean;
  650. (*var
  651. singlepathstring,
  652. filename : TCmdStr;
  653. Function UnitExists(const ext:string;var foundfile:TCmdStr):boolean;
  654. begin
  655. if CheckVerbosity(V_Tried) then
  656. Message1(unit_t_unitsearch,Singlepathstring+filename);
  657. UnitExists:=FindFile(FileName,Singlepathstring,true,foundfile);
  658. end;
  659. Function PPUSearchPath(const s:TCmdStr):boolean;
  660. var
  661. found : boolean;
  662. hs : TCmdStr;
  663. begin
  664. Found:=false;
  665. singlepathstring:=FixPath(s,false);
  666. { Check for PPU file }
  667. Found:=UnitExists(target_info.unitext,hs);
  668. if Found then
  669. Begin
  670. SetFileName(hs,false);
  671. //Found:=OpenPPU;
  672. End;
  673. PPUSearchPath:=Found;
  674. end;
  675. Function SearchPathList(list:TSearchPathList):boolean;
  676. var
  677. hp : TCmdStrListItem;
  678. found : boolean;
  679. begin
  680. found:=false;
  681. hp:=TCmdStrListItem(list.First);
  682. while assigned(hp) do
  683. begin
  684. found:=PPUSearchPath(hp.Str);
  685. if found then
  686. break;
  687. hp:=TCmdStrListItem(hp.next);
  688. end;
  689. SearchPathList:=found;
  690. end;*)
  691. var
  692. pkg : ppackageentry;
  693. pkgunit : pcontainedunit;
  694. i,idx : longint;
  695. strm : TCStream;
  696. begin
  697. result:=false;
  698. for i:=0 to packagelist.count-1 do
  699. begin
  700. pkg:=ppackageentry(packagelist[i]);
  701. if not assigned(pkg^.package) then
  702. internalerror(2013053103);
  703. idx:=pkg^.package.containedmodules.FindIndexOf(modulename^);
  704. if idx>=0 then
  705. begin
  706. { the unit is part of this package }
  707. pkgunit:=pcontainedunit(pkg^.package.containedmodules[idx]);
  708. if not assigned(pkgunit^.module) then
  709. pkgunit^.module:=self;
  710. { ToDo: check whether we really don't need this anymore }
  711. {filename:=pkgunit^.ppufile;
  712. if not SearchPathList(unitsearchpath) then
  713. exit};
  714. strm:=tpcppackage(pkg^.package).getmodulestream(self);
  715. if not assigned(strm) then
  716. internalerror(2015103002);
  717. if not openppustream(strm) then
  718. exit;
  719. package:=pkg^.package;
  720. Message2(unit_u_loading_from_package,modulename^,pkg^.package.packagename^);
  721. { now load the unit and all used units }
  722. load_interface;
  723. setdefgeneration;
  724. result:=Load_usedunits;
  725. Message1(unit_u_finished_loading_unit,modulename^);
  726. result:=true;
  727. break;
  728. end;
  729. end;
  730. end;
  731. procedure tppumodule.buildderefunitimportsyms;
  732. var
  733. i : longint;
  734. deref : pderef;
  735. begin
  736. unitimportsymsderefs.capacity:=unitimportsymsderefs.count+unitimportsyms.count;
  737. for i:=0 to unitimportsyms.count-1 do
  738. begin
  739. new(deref);
  740. deref^.build(unitimportsyms[i]);
  741. unitimportsymsderefs.add(deref);
  742. end;
  743. end;
  744. procedure tppumodule.derefunitimportsyms;
  745. var
  746. i : longint;
  747. sym : tsym;
  748. begin
  749. unitimportsyms.capacity:=unitimportsyms.count+unitimportsymsderefs.count;
  750. for i:=0 to unitimportsymsderefs.count-1 do
  751. begin
  752. sym:=tsym(pderef(unitimportsymsderefs[i])^.resolve);
  753. unitimportsyms.add(sym);
  754. end;
  755. end;
  756. procedure tppumodule.freederefunitimportsyms;
  757. var
  758. i : longint;
  759. deref : pderef;
  760. begin
  761. for i:=0 to unitimportsymsderefs.count-1 do
  762. begin
  763. deref:=pderef(unitimportsymsderefs[i]);
  764. system.dispose(deref);
  765. end;
  766. end;
  767. {**********************************
  768. PPU Reading/Writing Helpers
  769. ***********************************}
  770. {$IFDEF MACRO_DIFF_HINT}
  771. var
  772. is_initial: Boolean;
  773. procedure tppumodule.writeusedmacro(p:TNamedIndexItem;arg:pointer);
  774. begin
  775. if tmacro(p).is_used or is_initial then
  776. begin
  777. ppufile.putstring(p.name);
  778. ppufile.putboolean(is_initial);
  779. ppufile.putboolean(tmacro(p).is_used);
  780. end;
  781. end;
  782. procedure tppumodule.writeusedmacros;
  783. begin
  784. ppufile.do_crc:=false;
  785. is_initial:= true;
  786. initialmacrosymtable.foreach(@writeusedmacro,nil);
  787. is_initial:= false;
  788. if assigned(globalmacrosymtable) then
  789. globalmacrosymtable.foreach(@writeusedmacro,nil);
  790. localmacrosymtable.foreach(@writeusedmacro,nil);
  791. ppufile.writeentry(ibusedmacros);
  792. ppufile.do_crc:=true;
  793. end;
  794. {$ENDIF}
  795. procedure tppumodule.writesourcefiles;
  796. var
  797. hp : tinputfile;
  798. ifile : sizeint;
  799. begin
  800. { second write the used source files }
  801. ppufile.do_crc:=false;
  802. { write source files directly in good order }
  803. for ifile:=0 to sourcefiles.nfiles-1 do
  804. begin
  805. hp:=sourcefiles.files[ifile];
  806. ppufile.putstring(hp.inc_path+hp.name);
  807. ppufile.putlongint(hp.getfiletime);
  808. end;
  809. ppufile.writeentry(ibsourcefiles);
  810. ppufile.do_crc:=true;
  811. end;
  812. procedure tppumodule.writeusedunit(intf:boolean);
  813. var
  814. hp : tused_unit;
  815. oldcrc : boolean;
  816. begin
  817. { write a reference for each used unit }
  818. hp:=tused_unit(used_units.first);
  819. while assigned(hp) do
  820. begin
  821. if hp.in_interface=intf then
  822. begin
  823. ppufile.putstring(hp.u.realmodulename^);
  824. { the checksum should not affect the crc of this unit ! (PFV) }
  825. oldcrc:=ppufile.do_crc;
  826. ppufile.do_crc:=false;
  827. ppufile.putlongint(longint(hp.checksum));
  828. ppufile.putlongint(longint(hp.interface_checksum));
  829. ppufile.putlongint(longint(hp.indirect_checksum));
  830. ppufile.do_crc:=oldcrc;
  831. { combine all indirect checksums from units used by this unit }
  832. if intf then
  833. ppufile.indirect_crc:=ppufile.indirect_crc xor hp.indirect_checksum;
  834. end;
  835. hp:=tused_unit(hp.next);
  836. end;
  837. ppufile.do_interface_crc:=true;
  838. ppufile.writeentry(ibloadunit);
  839. end;
  840. procedure tppumodule.writelinkcontainer(var p:tlinkcontainer;id:byte;strippath:boolean);
  841. var
  842. hcontainer : tlinkcontainer;
  843. s : TPathStr;
  844. mask : cardinal;
  845. begin
  846. hcontainer:=TLinkContainer.Create;
  847. while not p.empty do
  848. begin
  849. s:=p.get(mask);
  850. if strippath then
  851. ppufile.putstring(ExtractFileName(s))
  852. else
  853. ppufile.putstring(s);
  854. ppufile.putlongint(mask);
  855. hcontainer.add(s,mask);
  856. end;
  857. ppufile.writeentry(id);
  858. p.Free;
  859. p:=hcontainer;
  860. end;
  861. procedure tppumodule.writederefmap;
  862. var
  863. i : longint;
  864. oldcrc : boolean;
  865. begin
  866. { This does not influence crc }
  867. oldcrc:=ppufile.do_crc;
  868. ppufile.do_crc:=false;
  869. { The unit map used for resolving }
  870. ppufile.putlongint(derefmapcnt);
  871. for i:=0 to derefmapcnt-1 do
  872. begin
  873. if not assigned(derefmap[i].u) then
  874. internalerror(2005011512);
  875. ppufile.putstring(derefmap[i].u.modulename^)
  876. end;
  877. ppufile.writeentry(ibderefmap);
  878. ppufile.do_crc:=oldcrc;
  879. end;
  880. procedure tppumodule.writederefdata;
  881. var
  882. oldcrc : boolean;
  883. len,hlen : longint;
  884. buf : array[0..1023] of byte;
  885. begin
  886. if longword(derefdataintflen)>derefdata.size then
  887. internalerror(200310223);
  888. derefdata.seek(0);
  889. { Write interface data }
  890. len:=derefdataintflen;
  891. while (len>0) do
  892. begin
  893. if len>1024 then
  894. hlen:=1024
  895. else
  896. hlen:=len;
  897. derefdata.read(buf,hlen);
  898. ppufile.putdata(buf,hlen);
  899. dec(len,hlen);
  900. end;
  901. { Write implementation data, this does not influence crc }
  902. oldcrc:=ppufile.do_crc;
  903. ppufile.do_crc:=false;
  904. len:=derefdata.size-derefdataintflen;
  905. while (len>0) do
  906. begin
  907. if len>1024 then
  908. hlen:=1024
  909. else
  910. hlen:=len;
  911. derefdata.read(buf,hlen);
  912. ppufile.putdata(buf,hlen);
  913. dec(len,hlen);
  914. end;
  915. if derefdata.pos<>derefdata.size then
  916. internalerror(200310224);
  917. ppufile.do_crc:=oldcrc;
  918. ppufile.writeentry(ibderefdata);
  919. end;
  920. procedure tppumodule.writeImportSymbols;
  921. var
  922. i,j : longint;
  923. ImportLibrary : TImportLibrary;
  924. ImportSymbol : TImportSymbol;
  925. begin
  926. for i:=0 to ImportLibraryList.Count-1 do
  927. begin
  928. ImportLibrary:=TImportLibrary(ImportLibraryList[i]);
  929. ppufile.putstring(ImportLibrary.Name);
  930. ppufile.putlongint(ImportLibrary.ImportSymbolList.Count);
  931. for j:=0 to ImportLibrary.ImportSymbolList.Count-1 do
  932. begin
  933. ImportSymbol:=TImportSymbol(ImportLibrary.ImportSymbolList[j]);
  934. ppufile.putstring(ImportSymbol.Name);
  935. ppufile.putstring(ImportSymbol.MangledName);
  936. ppufile.putlongint(ImportSymbol.OrdNr);
  937. ppufile.putbyte(byte(ImportSymbol.IsVar));
  938. end;
  939. end;
  940. ppufile.writeentry(ibImportSymbols);
  941. end;
  942. procedure tppumodule.writeResources;
  943. var
  944. res : TCmdStrListItem;
  945. begin
  946. res:=TCmdStrListItem(ResourceFiles.First);
  947. while res<>nil do
  948. begin
  949. ppufile.putstring(res.FPStr);
  950. res:=TCmdStrListItem(res.Next);
  951. end;
  952. ppufile.writeentry(ibresources);
  953. end;
  954. procedure tppumodule.writeOrderedSymbols;
  955. var
  956. res : TCmdStrListItem;
  957. begin
  958. res:=TCmdStrListItem(linkorderedsymbols.First);
  959. while res<>nil do
  960. begin
  961. ppufile.putstring(res.FPStr);
  962. res:=TCmdStrListItem(res.Next);
  963. end;
  964. ppufile.writeentry(iborderedsymbols);
  965. end;
  966. procedure tppumodule.writeunitimportsyms;
  967. var
  968. i : longint;
  969. begin
  970. ppufile.putlongint(unitimportsymsderefs.count);
  971. for i:=0 to unitimportsymsderefs.count-1 do
  972. ppufile.putderef(pderef(unitimportsymsderefs[i])^);
  973. ppufile.writeentry(ibunitimportsyms);
  974. end;
  975. procedure tppumodule.writeasmsyms(kind:tunitasmlisttype;list:tfphashobjectlist);
  976. var
  977. i : longint;
  978. sym : TAsmSymbol;
  979. begin
  980. ppufile.putbyte(ord(kind));
  981. ppufile.putlongint(list.count);
  982. for i:=0 to list.count-1 do
  983. begin
  984. sym:=TAsmSymbol(list[i]);
  985. ppufile.putstring(sym.Name);
  986. ppufile.putbyte(ord(sym.bind));
  987. ppufile.putbyte(ord(sym.typ));
  988. end;
  989. ppufile.writeentry(ibasmsymbols);
  990. end;
  991. procedure tppumodule.writeextraheader;
  992. var
  993. old_docrc: boolean;
  994. begin
  995. { create unit flags }
  996. if do_release then
  997. include(moduleflags,mf_release);
  998. if assigned(localsymtable) then
  999. include(moduleflags,mf_local_symtable);
  1000. if cs_checkpointer_called in current_settings.moduleswitches then
  1001. include(moduleflags,mf_checkpointer_called);
  1002. if cs_compilesystem in current_settings.moduleswitches then
  1003. include(moduleflags,mf_system_unit);
  1004. {$ifdef i8086}
  1005. if current_settings.x86memorymodel in [mm_medium,mm_large,mm_huge] then
  1006. include(moduleflags,mf_i8086_far_code);
  1007. if current_settings.x86memorymodel in [mm_compact,mm_large] then
  1008. include(moduleflags,mf_i8086_far_data);
  1009. if current_settings.x86memorymodel=mm_huge then
  1010. include(moduleflags,mf_i8086_huge_data);
  1011. if current_settings.x86memorymodel=mm_tiny then
  1012. include(moduleflags,mf_i8086_cs_equals_ds);
  1013. if current_settings.x86memorymodel in [mm_tiny,mm_small,mm_medium] then
  1014. include(moduleflags,mf_i8086_ss_equals_ds);
  1015. {$endif i8086}
  1016. {$ifdef wasm}
  1017. if ts_wasm_no_exceptions in current_settings.targetswitches then
  1018. include(moduleflags,mf_wasm_no_exceptions);
  1019. if ts_wasm_native_exceptions in current_settings.targetswitches then
  1020. include(moduleflags,mf_wasm_native_exceptions);
  1021. if ts_wasm_js_exceptions in current_settings.targetswitches then
  1022. include(moduleflags,mf_wasm_js_exceptions);
  1023. if ts_wasm_bf_exceptions in current_settings.targetswitches then
  1024. include(moduleflags,mf_wasm_bf_exceptions);
  1025. if ts_wasm_threads in current_settings.targetswitches then
  1026. include(moduleflags,mf_wasm_threads);
  1027. {$endif wasm}
  1028. {$ifdef llvm}
  1029. include(moduleflags,mf_llvm);
  1030. {$endif}
  1031. {$ifdef symansistr}
  1032. include(moduleflags,mf_symansistr);
  1033. {$endif}
  1034. old_docrc:=ppufile.do_crc;
  1035. ppufile.do_crc:=false;
  1036. ppufile.putlongint(longint(CurrentPPULongVersion));
  1037. ppufile.putset(tppuset4(moduleflags));
  1038. ppufile.writeentry(ibextraheader);
  1039. ppufile.do_crc:=old_docrc;
  1040. end;
  1041. {$IFDEF MACRO_DIFF_HINT}
  1042. {
  1043. Define MACRO_DIFF_HINT for the whole compiler (and ppudump)
  1044. to turn this facility on. Also the hint messages defined
  1045. below must be commented in in the msg/errore.msg file.
  1046. There is some problems with this, thats why it is shut off:
  1047. At the first compilation, consider a macro which is not initially
  1048. defined, but it is used (e g the check that it is undefined is true).
  1049. Since it do not exist, there is no macro object where the is_used
  1050. flag can be set. Later on when the macro is defined, and the ppu
  1051. is opened, the check cannot detect this.
  1052. Also, in which macro object should this flag be set ? It cant be set
  1053. for macros in the initialmacrosymboltable since this table is shared
  1054. between different files.
  1055. }
  1056. procedure tppumodule.readusedmacros;
  1057. var
  1058. hs : string;
  1059. mac : tmacro;
  1060. was_initial,
  1061. was_used : boolean;
  1062. {Reads macros which was defined or used when the module was compiled.
  1063. This is done when a ppu file is open, before it possibly is parsed.}
  1064. begin
  1065. while not ppufile.endofentry do
  1066. begin
  1067. hs:=ppufile.getstring;
  1068. was_initial:=ppufile.getboolean;
  1069. was_used:=ppufile.getboolean;
  1070. mac:=tmacro(initialmacrosymtable.Find(hs));
  1071. if assigned(mac) then
  1072. begin
  1073. {$ifndef EXTDEBUG}
  1074. { if we don't have the sources why tell }
  1075. if sources_avail then
  1076. {$endif ndef EXTDEBUG}
  1077. if (not was_initial) and was_used then
  1078. Message2(unit_h_cond_not_set_in_last_compile,hs,mainsource^);
  1079. end
  1080. else { not assigned }
  1081. if was_initial and
  1082. was_used then
  1083. Message2(unit_h_cond_set_in_last_compile,hs,mainsource^);
  1084. end;
  1085. end;
  1086. {$ENDIF}
  1087. procedure tppumodule.readsourcefiles;
  1088. var
  1089. temp,hs : string;
  1090. inc_path : string;
  1091. temp_dir : TCmdStr;
  1092. main_dir : TCmdStr;
  1093. found,
  1094. is_main : boolean;
  1095. orgfiletime,
  1096. source_time : longint;
  1097. hp : tinputfile;
  1098. begin
  1099. sources_avail:=not(mf_release in moduleflags);
  1100. is_main:=true;
  1101. main_dir:='';
  1102. while not ppufile.endofentry do
  1103. begin
  1104. hs:=SetDirSeparators(ppufile.getstring);
  1105. inc_path:=ExtractFilePath(hs);
  1106. orgfiletime:=ppufile.getlongint;
  1107. temp_dir:='';
  1108. if sources_avail then
  1109. begin
  1110. if (headerflags and uf_in_library)<>0 then
  1111. begin
  1112. sources_avail:=false;
  1113. temp:=' library';
  1114. end
  1115. else if pos('Macro ',hs)=1 then
  1116. begin
  1117. { we don't want to find this file }
  1118. { but there is a problem with file indexing !! }
  1119. temp:='';
  1120. end
  1121. else
  1122. begin
  1123. { check the date of the source files:
  1124. 1 path of sourcefn
  1125. 2 path of ppu
  1126. 3 path of main source
  1127. 4 current dir
  1128. 5 include/unit path }
  1129. found:=false;
  1130. if sourcefn<>'' then
  1131. begin
  1132. temp_dir:=ExtractFilePath(SetDirSeparators(sourcefn));
  1133. Source_Time:=GetNamedFileTime(temp_dir+hs);
  1134. if Source_Time<>-1 then
  1135. hs:=temp_dir+hs;
  1136. end else
  1137. Source_Time:=-1;
  1138. if Source_Time=-1 then
  1139. begin
  1140. Source_Time:=GetNamedFileTime(path+hs);
  1141. if Source_Time<>-1 then
  1142. hs:=path+hs
  1143. else
  1144. if not(is_main) then
  1145. begin
  1146. Source_Time:=GetNamedFileTime(main_dir+hs);
  1147. if Source_Time<>-1 then
  1148. hs:=main_dir+hs;
  1149. end;
  1150. end;
  1151. if Source_Time=-1 then
  1152. Source_Time:=GetNamedFileTime(hs);
  1153. if (Source_Time=-1) then
  1154. begin
  1155. if is_main then
  1156. found:=unitsearchpath.FindFile(hs,true,temp_dir)
  1157. else
  1158. found:=includesearchpath.FindFile(hs,true,temp_dir);
  1159. if found then
  1160. begin
  1161. Source_Time:=GetNamedFileTime(temp_dir);
  1162. if Source_Time<>-1 then
  1163. hs:=temp_dir;
  1164. end;
  1165. end;
  1166. if Source_Time<>-1 then
  1167. begin
  1168. if is_main then
  1169. main_dir:=ExtractFilePath(hs);
  1170. temp:=' time '+filetimestring(source_time);
  1171. if (orgfiletime<>-1) and
  1172. (source_time<>orgfiletime) then
  1173. begin
  1174. state:=ms_compile;
  1175. recompile_reason:=rr_sourcenewer;
  1176. Message2(unit_u_source_modified,hs,ppufilename,@queuecomment);
  1177. temp:=temp+' *';
  1178. end;
  1179. end
  1180. else
  1181. begin
  1182. sources_avail:=false;
  1183. temp:=' not found';
  1184. end;
  1185. hp:=tdosinputfile.create(hs);
  1186. hp.inc_path:=inc_path;
  1187. { the indexing is wrong here PM }
  1188. sourcefiles.register_file(hp);
  1189. end;
  1190. end
  1191. else
  1192. begin
  1193. { still register the source module for proper error messages
  1194. since source_avail for the module is still false, this should not hurt }
  1195. sourcefiles.register_file(tdosinputfile.create(hs));
  1196. temp:=' not available';
  1197. end;
  1198. if is_main then
  1199. begin
  1200. mainsource:=hs;
  1201. end;
  1202. Message1(unit_u_ppu_source,hs+temp,@queuecomment);
  1203. is_main:=false;
  1204. end;
  1205. { check if we want to rebuild every unit, only if the sources are
  1206. available }
  1207. if do_build and sources_avail then
  1208. begin
  1209. state:=ms_compile;
  1210. recompile_reason:=rr_build;
  1211. end;
  1212. end;
  1213. procedure tppumodule.readloadunit;
  1214. var
  1215. hs : string;
  1216. pu : tused_unit;
  1217. hp : tppumodule;
  1218. indchecksum,
  1219. intfchecksum,
  1220. checksum : cardinal;
  1221. isnew : boolean;
  1222. begin
  1223. while not ppufile.endofentry do
  1224. begin
  1225. hs:=ppufile.getstring;
  1226. checksum:=cardinal(ppufile.getlongint);
  1227. intfchecksum:=cardinal(ppufile.getlongint);
  1228. indchecksum:=cardinal(ppufile.getlongint);
  1229. { set the state of this unit before registering, this is
  1230. needed for a correct circular dependency check }
  1231. hp:=registerunit(self,hs,'',isnew);
  1232. if isnew then
  1233. usedunits.Concat(tused_unit.create(hp,in_interface,true,nil));
  1234. if LoadCount=1 then
  1235. pu:=addusedunit(hp,false,nil)
  1236. else
  1237. begin
  1238. pu:=findusedunit(hp);
  1239. { Safety, normally this should not happen:
  1240. The used units list cannot change between loads unless recompiled and then loadcount is 1... }
  1241. if pu=nil then
  1242. pu:=addusedunit(hp,false,nil);
  1243. end;
  1244. pu.checksum:=checksum;
  1245. pu.interface_checksum:=intfchecksum;
  1246. pu.indirect_checksum:=indchecksum;
  1247. end;
  1248. in_interface:=false;
  1249. end;
  1250. procedure tppumodule.readlinkcontainer(var p:tlinkcontainer);
  1251. var
  1252. s : string;
  1253. m : longint;
  1254. begin
  1255. while not ppufile.endofentry do
  1256. begin
  1257. s:=ppufile.getstring;
  1258. m:=ppufile.getlongint;
  1259. p.add(s,m);
  1260. end;
  1261. end;
  1262. procedure tppumodule.readderefmap;
  1263. var
  1264. i : longint;
  1265. begin
  1266. { Load unit map used for resolving }
  1267. derefmapsize:=ppufile.getlongint;
  1268. derefmapcnt:=derefmapsize;
  1269. getmem(derefmap,derefmapsize*sizeof(tderefmaprec));
  1270. fillchar(derefmap^,derefmapsize*sizeof(tderefmaprec),0);
  1271. for i:=0 to derefmapsize-1 do
  1272. derefmap[i].modulename:=ppufile.getpshortstring;
  1273. end;
  1274. procedure tppumodule.readderefdata;
  1275. var
  1276. len,hlen : longint;
  1277. buf : array[0..1023] of byte;
  1278. begin
  1279. len:=ppufile.entrysize;
  1280. while (len>0) do
  1281. begin
  1282. if len>1024 then
  1283. hlen:=1024
  1284. else
  1285. hlen:=len;
  1286. ppufile.getdata(buf,hlen);
  1287. derefdata.write(buf,hlen);
  1288. dec(len,hlen);
  1289. end;
  1290. end;
  1291. procedure tppumodule.readImportSymbols;
  1292. var
  1293. j,
  1294. extsymcnt : longint;
  1295. ImportLibrary : TImportLibrary;
  1296. extsymname : string;
  1297. extsymmangledname : string;
  1298. extsymordnr : longint;
  1299. extsymisvar : boolean;
  1300. begin
  1301. while not ppufile.endofentry do
  1302. begin
  1303. ImportLibrary:=TImportLibrary.Create(ImportLibraryList,ppufile.getstring);
  1304. extsymcnt:=ppufile.getlongint;
  1305. for j:=0 to extsymcnt-1 do
  1306. begin
  1307. extsymname:=ppufile.getstring;
  1308. extsymmangledname:=ppufile.getstring;
  1309. extsymordnr:=ppufile.getlongint;
  1310. extsymisvar:=(ppufile.getbyte<>0);
  1311. TImportSymbol.Create(ImportLibrary.ImportSymbolList,extsymname,
  1312. extsymmangledname,extsymordnr,extsymisvar);
  1313. end;
  1314. end;
  1315. end;
  1316. procedure tppumodule.readResources;
  1317. begin
  1318. while not ppufile.endofentry do
  1319. resourcefiles.Insert(ppufile.getstring);
  1320. end;
  1321. procedure tppumodule.readOrderedSymbols;
  1322. begin
  1323. while not ppufile.endofentry do
  1324. linkorderedsymbols.Concat(ppufile.getstring);
  1325. end;
  1326. procedure tppumodule.readwpofile;
  1327. var
  1328. orgwpofilename: string;
  1329. orgwpofiletime: longint;
  1330. begin
  1331. { check whether we are using the same wpo feedback input file as when
  1332. this unit was compiled (same file name and file date)
  1333. }
  1334. orgwpofilename:=ppufile.getstring;
  1335. orgwpofiletime:=ppufile.getlongint;
  1336. if (extractfilename(orgwpofilename)<>extractfilename(wpofeedbackinput)) or
  1337. (orgwpofiletime<>GetNamedFileTime(orgwpofilename)) then
  1338. { make sure we don't throw away a precompiled unit if the user simply
  1339. forgot to specify the right wpo feedback file
  1340. }
  1341. message3(unit_e_different_wpo_file,ppufilename,orgwpofilename,filetimestring(orgwpofiletime));
  1342. end;
  1343. procedure tppumodule.readunitimportsyms;
  1344. var
  1345. c,i : longint;
  1346. deref : pderef;
  1347. begin
  1348. c:=ppufile.getlongint;
  1349. for i:=0 to c-1 do
  1350. begin
  1351. new(deref);
  1352. ppufile.getderef(deref^);
  1353. unitimportsymsderefs.add(deref);
  1354. end;
  1355. end;
  1356. procedure tppumodule.readasmsyms;
  1357. var
  1358. c,i : longint;
  1359. name : TSymStr;
  1360. bind : TAsmsymbind;
  1361. typ : TAsmsymtype;
  1362. list : tfphashobjectlist;
  1363. begin
  1364. case tunitasmlisttype(ppufile.getbyte) of
  1365. ualt_public:
  1366. list:=publicasmsyms;
  1367. ualt_extern:
  1368. list:=externasmsyms;
  1369. end;
  1370. c:=ppufile.getlongint;
  1371. for i:=0 to c-1 do
  1372. begin
  1373. name:=ppufile.getstring;
  1374. bind:=TAsmsymbind(ppufile.getbyte);
  1375. typ:=TAsmsymtype(ppufile.getbyte);
  1376. TAsmSymbol.Create(list,name,bind,typ);
  1377. end;
  1378. end;
  1379. procedure tppumodule.readextraheader;
  1380. begin
  1381. longversion:=cardinal(ppufile.getlongint);
  1382. ppufile.getset(tppuset4(moduleflags));
  1383. end;
  1384. procedure tppumodule.load_interface;
  1385. var
  1386. b : byte;
  1387. newmodulename : string;
  1388. begin
  1389. { read interface part }
  1390. repeat
  1391. b:=ppufile.readentry;
  1392. case b of
  1393. ibjvmnamespace :
  1394. begin
  1395. namespace:=ppufile.getpshortstring;
  1396. end;
  1397. ibmodulename :
  1398. begin
  1399. newmodulename:=ppufile.getstring;
  1400. if (cs_check_unit_name in current_settings.globalswitches) and
  1401. (upper(newmodulename)<>modulename^) then
  1402. Message2(unit_f_unit_name_error,realmodulename^,newmodulename);
  1403. stringdispose(modulename);
  1404. stringdispose(realmodulename);
  1405. modulename:=stringdup(upper(newmodulename));
  1406. realmodulename:=stringdup(newmodulename);
  1407. end;
  1408. ibextraheader:
  1409. begin
  1410. readextraheader;
  1411. end;
  1412. ibfeatures :
  1413. begin
  1414. ppufile.getset(tppuset4(features));
  1415. end;
  1416. ibmoduleoptions:
  1417. begin
  1418. ppufile.getset(tppuset1(moduleoptions));
  1419. if mo_has_deprecated_msg in moduleoptions then
  1420. begin
  1421. stringdispose(deprecatedmsg);
  1422. deprecatedmsg:=ppufile.getpshortstring;
  1423. end;
  1424. end;
  1425. ibsourcefiles :
  1426. readsourcefiles;
  1427. {$IFDEF MACRO_DIFF_HINT}
  1428. ibusedmacros :
  1429. readusedmacros;
  1430. {$ENDIF}
  1431. ibloadunit :
  1432. readloadunit;
  1433. iblinkunitofiles :
  1434. readlinkcontainer(LinkUnitOFiles);
  1435. iblinkunitstaticlibs :
  1436. readlinkcontainer(LinkUnitStaticLibs);
  1437. iblinkunitsharedlibs :
  1438. readlinkcontainer(LinkUnitSharedLibs);
  1439. iblinkotherofiles :
  1440. readlinkcontainer(LinkotherOFiles);
  1441. iblinkotherstaticlibs :
  1442. readlinkcontainer(LinkotherStaticLibs);
  1443. iblinkothersharedlibs :
  1444. readlinkcontainer(LinkotherSharedLibs);
  1445. iblinkotherframeworks :
  1446. readlinkcontainer(LinkOtherFrameworks);
  1447. ibmainname:
  1448. begin
  1449. mainname:=ppufile.getpshortstring;
  1450. if (mainaliasname<>defaultmainaliasname) then
  1451. Message1(scan_w_multiple_main_name_overrides,mainaliasname);
  1452. mainaliasname:=mainname^;
  1453. end;
  1454. ibImportSymbols :
  1455. readImportSymbols;
  1456. ibderefmap :
  1457. readderefmap;
  1458. ibderefdata :
  1459. readderefdata;
  1460. ibresources:
  1461. readResources;
  1462. iborderedsymbols:
  1463. readOrderedSymbols;
  1464. ibwpofile:
  1465. readwpofile;
  1466. ibendinterface :
  1467. break;
  1468. else
  1469. Message1(unit_f_ppu_invalid_entry,tostr(b));
  1470. end;
  1471. { we can already stop when we know that we must recompile }
  1472. if state=ms_compile then
  1473. exit;
  1474. until false;
  1475. end;
  1476. procedure tppumodule.load_implementation;
  1477. var
  1478. b : byte;
  1479. begin
  1480. { read implementation part }
  1481. repeat
  1482. b:=ppufile.readentry;
  1483. case b of
  1484. ibloadunit :
  1485. readloadunit;
  1486. ibasmsymbols :
  1487. readasmsyms;
  1488. ibunitimportsyms:
  1489. readunitimportsyms;
  1490. ibendimplementation :
  1491. break;
  1492. else
  1493. Message1(unit_f_ppu_invalid_entry,tostr(b));
  1494. end;
  1495. until false;
  1496. end;
  1497. procedure tppumodule.writeppu;
  1498. begin
  1499. Message1(unit_u_ppu_write,realmodulename^);
  1500. { create unit flags }
  1501. {$ifdef cpufpemu}
  1502. if (cs_fp_emulation in current_settings.moduleswitches) then
  1503. headerflags:=headerflags or uf_fpu_emulation;
  1504. {$endif cpufpemu}
  1505. { create new ppufile }
  1506. ppufile:=tcompilerppufile.create(ppufilename);
  1507. if not ppufile.createfile then
  1508. Message(unit_f_ppu_cannot_write);
  1509. {$ifdef Test_Double_checksum_write}
  1510. { Re-use the values collected in .INT part }
  1511. if assigned(interface_crc_array) then
  1512. begin
  1513. ppufile.implementation_write_crc_index:=implementation_write_crc_index;
  1514. ppufile.interface_write_crc_index:=interface_write_crc_index;
  1515. ppufile.indirect_write_crc_index:=indirect_write_crc_index;
  1516. if assigned(ppufile.interface_crc_array) then
  1517. begin
  1518. dispose(ppufile.interface_crc_array);
  1519. ppufile.interface_crc_array:=interface_crc_array;
  1520. end;
  1521. if assigned(ppufile.implementation_crc_array) then
  1522. begin
  1523. dispose(ppufile.implementation_crc_array);
  1524. ppufile.implementation_crc_array:=implementation_crc_array;
  1525. end;
  1526. if assigned(ppufile.indirect_crc_array) then
  1527. begin
  1528. dispose(ppufile.indirect_crc_array);
  1529. ppufile.indirect_crc_array:=indirect_crc_array;
  1530. end;
  1531. end;
  1532. if FileExists(ppufilename+'.IMP',false) then
  1533. RenameFile(ppufilename+'.IMP',ppufilename+'.IMP-old');
  1534. Assign(ppufile.CRCFile,ppufilename+'.IMP');
  1535. Rewrite(ppufile.CRCFile);
  1536. Writeln(ppufile.CRCFile,'CRC in writeppu method of implementation of ',ppufilename,' defsgeneration=',defsgeneration);
  1537. {$endif def Test_Double_checksum_write}
  1538. { extra header (sub version, module flags) }
  1539. writeextraheader;
  1540. { first the (JVM) namespace }
  1541. if assigned(namespace) then
  1542. begin
  1543. ppufile.putstring(namespace^);
  1544. ppufile.writeentry(ibjvmnamespace);
  1545. end;
  1546. { the unitname }
  1547. ppufile.putstring(realmodulename^);
  1548. ppufile.writeentry(ibmodulename);
  1549. ppufile.putset(tppuset1(moduleoptions));
  1550. if mo_has_deprecated_msg in moduleoptions then
  1551. ppufile.putstring(deprecatedmsg^);
  1552. ppufile.writeentry(ibmoduleoptions);
  1553. { write the alternate main procedure name if any }
  1554. if assigned(mainname) then
  1555. begin
  1556. ppufile.putstring(mainname^);
  1557. ppufile.writeentry(ibmainname);
  1558. end;
  1559. if cs_compilesystem in current_settings.moduleswitches then
  1560. begin
  1561. ppufile.putset(tppuset4(features));
  1562. ppufile.writeentry(ibfeatures);
  1563. end;
  1564. writesourcefiles;
  1565. {$IFDEF MACRO_DIFF_HINT}
  1566. writeusedmacros;
  1567. {$ENDIF}
  1568. { write interface uses }
  1569. writeusedunit(true);
  1570. { write the objectfiles and libraries that come for this unit,
  1571. preserve the containers because they are still needed to load
  1572. the link.res.
  1573. All doesn't depend on the crc! It doesn't matter
  1574. if a unit is in a .o or .a file }
  1575. ppufile.do_crc:=false;
  1576. { write after source files, so that we know whether or not the compiler
  1577. will recompile the unit when checking whether the correct wpo file is
  1578. used (if it will recompile the unit anyway, it doesn't matter)
  1579. }
  1580. if (wpofeedbackinput<>'') then
  1581. begin
  1582. ppufile.putstring(wpofeedbackinput);
  1583. ppufile.putlongint(getnamedfiletime(wpofeedbackinput));
  1584. ppufile.writeentry(ibwpofile);
  1585. end;
  1586. writelinkcontainer(linkunitofiles,iblinkunitofiles,true);
  1587. writelinkcontainer(linkunitstaticlibs,iblinkunitstaticlibs,true);
  1588. writelinkcontainer(linkunitsharedlibs,iblinkunitsharedlibs,true);
  1589. writelinkcontainer(linkotherofiles,iblinkotherofiles,false);
  1590. writelinkcontainer(linkotherstaticlibs,iblinkotherstaticlibs,true);
  1591. writelinkcontainer(linkothersharedlibs,iblinkothersharedlibs,true);
  1592. writelinkcontainer(linkotherframeworks,iblinkotherframeworks,true);
  1593. writeImportSymbols;
  1594. writeResources;
  1595. writeOrderedSymbols;
  1596. ppufile.do_crc:=true;
  1597. { generate implementation deref data, the interface deref data is
  1598. already generated when calculating the interface crc }
  1599. if (cs_compilesystem in current_settings.moduleswitches) then
  1600. begin
  1601. tstoredsymtable(globalsymtable).buildderef;
  1602. derefdataintflen:=derefdata.size;
  1603. end
  1604. else
  1605. { the unit may have been re-resolved, in which case the current
  1606. position in derefdata is not necessarily at the end }
  1607. derefdata.seek(derefdata.size);
  1608. tstoredsymtable(globalsymtable).buildderefimpl;
  1609. tunitwpoinfo(wpoinfo).buildderef;
  1610. tunitwpoinfo(wpoinfo).buildderefimpl;
  1611. if assigned(globalmacrosymtable) and (globalmacrosymtable.SymList.count > 0) then
  1612. begin
  1613. tstoredsymtable(globalmacrosymtable).buildderef;
  1614. tstoredsymtable(globalmacrosymtable).buildderefimpl;
  1615. end;
  1616. if mf_local_symtable in moduleflags then
  1617. tstoredsymtable(localsymtable).buildderef_registered;
  1618. buildderefunitimportsyms;
  1619. writederefmap;
  1620. writederefdata;
  1621. ppufile.writeentry(ibendinterface);
  1622. { write the symtable entries }
  1623. tstoredsymtable(globalsymtable).ppuwrite(ppufile);
  1624. if assigned(globalmacrosymtable) and (globalmacrosymtable.SymList.count > 0) then
  1625. begin
  1626. ppufile.putbyte(byte(true));
  1627. ppufile.writeentry(ibexportedmacros);
  1628. tstoredsymtable(globalmacrosymtable).ppuwrite(ppufile);
  1629. end
  1630. else
  1631. begin
  1632. ppufile.putbyte(byte(false));
  1633. ppufile.writeentry(ibexportedmacros);
  1634. end;
  1635. { everything after this doesn't affect the crc }
  1636. ppufile.do_crc:=false;
  1637. { write implementation uses }
  1638. writeusedunit(false);
  1639. { write all public assembler symbols }
  1640. writeasmsyms(ualt_public,publicasmsyms);
  1641. { write all external assembler symbols }
  1642. writeasmsyms(ualt_extern,externasmsyms);
  1643. { write all symbols imported from another unit }
  1644. writeunitimportsyms;
  1645. { end of implementation }
  1646. ppufile.writeentry(ibendimplementation);
  1647. { write static symtable
  1648. needed for local debugging of unit functions }
  1649. if mf_local_symtable in moduleflags then
  1650. tstoredsymtable(localsymtable).ppuwrite(ppufile);
  1651. { write whole program optimisation-related information }
  1652. tunitwpoinfo(wpoinfo).ppuwrite(ppufile);
  1653. { the last entry ibend is written automatically }
  1654. { flush to be sure }
  1655. ppufile.flush;
  1656. { create and write header }
  1657. ppufile.header.common.size:=ppufile.size;
  1658. ppufile.header.checksum:=ppufile.crc;
  1659. ppufile.header.interface_checksum:=ppufile.interface_crc;
  1660. ppufile.header.indirect_checksum:=ppufile.indirect_crc;
  1661. ppufile.header.common.compiler:=wordversion;
  1662. ppufile.header.common.cpu:=word(target_cpu);
  1663. ppufile.header.common.target:=word(target_info.system);
  1664. ppufile.header.common.flags:=headerflags;
  1665. ppufile.header.deflistsize:=current_module.deflist.count;
  1666. ppufile.header.symlistsize:=current_module.symlist.count;
  1667. ppufile.writeheader;
  1668. { save crc in current module also }
  1669. crc:=ppufile.crc;
  1670. interface_crc:=ppufile.interface_crc;
  1671. indirect_crc:=ppufile.indirect_crc;
  1672. {$ifdef Test_Double_checksum_write}
  1673. Writeln(ppufile.CRCFile,'End of implementation CRC in writeppu method of ',ppufilename,
  1674. ' implementation_crc=$',hexstr(ppufile.crc,8),
  1675. ' interface_crc=$',hexstr(ppufile.interface_crc,8),
  1676. ' indirect_crc=$',hexstr(ppufile.indirect_crc,8),
  1677. ' implementation_crc_size=',ppufile.implementation_read_crc_index,
  1678. ' interface_crc_size=',ppufile.interface_read_crc_index,
  1679. ' indirect_crc_size=',ppufile.indirect_read_crc_index,
  1680. ' defsgeneration=',defsgeneration);
  1681. close(ppufile.CRCFile);
  1682. {$endif Test_Double_checksum_write}
  1683. discardppu;
  1684. end;
  1685. procedure tppumodule.getppucrc;
  1686. begin
  1687. { create new ppufile }
  1688. ppufile:=tcompilerppufile.create(ppufilename);
  1689. ppufile.crc_only:=true;
  1690. if not ppufile.createfile then
  1691. Message(unit_f_ppu_cannot_write);
  1692. {$ifdef Test_Double_checksum_write}
  1693. if FileExists(ppufilename+'.INT',false) then
  1694. RenameFile(ppufilename+'.INT',ppufilename+'.INT-old');
  1695. Assign(ppufile.CRCFile,ppufilename+'.INT');
  1696. Rewrite(ppufile.CRCFile);
  1697. Writeln(ppufile.CRCFile,'CRC of getppucrc of ',ppufilename,
  1698. ' defsgeneration=',defsgeneration);
  1699. {$endif def Test_Double_checksum_write}
  1700. { first the (JVM) namespace }
  1701. if assigned(namespace) then
  1702. begin
  1703. ppufile.putstring(namespace^);
  1704. ppufile.writeentry(ibjvmnamespace);
  1705. end;
  1706. { the unitname }
  1707. ppufile.putstring(realmodulename^);
  1708. ppufile.writeentry(ibmodulename);
  1709. { extra header (sub version, module flags) }
  1710. writeextraheader;
  1711. ppufile.putset(tppuset1(moduleoptions));
  1712. if mo_has_deprecated_msg in moduleoptions then
  1713. ppufile.putstring(deprecatedmsg^);
  1714. ppufile.writeentry(ibmoduleoptions);
  1715. { the interface units affect the crc }
  1716. writeusedunit(true);
  1717. { deref data of interface that affect the crc }
  1718. derefdata.reset;
  1719. tstoredsymtable(globalsymtable).buildderef;
  1720. derefdataintflen:=derefdata.size;
  1721. writederefmap;
  1722. writederefdata;
  1723. ppufile.writeentry(ibendinterface);
  1724. { write the symtable entries }
  1725. tstoredsymtable(globalsymtable).ppuwrite(ppufile);
  1726. if assigned(globalmacrosymtable) and (globalmacrosymtable.SymList.count > 0) then
  1727. begin
  1728. ppufile.putbyte(byte(true));
  1729. ppufile.writeentry(ibexportedmacros);
  1730. tstoredsymtable(globalmacrosymtable).ppuwrite(ppufile);
  1731. end
  1732. else
  1733. begin
  1734. ppufile.putbyte(byte(false));
  1735. ppufile.writeentry(ibexportedmacros);
  1736. end;
  1737. { save crc }
  1738. crc:=ppufile.crc;
  1739. interface_crc:=ppufile.interface_crc;
  1740. indirect_crc:=ppufile.indirect_crc;
  1741. { end of implementation, to generate a correct ppufile
  1742. for ppudump when using INTFPPU define }
  1743. ppufile.writeentry(ibendimplementation);
  1744. {$ifdef Test_Double_checksum_write}
  1745. Writeln(ppufile.CRCFile,'End of CRC of getppucrc of ',ppufilename,
  1746. ' implementation_crc=$',hexstr(ppufile.crc,8),
  1747. ' interface_crc=$',hexstr(ppufile.interface_crc,8),
  1748. ' indirect_crc=$',hexstr(ppufile.indirect_crc,8),
  1749. ' implementation_crc_size=',ppufile.implementation_write_crc_index,
  1750. ' interface_crc_size=',ppufile.interface_write_crc_index,
  1751. ' indirect_crc_size=',ppufile.indirect_write_crc_index,
  1752. ' defsgeneration=',defsgeneration);
  1753. close(ppufile.CRCFile);
  1754. { Remember the values generated in .INT part }
  1755. implementation_write_crc_index:=ppufile.implementation_write_crc_index;
  1756. interface_write_crc_index:=ppufile.interface_write_crc_index;
  1757. indirect_write_crc_index:=ppufile.indirect_write_crc_index;
  1758. interface_crc_array:=ppufile.interface_crc_array;
  1759. ppufile.interface_crc_array:=nil;
  1760. implementation_crc_array:=ppufile.implementation_crc_array;
  1761. ppufile.implementation_crc_array:=nil;
  1762. indirect_crc_array:=ppufile.indirect_crc_array;
  1763. ppufile.indirect_crc_array:=nil;
  1764. {$endif Test_Double_checksum_write}
  1765. { create and write header, this will only be used
  1766. for debugging purposes }
  1767. ppufile.header.common.size:=ppufile.size;
  1768. ppufile.header.checksum:=ppufile.crc;
  1769. ppufile.header.interface_checksum:=ppufile.interface_crc;
  1770. ppufile.header.indirect_checksum:=ppufile.indirect_crc;
  1771. ppufile.header.common.compiler:=wordversion;
  1772. ppufile.header.common.cpu:=word(target_cpu);
  1773. ppufile.header.common.target:=word(target_info.system);
  1774. ppufile.header.common.flags:=headerflags;
  1775. ppufile.writeheader;
  1776. discardppu;
  1777. end;
  1778. function tppumodule.load_usedunits : boolean;
  1779. var
  1780. pu : tused_unit;
  1781. s : string;
  1782. begin
  1783. if current_module<>self then
  1784. internalerror(200212284);
  1785. { load the used units from interface }
  1786. in_interface:=true;
  1787. result:=false;
  1788. pu:=tused_unit(used_units.first);
  1789. while assigned(pu) do
  1790. begin
  1791. if pu.in_interface then
  1792. begin
  1793. s:=pu.u.modulename^;
  1794. tppumodule(pu.u).loadppu(self);
  1795. { if this unit is scheduled for compilation or compiled we can stop }
  1796. if state in [ms_compile,ms_compiled,ms_processed] then
  1797. exit;
  1798. { add this unit to the dependencies }
  1799. pu.u.adddependency(self,true);
  1800. // Compiler decided the unit must be recompiled.
  1801. if pu.u.state=ms_compile then
  1802. begin
  1803. state:=ms_load;
  1804. exit;
  1805. end;
  1806. { need to recompile the current unit, check the interface
  1807. crc. And when not compiled with -Ur then check the complete
  1808. crc }
  1809. if (pu.u.interface_crc<>pu.interface_checksum) or
  1810. (pu.u.indirect_crc<>pu.indirect_checksum) or
  1811. (
  1812. (not(mf_release in moduleflags)) and
  1813. (pu.u.crc<>pu.checksum)
  1814. ) then
  1815. begin
  1816. Message2(unit_u_recompile_crc_change,realmodulename^,pu.u.ppufilename,@queuecomment);
  1817. {$ifdef DEBUG_UNIT_CRC_CHANGES}
  1818. if (pu.u.interface_crc<>pu.interface_checksum) then
  1819. Comment(V_Normal,' intfcrc change: '+hexstr(pu.u.interface_crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.interface_checksum,8)+' in unit '+realmodulename^);
  1820. if (pu.u.indirect_crc<>pu.indirect_checksum) then
  1821. Comment(V_Normal,' indcrc change: '+hexstr(pu.u.indirect_crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.indirect_checksum,8)+' in unit '+realmodulename^);
  1822. if (pu.u.crc<>pu.checksum) then
  1823. Comment(V_Normal,' implcrc change: '+hexstr(pu.u.crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.checksum,8)+' in unit '+realmodulename^);
  1824. {$endif DEBUG_UNIT_CRC_CHANGES}
  1825. recompile_reason:=rr_crcchanged;
  1826. state:=ms_compile;
  1827. exit;
  1828. end;
  1829. end;
  1830. pu:=tused_unit(pu.next);
  1831. end;
  1832. { ok, now load the interface of this unit }
  1833. if current_module<>self then
  1834. internalerror(200208187);
  1835. deflist.count:=ppufile.header.deflistsize;
  1836. symlist.count:=ppufile.header.symlistsize;
  1837. globalsymtable:=tglobalsymtable.create(modulename^,moduleid);
  1838. tstoredsymtable(globalsymtable).ppuload(ppufile);
  1839. if ppufile.readentry<>ibexportedmacros then
  1840. Message(unit_f_ppu_read_error);
  1841. if boolean(ppufile.getbyte) then
  1842. begin
  1843. globalmacrosymtable:=tmacrosymtable.Create(true);
  1844. tstoredsymtable(globalmacrosymtable).ppuload(ppufile)
  1845. end;
  1846. interface_compiled:=true;
  1847. { read the implementation part, containing
  1848. the implementation uses and ObjData }
  1849. in_interface:=false;
  1850. load_implementation;
  1851. { now only read the implementation uses }
  1852. pu:=tused_unit(used_units.first);
  1853. while assigned(pu) do
  1854. begin
  1855. if (not pu.in_interface) then
  1856. begin
  1857. s:=pu.u.modulename^;
  1858. tppumodule(pu.u).loadppu(self);
  1859. { if this unit is compiled we can stop }
  1860. if state=ms_compiled then
  1861. exit;
  1862. // compiler decided the unit must be recompiled.
  1863. if pu.u.state=ms_compile then
  1864. begin
  1865. state:=ms_load;
  1866. exit;
  1867. end;
  1868. { add this unit to the dependencies }
  1869. pu.u.adddependency(self,false);
  1870. { need to recompile the current unit ? }
  1871. if (pu.u.interface_crc<>pu.interface_checksum) or
  1872. (pu.u.indirect_crc<>pu.indirect_checksum) then
  1873. begin
  1874. Message2(unit_u_recompile_crc_change,realmodulename^,pu.u.ppufilename+' {impl}',@queuecomment);
  1875. {$ifdef DEBUG_UNIT_CRC_CHANGES}
  1876. if (pu.u.interface_crc<>pu.interface_checksum) then
  1877. Comment(V_Normal,' intfcrc change (2): '+hexstr(pu.u.interface_crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.interface_checksum,8)+' in unit '+realmodulename^);
  1878. if (pu.u.indirect_crc<>pu.indirect_checksum) then
  1879. Comment(V_Normal,' indcrc change (2): '+hexstr(pu.u.indirect_crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.indirect_checksum,8)+' in unit '+realmodulename^);
  1880. {$endif DEBUG_UNIT_CRC_CHANGES}
  1881. recompile_reason:=rr_crcchanged;
  1882. state:=ms_compile;
  1883. exit;
  1884. end;
  1885. end;
  1886. pu:=tused_unit(pu.next);
  1887. end;
  1888. { load implementation symtable }
  1889. if mf_local_symtable in moduleflags then
  1890. begin
  1891. localsymtable:=tstaticsymtable.create(modulename^,moduleid);
  1892. tstaticsymtable(localsymtable).ppuload(ppufile);
  1893. end;
  1894. { we can now derefence all pointers to the implementation parts }
  1895. tstoredsymtable(globalsymtable).derefimpl(false);
  1896. { we've just loaded the localsymtable from the ppu file, so everything
  1897. in it was registered by definition (otherwise it wouldn't have been in
  1898. there) }
  1899. if assigned(localsymtable) then
  1900. tstoredsymtable(localsymtable).derefimpl(false);
  1901. derefunitimportsyms;
  1902. { read whole program optimisation-related information }
  1903. wpoinfo:=tunitwpoinfo.ppuload(ppufile);
  1904. tunitwpoinfo(wpoinfo).deref;
  1905. tunitwpoinfo(wpoinfo).derefimpl;
  1906. Result:=True;
  1907. end;
  1908. function tppumodule.needrecompile:boolean;
  1909. var
  1910. pu : tused_unit;
  1911. begin
  1912. result:=false;
  1913. pu:=tused_unit(used_units.first);
  1914. while assigned(pu) do
  1915. begin
  1916. { need to recompile the current unit, check the interface
  1917. crc. And when not compiled with -Ur then check the complete
  1918. crc }
  1919. if (pu.u.interface_crc<>pu.interface_checksum) or
  1920. (pu.u.indirect_crc<>pu.indirect_checksum) or
  1921. (
  1922. (pu.in_interface) and
  1923. (pu.u.crc<>pu.checksum)
  1924. ) then
  1925. begin
  1926. {$ifdef DEBUG_UNIT_CRC_CHANGES}
  1927. if (pu.u.interface_crc<>pu.interface_checksum) then
  1928. Comment(V_Normal,' intfcrc change (3): '+hexstr(pu.u.interface_crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.interface_checksum,8)+' in unit '+realmodulename^)
  1929. else if (pu.u.indirect_crc<>pu.indirect_checksum) then
  1930. Comment(V_Normal,' indcrc change (3): '+hexstr(pu.u.indirect_crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.indirect_checksum,8)+' in unit '+realmodulename^)
  1931. else
  1932. Comment(V_Normal,' implcrc change (3): '+hexstr(pu.u.crc,8)+' for '+pu.u.ppufilename+' <> '+hexstr(pu.checksum,8)+' in unit '+realmodulename^);
  1933. {$endif DEBUG_UNIT_CRC_CHANGES}
  1934. result:=true;
  1935. exit;
  1936. end;
  1937. pu:=tused_unit(pu.next);
  1938. end;
  1939. end;
  1940. procedure tppumodule.setdefgeneration;
  1941. begin
  1942. defsgeneration:=currentdefgeneration;
  1943. inc(currentdefgeneration);
  1944. end;
  1945. procedure tppumodule.reload_flagged_units;
  1946. var
  1947. hp : tppumodule;
  1948. begin
  1949. { now reload all dependent units with outdated defs }
  1950. hp:=tppumodule(loaded_units.first);
  1951. while assigned(hp) do
  1952. begin
  1953. if hp.do_reload and
  1954. (hp.defsgeneration<defsgeneration) then
  1955. begin
  1956. hp.defsgeneration:=defsgeneration;
  1957. hp.loadppu(self)
  1958. end
  1959. else
  1960. hp.do_reload:=false;
  1961. hp:=tppumodule(hp.next);
  1962. end;
  1963. end;
  1964. procedure tppumodule.end_of_parsing;
  1965. begin
  1966. { module is now compiled }
  1967. state:=ms_compiled;
  1968. { free ppu }
  1969. discardppu;
  1970. inherited end_of_parsing;
  1971. end;
  1972. procedure tppumodule.check_reload(from_module : tmodule; var do_load : boolean);
  1973. begin
  1974. { A force reload }
  1975. if not do_reload then
  1976. exit;
  1977. Message(unit_u_forced_reload);
  1978. do_reload:=false;
  1979. { When the unit is already loaded or being loaded
  1980. we can maybe skip a complete reload/recompile }
  1981. if assigned(globalsymtable) and
  1982. (not needrecompile) then
  1983. begin
  1984. { When we don't have any data stored yet there
  1985. is nothing to resolve }
  1986. if interface_compiled and
  1987. { it makes no sense to re-resolve the unit if it is already finally compiled }
  1988. not(state=ms_compiled) then
  1989. begin
  1990. re_resolve(from_module);
  1991. end
  1992. else
  1993. Message1(unit_u_skipping_reresolving_unit,modulename^);
  1994. do_load:=false;
  1995. end;
  1996. end;
  1997. { Returns true if the module was loaded from package }
  1998. function tppumodule.check_loadfrompackage : boolean;
  1999. begin
  2000. { try to load it as a package unit first }
  2001. Result:=(packagelist.count>0) and loadfrompackage;
  2002. if Result then
  2003. begin
  2004. do_reload:=false;
  2005. state:=ms_compiled;
  2006. { PPU is not needed anymore }
  2007. if assigned(ppufile) then
  2008. begin
  2009. discardppu;
  2010. end;
  2011. { add the unit to the used units list of the program }
  2012. usedunits.concat(tused_unit.create(self,true,false,nil));
  2013. end;
  2014. end;
  2015. procedure tppumodule.prepare_second_load(from_module: tmodule);
  2016. const
  2017. CompileStates = [ms_compile, ms_compiling_waitintf, ms_compiling_waitimpl,
  2018. ms_compiling_waitfinish, ms_compiling_wait, ms_compiled,
  2019. ms_processed];
  2020. begin
  2021. { try to load the unit a second time first }
  2022. Message1(unit_u_second_load_unit,modulename^);
  2023. Message2(unit_u_previous_state,modulename^,ModuleStateStr[state]);
  2024. { Flag modules to reload }
  2025. flagdependent(from_module);
  2026. { Reset the module }
  2027. reset(false);
  2028. if state in CompileStates then
  2029. begin
  2030. Message1(unit_u_second_compile_unit,modulename^);
  2031. state:=ms_compile;
  2032. end
  2033. else
  2034. state:=ms_load;
  2035. end;
  2036. function tppumodule.try_load_ppufile(from_module : tmodule) : Boolean;
  2037. {
  2038. Return True if the unit was successfully loaded.
  2039. False means the unit must be reloaded or recompiled
  2040. }
  2041. begin
  2042. Result:=False;
  2043. Message1(unit_u_loading_unit,modulename^);
  2044. if auPPU in search_unit_files(from_module,false) then
  2045. state:=ms_load
  2046. else
  2047. state:=ms_compile;
  2048. if not (state=ms_compile) then
  2049. begin
  2050. load_interface;
  2051. setdefgeneration;
  2052. if not (state=ms_compile) then
  2053. begin
  2054. if load_usedunits then
  2055. begin
  2056. Message1(unit_u_finished_loading_unit,modulename^);
  2057. Result:=true;
  2058. end
  2059. else
  2060. reload_from:=(from_module as tppumodule);
  2061. end;
  2062. end;
  2063. { PPU is not needed anymore }
  2064. if assigned(ppufile) then
  2065. discardppu;
  2066. end;
  2067. procedure tppumodule.recompile_from_sources(from_module : tmodule);
  2068. var
  2069. pu : tused_unit;
  2070. begin
  2071. { recompile the unit or give a fatal error if sources not available }
  2072. if not(sources_avail) then
  2073. begin
  2074. search_unit_files(from_module,true);
  2075. if not(sources_avail) then
  2076. begin
  2077. printcomments;
  2078. if recompile_reason=rr_noppu then
  2079. begin
  2080. pu:=tused_unit(from_module.used_units.first);
  2081. while assigned(pu) do
  2082. begin
  2083. if pu.u=self then
  2084. break;
  2085. pu:=tused_unit(pu.next);
  2086. end;
  2087. if assigned(pu) and assigned(pu.unitsym) then
  2088. MessagePos2(pu.unitsym.fileinfo,unit_f_cant_find_ppu,realmodulename^,from_module.realmodulename^)
  2089. else
  2090. Message2(unit_f_cant_find_ppu,realmodulename^,from_module.realmodulename^);
  2091. end
  2092. else
  2093. Message1(unit_f_cant_compile_unit,realmodulename^);
  2094. end;
  2095. end;
  2096. { we found the sources, we do not need the verbose messages anymore }
  2097. if comments <> nil then
  2098. begin
  2099. comments.free;
  2100. comments:=nil;
  2101. end;
  2102. { Flag modules to reload }
  2103. flagdependent(from_module);
  2104. { Reset the module }
  2105. reset(true);
  2106. { mark this module for recompilation }
  2107. if not (state in [ms_compile]) then
  2108. state:=ms_compile;
  2109. setdefgeneration;
  2110. if assigned(schedule_recompile_proc) then
  2111. schedule_recompile_proc(self);
  2112. end;
  2113. procedure tppumodule.post_load_or_compile(from_module : tmodule; second_time : boolean);
  2114. begin
  2115. if current_module<>self then
  2116. internalerror(200212282);
  2117. if in_interface then
  2118. internalerror(200212283);
  2119. { for a second_time recompile reload all dependent units,
  2120. for a first time compile register the unit _once_ }
  2121. if second_time then
  2122. reload_flagged_units;
  2123. { reopen the old module }
  2124. {$ifdef SHORT_ON_FILE_HANDLES}
  2125. if from_module.is_unit and
  2126. assigned(tppumodule(from_module).ppufile) then
  2127. tppumodule(from_module).ppufile.tempopen;
  2128. {$endif SHORT_ON_FILE_HANDLES}
  2129. state:=ms_processed;
  2130. end;
  2131. function tppumodule.loadppu(from_module : tmodule) : boolean;
  2132. const
  2133. ImplIntf : array[boolean] of string[15]=('implementation','interface');
  2134. var
  2135. do_load,load_ok,
  2136. second_time : boolean;
  2137. begin
  2138. Inc(LoadCount);
  2139. Result:=false;
  2140. Message3(unit_u_load_unit,from_module.modulename^,
  2141. ImplIntf[from_module.in_interface],
  2142. modulename^);
  2143. { check if the globalsymtable is already available, but
  2144. we must reload when the do_reload flag is set }
  2145. if (not do_reload) and
  2146. assigned(globalsymtable) then
  2147. exit(True);
  2148. { reset }
  2149. do_load:=true;
  2150. second_time:=false;
  2151. set_current_module(self);
  2152. do_load:=not check_loadfrompackage;
  2153. { A force reload }
  2154. check_reload(from_module, do_load);
  2155. if not do_load then
  2156. begin
  2157. // No need to do anything, restore situation and exit.
  2158. set_current_module(from_module);
  2159. exit(state=ms_compiled);
  2160. end;
  2161. { loading the unit for a second time? }
  2162. if state=ms_registered then
  2163. state:=ms_load
  2164. else if (state in [ms_compile, ms_compiling_waitintf]) then
  2165. begin
  2166. { no use continuing if we must be compiled }
  2167. // but we still need to restore current_module!
  2168. set_current_module(from_module);
  2169. exit(false)
  2170. end
  2171. else
  2172. begin
  2173. second_time:=true;
  2174. prepare_second_load(from_module);
  2175. end;
  2176. { close old_current_ppu on system that are
  2177. short on file handles like DOS PM }
  2178. {$ifdef SHORT_ON_FILE_HANDLES}
  2179. if from_module.is_unit and
  2180. assigned(tppumodule(from_module).ppufile) then
  2181. tppumodule(from_module).ppufile.tempclose;
  2182. {$endif SHORT_ON_FILE_HANDLES}
  2183. { try to opening ppu, skip this when we already
  2184. know that we need to compile the unit }
  2185. load_ok:=False;
  2186. if not (state=ms_compile) then
  2187. load_ok:=try_load_ppufile(from_module);
  2188. { Do we need to recompile the unit }
  2189. if (state=ms_compile) then
  2190. recompile_from_sources(from_module)
  2191. else if load_ok then
  2192. state:=ms_compiled;
  2193. Result:=(state=ms_compiled);
  2194. // We cannot do this here, the order is all messed up...
  2195. // if not second_time then
  2196. // usedunits.concat(tused_unit.create(self,true,false,nil));
  2197. if result then
  2198. post_load_or_compile(from_module,second_time);
  2199. { we are back, restore current_module }
  2200. set_current_module(from_module);
  2201. { safety, so it does not become negative }
  2202. if LoadCount>0 then
  2203. Dec(LoadCount);
  2204. end;
  2205. procedure tppumodule.discardppu;
  2206. begin
  2207. { PPU is not needed anymore }
  2208. if not assigned(ppufile) then
  2209. exit;
  2210. ppufile.closefile;
  2211. ppufile.free;
  2212. ppufile:=nil;
  2213. end;
  2214. {*****************************************************************************
  2215. RegisterUnit
  2216. *****************************************************************************}
  2217. function registerunit(callermodule:tmodule;const s : TIDString;const fn:string; out is_new:boolean) : tppumodule;
  2218. function FindCycle(aFile, SearchFor: TModule; var Cycle: TFPList): boolean;
  2219. // Note: when traversing, add every search file to Cycle, to avoid running in circles.
  2220. // When a cycle is detected, clear the Cycle list and build the cycle path
  2221. var
  2222. aParent: tdependent_unit;
  2223. begin
  2224. Cycle.Add(aFile);
  2225. aParent:=tdependent_unit(afile.dependent_units.First);
  2226. While Assigned(aParent) do
  2227. begin
  2228. if aParent.in_interface then
  2229. begin
  2230. // writeln('Registering ',Callermodule.get_modulename,': checking cyclic dependency of ',aFile.get_modulename, ' on ',aparent.u.get_modulename);
  2231. if aParent.u=SearchFor then
  2232. begin
  2233. // unit cycle found
  2234. Cycle.Clear;
  2235. Cycle.Add(aParent.u);
  2236. Cycle.Add(aFile);
  2237. // Writeln('exit at ',aParent.u.get_modulename);
  2238. exit(true);
  2239. end;
  2240. if Cycle.IndexOf(aParent.u)<0 then
  2241. if FindCycle(aParent.u,SearchFor,Cycle) then
  2242. begin
  2243. // Writeln('Cycle found, exit at ',aParent.u.get_modulename);
  2244. Cycle.Add(aFile);
  2245. exit(true);
  2246. end;
  2247. end;
  2248. aParent:=tdependent_unit(aParent.Next);
  2249. end;
  2250. Result:=false;
  2251. end;
  2252. var
  2253. ups : TIDString;
  2254. hp : tppumodule;
  2255. hp2 : tmodule;
  2256. cycle : TFPList;
  2257. havecycle: boolean;
  2258. {$IFDEF DEBUGCYCLE}
  2259. cyclepath : ansistring
  2260. {$ENDIF}
  2261. begin
  2262. { Info }
  2263. ups:=upper(s);
  2264. { search all loaded units }
  2265. hp:=tppumodule(loaded_units.first);
  2266. hp2:=nil;
  2267. while assigned(hp) do
  2268. begin
  2269. if hp.modulename^=ups then
  2270. begin
  2271. { only check for units. The main program is also
  2272. as a unit in the loaded_units list. We simply need
  2273. to ignore this entry (PFV) }
  2274. if hp.is_unit then
  2275. begin
  2276. { both units in interface ? }
  2277. if hp.in_interface and callermodule.in_interface then
  2278. begin
  2279. { check for a cycle }
  2280. Cycle:=TFPList.Create;
  2281. try
  2282. HaveCycle:=FindCycle(CallerModule,hp,Cycle);
  2283. if HaveCycle then
  2284. begin
  2285. {$IFDEF DEBUGCYCLE}
  2286. Writeln('Done cycle check');
  2287. CyclePath:='';
  2288. hp2:=TModule(Cycle[Cycle.Count-1]);
  2289. for i:=0 to Cycle.Count-1 do begin
  2290. if i>0 then CyclePath:=CyclePath+',';
  2291. CyclePath:=CyclePath+TModule(Cycle[i]).realmodulename^;
  2292. end;
  2293. Writeln('Unit cycle detected: ',CyclePath);
  2294. {$ENDIF}
  2295. Message2(unit_f_circular_unit_reference,callermodule.realmodulename^,hp.realmodulename^);
  2296. end;
  2297. finally
  2298. Cycle.Free;
  2299. end;
  2300. if assigned(hp2) then
  2301. Message2(unit_f_circular_unit_reference,callermodule.realmodulename^,hp.realmodulename^);
  2302. end;
  2303. break;
  2304. end;
  2305. end;
  2306. { the next unit }
  2307. hp:=tppumodule(hp.next);
  2308. end;
  2309. { the unit is not in the loaded units,
  2310. we create an entry and register the unit }
  2311. is_new:=not assigned(hp);
  2312. if is_new then
  2313. begin
  2314. Message1(unit_u_registering_new_unit,ups);
  2315. hp:=tppumodule.create(callermodule,s,fn,true);
  2316. addloadedunit(hp);
  2317. end;
  2318. { return }
  2319. registerunit:=hp;
  2320. end;
  2321. end.