cg386inl.pas 62 KB

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