fppu.pas 87 KB

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