cg386inl.pas 63 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 by Florian Klaempfl
  4. Generate i386 inline nodes
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit cg386inl;
  19. interface
  20. uses
  21. tree;
  22. procedure secondinline(var p : ptree);
  23. implementation
  24. uses
  25. globtype,systems,
  26. cobjects,verbose,globals,files,
  27. symtable,aasm,types,
  28. hcodegen,temp_gen,pass_2,
  29. {$ifdef ag386bin}
  30. i386base,i386asm,
  31. {$else}
  32. i386,
  33. {$endif}
  34. cgai386,tgeni386,cg386cal;
  35. {*****************************************************************************
  36. Helpers
  37. *****************************************************************************}
  38. { reverts the parameter list }
  39. var nb_para : integer;
  40. function reversparameter(p : ptree) : ptree;
  41. var
  42. hp1,hp2 : ptree;
  43. begin
  44. hp1:=nil;
  45. nb_para := 0;
  46. while assigned(p) do
  47. begin
  48. { pull out }
  49. hp2:=p;
  50. p:=p^.right;
  51. inc(nb_para);
  52. { pull in }
  53. hp2^.right:=hp1;
  54. hp1:=hp2;
  55. end;
  56. reversparameter:=hp1;
  57. end;
  58. {*****************************************************************************
  59. SecondInLine
  60. *****************************************************************************}
  61. procedure StoreDirectFuncResult(dest:ptree);
  62. var
  63. hp : ptree;
  64. hdef : porddef;
  65. hreg : tregister;
  66. oldregisterdef : boolean;
  67. begin
  68. SecondPass(dest);
  69. if Codegenerror then
  70. exit;
  71. Case dest^.resulttype^.deftype of
  72. floatdef:
  73. floatstore(PFloatDef(dest^.resulttype)^.typ,dest^.location.reference);
  74. orddef:
  75. begin
  76. Case dest^.resulttype^.size of
  77. 1 : hreg:=regtoreg8(accumulator);
  78. 2 : hreg:=regtoreg16(accumulator);
  79. 4 : hreg:=accumulator;
  80. End;
  81. emit_mov_reg_loc(hreg,dest^.location);
  82. If (cs_check_range in aktlocalswitches) and
  83. {no need to rangecheck longints or cardinals on 32bit processors}
  84. not((porddef(dest^.resulttype)^.typ = s32bit) and
  85. (porddef(dest^.resulttype)^.low = $80000000) and
  86. (porddef(dest^.resulttype)^.high = $7fffffff)) and
  87. not((porddef(dest^.resulttype)^.typ = u32bit) and
  88. (porddef(dest^.resulttype)^.low = 0) and
  89. (porddef(dest^.resulttype)^.high = $ffffffff)) then
  90. Begin
  91. {do not register this temporary def}
  92. OldRegisterDef := RegisterDef;
  93. RegisterDef := False;
  94. hdef:=nil;
  95. Case PordDef(dest^.resulttype)^.typ of
  96. u8bit,u16bit,u32bit:
  97. begin
  98. new(hdef,init(u32bit,0,$ffffffff));
  99. hreg:=accumulator;
  100. end;
  101. s8bit,s16bit,s32bit:
  102. begin
  103. new(hdef,init(s32bit,$80000000,$7fffffff));
  104. hreg:=accumulator;
  105. end;
  106. end;
  107. { create a fake node }
  108. hp := genzeronode(nothingn);
  109. hp^.location.loc := LOC_REGISTER;
  110. hp^.location.register := hreg;
  111. if assigned(hdef) then
  112. hp^.resulttype:=hdef
  113. else
  114. hp^.resulttype:=dest^.resulttype;
  115. { emit the range check }
  116. emitrangecheck(hp,dest^.resulttype);
  117. hp^.right := nil;
  118. if assigned(hdef) then
  119. Dispose(hdef, Done);
  120. RegisterDef := OldRegisterDef;
  121. disposetree(hp);
  122. End;
  123. End;
  124. else
  125. internalerror(66766766);
  126. end;
  127. end;
  128. procedure secondinline(var p : ptree);
  129. const
  130. { tfloattype = (f32bit,s32real,s64real,s80real,s64bit); }
  131. float_name: array[tfloattype] of string[8]=
  132. ('FIXED','SINGLE','REAL','EXTENDED','COMP','FIXED16');
  133. incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC);
  134. addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB);
  135. var
  136. aktfile : treference;
  137. ft : tfiletype;
  138. opsize : topsize;
  139. op,
  140. asmop : tasmop;
  141. pushed : tpushed;
  142. {inc/dec}
  143. addconstant : boolean;
  144. addvalue : longint;
  145. procedure handlereadwrite(doread,doln : boolean);
  146. { produces code for READ(LN) and WRITE(LN) }
  147. procedure loadstream;
  148. const
  149. io:array[boolean] of string[7]=('_OUTPUT','_INPUT');
  150. var
  151. r : preference;
  152. begin
  153. new(r);
  154. reset_reference(r^);
  155. r^.symbol:=newasmsymbol('U_'+upper(target_info.system_unit)+io[doread]);
  156. concat_external(r^.symbol^.name,EXT_NEAR);
  157. exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,r,R_EDI)))
  158. end;
  159. const
  160. rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
  161. var
  162. destpara,
  163. node,hp : ptree;
  164. typedtyp,
  165. pararesult : pdef;
  166. has_length : boolean;
  167. dummycoll : tdefcoll;
  168. iolabel : plabel;
  169. npara : longint;
  170. begin
  171. { I/O check }
  172. if (cs_check_io in aktlocalswitches) and
  173. ((aktprocsym^.definition^.options and poiocheck)=0) then
  174. begin
  175. getlabel(iolabel);
  176. emitlab(iolabel);
  177. end
  178. else
  179. iolabel:=nil;
  180. { for write of real with the length specified }
  181. has_length:=false;
  182. hp:=nil;
  183. { reserve temporary pointer to data variable }
  184. aktfile.symbol:=nil;
  185. gettempofsizereference(4,aktfile);
  186. { first state text data }
  187. ft:=ft_text;
  188. { and state a parameter ? }
  189. if p^.left=nil then
  190. begin
  191. { the following instructions are for "writeln;" }
  192. loadstream;
  193. { save @aktfile in temporary variable }
  194. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile))));
  195. end
  196. else
  197. begin
  198. { revers paramters }
  199. node:=reversparameter(p^.left);
  200. p^.left := node;
  201. npara := nb_para;
  202. { calculate data variable }
  203. { is first parameter a file type ? }
  204. if node^.left^.resulttype^.deftype=filedef then
  205. begin
  206. ft:=pfiledef(node^.left^.resulttype)^.filetype;
  207. if ft=ft_typed then
  208. typedtyp:=pfiledef(node^.left^.resulttype)^.typed_as;
  209. secondpass(node^.left);
  210. if codegenerror then
  211. exit;
  212. { save reference in temporary variables }
  213. if node^.left^.location.loc<>LOC_REFERENCE then
  214. begin
  215. CGMessage(cg_e_illegal_expression);
  216. exit;
  217. end;
  218. exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(node^.left^.location.reference),R_EDI)));
  219. { skip to the next parameter }
  220. node:=node^.right;
  221. end
  222. else
  223. begin
  224. { load stdin/stdout stream }
  225. loadstream;
  226. end;
  227. { save @aktfile in temporary variable }
  228. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile))));
  229. if doread then
  230. { parameter by READ gives call by reference }
  231. dummycoll.paratyp:=vs_var
  232. { an WRITE Call by "Const" }
  233. else
  234. dummycoll.paratyp:=vs_const;
  235. { because of secondcallparan, which otherwise attaches }
  236. if ft=ft_typed then
  237. { this is to avoid copy of simple const parameters }
  238. {dummycoll.data:=new(pformaldef,init)}
  239. dummycoll.data:=cformaldef
  240. else
  241. { I think, this isn't a good solution (FK) }
  242. dummycoll.data:=nil;
  243. while assigned(node) do
  244. begin
  245. pushusedregisters(pushed,$ff);
  246. hp:=node;
  247. node:=node^.right;
  248. hp^.right:=nil;
  249. if hp^.is_colon_para then
  250. CGMessage(parser_e_illegal_colon_qualifier);
  251. { when read ord,floats are functions, so they need this
  252. parameter as their destination instead of being pushed }
  253. if doread and
  254. (ft<>ft_typed) and
  255. (hp^.resulttype^.deftype in [orddef,floatdef]) then
  256. destpara:=hp^.left
  257. else
  258. begin
  259. if ft=ft_typed then
  260. never_copy_const_param:=true;
  261. { reset data type }
  262. dummycoll.data:=nil;
  263. { support openstring calling for readln(shortstring) }
  264. if doread and (is_shortstring(hp^.resulttype)) then
  265. dummycoll.data:=openshortstringdef;
  266. secondcallparan(hp,@dummycoll,false,false,0);
  267. if ft=ft_typed then
  268. never_copy_const_param:=false;
  269. end;
  270. hp^.right:=node;
  271. if codegenerror then
  272. exit;
  273. emit_push_mem(aktfile);
  274. if (ft=ft_typed) then
  275. begin
  276. { OK let's try this }
  277. { first we must only allow the right type }
  278. { we have to call blockread or blockwrite }
  279. { but the real problem is that }
  280. { reset and rewrite should have set }
  281. { the type size }
  282. { as recordsize for that file !!!! }
  283. { how can we make that }
  284. { I think that is only possible by adding }
  285. { reset and rewrite to the inline list a call }
  286. { allways read only one record by element }
  287. push_int(typedtyp^.size);
  288. if doread then
  289. emitcall('FPC_TYPED_READ',true)
  290. else
  291. emitcall('FPC_TYPED_WRITE',true);
  292. end
  293. else
  294. begin
  295. { save current position }
  296. pararesult:=hp^.left^.resulttype;
  297. { handle possible field width }
  298. { of course only for write(ln) }
  299. if not doread then
  300. begin
  301. { handle total width parameter }
  302. if assigned(node) and node^.is_colon_para then
  303. begin
  304. hp:=node;
  305. node:=node^.right;
  306. hp^.right:=nil;
  307. secondcallparan(hp,@dummycoll,false,false,0);
  308. hp^.right:=node;
  309. if codegenerror then
  310. exit;
  311. has_length:=true;
  312. end
  313. else
  314. if pararesult^.deftype<>floatdef then
  315. push_int(0)
  316. else
  317. push_int(-32767);
  318. { a second colon para for a float ? }
  319. if assigned(node) and node^.is_colon_para then
  320. begin
  321. hp:=node;
  322. node:=node^.right;
  323. hp^.right:=nil;
  324. secondcallparan(hp,@dummycoll,false,false,0);
  325. hp^.right:=node;
  326. if pararesult^.deftype<>floatdef then
  327. CGMessage(parser_e_illegal_colon_qualifier);
  328. if codegenerror then
  329. exit;
  330. end
  331. else
  332. begin
  333. if pararesult^.deftype=floatdef then
  334. push_int(-1);
  335. end
  336. end;
  337. case pararesult^.deftype of
  338. stringdef :
  339. begin
  340. {$ifndef OLDREAD}
  341. emitcall(rdwrprefix[doread]+pstringdef(pararesult)^.stringtypname,true);
  342. {$else}
  343. if doread then
  344. begin
  345. { push maximum string length }
  346. case pstringdef(pararesult)^.string_typ of
  347. st_shortstring:
  348. emitcall ('FPC_READ_TEXT_STRING',true);
  349. st_ansistring:
  350. emitcall ('FPC_READ_TEXT_ANSISTRING',true);
  351. st_longstring:
  352. emitcall ('FPC_READ_TEXT_LONGSTRING',true);
  353. st_widestring:
  354. emitcall ('FPC_READ_TEXT_ANSISTRING',true);
  355. end
  356. end
  357. else
  358. Case pstringdef(Pararesult)^.string_typ of
  359. st_shortstring:
  360. emitcall ('FPC_WRITE_TEXT_STRING',true);
  361. st_ansistring:
  362. emitcall ('FPC_WRITE_TEXT_ANSISTRING',true);
  363. st_longstring:
  364. emitcall ('FPC_WRITE_TEXT_LONGSTRING',true);
  365. st_widestring:
  366. emitcall ('FPC_WRITE_TEXT_ANSISTRING',true);
  367. end;
  368. {$endif}
  369. end;
  370. pointerdef :
  371. begin
  372. if is_pchar(pararesult) then
  373. emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER',true)
  374. end;
  375. arraydef :
  376. begin
  377. if is_chararray(pararesult) then
  378. emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY',true)
  379. end;
  380. floatdef :
  381. begin
  382. {$ifndef OLDREAD}
  383. if doread then
  384. begin
  385. emitcall(rdwrprefix[doread]+'FLOAT',true);
  386. StoreDirectFuncResult(destpara);
  387. end
  388. else
  389. {$endif}
  390. emitcall(rdwrprefix[doread]+float_name[pfloatdef(pararesult)^.typ],true)
  391. end;
  392. orddef :
  393. begin
  394. case porddef(pararesult)^.typ of
  395. {$ifndef OLDREAD}
  396. s8bit,s16bit,s32bit :
  397. emitcall(rdwrprefix[doread]+'SINT',true);
  398. u8bit,u16bit,u32bit :
  399. emitcall(rdwrprefix[doread]+'UINT',true);
  400. {$else}
  401. u8bit :
  402. if doread then
  403. emitcall('FPC_READ_TEXT_BYTE',true);
  404. s8bit :
  405. if doread then
  406. emitcall('FPC_READ_TEXT_SHORTINT',true);
  407. u16bit :
  408. if doread then
  409. emitcall('FPC_READ_TEXT_WORD',true);
  410. s16bit :
  411. if doread then
  412. emitcall('FPC_READ_TEXT_INTEGER',true);
  413. s32bit :
  414. if doread then
  415. emitcall('FPC_READ_TEXT_LONGINT',true)
  416. else
  417. emitcall('FPC_WRITE_TEXT_LONGINT',true);
  418. u32bit :
  419. if doread then
  420. emitcall('FPC_READ_TEXT_CARDINAL',true)
  421. else
  422. emitcall('FPC_WRITE_TEXT_CARDINAL',true);
  423. {$endif}
  424. uchar :
  425. emitcall(rdwrprefix[doread]+'CHAR',true);
  426. s64bitint:
  427. emitcall(rdwrprefix[doread]+'INT64',true);
  428. u64bit :
  429. emitcall(rdwrprefix[doread]+'QWORD',true);
  430. bool8bit,
  431. bool16bit,
  432. bool32bit :
  433. emitcall(rdwrprefix[doread]+'BOOLEAN',true);
  434. end;
  435. {$ifndef OLDREAD}
  436. if doread then
  437. StoreDirectFuncResult(destpara);
  438. {$endif}
  439. end;
  440. end;
  441. end;
  442. { load ESI in methods again }
  443. popusedregisters(pushed);
  444. maybe_loadesi;
  445. end;
  446. end;
  447. { Insert end of writing for textfiles }
  448. if ft=ft_text then
  449. begin
  450. pushusedregisters(pushed,$ff);
  451. emit_push_mem(aktfile);
  452. if doread then
  453. begin
  454. if doln then
  455. emitcall('FPC_READLN_END',true)
  456. else
  457. emitcall('FPC_READ_END',true);
  458. end
  459. else
  460. begin
  461. if doln then
  462. emitcall('FPC_WRITELN_END',true)
  463. else
  464. emitcall('FPC_WRITE_END',true);
  465. end;
  466. popusedregisters(pushed);
  467. maybe_loadesi;
  468. end;
  469. { Insert IOCheck if set }
  470. if assigned(iolabel) then
  471. begin
  472. { registers are saved in the procedure }
  473. exprasmlist^.concat(new(pai386,op_sym(A_PUSH,S_L,newasmsymbol(lab2str(iolabel)))));
  474. emitcall('FPC_IOCHECK',true);
  475. end;
  476. { Freeup all used temps }
  477. ungetiftemp(aktfile);
  478. if assigned(p^.left) then
  479. begin
  480. p^.left:=reversparameter(p^.left);
  481. if npara<>nb_para then
  482. CGMessage(cg_f_internal_error_in_secondinline);
  483. hp:=p^.left;
  484. while assigned(hp) do
  485. begin
  486. if assigned(hp^.left) then
  487. if (hp^.left^.location.loc in [LOC_MEM,LOC_REFERENCE]) then
  488. ungetiftemp(hp^.left^.location.reference);
  489. hp:=hp^.right;
  490. end;
  491. end;
  492. end;
  493. procedure handle_str;
  494. var
  495. hp,node : ptree;
  496. dummycoll : tdefcoll;
  497. is_real,has_length : boolean;
  498. procedureprefix : string;
  499. begin
  500. pushusedregisters(pushed,$ff);
  501. node:=p^.left;
  502. is_real:=false;
  503. has_length:=false;
  504. while assigned(node^.right) do node:=node^.right;
  505. { if a real parameter somewhere then call REALSTR }
  506. if (node^.left^.resulttype^.deftype=floatdef) then
  507. is_real:=true;
  508. node:=p^.left;
  509. { we have at least two args }
  510. { with at max 2 colon_para in between }
  511. { string arg }
  512. hp:=node;
  513. node:=node^.right;
  514. hp^.right:=nil;
  515. dummycoll.paratyp:=vs_var;
  516. if is_shortstring(hp^.resulttype) then
  517. dummycoll.data:=openshortstringdef
  518. else
  519. dummycoll.data:=hp^.resulttype;
  520. procedureprefix:='FPC_'+pstringdef(hp^.resulttype)^.stringtypname+'_';
  521. secondcallparan(hp,@dummycoll,false,false,0);
  522. if codegenerror then
  523. exit;
  524. dummycoll.paratyp:=vs_const;
  525. disposetree(p^.left);
  526. p^.left:=nil;
  527. { second arg }
  528. hp:=node;
  529. node:=node^.right;
  530. hp^.right:=nil;
  531. { frac para }
  532. if hp^.is_colon_para and assigned(node) and
  533. node^.is_colon_para then
  534. begin
  535. dummycoll.data:=hp^.resulttype;
  536. secondcallparan(hp,@dummycoll,false
  537. ,false,0
  538. );
  539. if codegenerror then
  540. exit;
  541. disposetree(hp);
  542. hp:=node;
  543. node:=node^.right;
  544. hp^.right:=nil;
  545. has_length:=true;
  546. end
  547. else
  548. if is_real then
  549. push_int(-1);
  550. { third arg, length only if is_real }
  551. if hp^.is_colon_para then
  552. begin
  553. dummycoll.data:=hp^.resulttype;
  554. secondcallparan(hp,@dummycoll,false
  555. ,false,0
  556. );
  557. if codegenerror then
  558. exit;
  559. disposetree(hp);
  560. hp:=node;
  561. node:=node^.right;
  562. hp^.right:=nil;
  563. end
  564. else
  565. if is_real then
  566. push_int(-32767)
  567. else
  568. push_int(-1);
  569. { last arg longint or real }
  570. secondcallparan(hp,@dummycoll,false
  571. ,false,0
  572. );
  573. disposetree(hp);
  574. if codegenerror then
  575. exit;
  576. if is_real then
  577. emitcall(procedureprefix+float_name[pfloatdef(hp^.resulttype)^.typ],true)
  578. else
  579. case porddef(hp^.resulttype)^.typ of
  580. u32bit:
  581. emitcall(procedureprefix+'CARDINAL',true);
  582. u64bit:
  583. emitcall(procedureprefix+'QWORD',true);
  584. s64bitint:
  585. emitcall(procedureprefix+'INT64',true);
  586. else
  587. emitcall(procedureprefix+'LONGINT',true);
  588. end;
  589. popusedregisters(pushed);
  590. end;
  591. {$IfnDef OLDVAL}
  592. Procedure Handle_Val;
  593. var
  594. hp,node, code_para, dest_para : ptree;
  595. hreg: TRegister;
  596. hdef: POrdDef;
  597. procedureprefix : string;
  598. hr: TReference;
  599. dummycoll : tdefcoll;
  600. has_code, has_32bit_code, oldregisterdef: boolean;
  601. pushed2: TPushed;
  602. unusedregs: TRegisterSet;
  603. begin
  604. node:=p^.left;
  605. hp:=node;
  606. node:=node^.right;
  607. hp^.right:=nil;
  608. {if we have 3 parameters, we have a code parameter}
  609. has_code := Assigned(node^.right);
  610. has_32bit_code := false;
  611. reset_reference(hr);
  612. hreg := R_NO;
  613. If has_code then
  614. Begin
  615. {code is an orddef, that's checked in tcinl}
  616. code_para := hp;
  617. hp := node;
  618. node := node^.right;
  619. hp^.right := nil;
  620. has_32bit_code := (porddef(code_para^.left^.resulttype)^.typ in [u32bit,s32bit]);
  621. End;
  622. {hp = destination now, save for later use}
  623. dest_para := hp;
  624. {the function result will be in EAX, so we need to reserve it so
  625. that secondpass(dest_para^.left) won't use it}
  626. hreg := getexplicitregister32(R_EAX);
  627. {if EAX is already in use, it's a register variable. Since we don't
  628. need another register besides EAX, release the one we got}
  629. If hreg <> R_EAX Then ungetregister32(hreg);
  630. {load the address of the destination}
  631. secondpass(dest_para^.left);
  632. {unget EAX (if we got it before), since otherwise pushusedregisters
  633. will push it on the stack.}
  634. If (hreg = R_EAX) then Ungetregister32(hreg);
  635. {save which registers are (not) used now, we'll need it after the
  636. function call}
  637. UnusedRegs := Unused;
  638. {(if necessary) save the address loading of dest_para and possibly
  639. register variables}
  640. pushusedregisters(pushed,$ff);
  641. {only now load the address of the code parameter, since we want
  642. to handle it before the destination after the function call}
  643. If has_code and (not has_32bit_code) Then
  644. Begin
  645. {make sure this secondpass doesn't use EAX either}
  646. hreg := getexplicitregister32(R_EAX);
  647. If hreg <> R_EAX Then ungetregister32(hreg);
  648. secondpass(code_para^.left);
  649. If hreg = R_EAX Then ungetregister32(hreg);
  650. {maybe secondpass(code_para^.left) required more registers than
  651. secondpass(dest_para^.left). The registers where we can store
  652. the result afterwards have to be unused in both cases}
  653. UnusedRegs := UnusedRegs * Unused;
  654. pushusedregisters(pushed2, $ff)
  655. End;
  656. {now that we've already pushed the results from
  657. secondpass(code_para^.left) and secondpass(dest_para^.left) on the
  658. stack, we can put the real parameters on the stack}
  659. If has_32bit_code Then
  660. Begin
  661. dummycoll.paratyp:=vs_var;
  662. dummycoll.data:=code_para^.resulttype;
  663. secondcallparan(code_para,@dummycoll,false,false,0);
  664. if codegenerror then
  665. exit;
  666. Disposetree(code_para);
  667. End
  668. Else
  669. Begin
  670. {only 32bit code parameter is supported, so fake one}
  671. GetTempOfSizeReference(4,hr);
  672. emitpushreferenceaddr(exprasmlist,hr);
  673. End;
  674. {node = first parameter = string}
  675. dummycoll.paratyp:=vs_const;
  676. dummycoll.data:=node^.resulttype;
  677. secondcallparan(node,@dummycoll,false,false,0);
  678. if codegenerror then
  679. exit;
  680. Case dest_para^.resulttype^.deftype of
  681. floatdef:
  682. procedureprefix := 'FPC_VAL_REAL_';
  683. orddef:
  684. if is_signed(dest_para^.resulttype) then
  685. begin
  686. {if we are converting to a signed number, we have to include the
  687. size of the destination, so the Val function can extend the sign
  688. of the result to allow proper range checking}
  689. exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,dest_para^.resulttype^.size)));
  690. procedureprefix := 'FPC_VAL_SINT_'
  691. end
  692. else
  693. procedureprefix := 'FPC_VAL_UINT_';
  694. End;
  695. emitcall(procedureprefix+pstringdef(node^.resulttype)^.stringtypname,true);
  696. { before disposing node we need to ungettemp !! PM }
  697. if node^.left^.location.loc in [LOC_REFERENCE,LOC_MEM] then
  698. ungetiftemp(node^.left^.location.reference);
  699. disposetree(node);
  700. p^.left := nil;
  701. {reload esi in case the dest_para/code_para is a class variable or so}
  702. maybe_loadesi;
  703. If (dest_para^.resulttype^.deftype = orddef) Then
  704. Begin
  705. {restore which registers are used by register variables and/or
  706. the address loading of the dest/code_para, so we can store the
  707. result in a safe place}
  708. unused := UnusedRegs;
  709. {as of now, hreg now holds the location of the result, if it was
  710. integer}
  711. hreg := getexplicitregister32(R_EAX);
  712. emit_reg_reg(A_MOV,S_L,R_EAX,hreg);
  713. End;
  714. If has_code and Not(has_32bit_code) Then
  715. {only 16bit code is possible}
  716. Begin
  717. {restore the address loaded by secondpass(code_para)}
  718. popusedregisters(pushed2);
  719. {move the code to its destination}
  720. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI)));
  721. emit_mov_reg_loc(R_DI,code_para^.left^.location);
  722. Disposetree(code_para);
  723. End;
  724. {restore the addresses loaded by secondpass(dest_para)}
  725. popusedregisters(pushed);
  726. {save the function result in the destination variable}
  727. Case dest_para^.left^.resulttype^.deftype of
  728. floatdef:
  729. floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ,dest_para^.left^.location.reference);
  730. orddef:
  731. Case PordDef(dest_para^.left^.resulttype)^.typ of
  732. u8bit,s8bit:
  733. emit_mov_reg_loc(RegToReg8(hreg),dest_para^.left^.location);
  734. u16bit,s16bit:
  735. emit_mov_reg_loc(RegToReg16(hreg),dest_para^.left^.location);
  736. u32bit,s32bit:
  737. emit_mov_reg_loc(hreg,dest_para^.left^.location);
  738. {u64bit,s64bitint: ???}
  739. End;
  740. End;
  741. If (cs_check_range in aktlocalswitches) and
  742. (dest_para^.left^.resulttype^.deftype = orddef) and
  743. {the following has to be changed to 64bit checking, once Val
  744. returns 64 bit values (unless a special Val function is created
  745. for that)}
  746. {no need to rangecheck longints or cardinals on 32bit processors}
  747. not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and
  748. (porddef(dest_para^.left^.resulttype)^.low = $80000000) and
  749. (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and
  750. not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and
  751. (porddef(dest_para^.left^.resulttype)^.low = 0) and
  752. (porddef(dest_para^.left^.resulttype)^.high = $ffffffff)) then
  753. Begin
  754. hp := getcopy(dest_para^.left);
  755. hp^.location.loc := LOC_REGISTER;
  756. hp^.location.register := hreg;
  757. {do not register this temporary def}
  758. OldRegisterDef := RegisterDef;
  759. RegisterDef := False;
  760. Case PordDef(dest_para^.left^.resulttype)^.typ of
  761. u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$ffffffff));
  762. s8bit,s16bit,s32bit: new(hdef,init(s32bit,$80000000,$7fffffff));
  763. end;
  764. hp^.resulttype := hdef;
  765. emitrangecheck(hp,dest_para^.left^.resulttype);
  766. hp^.right := nil;
  767. Dispose(hp^.resulttype, Done);
  768. RegisterDef := OldRegisterDef;
  769. disposetree(hp);
  770. End;
  771. {dest_para^.right is already nil}
  772. disposetree(dest_para);
  773. UnGetIfTemp(hr);
  774. end;
  775. {$EndIf OLDVAL}
  776. var
  777. r : preference;
  778. hp : ptree;
  779. l : longint;
  780. ispushed : boolean;
  781. hregister : tregister;
  782. otlabel,oflabel : plabel;
  783. oldpushedparasize : longint;
  784. begin
  785. { save & reset pushedparasize }
  786. oldpushedparasize:=pushedparasize;
  787. pushedparasize:=0;
  788. case p^.inlinenumber of
  789. in_assert_x_y:
  790. begin
  791. otlabel:=truelabel;
  792. oflabel:=falselabel;
  793. getlabel(truelabel);
  794. getlabel(falselabel);
  795. secondpass(p^.left^.left);
  796. if cs_do_assertion in aktlocalswitches then
  797. begin
  798. maketojumpbool(p^.left^.left);
  799. emitlab(falselabel);
  800. { erroraddr }
  801. exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBP)));
  802. { lineno }
  803. exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,aktfilepos.line)));
  804. { filename string }
  805. hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex));
  806. secondpass(hp);
  807. if codegenerror then
  808. exit;
  809. emitpushreferenceaddr(exprasmlist,hp^.location.reference);
  810. disposetree(hp);
  811. { push msg }
  812. secondpass(p^.left^.right^.left);
  813. emitpushreferenceaddr(exprasmlist,p^.left^.right^.left^.location.reference);
  814. { call }
  815. emitcall('FPC_ASSERT',true);
  816. emitlab(truelabel);
  817. end;
  818. freelabel(truelabel);
  819. freelabel(falselabel);
  820. truelabel:=otlabel;
  821. falselabel:=oflabel;
  822. end;
  823. in_lo_word,
  824. in_hi_word :
  825. begin
  826. secondpass(p^.left);
  827. p^.location.loc:=LOC_REGISTER;
  828. if p^.left^.location.loc<>LOC_REGISTER then
  829. begin
  830. if p^.left^.location.loc=LOC_CREGISTER then
  831. begin
  832. p^.location.register:=reg32toreg16(getregister32);
  833. emit_reg_reg(A_MOV,S_W,p^.left^.location.register,
  834. p^.location.register);
  835. end
  836. else
  837. begin
  838. del_reference(p^.left^.location.reference);
  839. p^.location.register:=reg32toreg16(getregister32);
  840. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference),
  841. p^.location.register)));
  842. end;
  843. end
  844. else p^.location.register:=p^.left^.location.register;
  845. if p^.inlinenumber=in_hi_word then
  846. exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register)));
  847. p^.location.register:=reg16toreg8(p^.location.register);
  848. end;
  849. in_sizeof_x,
  850. in_typeof_x :
  851. begin
  852. { for both cases load vmt }
  853. if p^.left^.treetype=typen then
  854. begin
  855. p^.location.register:=getregister32;
  856. exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,
  857. S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
  858. p^.location.register)));
  859. end
  860. else
  861. begin
  862. secondpass(p^.left);
  863. del_reference(p^.left^.location.reference);
  864. p^.location.loc:=LOC_REGISTER;
  865. p^.location.register:=getregister32;
  866. { load VMT pointer }
  867. inc(p^.left^.location.reference.offset,
  868. pobjectdef(p^.left^.resulttype)^.vmt_offset);
  869. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  870. newreference(p^.left^.location.reference),
  871. p^.location.register)));
  872. end;
  873. { in sizeof load size }
  874. if p^.inlinenumber=in_sizeof_x then
  875. begin
  876. new(r);
  877. reset_reference(r^);
  878. r^.base:=p^.location.register;
  879. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
  880. p^.location.register)));
  881. end;
  882. end;
  883. in_lo_long,
  884. in_hi_long :
  885. begin
  886. secondpass(p^.left);
  887. p^.location.loc:=LOC_REGISTER;
  888. if p^.left^.location.loc<>LOC_REGISTER then
  889. begin
  890. if p^.left^.location.loc=LOC_CREGISTER then
  891. begin
  892. p^.location.register:=getregister32;
  893. emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
  894. p^.location.register);
  895. end
  896. else
  897. begin
  898. del_reference(p^.left^.location.reference);
  899. p^.location.register:=getregister32;
  900. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
  901. p^.location.register)));
  902. end;
  903. end
  904. else p^.location.register:=p^.left^.location.register;
  905. if p^.inlinenumber=in_hi_long then
  906. exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register)));
  907. p^.location.register:=reg32toreg16(p^.location.register);
  908. end;
  909. in_length_string :
  910. begin
  911. secondpass(p^.left);
  912. set_location(p^.location,p^.left^.location);
  913. { length in ansi strings is at offset -8 }
  914. if is_ansistring(p^.left^.resulttype) then
  915. dec(p^.location.reference.offset,8)
  916. { char is always 1, so make it a constant value }
  917. else if is_char(p^.left^.resulttype) then
  918. begin
  919. clear_location(p^.location);
  920. p^.location.loc:=LOC_MEM;
  921. p^.location.reference.is_immediate:=true;
  922. p^.location.reference.offset:=1;
  923. end;
  924. end;
  925. in_pred_x,
  926. in_succ_x:
  927. begin
  928. secondpass(p^.left);
  929. if not (cs_check_overflow in aktlocalswitches) then
  930. if p^.inlinenumber=in_pred_x then
  931. asmop:=A_DEC
  932. else
  933. asmop:=A_INC
  934. else
  935. if p^.inlinenumber=in_pred_x then
  936. asmop:=A_SUB
  937. else
  938. asmop:=A_ADD;
  939. case p^.resulttype^.size of
  940. 4 : opsize:=S_L;
  941. 2 : opsize:=S_W;
  942. 1 : opsize:=S_B;
  943. else
  944. internalerror(10080);
  945. end;
  946. p^.location.loc:=LOC_REGISTER;
  947. if p^.left^.location.loc<>LOC_REGISTER then
  948. begin
  949. p^.location.register:=getregister32;
  950. if (p^.resulttype^.size=2) then
  951. p^.location.register:=reg32toreg16(p^.location.register);
  952. if (p^.resulttype^.size=1) then
  953. p^.location.register:=reg32toreg8(p^.location.register);
  954. if p^.left^.location.loc=LOC_CREGISTER then
  955. emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
  956. p^.location.register)
  957. else
  958. if p^.left^.location.loc=LOC_FLAGS then
  959. emit_flag2reg(p^.left^.location.resflags,p^.location.register)
  960. else
  961. begin
  962. del_reference(p^.left^.location.reference);
  963. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference),
  964. p^.location.register)));
  965. end;
  966. end
  967. else p^.location.register:=p^.left^.location.register;
  968. if not (cs_check_overflow in aktlocalswitches) then
  969. exprasmlist^.concat(new(pai386,op_reg(asmop,opsize,
  970. p^.location.register)))
  971. else
  972. exprasmlist^.concat(new(pai386,op_const_reg(asmop,opsize,1,
  973. p^.location.register)));
  974. emitoverflowcheck(p);
  975. emitrangecheck(p,p^.resulttype);
  976. end;
  977. in_dec_x,
  978. in_inc_x :
  979. begin
  980. { set defaults }
  981. addvalue:=1;
  982. addconstant:=true;
  983. { load first parameter, must be a reference }
  984. secondpass(p^.left^.left);
  985. case p^.left^.left^.resulttype^.deftype of
  986. orddef,
  987. enumdef : begin
  988. case p^.left^.left^.resulttype^.size of
  989. 1 : opsize:=S_B;
  990. 2 : opsize:=S_W;
  991. 4 : opsize:=S_L;
  992. end;
  993. end;
  994. pointerdef : begin
  995. opsize:=S_L;
  996. if porddef(ppointerdef(p^.left^.left^.resulttype)^.definition)=voiddef then
  997. addvalue:=1
  998. else
  999. addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.savesize;
  1000. end;
  1001. else
  1002. internalerror(10081);
  1003. end;
  1004. { second argument specified?, must be a s32bit in register }
  1005. if assigned(p^.left^.right) then
  1006. begin
  1007. secondpass(p^.left^.right^.left);
  1008. { when constant, just multiply the addvalue }
  1009. if is_constintnode(p^.left^.right^.left) then
  1010. addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left)
  1011. else
  1012. begin
  1013. case p^.left^.right^.left^.location.loc of
  1014. LOC_REGISTER,
  1015. LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register;
  1016. LOC_MEM,
  1017. LOC_REFERENCE : begin
  1018. del_reference(p^.left^.right^.left^.location.reference);
  1019. hregister:=getregister32;
  1020. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  1021. newreference(p^.left^.right^.left^.location.reference),hregister)));
  1022. end;
  1023. else
  1024. internalerror(10082);
  1025. end;
  1026. { insert multiply with addvalue if its >1 }
  1027. if addvalue>1 then
  1028. exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,opsize,
  1029. addvalue,hregister)));
  1030. addconstant:=false;
  1031. end;
  1032. end;
  1033. { write the add instruction }
  1034. if addconstant then
  1035. begin
  1036. if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then
  1037. begin
  1038. if p^.left^.left^.location.loc=LOC_CREGISTER then
  1039. exprasmlist^.concat(new(pai386,op_reg(incdecop[p^.inlinenumber],opsize,
  1040. p^.left^.left^.location.register)))
  1041. else
  1042. exprasmlist^.concat(new(pai386,op_ref(incdecop[p^.inlinenumber],opsize,
  1043. newreference(p^.left^.left^.location.reference))))
  1044. end
  1045. else
  1046. begin
  1047. if p^.left^.left^.location.loc=LOC_CREGISTER then
  1048. exprasmlist^.concat(new(pai386,op_const_reg(addsubop[p^.inlinenumber],opsize,
  1049. addvalue,p^.left^.left^.location.register)))
  1050. else
  1051. exprasmlist^.concat(new(pai386,op_const_ref(addsubop[p^.inlinenumber],opsize,
  1052. addvalue,newreference(p^.left^.left^.location.reference))));
  1053. end
  1054. end
  1055. else
  1056. begin
  1057. { BUG HERE : detected with nasm :
  1058. hregister is allways 32 bit
  1059. it should be converted to 16 or 8 bit depending on op_size PM }
  1060. { still not perfect :
  1061. if hregister is already a 16 bit reg ?? PM }
  1062. case opsize of
  1063. S_B : hregister:=reg32toreg8(hregister);
  1064. S_W : hregister:=reg32toreg16(hregister);
  1065. end;
  1066. if p^.left^.left^.location.loc=LOC_CREGISTER then
  1067. exprasmlist^.concat(new(pai386,op_reg_reg(addsubop[p^.inlinenumber],opsize,
  1068. hregister,p^.left^.left^.location.register)))
  1069. else
  1070. exprasmlist^.concat(new(pai386,op_reg_ref(addsubop[p^.inlinenumber],opsize,
  1071. hregister,newreference(p^.left^.left^.location.reference))));
  1072. case opsize of
  1073. S_B : hregister:=reg8toreg32(hregister);
  1074. S_W : hregister:=reg16toreg32(hregister);
  1075. end;
  1076. ungetregister32(hregister);
  1077. end;
  1078. emitoverflowcheck(p^.left^.left);
  1079. emitrangecheck(p^.left^.left,p^.left^.left^.resulttype);
  1080. end;
  1081. in_assigned_x :
  1082. begin
  1083. secondpass(p^.left^.left);
  1084. p^.location.loc:=LOC_FLAGS;
  1085. if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  1086. begin
  1087. exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,
  1088. p^.left^.left^.location.register,
  1089. p^.left^.left^.location.register)));
  1090. ungetregister32(p^.left^.left^.location.register);
  1091. end
  1092. else
  1093. begin
  1094. exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0,
  1095. newreference(p^.left^.left^.location.reference))));
  1096. del_reference(p^.left^.left^.location.reference);
  1097. end;
  1098. p^.location.resflags:=F_NE;
  1099. end;
  1100. in_reset_typedfile,in_rewrite_typedfile :
  1101. begin
  1102. pushusedregisters(pushed,$ff);
  1103. exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size)));
  1104. secondpass(p^.left);
  1105. emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
  1106. if p^.inlinenumber=in_reset_typedfile then
  1107. emitcall('FPC_RESET_TYPED',true)
  1108. else
  1109. emitcall('FPC_REWRITE_TYPED',true);
  1110. popusedregisters(pushed);
  1111. end;
  1112. in_write_x :
  1113. handlereadwrite(false,false);
  1114. in_writeln_x :
  1115. handlereadwrite(false,true);
  1116. in_read_x :
  1117. handlereadwrite(true,false);
  1118. in_readln_x :
  1119. handlereadwrite(true,true);
  1120. in_str_x_string :
  1121. begin
  1122. handle_str;
  1123. maybe_loadesi;
  1124. end;
  1125. {$IfnDef OLDVAL}
  1126. in_val_x :
  1127. Begin
  1128. handle_val;
  1129. End;
  1130. {$EndIf OLDVAL}
  1131. in_include_x_y,
  1132. in_exclude_x_y:
  1133. begin
  1134. secondpass(p^.left^.left);
  1135. if p^.left^.right^.left^.treetype=ordconstn then
  1136. begin
  1137. { calculate bit position }
  1138. l:=1 shl (p^.left^.right^.left^.value mod 32);
  1139. { determine operator }
  1140. if p^.inlinenumber=in_include_x_y then
  1141. asmop:=A_OR
  1142. else
  1143. begin
  1144. asmop:=A_AND;
  1145. l:=not(l);
  1146. end;
  1147. if (p^.left^.left^.location.loc=LOC_REFERENCE) then
  1148. begin
  1149. inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4);
  1150. exprasmlist^.concat(new(pai386,op_const_ref(asmop,S_L,
  1151. l,newreference(p^.left^.left^.location.reference))));
  1152. del_reference(p^.left^.left^.location.reference);
  1153. end
  1154. else
  1155. { LOC_CREGISTER }
  1156. exprasmlist^.concat(new(pai386,op_const_reg(asmop,S_L,
  1157. l,p^.left^.left^.location.register)));
  1158. end
  1159. else
  1160. begin
  1161. { generate code for the element to set }
  1162. ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left);
  1163. secondpass(p^.left^.right^.left);
  1164. if ispushed then
  1165. restore(p^.left^.left);
  1166. { determine asm operator }
  1167. if p^.inlinenumber=in_include_x_y then
  1168. asmop:=A_BTS
  1169. else
  1170. asmop:=A_BTR;
  1171. if psetdef(p^.left^.resulttype)^.settype=smallset then
  1172. begin
  1173. if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
  1174. hregister:=p^.left^.right^.left^.location.register
  1175. else
  1176. begin
  1177. hregister:=R_EDI;
  1178. opsize:=def2def_opsize(p^.left^.right^.left^.resulttype,u32bitdef);
  1179. if opsize in [S_B,S_W,S_L] then
  1180. op:=A_MOV
  1181. else
  1182. op:=A_MOVZX;
  1183. exprasmlist^.concat(new(pai386,op_ref_reg(op,opsize,
  1184. newreference(p^.left^.right^.left^.location.reference),R_EDI)));
  1185. end;
  1186. if (p^.left^.left^.location.loc=LOC_REFERENCE) then
  1187. exprasmlist^.concat(new(pai386,op_reg_ref(asmop,S_L,hregister,
  1188. newreference(p^.left^.right^.left^.location.reference))))
  1189. else
  1190. exprasmlist^.concat(new(pai386,op_reg_reg(asmop,S_L,hregister,
  1191. p^.left^.right^.left^.location.register)));
  1192. end
  1193. else
  1194. begin
  1195. pushsetelement(p^.left^.right^.left);
  1196. { normset is allways a ref }
  1197. emitpushreferenceaddr(exprasmlist,
  1198. p^.left^.left^.location.reference);
  1199. if p^.inlinenumber=in_include_x_y then
  1200. emitcall('FPC_SET_SET_BYTE',true)
  1201. else
  1202. emitcall('FPC_SET_UNSET_BYTE',true);
  1203. {CGMessage(cg_e_include_not_implemented);}
  1204. end;
  1205. end;
  1206. end;
  1207. else internalerror(9);
  1208. end;
  1209. { remove temp. objects, we don't generate them here }
  1210. removetemps(exprasmlist,temptoremove);
  1211. temptoremove^.clear;
  1212. { reset pushedparasize }
  1213. pushedparasize:=oldpushedparasize;
  1214. end;
  1215. end.
  1216. {
  1217. $Log$
  1218. Revision 1.42 1999-04-14 09:11:59 peter
  1219. * fixed include
  1220. Revision 1.41 1999/04/08 23:59:49 pierre
  1221. * temp string for val code freed
  1222. Revision 1.40 1999/04/08 15:57:46 peter
  1223. + subrange checking for readln()
  1224. Revision 1.39 1999/04/07 15:31:16 pierre
  1225. * all formaldefs are now a sinlge definition
  1226. cformaldef (this was necessary for double_checksum)
  1227. + small part of double_checksum code
  1228. Revision 1.38 1999/04/05 11:07:26 jonas
  1229. * fixed some typos in the constants of the range checking for Val
  1230. Revision 1.37 1999/04/01 22:07:51 peter
  1231. * universal string names (ansistr instead of stransi) for val/str
  1232. Revision 1.36 1999/04/01 06:21:04 jonas
  1233. * added initialization for has_32bit_code (caused problems with Val statement
  1234. without code parameter)
  1235. Revision 1.35 1999/03/31 20:30:49 michael
  1236. * fixed typo: odlval to oldval
  1237. Revision 1.34 1999/03/31 17:13:09 jonas
  1238. * bugfix for -Ox with internal val code
  1239. * internal val code now requires less free registers
  1240. * internal val code no longer needs a temp var for range checking
  1241. Revision 1.33 1999/03/26 00:24:15 peter
  1242. * last para changed to long for easier pushing with 4 byte aligns
  1243. Revision 1.32 1999/03/26 00:05:26 peter
  1244. * released valintern
  1245. + deffile is now removed when compiling is finished
  1246. * ^( compiles now correct
  1247. + static directive
  1248. * shrd fixed
  1249. Revision 1.31 1999/03/24 23:16:49 peter
  1250. * fixed bugs 212,222,225,227,229,231,233
  1251. Revision 1.30 1999/03/16 17:52:56 jonas
  1252. * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
  1253. * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
  1254. * in cgai386: also small fixes to emitrangecheck
  1255. Revision 1.29 1999/02/25 21:02:27 peter
  1256. * ag386bin updates
  1257. + coff writer
  1258. Revision 1.28 1999/02/22 02:15:11 peter
  1259. * updates for ag386bin
  1260. Revision 1.27 1999/02/17 14:21:40 pierre
  1261. * unused local removed
  1262. Revision 1.26 1999/02/15 11:40:21 pierre
  1263. * pred/succ with overflow check must use ADD DEC !!
  1264. Revision 1.25 1999/02/05 10:56:19 florian
  1265. * in some cases a writeln of temp. ansistrings cause a memory leak, fixed
  1266. Revision 1.24 1999/01/21 22:10:39 peter
  1267. * fixed array of const
  1268. * generic platform independent high() support
  1269. Revision 1.23 1999/01/06 12:23:29 florian
  1270. * str(...) for ansi/long and widestrings fixed
  1271. Revision 1.22 1998/12/11 23:36:07 florian
  1272. + again more stuff for int64/qword:
  1273. - comparision operators
  1274. - code generation for: str, read(ln), write(ln)
  1275. Revision 1.21 1998/12/11 00:02:50 peter
  1276. + globtype,tokens,version unit splitted from globals
  1277. Revision 1.20 1998/11/27 14:50:32 peter
  1278. + open strings, $P switch support
  1279. Revision 1.19 1998/11/26 13:10:40 peter
  1280. * new int - int conversion -dNEWCNV
  1281. * some function renamings
  1282. Revision 1.18 1998/11/24 17:04:27 peter
  1283. * fixed length(char) when char is a variable
  1284. Revision 1.17 1998/11/05 12:02:33 peter
  1285. * released useansistring
  1286. * removed -Sv, its now available in fpc modes
  1287. Revision 1.16 1998/10/22 17:11:13 pierre
  1288. + terminated the include exclude implementation for i386
  1289. * enums inside records fixed
  1290. Revision 1.15 1998/10/21 15:12:50 pierre
  1291. * bug fix for IOCHECK inside a procedure with iocheck modifier
  1292. * removed the GPF for unexistant overloading
  1293. (firstcall was called with procedinition=nil !)
  1294. * changed typen to what Florian proposed
  1295. gentypenode(p : pdef) sets the typenodetype field
  1296. and resulttype is only set if inside bt_type block !
  1297. Revision 1.14 1998/10/20 08:06:40 pierre
  1298. * several memory corruptions due to double freemem solved
  1299. => never use p^.loc.location:=p^.left^.loc.location;
  1300. + finally I added now by default
  1301. that ra386dir translates global and unit symbols
  1302. + added a first field in tsymtable and
  1303. a nextsym field in tsym
  1304. (this allows to obtain ordered type info for
  1305. records and objects in gdb !)
  1306. Revision 1.13 1998/10/13 16:50:02 pierre
  1307. * undid some changes of Peter that made the compiler wrong
  1308. for m68k (I had to reinsert some ifdefs)
  1309. * removed several memory leaks under m68k
  1310. * removed the meory leaks for assembler readers
  1311. * cross compiling shoud work again better
  1312. ( crosscompiling sysamiga works
  1313. but as68k still complain about some code !)
  1314. Revision 1.12 1998/10/08 17:17:12 pierre
  1315. * current_module old scanner tagged as invalid if unit is recompiled
  1316. + added ppheap for better info on tracegetmem of heaptrc
  1317. (adds line column and file index)
  1318. * several memory leaks removed ith help of heaptrc !!
  1319. Revision 1.11 1998/10/05 21:33:15 peter
  1320. * fixed 161,165,166,167,168
  1321. Revision 1.10 1998/10/05 12:32:44 peter
  1322. + assert() support
  1323. Revision 1.8 1998/10/02 10:35:09 peter
  1324. * support for inc(pointer,value) which now increases with value instead
  1325. of 0*value :)
  1326. Revision 1.7 1998/09/21 08:45:07 pierre
  1327. + added vmt_offset in tobjectdef.write for fututre use
  1328. (first steps to have objects without vmt if no virtual !!)
  1329. + added fpu_used field for tabstractprocdef :
  1330. sets this level to 2 if the functions return with value in FPU
  1331. (is then set to correct value at parsing of implementation)
  1332. THIS MIGHT refuse some code with FPU expression too complex
  1333. that were accepted before and even in some cases
  1334. that don't overflow in fact
  1335. ( like if f : float; is a forward that finally in implementation
  1336. only uses one fpu register !!)
  1337. Nevertheless I think that it will improve security on
  1338. FPU operations !!
  1339. * most other changes only for UseBrowser code
  1340. (added symtable references for record and objects)
  1341. local switch for refs to args and local of each function
  1342. (static symtable still missing)
  1343. UseBrowser still not stable and probably broken by
  1344. the definition hash array !!
  1345. Revision 1.6 1998/09/20 12:26:37 peter
  1346. * merged fixes
  1347. Revision 1.5 1998/09/17 09:42:15 peter
  1348. + pass_2 for cg386
  1349. * Message() -> CGMessage() for pass_1/pass_2
  1350. Revision 1.4 1998/09/14 10:43:49 peter
  1351. * all internal RTL functions start with FPC_
  1352. Revision 1.3.2.1 1998/09/20 12:20:07 peter
  1353. * Fixed stack not on 4 byte boundary when doing a call
  1354. Revision 1.3 1998/09/05 23:03:57 florian
  1355. * some fixes to get -Or work:
  1356. - inc/dec didn't take care of CREGISTER
  1357. - register calculcation of inc/dec was wrong
  1358. - var/const parameters get now assigned 32 bit register, but
  1359. const parameters only if they are passed by reference !
  1360. Revision 1.2 1998/09/04 08:41:40 peter
  1361. * updated some error CGMessages
  1362. Revision 1.1 1998/08/31 12:22:14 peter
  1363. * secondinline moved to cg386inl
  1364. Revision 1.19 1998/08/31 08:52:03 peter
  1365. * fixed error 10 with succ() and pref()
  1366. Revision 1.18 1998/08/20 21:36:38 peter
  1367. * fixed 'with object do' bug
  1368. Revision 1.17 1998/08/19 16:07:36 jonas
  1369. * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas
  1370. Revision 1.16 1998/08/18 09:24:36 pierre
  1371. * small warning position bug fixed
  1372. * support_mmx switches splitting was missing
  1373. * rhide error and warning output corrected
  1374. Revision 1.15 1998/08/13 11:00:09 peter
  1375. * fixed procedure<>procedure construct
  1376. Revision 1.14 1998/08/11 14:05:33 peter
  1377. * fixed sizeof(array of char)
  1378. Revision 1.13 1998/08/10 14:49:45 peter
  1379. + localswitches, moduleswitches, globalswitches splitting
  1380. Revision 1.12 1998/07/30 13:30:31 florian
  1381. * final implemenation of exception support, maybe it needs
  1382. some fixes :)
  1383. Revision 1.11 1998/07/24 22:16:52 florian
  1384. * internal error 10 together with array access fixed. I hope
  1385. that's the final fix.
  1386. Revision 1.10 1998/07/18 22:54:23 florian
  1387. * some ansi/wide/longstring support fixed:
  1388. o parameter passing
  1389. o returning as result from functions
  1390. Revision 1.9 1998/07/07 17:40:37 peter
  1391. * packrecords 4 works
  1392. * word aligning of parameters
  1393. Revision 1.8 1998/07/06 15:51:15 michael
  1394. Added length checking for string reading
  1395. Revision 1.7 1998/07/06 14:19:51 michael
  1396. + Added calls for reading/writing ansistrings
  1397. Revision 1.6 1998/07/01 15:28:48 peter
  1398. + better writeln/readln handling, now 100% like tp7
  1399. Revision 1.5 1998/06/25 14:04:17 peter
  1400. + internal inc/dec
  1401. Revision 1.4 1998/06/25 08:48:06 florian
  1402. * first version of rtti support
  1403. Revision 1.3 1998/06/09 16:01:33 pierre
  1404. + added procedure directive parsing for procvars
  1405. (accepted are popstack cdecl and pascal)
  1406. + added C vars with the following syntax
  1407. var C calias 'true_c_name';(can be followed by external)
  1408. reason is that you must add the Cprefix
  1409. which is target dependent
  1410. Revision 1.2 1998/06/08 13:13:29 pierre
  1411. + temporary variables now in temp_gen.pas unit
  1412. because it is processor independent
  1413. * mppc68k.bat modified to undefine i386 and support_mmx
  1414. (which are defaults for i386)
  1415. Revision 1.1 1998/06/05 17:44:10 peter
  1416. * splitted cgi386
  1417. }