cg386inl.pas 63 KB

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