n386inl.pas 73 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770
  1. {
  2. $Id$
  3. Copyright (c) 1998-2000 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 n386inl;
  19. {$i defines.inc}
  20. interface
  21. uses
  22. node,ninl;
  23. type
  24. ti386inlinenode = class(tinlinenode)
  25. procedure pass_2;override;
  26. end;
  27. implementation
  28. uses
  29. globtype,systems,
  30. cutils,verbose,globals,fmodule,
  31. symconst,symbase,symtype,symdef,symsym,aasm,types,
  32. hcodegen,temp_gen,pass_1,pass_2,
  33. cpubase,
  34. nbas,ncon,ncal,ncnv,nld,
  35. cgai386,tgcpu,n386util;
  36. {*****************************************************************************
  37. Helpers
  38. *****************************************************************************}
  39. { reverts the parameter list }
  40. var nb_para : longint;
  41. function reversparameter(p : tnode) : tnode;
  42. var
  43. hp1,hp2 : tnode;
  44. begin
  45. hp1:=nil;
  46. nb_para := 0;
  47. while assigned(p) do
  48. begin
  49. { pull out }
  50. hp2:=p;
  51. p:=tbinarynode(p).right;
  52. inc(nb_para);
  53. { pull in }
  54. tbinarynode(hp2).right:=hp1;
  55. hp1:=hp2;
  56. end;
  57. reversparameter:=hp1;
  58. end;
  59. {*****************************************************************************
  60. TI386INLINENODE
  61. *****************************************************************************}
  62. procedure StoreDirectFuncResult(var dest:tnode);
  63. var
  64. hp : tnode;
  65. htype : ttype;
  66. hreg : tregister;
  67. hregister : tregister;
  68. oldregisterdef : boolean;
  69. op : tasmop;
  70. opsize : topsize;
  71. begin
  72. { Get the accumulator first so it can't be used in the dest }
  73. if (dest.resulttype.def.deftype=orddef) and
  74. not(is_64bitint(dest.resulttype.def)) then
  75. hregister:=getexplicitregister32(accumulator);
  76. { process dest }
  77. SecondPass(dest);
  78. if Codegenerror then
  79. exit;
  80. { store the value }
  81. Case dest.resulttype.def.deftype of
  82. floatdef:
  83. if dest.location.loc=LOC_CFPUREGISTER then
  84. begin
  85. floatstoreops(tfloatdef(dest.resulttype.def).typ,op,opsize);
  86. emit_reg(op,opsize,correct_fpuregister(dest.location.register,fpuvaroffset+1));
  87. end
  88. else
  89. begin
  90. inc(fpuvaroffset);
  91. floatstore(tfloatdef(dest.resulttype.def).typ,dest.location.reference);
  92. { floatstore decrements the fpu var offset }
  93. { but in fact we didn't increment it }
  94. end;
  95. orddef:
  96. begin
  97. if is_64bitint(dest.resulttype.def) then
  98. begin
  99. emit_movq_reg_loc(R_EDX,R_EAX,dest.location);
  100. end
  101. else
  102. begin
  103. Case dest.resulttype.def.size of
  104. 1 : hreg:=regtoreg8(hregister);
  105. 2 : hreg:=regtoreg16(hregister);
  106. 4 : hreg:=hregister;
  107. End;
  108. emit_mov_reg_loc(hreg,dest.location);
  109. If (cs_check_range in aktlocalswitches) and
  110. {no need to rangecheck longints or cardinals on 32bit processors}
  111. not((torddef(dest.resulttype.def).typ = s32bit) and
  112. (torddef(dest.resulttype.def).low = longint($80000000)) and
  113. (torddef(dest.resulttype.def).high = $7fffffff)) and
  114. not((torddef(dest.resulttype.def).typ = u32bit) and
  115. (torddef(dest.resulttype.def).low = 0) and
  116. (torddef(dest.resulttype.def).high = longint($ffffffff))) then
  117. Begin
  118. {do not register this temporary def}
  119. OldRegisterDef := RegisterDef;
  120. RegisterDef := False;
  121. htype.reset;
  122. Case torddef(dest.resulttype.def).typ of
  123. u8bit,u16bit,u32bit:
  124. begin
  125. htype.setdef(torddef.create(u32bit,0,longint($ffffffff)));
  126. hreg:=hregister;
  127. end;
  128. s8bit,s16bit,s32bit:
  129. begin
  130. htype.setdef(torddef.create(s32bit,longint($80000000),$7fffffff));
  131. hreg:=hregister;
  132. end;
  133. end;
  134. { create a fake node }
  135. hp := cnothingnode.create;
  136. hp.location.loc := LOC_REGISTER;
  137. hp.location.register := hreg;
  138. if assigned(htype.def) then
  139. hp.resulttype:=htype
  140. else
  141. hp.resulttype:=dest.resulttype;
  142. { emit the range check }
  143. emitrangecheck(hp,dest.resulttype.def);
  144. if assigned(htype.def) then
  145. htype.def.free;
  146. RegisterDef := OldRegisterDef;
  147. hp.free;
  148. End;
  149. ungetregister(hregister);
  150. end;
  151. End;
  152. else
  153. internalerror(66766766);
  154. end;
  155. { free used registers }
  156. del_locref(dest.location);
  157. end;
  158. procedure ti386inlinenode.pass_2;
  159. const
  160. {tfloattype = (s32real,s64real,s80real,s64bit,f16bit,f32bit);}
  161. { float_name: array[tfloattype] of string[8]=
  162. ('S32REAL','S64REAL','S80REAL','S64BIT','F16BIT','F32BIT'); }
  163. incdecop:array[in_inc_x..in_dec_x] of tasmop=(A_INC,A_DEC);
  164. addsubop:array[in_inc_x..in_dec_x] of tasmop=(A_ADD,A_SUB);
  165. var
  166. aktfile : treference;
  167. ft : tfiletyp;
  168. opsize : topsize;
  169. op,
  170. asmop : tasmop;
  171. pushed : tpushed;
  172. {inc/dec}
  173. addconstant : boolean;
  174. addvalue : longint;
  175. hp : tnode;
  176. procedure handlereadwrite(doread,doln : boolean);
  177. { produces code for READ(LN) and WRITE(LN) }
  178. procedure loadstream;
  179. const
  180. io:array[boolean] of string[6]=('OUTPUT','INPUT');
  181. var
  182. r : preference;
  183. begin
  184. new(r);
  185. reset_reference(r^);
  186. r^.symbol:=newasmsymbol(
  187. 'U_SYSTEM_'+io[doread]);
  188. getexplicitregister32(R_EDI);
  189. emit_ref_reg(A_LEA,S_L,r,R_EDI)
  190. end;
  191. const
  192. rdwrprefix:array[boolean] of string[15]=('FPC_WRITE_TEXT_','FPC_READ_TEXT_');
  193. var
  194. node : tcallparanode;
  195. hp : tnode;
  196. typedtyp,
  197. pararesult : tdef;
  198. orgfloattype : tfloattype;
  199. dummycoll : tparaitem;
  200. iolabel : tasmlabel;
  201. npara : longint;
  202. esireloaded : boolean;
  203. label
  204. myexit;
  205. begin
  206. { here we don't use register calling conventions }
  207. dummycoll:=TParaItem.Create;
  208. dummycoll.register:=R_NO;
  209. { I/O check }
  210. if (cs_check_io in aktlocalswitches) and
  211. not(po_iocheck in aktprocsym.definition.procoptions) then
  212. begin
  213. getaddrlabel(iolabel);
  214. emitlab(iolabel);
  215. end
  216. else
  217. iolabel:=nil;
  218. { for write of real with the length specified }
  219. hp:=nil;
  220. { reserve temporary pointer to data variable }
  221. aktfile.symbol:=nil;
  222. gettempofsizereference(4,aktfile);
  223. { first state text data }
  224. ft:=ft_text;
  225. { and state a parameter ? }
  226. if left=nil then
  227. begin
  228. { the following instructions are for "writeln;" }
  229. loadstream;
  230. { save @aktfile in temporary variable }
  231. emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
  232. ungetregister32(R_EDI);
  233. end
  234. else
  235. begin
  236. { revers paramters }
  237. node:=tcallparanode(reversparameter(left));
  238. left := node;
  239. npara := nb_para;
  240. { calculate data variable }
  241. { is first parameter a file type ? }
  242. if node.left.resulttype.def.deftype=filedef then
  243. begin
  244. ft:=tfiledef(node.left.resulttype.def).filetyp;
  245. if ft=ft_typed then
  246. typedtyp:=tfiledef(node.left.resulttype.def).typedfiletype.def;
  247. secondpass(node.left);
  248. if codegenerror then
  249. goto myexit;
  250. { save reference in temporary variables }
  251. if node.left.location.loc<>LOC_REFERENCE then
  252. begin
  253. CGMessage(cg_e_illegal_expression);
  254. goto myexit;
  255. end;
  256. getexplicitregister32(R_EDI);
  257. emit_ref_reg(A_LEA,S_L,newreference(node.left.location.reference),R_EDI);
  258. del_reference(node.left.location.reference);
  259. { skip to the next parameter }
  260. node:=tcallparanode(node.right);
  261. end
  262. else
  263. begin
  264. { load stdin/stdout stream }
  265. loadstream;
  266. end;
  267. { save @aktfile in temporary variable }
  268. emit_reg_ref(A_MOV,S_L,R_EDI,newreference(aktfile));
  269. ungetregister32(R_EDI);
  270. if doread then
  271. { parameter by READ gives call by reference }
  272. dummycoll.paratyp:=vs_var
  273. { an WRITE Call by "Const" }
  274. else
  275. dummycoll.paratyp:=vs_const;
  276. { because of secondcallparan, which otherwise attaches }
  277. if ft=ft_typed then
  278. { this is to avoid copy of simple const parameters }
  279. {dummycoll.data:=new(pformaldef.create)}
  280. dummycoll.paratype:=cformaltype
  281. else
  282. { I think, this isn't a good solution (FK) }
  283. dummycoll.paratype.reset;
  284. while assigned(node) do
  285. begin
  286. esireloaded:=false;
  287. pushusedregisters(pushed,$ff);
  288. hp:=node;
  289. node:=tcallparanode(node.right);
  290. tcallparanode(hp).right:=nil;
  291. if cpf_is_colon_para in tcallparanode(hp).callparaflags then
  292. CGMessage(parser_e_illegal_colon_qualifier);
  293. { when float is written then we need bestreal to be pushed
  294. convert here else we loose the old float type }
  295. if (not doread) and
  296. (ft<>ft_typed) and
  297. (tcallparanode(hp).left.resulttype.def.deftype=floatdef) then
  298. begin
  299. orgfloattype:=tfloatdef(tcallparanode(hp).left.resulttype.def).typ;
  300. tcallparanode(hp).left:=ctypeconvnode.create(tcallparanode(hp).left,pbestrealtype^);
  301. firstpass(tcallparanode(hp).left);
  302. end;
  303. { when read ord,floats are functions, so they need this
  304. parameter as their destination instead of being pushed }
  305. if doread and
  306. (ft<>ft_typed) and
  307. (tcallparanode(hp).resulttype.def.deftype in [orddef,floatdef]) then
  308. begin
  309. end
  310. else
  311. begin
  312. if ft=ft_typed then
  313. never_copy_const_param:=true;
  314. { reset data type }
  315. dummycoll.paratype.reset;
  316. { create temporary defs for high tree generation }
  317. if doread and (is_shortstring(tcallparanode(hp).resulttype.def)) then
  318. dummycoll.paratype:=openshortstringtype
  319. else
  320. if (is_chararray(tcallparanode(hp).resulttype.def)) then
  321. dummycoll.paratype:=openchararraytype;
  322. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  323. if ft=ft_typed then
  324. never_copy_const_param:=false;
  325. end;
  326. tcallparanode(hp).right:=node;
  327. if codegenerror then
  328. goto myexit;
  329. emit_push_mem(aktfile);
  330. if (ft=ft_typed) then
  331. begin
  332. { OK let's try this }
  333. { first we must only allow the right type }
  334. { we have to call blockread or blockwrite }
  335. { but the real problem is that }
  336. { reset and rewrite should have set }
  337. { the type size }
  338. { as recordsize for that file !!!! }
  339. { how can we make that }
  340. { I think that is only possible by adding }
  341. { reset and rewrite to the inline list a call }
  342. { allways read only one record by element }
  343. push_int(typedtyp.size);
  344. saveregvars($ff);
  345. if doread then
  346. emitcall('FPC_TYPED_READ')
  347. else
  348. emitcall('FPC_TYPED_WRITE');
  349. end
  350. else
  351. begin
  352. { save current position }
  353. pararesult:=tcallparanode(hp).left.resulttype.def;
  354. { handle possible field width }
  355. { of course only for write(ln) }
  356. if not doread then
  357. begin
  358. { handle total width parameter }
  359. if assigned(node) and (cpf_is_colon_para in node.callparaflags) then
  360. begin
  361. hp:=node;
  362. node:=tcallparanode(node.right);
  363. tcallparanode(hp).right:=nil;
  364. dummycoll.paratype.setdef(hp.resulttype.def);
  365. dummycoll.paratyp:=vs_value;
  366. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  367. tcallparanode(hp).right:=node;
  368. if codegenerror then
  369. goto myexit;
  370. end
  371. else
  372. if pararesult.deftype<>floatdef then
  373. push_int(0)
  374. else
  375. push_int(-32767);
  376. { a second colon para for a float ? }
  377. if assigned(node) and (cpf_is_colon_para in node.callparaflags) then
  378. begin
  379. hp:=node;
  380. node:=tcallparanode(node.right);
  381. tcallparanode(hp).right:=nil;
  382. dummycoll.paratype.setdef(hp.resulttype.def);
  383. dummycoll.paratyp:=vs_value;
  384. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  385. tcallparanode(hp).right:=node;
  386. if pararesult.deftype<>floatdef then
  387. CGMessage(parser_e_illegal_colon_qualifier);
  388. if codegenerror then
  389. goto myexit;
  390. end
  391. else
  392. begin
  393. if pararesult.deftype=floatdef then
  394. push_int(-1);
  395. end;
  396. { push also the real type for floats }
  397. if pararesult.deftype=floatdef then
  398. push_int(ord(orgfloattype));
  399. end;
  400. saveregvars($ff);
  401. case pararesult.deftype of
  402. stringdef :
  403. begin
  404. emitcall(rdwrprefix[doread]+tstringdef(pararesult).stringtypname);
  405. end;
  406. pointerdef :
  407. begin
  408. if is_pchar(pararesult) then
  409. emitcall(rdwrprefix[doread]+'PCHAR_AS_POINTER')
  410. end;
  411. arraydef :
  412. begin
  413. if is_chararray(pararesult) then
  414. emitcall(rdwrprefix[doread]+'PCHAR_AS_ARRAY')
  415. end;
  416. floatdef :
  417. begin
  418. emitcall(rdwrprefix[doread]+'FLOAT');
  419. {
  420. if tfloatdef(resulttype.def).typ<>f32bit then
  421. dec(fpuvaroffset);
  422. }
  423. if doread then
  424. begin
  425. maybe_loadself;
  426. esireloaded:=true;
  427. StoreDirectFuncResult(tcallparanode(hp).left);
  428. end;
  429. end;
  430. orddef :
  431. begin
  432. case torddef(pararesult).typ of
  433. s8bit,s16bit,s32bit :
  434. emitcall(rdwrprefix[doread]+'SINT');
  435. u8bit,u16bit,u32bit :
  436. emitcall(rdwrprefix[doread]+'UINT');
  437. uchar :
  438. emitcall(rdwrprefix[doread]+'CHAR');
  439. uwidechar :
  440. emitcall(rdwrprefix[doread]+'WIDECHAR');
  441. s64bit :
  442. emitcall(rdwrprefix[doread]+'INT64');
  443. u64bit :
  444. emitcall(rdwrprefix[doread]+'QWORD');
  445. bool8bit,
  446. bool16bit,
  447. bool32bit :
  448. emitcall(rdwrprefix[doread]+'BOOLEAN');
  449. end;
  450. if doread then
  451. begin
  452. maybe_loadself;
  453. esireloaded:=true;
  454. StoreDirectFuncResult(tcallparanode(hp).left);
  455. end;
  456. end;
  457. end;
  458. end;
  459. { load ESI in methods again }
  460. popusedregisters(pushed);
  461. if not(esireloaded) then
  462. maybe_loadself;
  463. end;
  464. end;
  465. { Insert end of writing for textfiles }
  466. if ft=ft_text then
  467. begin
  468. pushusedregisters(pushed,$ff);
  469. emit_push_mem(aktfile);
  470. saveregvars($ff);
  471. if doread then
  472. begin
  473. if doln then
  474. emitcall('FPC_READLN_END')
  475. else
  476. emitcall('FPC_READ_END');
  477. end
  478. else
  479. begin
  480. if doln then
  481. emitcall('FPC_WRITELN_END')
  482. else
  483. emitcall('FPC_WRITE_END');
  484. end;
  485. popusedregisters(pushed);
  486. maybe_loadself;
  487. end;
  488. { Insert IOCheck if set }
  489. if assigned(iolabel) then
  490. begin
  491. { registers are saved in the procedure }
  492. emit_sym(A_PUSH,S_L,iolabel);
  493. emitcall('FPC_IOCHECK');
  494. end;
  495. { Freeup all used temps }
  496. ungetiftemp(aktfile);
  497. if assigned(left) then
  498. begin
  499. left:=reversparameter(left);
  500. if npara<>nb_para then
  501. CGMessage(cg_f_internal_error_in_secondinline);
  502. hp:=left;
  503. while assigned(hp) do
  504. begin
  505. if assigned(tcallparanode(hp).left) then
  506. if (tcallparanode(hp).left.location.loc in [LOC_MEM,LOC_REFERENCE]) then
  507. ungetiftemp(tcallparanode(hp).left.location.reference);
  508. hp:=tcallparanode(hp).right;
  509. end;
  510. end;
  511. myexit:
  512. dummycoll.free;
  513. end;
  514. procedure handle_str;
  515. var
  516. hp,
  517. node : tcallparanode;
  518. dummycoll : tparaitem;
  519. //hp2 : tstringconstnode;
  520. is_real : boolean;
  521. realtype : tfloattype;
  522. procedureprefix : string;
  523. label
  524. myexit;
  525. begin
  526. dummycoll:=TParaItem.Create;
  527. dummycoll.register:=R_NO;
  528. pushusedregisters(pushed,$ff);
  529. node:=tcallparanode(left);
  530. is_real:=false;
  531. while assigned(node.right) do node:=tcallparanode(node.right);
  532. { if a real parameter somewhere then call REALSTR }
  533. if (node.left.resulttype.def.deftype=floatdef) then
  534. begin
  535. is_real:=true;
  536. realtype:=tfloatdef(node.left.resulttype.def).typ;
  537. end;
  538. node:=tcallparanode(left);
  539. { we have at least two args }
  540. { with at max 2 colon_para in between }
  541. { string arg }
  542. hp:=node;
  543. node:=tcallparanode(node.right);
  544. hp.right:=nil;
  545. dummycoll.paratyp:=vs_var;
  546. if is_shortstring(hp.resulttype.def) then
  547. dummycoll.paratype:=openshortstringtype
  548. else
  549. dummycoll.paratype:=hp.resulttype;
  550. procedureprefix:='FPC_'+tstringdef(hp.resulttype.def).stringtypname+'_';
  551. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  552. if codegenerror then
  553. goto myexit;
  554. dummycoll.paratyp:=vs_const;
  555. left.free;
  556. left:=nil;
  557. { second arg }
  558. hp:=node;
  559. node:=tcallparanode(node.right);
  560. hp.right:=nil;
  561. { if real push real type }
  562. if is_real then
  563. push_int(ord(realtype));
  564. { frac para }
  565. if (cpf_is_colon_para in hp.callparaflags) and assigned(node) and
  566. (cpf_is_colon_para in node.callparaflags) then
  567. begin
  568. dummycoll.paratype.setdef(hp.resulttype.def);
  569. dummycoll.paratyp:=vs_value;
  570. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  571. if codegenerror then
  572. goto myexit;
  573. hp.free;
  574. hp:=node;
  575. node:=tcallparanode(node.right);
  576. hp.right:=nil;
  577. end
  578. else
  579. if is_real then
  580. push_int(-1);
  581. { third arg, length only if is_real }
  582. if (cpf_is_colon_para in hp.callparaflags) then
  583. begin
  584. dummycoll.paratype.setdef(hp.resulttype.def);
  585. dummycoll.paratyp:=vs_value;
  586. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  587. if codegenerror then
  588. goto myexit;
  589. hp.free;
  590. hp:=node;
  591. node:=tcallparanode(node.right);
  592. hp.right:=nil;
  593. end
  594. else
  595. if is_real then
  596. push_int(-32767)
  597. else
  598. push_int(-1);
  599. { Convert float to bestreal }
  600. if is_real then
  601. begin
  602. hp.left:=ctypeconvnode.create(hp.left,pbestrealtype^);
  603. firstpass(hp.left);
  604. end;
  605. { last arg longint or real }
  606. dummycoll.paratype.setdef(hp.resulttype.def);
  607. dummycoll.paratyp:=vs_value;
  608. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  609. if codegenerror then
  610. goto myexit;
  611. saveregvars($ff);
  612. if is_real then
  613. emitcall(procedureprefix+'FLOAT')
  614. else
  615. case torddef(hp.resulttype.def).typ of
  616. u32bit:
  617. emitcall(procedureprefix+'CARDINAL');
  618. u64bit:
  619. emitcall(procedureprefix+'QWORD');
  620. s64bit:
  621. emitcall(procedureprefix+'INT64');
  622. else
  623. emitcall(procedureprefix+'LONGINT');
  624. end;
  625. popusedregisters(pushed);
  626. hp.free;
  627. myexit:
  628. dummycoll.free;
  629. end;
  630. Procedure Handle_Val;
  631. var
  632. hp,node,
  633. code_para, dest_para : tcallparanode;
  634. hreg,hreg2: TRegister;
  635. hdef: torddef;
  636. procedureprefix : string;
  637. hr, hr2: TReference;
  638. dummycoll : tparaitem;
  639. has_code, has_32bit_code, oldregisterdef: boolean;
  640. r : preference;
  641. label
  642. myexit;
  643. begin
  644. dummycoll:=TParaItem.Create;
  645. dummycoll.register:=R_NO;
  646. node:=tcallparanode(left);
  647. hp:=node;
  648. node:=tcallparanode(node.right);
  649. hp.right:=nil;
  650. {if we have 3 parameters, we have a code parameter}
  651. has_code := Assigned(node.right);
  652. has_32bit_code := false;
  653. reset_reference(hr);
  654. hreg := R_NO;
  655. If has_code then
  656. Begin
  657. {code is an orddef, that's checked in tcinl}
  658. code_para := hp;
  659. hp := node;
  660. node := tcallparanode(node.right);
  661. hp.right := nil;
  662. has_32bit_code := (torddef(tcallparanode(code_para).left.resulttype.def).typ in [u32bit,s32bit]);
  663. End;
  664. {hp = destination now, save for later use}
  665. dest_para := hp;
  666. {if EAX is already in use, it's a register variable. Since we don't
  667. need another register besides EAX, release the one we got}
  668. If hreg <> R_EAX Then ungetregister32(hreg);
  669. {load and push the address of the destination}
  670. dummycoll.paratyp:=vs_var;
  671. dummycoll.paratype.setdef(dest_para.resulttype.def);
  672. dest_para.secondcallparan(dummycoll,false,false,false,0,0);
  673. if codegenerror then
  674. goto myexit;
  675. {save the regvars}
  676. pushusedregisters(pushed,$ff);
  677. {now that we've already pushed the addres of dest_para.left on the
  678. stack, we can put the real parameters on the stack}
  679. If has_32bit_code Then
  680. Begin
  681. dummycoll.paratyp:=vs_var;
  682. dummycoll.paratype.setdef(code_para.resulttype.def);
  683. code_para.secondcallparan(dummycoll,false,false,false,0,0);
  684. if codegenerror then
  685. goto myexit;
  686. code_para.free;
  687. End
  688. Else
  689. Begin
  690. {only 32bit code parameter is supported, so fake one}
  691. GetTempOfSizeReference(4,hr);
  692. emitpushreferenceaddr(hr);
  693. End;
  694. {node = first parameter = string}
  695. dummycoll.paratyp:=vs_const;
  696. dummycoll.paratype.setdef(node.resulttype.def);
  697. node.secondcallparan(dummycoll,false,false,false,0,0);
  698. if codegenerror then
  699. goto myexit;
  700. Case dest_para.resulttype.def.deftype of
  701. floatdef:
  702. begin
  703. procedureprefix := 'FPC_VAL_REAL_';
  704. inc(fpuvaroffset);
  705. end;
  706. orddef:
  707. if is_64bitint(dest_para.resulttype.def) then
  708. begin
  709. if is_signed(dest_para.resulttype.def) then
  710. procedureprefix := 'FPC_VAL_INT64_'
  711. else
  712. procedureprefix := 'FPC_VAL_QWORD_';
  713. end
  714. else
  715. begin
  716. if is_signed(dest_para.resulttype.def) then
  717. begin
  718. {if we are converting to a signed number, we have to include the
  719. size of the destination, so the Val function can extend the sign
  720. of the result to allow proper range checking}
  721. emit_const(A_PUSH,S_L,dest_para.resulttype.def.size);
  722. procedureprefix := 'FPC_VAL_SINT_'
  723. end
  724. else
  725. procedureprefix := 'FPC_VAL_UINT_';
  726. end;
  727. End;
  728. saveregvars($ff);
  729. emitcall(procedureprefix+tstringdef(node.resulttype.def).stringtypname);
  730. { before disposing node we need to ungettemp !! PM }
  731. if node.left.location.loc in [LOC_REFERENCE,LOC_MEM] then
  732. ungetiftemp(node.left.location.reference);
  733. node.free;
  734. left := nil;
  735. {reload esi in case the dest_para/code_para is a class variable or so}
  736. maybe_loadself;
  737. If (dest_para.resulttype.def.deftype = orddef) Then
  738. Begin
  739. {store the result in a safe place, because EAX may be used by a
  740. register variable}
  741. hreg := getexplicitregister32(R_EAX);
  742. emit_reg_reg(A_MOV,S_L,R_EAX,hreg);
  743. if is_64bitint(dest_para.resulttype.def) then
  744. begin
  745. hreg2:=getexplicitregister32(R_EDX);
  746. emit_reg_reg(A_MOV,S_L,R_EDX,hreg2);
  747. end;
  748. {as of now, hreg now holds the location of the result, if it was
  749. integer}
  750. End;
  751. { restore the register vars}
  752. popusedregisters(pushed);
  753. If has_code and Not(has_32bit_code) Then
  754. {only 16bit code is possible}
  755. Begin
  756. {load the address of the code parameter}
  757. secondpass(code_para.left);
  758. {move the code to its destination}
  759. getexplicitregister32(R_EDI);
  760. emit_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI);
  761. emit_mov_reg_loc(R_DI,code_para.left.location);
  762. ungetregister32(R_EDI);
  763. code_para.free;
  764. End;
  765. {restore the address of the result}
  766. getexplicitregister32(R_EDI);
  767. emit_reg(A_POP,S_L,R_EDI);
  768. {set up hr2 to a refernce with EDI as base register}
  769. reset_reference(hr2);
  770. hr2.base := R_EDI;
  771. {save the function result in the destination variable}
  772. Case dest_para.left.resulttype.def.deftype of
  773. floatdef:
  774. floatstore(tfloatdef(dest_para.left.resulttype.def).typ, hr2);
  775. orddef:
  776. Case torddef(dest_para.left.resulttype.def).typ of
  777. u8bit,s8bit:
  778. emit_reg_ref(A_MOV, S_B,
  779. RegToReg8(hreg),newreference(hr2));
  780. u16bit,s16bit:
  781. emit_reg_ref(A_MOV, S_W,
  782. RegToReg16(hreg),newreference(hr2));
  783. u32bit,s32bit:
  784. emit_reg_ref(A_MOV, S_L,
  785. hreg,newreference(hr2));
  786. u64bit,s64bit:
  787. begin
  788. emit_reg_ref(A_MOV, S_L,
  789. hreg,newreference(hr2));
  790. r:=newreference(hr2);
  791. inc(r^.offset,4);
  792. emit_reg_ref(A_MOV, S_L,
  793. hreg2,r);
  794. end;
  795. End;
  796. End;
  797. ungetregister32(R_EDI);
  798. If (cs_check_range in aktlocalswitches) and
  799. (dest_para.left.resulttype.def.deftype = orddef) and
  800. (not(is_64bitint(dest_para.left.resulttype.def))) and
  801. {the following has to be changed to 64bit checking, once Val
  802. returns 64 bit values (unless a special Val function is created
  803. for that)}
  804. {no need to rangecheck longints or cardinals on 32bit processors}
  805. not((torddef(dest_para.left.resulttype.def).typ = s32bit) and
  806. (torddef(dest_para.left.resulttype.def).low = longint($80000000)) and
  807. (torddef(dest_para.left.resulttype.def).high = $7fffffff)) and
  808. not((torddef(dest_para.left.resulttype.def).typ = u32bit) and
  809. (torddef(dest_para.left.resulttype.def).low = 0) and
  810. (torddef(dest_para.left.resulttype.def).high = longint($ffffffff))) then
  811. Begin
  812. hp:=tcallparanode(dest_para.left.getcopy);
  813. hp.location.loc := LOC_REGISTER;
  814. hp.location.register := hreg;
  815. {do not register this temporary def}
  816. OldRegisterDef := RegisterDef;
  817. RegisterDef := False;
  818. Case torddef(dest_para.left.resulttype.def).typ of
  819. u8bit,u16bit,u32bit: hdef:=torddef.create(u32bit,0,longint($ffffffff));
  820. s8bit,s16bit,s32bit: hdef:=torddef.create(s32bit,longint($80000000),$7fffffff);
  821. end;
  822. hp.resulttype.def := hdef;
  823. emitrangecheck(hp,dest_para.left.resulttype.def);
  824. hp.right := nil;
  825. hp.resulttype.def.free;
  826. RegisterDef := OldRegisterDef;
  827. hp.free;
  828. End;
  829. {dest_para.right is already nil}
  830. dest_para.free;
  831. UnGetIfTemp(hr);
  832. myexit:
  833. dummycoll.free;
  834. end;
  835. var
  836. r : preference;
  837. //hp : tcallparanode;
  838. hp2 : tstringconstnode;
  839. dummycoll : tparaitem;
  840. l : longint;
  841. ispushed : boolean;
  842. hregister : tregister;
  843. lengthlab,
  844. otlabel,oflabel{,l1} : tasmlabel;
  845. oldpushedparasize : longint;
  846. def : tdef;
  847. hr,hr2 : treference;
  848. begin
  849. { save & reset pushedparasize }
  850. oldpushedparasize:=pushedparasize;
  851. pushedparasize:=0;
  852. case inlinenumber of
  853. in_assert_x_y:
  854. begin
  855. { the node should be removed in the firstpass }
  856. if not (cs_do_assertion in aktlocalswitches) then
  857. internalerror(7123458);
  858. otlabel:=truelabel;
  859. oflabel:=falselabel;
  860. getlabel(truelabel);
  861. getlabel(falselabel);
  862. secondpass(tcallparanode(left).left);
  863. maketojumpbool(tcallparanode(left).left);
  864. emitlab(falselabel);
  865. { erroraddr }
  866. emit_reg(A_PUSH,S_L,R_EBP);
  867. { lineno }
  868. emit_const(A_PUSH,S_L,aktfilepos.line);
  869. { filename string }
  870. hp2:=cstringconstnode.createstr(current_module.sourcefiles.get_file_name(aktfilepos.fileindex),st_shortstring);
  871. firstpass(hp2);
  872. secondpass(hp2);
  873. if codegenerror then
  874. exit;
  875. emitpushreferenceaddr(hp2.location.reference);
  876. hp2.free;
  877. { push msg }
  878. secondpass(tcallparanode(tcallparanode(left).right).left);
  879. emitpushreferenceaddr(tcallparanode(tcallparanode(left).right).left.location.reference);
  880. { call }
  881. emitcall('FPC_ASSERT');
  882. emitlab(truelabel);
  883. truelabel:=otlabel;
  884. falselabel:=oflabel;
  885. end;
  886. in_lo_word,
  887. in_hi_word :
  888. begin
  889. secondpass(left);
  890. location.loc:=LOC_REGISTER;
  891. if left.location.loc<>LOC_REGISTER then
  892. begin
  893. if left.location.loc=LOC_CREGISTER then
  894. begin
  895. location.register:=reg32toreg16(getregister32);
  896. emit_reg_reg(A_MOV,S_W,left.location.register,
  897. location.register);
  898. end
  899. else
  900. begin
  901. del_reference(left.location.reference);
  902. location.register:=reg32toreg16(getregister32);
  903. emit_ref_reg(A_MOV,S_W,newreference(left.location.reference),
  904. location.register);
  905. end;
  906. end
  907. else location.register:=left.location.register;
  908. if inlinenumber=in_hi_word then
  909. emit_const_reg(A_SHR,S_W,8,location.register);
  910. location.register:=reg16toreg8(location.register);
  911. end;
  912. in_sizeof_x,
  913. in_typeof_x :
  914. begin
  915. { for both cases load vmt }
  916. if left.nodetype=typen then
  917. begin
  918. location.register:=getregister32;
  919. emit_sym_ofs_reg(A_MOV,
  920. S_L,newasmsymbol(tobjectdef(left.resulttype.def).vmt_mangledname),0,
  921. location.register);
  922. end
  923. else
  924. begin
  925. secondpass(left);
  926. del_reference(left.location.reference);
  927. location.loc:=LOC_REGISTER;
  928. location.register:=getregister32;
  929. { load VMT pointer }
  930. inc(left.location.reference.offset,
  931. tobjectdef(left.resulttype.def).vmt_offset);
  932. emit_ref_reg(A_MOV,S_L,
  933. newreference(left.location.reference),
  934. location.register);
  935. end;
  936. { in sizeof load size }
  937. if inlinenumber=in_sizeof_x then
  938. begin
  939. new(r);
  940. reset_reference(r^);
  941. r^.base:=location.register;
  942. emit_ref_reg(A_MOV,S_L,r,
  943. location.register);
  944. end;
  945. end;
  946. in_lo_long,
  947. in_hi_long :
  948. begin
  949. secondpass(left);
  950. location.loc:=LOC_REGISTER;
  951. if left.location.loc<>LOC_REGISTER then
  952. begin
  953. if left.location.loc=LOC_CREGISTER then
  954. begin
  955. location.register:=getregister32;
  956. emit_reg_reg(A_MOV,S_L,left.location.register,
  957. location.register);
  958. end
  959. else
  960. begin
  961. del_reference(left.location.reference);
  962. location.register:=getregister32;
  963. emit_ref_reg(A_MOV,S_L,newreference(left.location.reference),
  964. location.register);
  965. end;
  966. end
  967. else location.register:=left.location.register;
  968. if inlinenumber=in_hi_long then
  969. emit_const_reg(A_SHR,S_L,16,location.register);
  970. location.register:=reg32toreg16(location.register);
  971. end;
  972. in_lo_qword,
  973. in_hi_qword:
  974. begin
  975. secondpass(left);
  976. location.loc:=LOC_REGISTER;
  977. case left.location.loc of
  978. LOC_CREGISTER:
  979. begin
  980. location.register:=getregister32;
  981. if inlinenumber=in_hi_qword then
  982. emit_reg_reg(A_MOV,S_L,left.location.registerhigh,
  983. location.register)
  984. else
  985. emit_reg_reg(A_MOV,S_L,left.location.registerlow,
  986. location.register)
  987. end;
  988. LOC_MEM,LOC_REFERENCE:
  989. begin
  990. del_reference(left.location.reference);
  991. location.register:=getregister32;
  992. r:=newreference(left.location.reference);
  993. if inlinenumber=in_hi_qword then
  994. inc(r^.offset,4);
  995. emit_ref_reg(A_MOV,S_L,
  996. r,location.register);
  997. end;
  998. LOC_REGISTER:
  999. begin
  1000. if inlinenumber=in_hi_qword then
  1001. begin
  1002. location.register:=left.location.registerhigh;
  1003. ungetregister32(left.location.registerlow);
  1004. end
  1005. else
  1006. begin
  1007. location.register:=left.location.registerlow;
  1008. ungetregister32(left.location.registerhigh);
  1009. end;
  1010. end;
  1011. end;
  1012. end;
  1013. in_length_x :
  1014. begin
  1015. secondpass(left);
  1016. set_location(location,left.location);
  1017. { length in ansi strings is at offset -8 }
  1018. if is_ansistring(left.resulttype.def) or
  1019. is_widestring(left.resulttype.def) then
  1020. begin
  1021. if left.location.loc<>LOC_REGISTER then
  1022. begin
  1023. del_location(left.location);
  1024. hregister:=getregister32;
  1025. emit_mov_loc_reg(left.location,hregister);
  1026. end
  1027. else
  1028. hregister:=left.location.register;
  1029. reset_reference(hr);
  1030. hr.base:=hregister;
  1031. hr.offset:=-8;
  1032. getlabel(lengthlab);
  1033. emit_reg_reg(A_OR,S_L,hregister,hregister);
  1034. emitjmp(C_Z,lengthlab);
  1035. emit_ref_reg(A_MOV,S_L,newreference(hr),hregister);
  1036. emitlab(lengthlab);
  1037. location.loc:=LOC_REGISTER;
  1038. location.register:=hregister;
  1039. end;
  1040. end;
  1041. in_pred_x,
  1042. in_succ_x:
  1043. begin
  1044. secondpass(left);
  1045. if not (cs_check_overflow in aktlocalswitches) then
  1046. if inlinenumber=in_pred_x then
  1047. asmop:=A_DEC
  1048. else
  1049. asmop:=A_INC
  1050. else
  1051. if inlinenumber=in_pred_x then
  1052. asmop:=A_SUB
  1053. else
  1054. asmop:=A_ADD;
  1055. case resulttype.def.size of
  1056. 8 : opsize:=S_L;
  1057. 4 : opsize:=S_L;
  1058. 2 : opsize:=S_W;
  1059. 1 : opsize:=S_B;
  1060. else
  1061. internalerror(10080);
  1062. end;
  1063. location.loc:=LOC_REGISTER;
  1064. if resulttype.def.size=8 then
  1065. begin
  1066. if left.location.loc<>LOC_REGISTER then
  1067. begin
  1068. if left.location.loc=LOC_CREGISTER then
  1069. begin
  1070. location.registerlow:=getregister32;
  1071. location.registerhigh:=getregister32;
  1072. emit_reg_reg(A_MOV,opsize,left.location.registerlow,
  1073. location.registerlow);
  1074. emit_reg_reg(A_MOV,opsize,left.location.registerhigh,
  1075. location.registerhigh);
  1076. end
  1077. else
  1078. begin
  1079. del_reference(left.location.reference);
  1080. location.registerlow:=getregister32;
  1081. location.registerhigh:=getregister32;
  1082. emit_ref_reg(A_MOV,opsize,newreference(left.location.reference),
  1083. location.registerlow);
  1084. r:=newreference(left.location.reference);
  1085. inc(r^.offset,4);
  1086. emit_ref_reg(A_MOV,opsize,r,
  1087. location.registerhigh);
  1088. end;
  1089. end
  1090. else
  1091. begin
  1092. location.registerhigh:=left.location.registerhigh;
  1093. location.registerlow:=left.location.registerlow;
  1094. end;
  1095. if inlinenumber=in_succ_x then
  1096. begin
  1097. emit_const_reg(A_ADD,opsize,1,
  1098. location.registerlow);
  1099. emit_const_reg(A_ADC,opsize,0,
  1100. location.registerhigh);
  1101. end
  1102. else
  1103. begin
  1104. emit_const_reg(A_SUB,opsize,1,
  1105. location.registerlow);
  1106. emit_const_reg(A_SBB,opsize,0,
  1107. location.registerhigh);
  1108. end;
  1109. end
  1110. else
  1111. begin
  1112. if left.location.loc<>LOC_REGISTER then
  1113. begin
  1114. { first, we've to release the source location ... }
  1115. if left.location.loc in [LOC_MEM,LOC_REFERENCE] then
  1116. del_reference(left.location.reference);
  1117. location.register:=getregister32;
  1118. if (resulttype.def.size=2) then
  1119. location.register:=reg32toreg16(location.register);
  1120. if (resulttype.def.size=1) then
  1121. location.register:=reg32toreg8(location.register);
  1122. if left.location.loc=LOC_CREGISTER then
  1123. emit_reg_reg(A_MOV,opsize,left.location.register,
  1124. location.register)
  1125. else
  1126. if left.location.loc=LOC_FLAGS then
  1127. emit_flag2reg(left.location.resflags,location.register)
  1128. else
  1129. emit_ref_reg(A_MOV,opsize,newreference(left.location.reference),
  1130. location.register);
  1131. end
  1132. else location.register:=left.location.register;
  1133. if not (cs_check_overflow in aktlocalswitches) then
  1134. emit_reg(asmop,opsize,
  1135. location.register)
  1136. else
  1137. emit_const_reg(asmop,opsize,1,
  1138. location.register);
  1139. end;
  1140. emitoverflowcheck(self);
  1141. emitrangecheck(self,resulttype.def);
  1142. end;
  1143. in_dec_x,
  1144. in_inc_x :
  1145. begin
  1146. { set defaults }
  1147. addvalue:=1;
  1148. addconstant:=true;
  1149. { load first parameter, must be a reference }
  1150. secondpass(tcallparanode(left).left);
  1151. case tcallparanode(left).left.resulttype.def.deftype of
  1152. orddef,
  1153. enumdef : begin
  1154. case tcallparanode(left).left.resulttype.def.size of
  1155. 1 : opsize:=S_B;
  1156. 2 : opsize:=S_W;
  1157. 4 : opsize:=S_L;
  1158. 8 : opsize:=S_L;
  1159. end;
  1160. end;
  1161. pointerdef : begin
  1162. opsize:=S_L;
  1163. if is_void(tpointerdef(tcallparanode(left).left.resulttype.def).pointertype.def) then
  1164. addvalue:=1
  1165. else
  1166. addvalue:=tpointerdef(tcallparanode(left).left.resulttype.def).pointertype.def.size;
  1167. end;
  1168. else
  1169. internalerror(10081);
  1170. end;
  1171. { second argument specified?, must be a s32bit in register }
  1172. if assigned(tcallparanode(left).right) then
  1173. begin
  1174. ispushed:=maybe_push(tcallparanode(tcallparanode(left).right).left.registers32,
  1175. tcallparanode(left).left,false);
  1176. secondpass(tcallparanode(tcallparanode(left).right).left);
  1177. if ispushed then
  1178. restore(tcallparanode(left).left,false);
  1179. { when constant, just multiply the addvalue }
  1180. if is_constintnode(tcallparanode(tcallparanode(left).right).left) then
  1181. addvalue:=addvalue*get_ordinal_value(tcallparanode(tcallparanode(left).right).left)
  1182. else
  1183. begin
  1184. case tcallparanode(tcallparanode(left).right).left.location.loc of
  1185. LOC_REGISTER,
  1186. LOC_CREGISTER : hregister:=tcallparanode(tcallparanode(left).right).left.location.register;
  1187. LOC_MEM,
  1188. LOC_REFERENCE : begin
  1189. del_reference(tcallparanode(tcallparanode(left).right).left.location.reference);
  1190. hregister:=getregister32;
  1191. emit_ref_reg(A_MOV,S_L,
  1192. newreference(tcallparanode(tcallparanode(left).right).left.location.reference),hregister);
  1193. end;
  1194. else
  1195. internalerror(10082);
  1196. end;
  1197. { insert multiply with addvalue if its >1 }
  1198. if addvalue>1 then
  1199. emit_const_reg(A_IMUL,opsize,
  1200. addvalue,hregister);
  1201. addconstant:=false;
  1202. end;
  1203. end;
  1204. { write the add instruction }
  1205. if addconstant then
  1206. begin
  1207. if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then
  1208. begin
  1209. if tcallparanode(left).left.location.loc=LOC_CREGISTER then
  1210. emit_reg(incdecop[inlinenumber],opsize,
  1211. tcallparanode(left).left.location.register)
  1212. else
  1213. emit_ref(incdecop[inlinenumber],opsize,
  1214. newreference(tcallparanode(left).left.location.reference))
  1215. end
  1216. else
  1217. begin
  1218. if tcallparanode(left).left.location.loc=LOC_CREGISTER then
  1219. emit_const_reg(addsubop[inlinenumber],opsize,
  1220. addvalue,tcallparanode(left).left.location.register)
  1221. else
  1222. emit_const_ref(addsubop[inlinenumber],opsize,
  1223. addvalue,newreference(tcallparanode(left).left.location.reference));
  1224. end
  1225. end
  1226. else
  1227. begin
  1228. { BUG HERE : detected with nasm :
  1229. hregister is allways 32 bit
  1230. it should be converted to 16 or 8 bit depending on op_size PM }
  1231. { still not perfect :
  1232. if hregister is already a 16 bit reg ?? PM }
  1233. { makeregXX is the solution (FK) }
  1234. case opsize of
  1235. S_B : hregister:=makereg8(hregister);
  1236. S_W : hregister:=makereg16(hregister);
  1237. end;
  1238. if tcallparanode(left).left.location.loc=LOC_CREGISTER then
  1239. emit_reg_reg(addsubop[inlinenumber],opsize,
  1240. hregister,tcallparanode(left).left.location.register)
  1241. else
  1242. emit_reg_ref(addsubop[inlinenumber],opsize,
  1243. hregister,newreference(tcallparanode(left).left.location.reference));
  1244. case opsize of
  1245. S_B : hregister:=reg8toreg32(hregister);
  1246. S_W : hregister:=reg16toreg32(hregister);
  1247. end;
  1248. ungetregister32(hregister);
  1249. end;
  1250. emitoverflowcheck(tcallparanode(left).left);
  1251. emitrangecheck(tcallparanode(left).left,tcallparanode(left).left.resulttype.def);
  1252. end;
  1253. in_typeinfo_x:
  1254. begin
  1255. tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).generate_rtti;
  1256. location.register:=getregister32;
  1257. new(r);
  1258. reset_reference(r^);
  1259. r^.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).rtti_label;
  1260. emit_ref_reg(A_LEA,S_L,r,location.register);
  1261. end;
  1262. in_finalize_x:
  1263. begin
  1264. pushusedregisters(pushed,$ff);
  1265. { force rtti generation }
  1266. tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).generate_rtti;
  1267. { if a count is passed, push size, typeinfo and count }
  1268. if assigned(tcallparanode(left).right) then
  1269. begin
  1270. secondpass(tcallparanode(tcallparanode(left).right).left);
  1271. push_int(tcallparanode(left).left.resulttype.def.size);
  1272. if codegenerror then
  1273. exit;
  1274. emit_push_loc(tcallparanode(tcallparanode(left).right).left.location);
  1275. end;
  1276. { generate a reference }
  1277. reset_reference(hr);
  1278. hr.symbol:=tstoreddef(ttypenode(tcallparanode(left).left).resulttype.def).rtti_label;
  1279. emitpushreferenceaddr(hr);
  1280. { data to finalize }
  1281. secondpass(tcallparanode(left).left);
  1282. if codegenerror then
  1283. exit;
  1284. emitpushreferenceaddr(tcallparanode(left).left.location.reference);
  1285. saveregvars($ff);
  1286. if assigned(tcallparanode(left).right) then
  1287. emitcall('FPC_FINALIZEARRAY')
  1288. else
  1289. emitcall('FPC_FINALIZE');
  1290. popusedregisters(pushed);
  1291. end;
  1292. in_assigned_x :
  1293. begin
  1294. secondpass(tcallparanode(left).left);
  1295. location.loc:=LOC_FLAGS;
  1296. if (tcallparanode(left).left.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  1297. begin
  1298. emit_reg_reg(A_OR,S_L,
  1299. tcallparanode(left).left.location.register,
  1300. tcallparanode(left).left.location.register);
  1301. ungetregister32(tcallparanode(left).left.location.register);
  1302. end
  1303. else
  1304. begin
  1305. emit_const_ref(A_CMP,S_L,0,
  1306. newreference(tcallparanode(left).left.location.reference));
  1307. del_reference(tcallparanode(left).left.location.reference);
  1308. end;
  1309. location.resflags:=F_NE;
  1310. end;
  1311. in_reset_typedfile,in_rewrite_typedfile :
  1312. begin
  1313. pushusedregisters(pushed,$ff);
  1314. emit_const(A_PUSH,S_L,tfiledef(left.resulttype.def).typedfiletype.def.size);
  1315. secondpass(left);
  1316. emitpushreferenceaddr(left.location.reference);
  1317. saveregvars($ff);
  1318. if inlinenumber=in_reset_typedfile then
  1319. emitcall('FPC_RESET_TYPED')
  1320. else
  1321. emitcall('FPC_REWRITE_TYPED');
  1322. popusedregisters(pushed);
  1323. end;
  1324. in_setlength_x:
  1325. begin
  1326. pushusedregisters(pushed,$ff);
  1327. l:=0;
  1328. { push dimensions }
  1329. hp:=left;
  1330. while assigned(tcallparanode(hp).right) do
  1331. begin
  1332. inc(l);
  1333. hp:=tcallparanode(hp).right;
  1334. end;
  1335. def:=tcallparanode(hp).left.resulttype.def;
  1336. hp:=left;
  1337. if is_dynamic_array(def) then
  1338. begin
  1339. { get temp. space }
  1340. gettempofsizereference(l*4,hr);
  1341. { keep data start }
  1342. hr2:=hr;
  1343. { copy dimensions }
  1344. hp:=left;
  1345. while assigned(tcallparanode(hp).right) do
  1346. begin
  1347. secondpass(tcallparanode(hp).left);
  1348. emit_mov_loc_ref(tcallparanode(hp).left.location,hr,
  1349. S_L,true);
  1350. inc(hr.offset,4);
  1351. hp:=tcallparanode(hp).right;
  1352. end;
  1353. end
  1354. else
  1355. begin
  1356. secondpass(tcallparanode(hp).left);
  1357. emit_push_loc(tcallparanode(hp).left.location);
  1358. hp:=tcallparanode(hp).right;
  1359. end;
  1360. { handle shortstrings separately since the hightree must be }
  1361. { pushed too (JM) }
  1362. if not(is_dynamic_array(def)) and
  1363. (tstringdef(def).string_typ = st_shortstring) then
  1364. begin
  1365. dummycoll:=TParaItem.Create;
  1366. dummycoll.paratyp:=vs_var;
  1367. dummycoll.paratype:=openshortstringtype;
  1368. tcallparanode(hp).secondcallparan(dummycoll,false,false,false,0,0);
  1369. dummycoll.free;
  1370. if codegenerror then
  1371. exit;
  1372. end
  1373. else secondpass(tcallparanode(hp).left);
  1374. if is_dynamic_array(def) then
  1375. begin
  1376. emitpushreferenceaddr(hr2);
  1377. push_int(l);
  1378. reset_reference(hr2);
  1379. hr2.symbol:=tstoreddef(def).get_inittable_label;
  1380. emitpushreferenceaddr(hr2);
  1381. emitpushreferenceaddr(tcallparanode(hp).left.location.reference);
  1382. saveregvars($ff);
  1383. emitcall('FPC_DYNARR_SETLENGTH');
  1384. ungetiftemp(hr);
  1385. end
  1386. else
  1387. { must be string }
  1388. begin
  1389. case tstringdef(def).string_typ of
  1390. st_widestring:
  1391. begin
  1392. emitpushreferenceaddr(tcallparanode(hp).left.location.reference);
  1393. saveregvars($ff);
  1394. emitcall('FPC_WIDESTR_SETLENGTH');
  1395. end;
  1396. st_ansistring:
  1397. begin
  1398. emitpushreferenceaddr(tcallparanode(hp).left.location.reference);
  1399. saveregvars($ff);
  1400. emitcall('FPC_ANSISTR_SETLENGTH');
  1401. end;
  1402. st_shortstring:
  1403. begin
  1404. saveregvars($ff);
  1405. emitcall('FPC_SHORTSTR_SETLENGTH');
  1406. end;
  1407. end;
  1408. end;
  1409. popusedregisters(pushed);
  1410. end;
  1411. in_write_x :
  1412. handlereadwrite(false,false);
  1413. in_writeln_x :
  1414. handlereadwrite(false,true);
  1415. in_read_x :
  1416. handlereadwrite(true,false);
  1417. in_readln_x :
  1418. handlereadwrite(true,true);
  1419. in_str_x_string :
  1420. begin
  1421. handle_str;
  1422. maybe_loadself;
  1423. end;
  1424. in_val_x :
  1425. Begin
  1426. handle_val;
  1427. End;
  1428. in_include_x_y,
  1429. in_exclude_x_y:
  1430. begin
  1431. secondpass(tcallparanode(left).left);
  1432. if tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn then
  1433. begin
  1434. { calculate bit position }
  1435. l:=1 shl (tordconstnode(tcallparanode(tcallparanode(left).right).left).value mod 32);
  1436. { determine operator }
  1437. if inlinenumber=in_include_x_y then
  1438. asmop:=A_OR
  1439. else
  1440. begin
  1441. asmop:=A_AND;
  1442. l:=not(l);
  1443. end;
  1444. if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
  1445. begin
  1446. inc(tcallparanode(left).left.location.reference.offset,
  1447. (tordconstnode(tcallparanode(tcallparanode(left).right).left).value div 32)*4);
  1448. emit_const_ref(asmop,S_L,
  1449. l,newreference(tcallparanode(left).left.location.reference));
  1450. del_reference(tcallparanode(left).left.location.reference);
  1451. end
  1452. else
  1453. { LOC_CREGISTER }
  1454. begin
  1455. secondpass(tcallparanode(left).left);
  1456. emit_const_reg(asmop,S_L,
  1457. l,tcallparanode(left).left.location.register);
  1458. end;
  1459. end
  1460. else
  1461. begin
  1462. { generate code for the element to set }
  1463. ispushed:=maybe_push(tcallparanode(tcallparanode(left).right).left.registers32,
  1464. tcallparanode(left).left,false);
  1465. secondpass(tcallparanode(tcallparanode(left).right).left);
  1466. if ispushed then
  1467. restore(tcallparanode(left).left,false);
  1468. { determine asm operator }
  1469. if inlinenumber=in_include_x_y then
  1470. asmop:=A_BTS
  1471. else
  1472. asmop:=A_BTR;
  1473. if tsetdef(left.resulttype.def).settype=smallset then
  1474. begin
  1475. if tcallparanode(tcallparanode(left).right).left.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
  1476. { we don't need a mod 32 because this is done automatically }
  1477. { by the bts instruction. For proper checking we would }
  1478. { need a cmp and jmp, but this should be done by the }
  1479. { type cast code which does range checking if necessary (FK) }
  1480. hregister:=makereg32(tcallparanode(tcallparanode(left).right).left.location.register)
  1481. else
  1482. begin
  1483. getexplicitregister32(R_EDI);
  1484. hregister:=R_EDI;
  1485. opsize:=def2def_opsize(
  1486. tcallparanode(tcallparanode(left).right).left.resulttype.def,u32bittype.def);
  1487. if opsize in [S_B,S_W,S_L] then
  1488. op:=A_MOV
  1489. else
  1490. op:=A_MOVZX;
  1491. emit_ref_reg(op,opsize,
  1492. newreference(
  1493. tcallparanode(tcallparanode(left).right).left.location.reference),R_EDI);
  1494. end;
  1495. if (tcallparanode(left).left.location.loc=LOC_REFERENCE) then
  1496. emit_reg_ref(asmop,S_L,hregister,
  1497. newreference(tcallparanode(left).left.location.reference))
  1498. else
  1499. emit_reg_reg(asmop,S_L,hregister,
  1500. tcallparanode(left).left.location.register);
  1501. if hregister = R_EDI then
  1502. ungetregister32(R_EDI);
  1503. end
  1504. else
  1505. begin
  1506. pushsetelement(tcallparanode(tcallparanode(left).right).left);
  1507. { normset is allways a ref }
  1508. emitpushreferenceaddr(tcallparanode(left).left.location.reference);
  1509. if inlinenumber=in_include_x_y then
  1510. emitcall('FPC_SET_SET_BYTE')
  1511. else
  1512. emitcall('FPC_SET_UNSET_BYTE');
  1513. {CGMessage(cg_e_include_not_implemented);}
  1514. end;
  1515. end;
  1516. end;
  1517. in_pi:
  1518. begin
  1519. emit_none(A_FLDPI,S_NO);
  1520. inc(fpuvaroffset);
  1521. end;
  1522. in_sin_extended,
  1523. in_arctan_extended,
  1524. in_abs_extended,
  1525. in_sqr_extended,
  1526. in_sqrt_extended,
  1527. in_ln_extended,
  1528. in_cos_extended:
  1529. begin
  1530. secondpass(left);
  1531. case left.location.loc of
  1532. LOC_FPU:
  1533. ;
  1534. LOC_CFPUREGISTER:
  1535. begin
  1536. emit_reg(A_FLD,S_NO,
  1537. correct_fpuregister(left.location.register,fpuvaroffset));
  1538. inc(fpuvaroffset);
  1539. end;
  1540. LOC_REFERENCE,LOC_MEM:
  1541. begin
  1542. floatload(tfloatdef(left.resulttype.def).typ,left.location.reference);
  1543. del_reference(left.location.reference);
  1544. end
  1545. else
  1546. internalerror(309991);
  1547. end;
  1548. case inlinenumber of
  1549. in_sin_extended,
  1550. in_cos_extended:
  1551. begin
  1552. if inlinenumber=in_sin_extended then
  1553. emit_none(A_FSIN,S_NO)
  1554. else
  1555. emit_none(A_FCOS,S_NO);
  1556. {
  1557. getlabel(l1);
  1558. emit_reg(A_FNSTSW,S_NO,R_AX);
  1559. emit_none(A_SAHF,S_NO);
  1560. emitjmp(C_NP,l1);
  1561. emit_reg(A_FSTP,S_NO,R_ST0);
  1562. emit_none(A_FLDZ,S_NO);
  1563. emitlab(l1);
  1564. }
  1565. end;
  1566. in_arctan_extended:
  1567. begin
  1568. emit_none(A_FLD1,S_NO);
  1569. emit_none(A_FPATAN,S_NO);
  1570. end;
  1571. in_abs_extended:
  1572. emit_none(A_FABS,S_NO);
  1573. in_sqr_extended:
  1574. begin
  1575. (* emit_reg(A_FLD,S_NO,R_ST0);
  1576. { emit_none(A_FMULP,S_NO); nasm does not accept this PM }
  1577. emit_reg_reg(A_FMULP,S_NO,R_ST0,R_ST1);
  1578. can be shorten to *)
  1579. emit_reg_reg(A_FMUL,S_NO,R_ST0,R_ST0);
  1580. end;
  1581. in_sqrt_extended:
  1582. emit_none(A_FSQRT,S_NO);
  1583. in_ln_extended:
  1584. begin
  1585. emit_none(A_FLDLN2,S_NO);
  1586. emit_none(A_FXCH,S_NO);
  1587. emit_none(A_FYL2X,S_NO);
  1588. end;
  1589. end;
  1590. end;
  1591. {$ifdef SUPPORT_MMX}
  1592. in_mmx_pcmpeqb..in_mmx_pcmpgtw:
  1593. begin
  1594. if left.location.loc=LOC_REGISTER then
  1595. begin
  1596. {!!!!!!!}
  1597. end
  1598. else if tcallparanode(left).left.location.loc=LOC_REGISTER then
  1599. begin
  1600. {!!!!!!!}
  1601. end
  1602. else
  1603. begin
  1604. {!!!!!!!}
  1605. end;
  1606. end;
  1607. {$endif SUPPORT_MMX}
  1608. else internalerror(9);
  1609. end;
  1610. { reset pushedparasize }
  1611. pushedparasize:=oldpushedparasize;
  1612. end;
  1613. begin
  1614. cinlinenode:=ti386inlinenode;
  1615. end.
  1616. {
  1617. $Log$
  1618. Revision 1.16 2001-07-10 18:01:08 peter
  1619. * internal length for ansistring and widestrings
  1620. Revision 1.15 2001/07/08 21:00:18 peter
  1621. * various widestring updates, it works now mostly without charset
  1622. mapping supported
  1623. Revision 1.14 2001/04/13 01:22:19 peter
  1624. * symtable change to classes
  1625. * range check generation and errors fixed, make cycle DEBUG=1 works
  1626. * memory leaks fixed
  1627. Revision 1.13 2001/04/02 21:20:37 peter
  1628. * resulttype rewrite
  1629. Revision 1.12 2001/03/13 11:52:48 jonas
  1630. * fixed some memory leaks
  1631. Revision 1.11 2000/12/25 00:07:33 peter
  1632. + new tlinkedlist class (merge of old tstringqueue,tcontainer and
  1633. tlinkedlist objects)
  1634. Revision 1.10 2000/12/09 22:51:37 florian
  1635. * helper name of val for qword fixed
  1636. Revision 1.9 2000/12/07 17:19:46 jonas
  1637. * new constant handling: from now on, hex constants >$7fffffff are
  1638. parsed as unsigned constants (otherwise, $80000000 got sign extended
  1639. and became $ffffffff80000000), all constants in the longint range
  1640. become longints, all constants >$7fffffff and <=cardinal($ffffffff)
  1641. are cardinals and the rest are int64's.
  1642. * added lots of longint typecast to prevent range check errors in the
  1643. compiler and rtl
  1644. * type casts of symbolic ordinal constants are now preserved
  1645. * fixed bug where the original resulttype.def wasn't restored correctly
  1646. after doing a 64bit rangecheck
  1647. Revision 1.8 2000/12/05 11:44:33 jonas
  1648. + new integer regvar handling, should be much more efficient
  1649. Revision 1.7 2000/11/29 00:30:47 florian
  1650. * unused units removed from uses clause
  1651. * some changes for widestrings
  1652. Revision 1.6 2000/11/12 23:24:15 florian
  1653. * interfaces are basically running
  1654. Revision 1.5 2000/11/09 17:46:56 florian
  1655. * System.TypeInfo fixed
  1656. + System.Finalize implemented
  1657. + some new keywords for interface support added
  1658. Revision 1.4 2000/10/31 22:02:56 peter
  1659. * symtable splitted, no real code changes
  1660. Revision 1.3 2000/10/26 14:15:07 jonas
  1661. * fixed setlength for shortstrings
  1662. Revision 1.2 2000/10/21 18:16:13 florian
  1663. * a lot of changes:
  1664. - basic dyn. array support
  1665. - basic C++ support
  1666. - some work for interfaces done
  1667. ....
  1668. Revision 1.1 2000/10/15 09:33:31 peter
  1669. * moved n386*.pas to i386/ cpu_target dir
  1670. Revision 1.2 2000/10/15 09:08:58 peter
  1671. * use System for the systemunit instead of target dependent
  1672. Revision 1.1 2000/10/14 10:14:49 peter
  1673. * moehrendorf oct 2000 rewrite
  1674. }