cg386inl.pas 63 KB

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