cg386inl.pas 64 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529
  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,cg386ld,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_STRWIDE_';
  495. st_ansistring:
  496. procedureprefix:='FPC_STRANSI_';
  497. st_shortstring:
  498. procedureprefix:='FPC_STR_';
  499. st_longstring:
  500. procedureprefix:='FPC_STRLONG_';
  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. {$IfDef ValIntern}
  573. Procedure Handle_Val;
  574. var
  575. hp,node, code_para, dest_para : ptree;
  576. hreg: TRegister;
  577. hdef: POrdDef;
  578. pushed2: TPushed;
  579. procedureprefix : string;
  580. hr: TReference;
  581. dummycoll : tdefcoll;
  582. has_code, has_32bit_code, oldregisterdef: boolean;
  583. begin
  584. {save the register variables}
  585. pushusedregisters(pushed,$ff);
  586. node:=p^.left;
  587. hp:=node;
  588. node:=node^.right;
  589. hp^.right:=nil;
  590. has_32bit_code := false;
  591. {if we have 3 parameters, we have a code parameter}
  592. has_code := Assigned(node^.right);
  593. reset_reference(hr);
  594. hreg := R_NO;
  595. {the function result will be in EAX, so we need to reserve it so
  596. that secondpass(dest_para^.left) and secondpass(code_para^.left)
  597. won't use it}
  598. hreg := getexplicitregister32(R_EAX);
  599. {if EAX is already in use, it's a register variable (ok, we've saved
  600. those with pushusedregisters). Since we don't need another
  601. register besides EAX, release it}
  602. If hreg <> R_EAX Then ungetregister32(hreg);
  603. If has_code then
  604. Begin
  605. {code is an orddef, that's checked in tcinl}
  606. If (porddef(hp^.left^.resulttype)^.typ in [u32bit,s32bit]) Then
  607. Begin
  608. has_32bit_code := true;
  609. code_para := hp;
  610. hp:=node;
  611. node:=node^.right;
  612. hp^.right:=nil;
  613. End
  614. Else
  615. Begin
  616. secondpass(hp^.left);
  617. code_para := hp;
  618. hp := node;
  619. node:=node^.right;
  620. hp^.right:=nil;
  621. End;
  622. End;
  623. {hp = destination now, save for later use}
  624. dest_para := hp;
  625. secondpass(dest_para^.left);
  626. {unget EAX (if we got it before), since otherwise pushusedregisters
  627. will push it on the stack. No more registers are allocated before
  628. the function call that will also have to be accessed afterwards,
  629. so if EAX is allocated now before the function call, it doesn't
  630. matter.}
  631. If (hreg = R_EAX) then Ungetregister32(R_EAX);
  632. {(if necessary) save the address loading of code_para and dest_para}
  633. pushusedregisters(pushed2,$ff);
  634. {now that we've already pushed the results from
  635. secondpass(code_para^.left) and secondpass(dest_para^.left) on the
  636. stack, we can put the real parameters on the stack}
  637. If has_32bit_code Then
  638. Begin
  639. dummycoll.paratyp:=vs_var;
  640. dummycoll.data:=code_para^.resulttype;
  641. secondcallparan(code_para,@dummycoll,false,false,0);
  642. if codegenerror then
  643. exit;
  644. Disposetree(code_para);
  645. End
  646. Else
  647. Begin
  648. {only 32bit code parameter is supported, so fake one}
  649. GetTempOfSizeReference(4,hr);
  650. emitpushreferenceaddr(exprasmlist,hr);
  651. End;
  652. Case dest_para^.resulttype^.deftype of
  653. floatdef: procedureprefix := 'FPC_VAL_REAL_';
  654. orddef:
  655. Case PordDef(dest_para^.resulttype)^.typ of
  656. u8bit,u16bit,u32bit{,u64bit}: procedureprefix := 'FPC_VAL_UINT_';
  657. s8bit,s16bit,s32bit{,s64bitint}: procedureprefix := 'FPC_VAL_SINT_';
  658. End;
  659. End;
  660. {node = first parameter = string}
  661. dummycoll.paratyp:=vs_const;
  662. dummycoll.data:=node^.resulttype;
  663. secondcallparan(node,@dummycoll,false,false,0);
  664. if codegenerror then
  665. exit;
  666. {if we are converting to a signed number, we have to include the
  667. size of the destination, so the Val function can extend the sign
  668. of the result to allow proper range checking}
  669. If (dest_para^.resulttype^.deftype = orddef) Then
  670. Case PordDef(dest_para^.resulttype)^.typ of
  671. s8bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,1)));
  672. s16bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,2)));
  673. s32bit: exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_W,4)));
  674. End;
  675. case pstringdef(node^.resulttype)^.string_typ of
  676. st_widestring:
  677. emitcall(procedureprefix+'STRWIDE',true);
  678. st_ansistring:
  679. emitcall(procedureprefix+'STRANSI',true);
  680. st_shortstring:
  681. emitcall(procedureprefix+'SSTRING',true);
  682. st_longstring:
  683. emitcall(procedureprefix+'STRLONG',true);
  684. end;
  685. disposetree(node);
  686. p^.left := nil;
  687. {restore the addresses loaded by secondpass}
  688. popusedregisters(pushed2);
  689. {reload esi in case the dest_para/code_para is a class variable or so}
  690. maybe_loadesi;
  691. If has_code and Not(has_32bit_code) Then
  692. {only 16bit code is possible}
  693. Begin
  694. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,NewReference(hr),R_EDI)));
  695. emit_mov_reg_loc(R_DI,code_para^.left^.location);
  696. Disposetree(code_para);
  697. End;
  698. {save the function result in the destinatin variable}
  699. Case dest_para^.left^.resulttype^.deftype of
  700. floatdef: floatstore(PFloatDef(dest_para^.left^.resulttype)^.typ,
  701. dest_para^.left^.location.reference);
  702. orddef:
  703. Case PordDef(dest_para^.left^.resulttype)^.typ of
  704. u8bit,s8bit:
  705. emit_mov_reg_loc(R_AL,dest_para^.left^.location);
  706. u16bit,s16bit:
  707. emit_mov_reg_loc(R_AX,dest_para^.left^.location);
  708. u32bit,s32bit:
  709. emit_mov_reg_loc(R_EAX,dest_para^.left^.location);
  710. {u64bit,s64bitint: ???}
  711. End;
  712. End;
  713. If (cs_check_range in aktlocalswitches) and
  714. (dest_para^.left^.resulttype^.deftype = orddef) and
  715. {the following has to be changed to 64bit checking, once Val
  716. returns 64 bit values (unless a special Val function is created
  717. for that}
  718. {no need to rangecheck longints or cardinals on 32bit processors}
  719. not((porddef(dest_para^.left^.resulttype)^.typ = s32bit) and
  720. (porddef(dest_para^.left^.resulttype)^.low = $80000000) and
  721. (porddef(dest_para^.left^.resulttype)^.high = $7fffffff)) and
  722. not((porddef(dest_para^.left^.resulttype)^.typ = u32bit) and
  723. (porddef(dest_para^.left^.resulttype)^.low = 0) and
  724. (porddef(dest_para^.left^.resulttype)^.high = $ffffffff)) then
  725. Begin
  726. If has_32bit_code then
  727. {we don't have temporary variable space yet}
  728. GetTempOfSizeReference(4,hr);
  729. {save the result in a temp variable, because EAX may be
  730. overwritten by popusedregs()}
  731. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,S_L,R_EAX,NewReference(hr))));
  732. {clean up the stack, so a backtrace is possible if range check
  733. fails}
  734. popusedregisters(pushed);
  735. {create a temporary 32bit location for the returned value}
  736. hp := getcopy(dest_para^.left);
  737. hp^.location.loc := LOC_REFERENCE;
  738. hp^.location.reference := hr;
  739. {do not register this temporary def}
  740. OldRegisterDef := RegisterDef;
  741. RegisterDef := False;
  742. Case PordDef(dest_para^.left^.resulttype)^.typ of
  743. u8bit,u16bit,u32bit: new(hdef,init(u32bit,0,$fffffff));
  744. s8bit,s16bit,s32bit: new(hdef,init(s32bit,$fffffff,$7ffffff));
  745. end;
  746. hp^.resulttype := hdef;
  747. emitrangecheck(hp,dest_para^.left^.resulttype);
  748. hp^.right := nil;
  749. Dispose(hp^.resulttype, Done);
  750. RegisterDef := OldRegisterDef;
  751. disposetree(hp);
  752. {it's possible that the range cheking was handled by a
  753. procedure that has destroyed ESI}
  754. maybe_loadesi;
  755. End
  756. Else
  757. {clean up the stack}
  758. popusedregisters(pushed);
  759. {dest_para^right is already nil}
  760. disposetree(dest_para);
  761. UnGetIfTemp(hr);
  762. end;
  763. {$EndIf ValIntern}
  764. var
  765. r : preference;
  766. hp : ptree;
  767. l : longint;
  768. ispushed : boolean;
  769. hregister : tregister;
  770. otlabel,oflabel : plabel;
  771. oldpushedparasize : longint;
  772. begin
  773. { save & reset pushedparasize }
  774. oldpushedparasize:=pushedparasize;
  775. pushedparasize:=0;
  776. case p^.inlinenumber of
  777. in_assert_x_y:
  778. begin
  779. otlabel:=truelabel;
  780. oflabel:=falselabel;
  781. getlabel(truelabel);
  782. getlabel(falselabel);
  783. secondpass(p^.left^.left);
  784. if cs_do_assertion in aktlocalswitches then
  785. begin
  786. maketojumpbool(p^.left^.left);
  787. emitlab(falselabel);
  788. { erroraddr }
  789. exprasmlist^.concat(new(pai386,op_reg(A_PUSH,S_L,R_EBP)));
  790. { lineno }
  791. exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,aktfilepos.line)));
  792. { filename string }
  793. hp:=genstringconstnode(current_module^.sourcefiles^.get_file_name(aktfilepos.fileindex));
  794. secondpass(hp);
  795. if codegenerror then
  796. exit;
  797. emitpushreferenceaddr(exprasmlist,hp^.location.reference);
  798. disposetree(hp);
  799. { push msg }
  800. secondpass(p^.left^.right^.left);
  801. emitpushreferenceaddr(exprasmlist,p^.left^.right^.left^.location.reference);
  802. { call }
  803. emitcall('FPC_ASSERT',true);
  804. emitlab(truelabel);
  805. end;
  806. freelabel(truelabel);
  807. freelabel(falselabel);
  808. truelabel:=otlabel;
  809. falselabel:=oflabel;
  810. end;
  811. in_lo_word,
  812. in_hi_word :
  813. begin
  814. secondpass(p^.left);
  815. p^.location.loc:=LOC_REGISTER;
  816. if p^.left^.location.loc<>LOC_REGISTER then
  817. begin
  818. if p^.left^.location.loc=LOC_CREGISTER then
  819. begin
  820. p^.location.register:=reg32toreg16(getregister32);
  821. emit_reg_reg(A_MOV,S_W,p^.left^.location.register,
  822. p^.location.register);
  823. end
  824. else
  825. begin
  826. del_reference(p^.left^.location.reference);
  827. p^.location.register:=reg32toreg16(getregister32);
  828. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_W,newreference(p^.left^.location.reference),
  829. p^.location.register)));
  830. end;
  831. end
  832. else p^.location.register:=p^.left^.location.register;
  833. if p^.inlinenumber=in_hi_word then
  834. exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_W,8,p^.location.register)));
  835. p^.location.register:=reg16toreg8(p^.location.register);
  836. end;
  837. {$ifdef OLDHIGH}
  838. in_high_x :
  839. begin
  840. if is_open_array(p^.left^.resulttype) or
  841. is_open_string(p^.left^.resulttype) then
  842. begin
  843. secondpass(p^.left);
  844. del_reference(p^.left^.location.reference);
  845. p^.location.register:=getregister32;
  846. r:=new_reference(highframepointer,highoffset+4);
  847. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  848. r,p^.location.register)));
  849. end
  850. end;
  851. {$endif OLDHIGH}
  852. in_sizeof_x,
  853. in_typeof_x :
  854. begin
  855. {$ifdef OLDHIGH}
  856. { sizeof(openarray) handling }
  857. if (p^.inlinenumber=in_sizeof_x) and
  858. (is_open_array(p^.left^.resulttype) or
  859. is_open_string(p^.left^.resulttype)) then
  860. begin
  861. { sizeof(openarray)=high(openarray)+1 }
  862. secondpass(p^.left);
  863. del_reference(p^.left^.location.reference);
  864. p^.location.register:=getregister32;
  865. r:=new_reference(highframepointer,highoffset+4);
  866. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  867. r,p^.location.register)));
  868. exprasmlist^.concat(new(pai386,op_reg(A_INC,S_L,
  869. p^.location.register)));
  870. if (p^.left^.resulttype^.deftype=arraydef) and
  871. (parraydef(p^.left^.resulttype)^.elesize<>1) then
  872. exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,S_L,
  873. parraydef(p^.left^.resulttype)^.elesize,p^.location.register)));
  874. end
  875. else
  876. {$endif OLDHIGH}
  877. begin
  878. { for both cases load vmt }
  879. if p^.left^.treetype=typen then
  880. begin
  881. p^.location.register:=getregister32;
  882. exprasmlist^.concat(new(pai386,op_sym_ofs_reg(A_MOV,
  883. S_L,newasmsymbol(pobjectdef(p^.left^.resulttype)^.vmt_mangledname),0,
  884. p^.location.register)));
  885. end
  886. else
  887. begin
  888. secondpass(p^.left);
  889. del_reference(p^.left^.location.reference);
  890. p^.location.loc:=LOC_REGISTER;
  891. p^.location.register:=getregister32;
  892. { load VMT pointer }
  893. inc(p^.left^.location.reference.offset,
  894. pobjectdef(p^.left^.resulttype)^.vmt_offset);
  895. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  896. newreference(p^.left^.location.reference),
  897. p^.location.register)));
  898. end;
  899. { in sizeof load size }
  900. if p^.inlinenumber=in_sizeof_x then
  901. begin
  902. new(r);
  903. reset_reference(r^);
  904. r^.base:=p^.location.register;
  905. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,r,
  906. p^.location.register)));
  907. end;
  908. end;
  909. end;
  910. in_lo_long,
  911. in_hi_long :
  912. begin
  913. secondpass(p^.left);
  914. p^.location.loc:=LOC_REGISTER;
  915. if p^.left^.location.loc<>LOC_REGISTER then
  916. begin
  917. if p^.left^.location.loc=LOC_CREGISTER then
  918. begin
  919. p^.location.register:=getregister32;
  920. emit_reg_reg(A_MOV,S_L,p^.left^.location.register,
  921. p^.location.register);
  922. end
  923. else
  924. begin
  925. del_reference(p^.left^.location.reference);
  926. p^.location.register:=getregister32;
  927. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.left^.location.reference),
  928. p^.location.register)));
  929. end;
  930. end
  931. else p^.location.register:=p^.left^.location.register;
  932. if p^.inlinenumber=in_hi_long then
  933. exprasmlist^.concat(new(pai386,op_const_reg(A_SHR,S_L,16,p^.location.register)));
  934. p^.location.register:=reg32toreg16(p^.location.register);
  935. end;
  936. in_length_string :
  937. begin
  938. secondpass(p^.left);
  939. set_location(p^.location,p^.left^.location);
  940. { length in ansi strings is at offset -8 }
  941. if is_ansistring(p^.left^.resulttype) then
  942. dec(p^.location.reference.offset,8)
  943. { char is always 1, so make it a constant value }
  944. else if is_char(p^.left^.resulttype) then
  945. begin
  946. clear_location(p^.location);
  947. p^.location.loc:=LOC_MEM;
  948. p^.location.reference.is_immediate:=true;
  949. p^.location.reference.offset:=1;
  950. end;
  951. end;
  952. in_pred_x,
  953. in_succ_x:
  954. begin
  955. secondpass(p^.left);
  956. if not (cs_check_overflow in aktlocalswitches) then
  957. if p^.inlinenumber=in_pred_x then
  958. asmop:=A_DEC
  959. else
  960. asmop:=A_INC
  961. else
  962. if p^.inlinenumber=in_pred_x then
  963. asmop:=A_SUB
  964. else
  965. asmop:=A_ADD;
  966. case p^.resulttype^.size of
  967. 4 : opsize:=S_L;
  968. 2 : opsize:=S_W;
  969. 1 : opsize:=S_B;
  970. else
  971. internalerror(10080);
  972. end;
  973. p^.location.loc:=LOC_REGISTER;
  974. if p^.left^.location.loc<>LOC_REGISTER then
  975. begin
  976. p^.location.register:=getregister32;
  977. if (p^.resulttype^.size=2) then
  978. p^.location.register:=reg32toreg16(p^.location.register);
  979. if (p^.resulttype^.size=1) then
  980. p^.location.register:=reg32toreg8(p^.location.register);
  981. if p^.left^.location.loc=LOC_CREGISTER then
  982. emit_reg_reg(A_MOV,opsize,p^.left^.location.register,
  983. p^.location.register)
  984. else
  985. if p^.left^.location.loc=LOC_FLAGS then
  986. emit_flag2reg(p^.left^.location.resflags,p^.location.register)
  987. else
  988. begin
  989. del_reference(p^.left^.location.reference);
  990. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,newreference(p^.left^.location.reference),
  991. p^.location.register)));
  992. end;
  993. end
  994. else p^.location.register:=p^.left^.location.register;
  995. if not (cs_check_overflow in aktlocalswitches) then
  996. exprasmlist^.concat(new(pai386,op_reg(asmop,opsize,
  997. p^.location.register)))
  998. else
  999. exprasmlist^.concat(new(pai386,op_const_reg(asmop,opsize,1,
  1000. p^.location.register)));
  1001. emitoverflowcheck(p);
  1002. emitrangecheck(p,p^.resulttype);
  1003. end;
  1004. in_dec_x,
  1005. in_inc_x :
  1006. begin
  1007. { set defaults }
  1008. addvalue:=1;
  1009. addconstant:=true;
  1010. { load first parameter, must be a reference }
  1011. secondpass(p^.left^.left);
  1012. case p^.left^.left^.resulttype^.deftype of
  1013. orddef,
  1014. enumdef : begin
  1015. case p^.left^.left^.resulttype^.size of
  1016. 1 : opsize:=S_B;
  1017. 2 : opsize:=S_W;
  1018. 4 : opsize:=S_L;
  1019. end;
  1020. end;
  1021. pointerdef : begin
  1022. opsize:=S_L;
  1023. if porddef(ppointerdef(p^.left^.left^.resulttype)^.definition)=voiddef then
  1024. addvalue:=1
  1025. else
  1026. addvalue:=ppointerdef(p^.left^.left^.resulttype)^.definition^.savesize;
  1027. end;
  1028. else
  1029. internalerror(10081);
  1030. end;
  1031. { second argument specified?, must be a s32bit in register }
  1032. if assigned(p^.left^.right) then
  1033. begin
  1034. secondpass(p^.left^.right^.left);
  1035. { when constant, just multiply the addvalue }
  1036. if is_constintnode(p^.left^.right^.left) then
  1037. addvalue:=addvalue*get_ordinal_value(p^.left^.right^.left)
  1038. else
  1039. begin
  1040. case p^.left^.right^.left^.location.loc of
  1041. LOC_REGISTER,
  1042. LOC_CREGISTER : hregister:=p^.left^.right^.left^.location.register;
  1043. LOC_MEM,
  1044. LOC_REFERENCE : begin
  1045. del_reference(p^.left^.right^.left^.location.reference);
  1046. hregister:=getregister32;
  1047. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  1048. newreference(p^.left^.right^.left^.location.reference),hregister)));
  1049. end;
  1050. else
  1051. internalerror(10082);
  1052. end;
  1053. { insert multiply with addvalue if its >1 }
  1054. if addvalue>1 then
  1055. exprasmlist^.concat(new(pai386,op_const_reg(A_IMUL,opsize,
  1056. addvalue,hregister)));
  1057. addconstant:=false;
  1058. end;
  1059. end;
  1060. { write the add instruction }
  1061. if addconstant then
  1062. begin
  1063. if (addvalue=1) and not(cs_check_overflow in aktlocalswitches) then
  1064. begin
  1065. if p^.left^.left^.location.loc=LOC_CREGISTER then
  1066. exprasmlist^.concat(new(pai386,op_reg(incdecop[p^.inlinenumber],opsize,
  1067. p^.left^.left^.location.register)))
  1068. else
  1069. exprasmlist^.concat(new(pai386,op_ref(incdecop[p^.inlinenumber],opsize,
  1070. newreference(p^.left^.left^.location.reference))))
  1071. end
  1072. else
  1073. begin
  1074. if p^.left^.left^.location.loc=LOC_CREGISTER then
  1075. exprasmlist^.concat(new(pai386,op_const_reg(addsubop[p^.inlinenumber],opsize,
  1076. addvalue,p^.left^.left^.location.register)))
  1077. else
  1078. exprasmlist^.concat(new(pai386,op_const_ref(addsubop[p^.inlinenumber],opsize,
  1079. addvalue,newreference(p^.left^.left^.location.reference))));
  1080. end
  1081. end
  1082. else
  1083. begin
  1084. { BUG HERE : detected with nasm :
  1085. hregister is allways 32 bit
  1086. it should be converted to 16 or 8 bit depending on op_size PM }
  1087. { still not perfect :
  1088. if hregister is already a 16 bit reg ?? PM }
  1089. case opsize of
  1090. S_B : hregister:=reg32toreg8(hregister);
  1091. S_W : hregister:=reg32toreg16(hregister);
  1092. end;
  1093. if p^.left^.left^.location.loc=LOC_CREGISTER then
  1094. exprasmlist^.concat(new(pai386,op_reg_reg(addsubop[p^.inlinenumber],opsize,
  1095. hregister,p^.left^.left^.location.register)))
  1096. else
  1097. exprasmlist^.concat(new(pai386,op_reg_ref(addsubop[p^.inlinenumber],opsize,
  1098. hregister,newreference(p^.left^.left^.location.reference))));
  1099. case opsize of
  1100. S_B : hregister:=reg8toreg32(hregister);
  1101. S_W : hregister:=reg16toreg32(hregister);
  1102. end;
  1103. ungetregister32(hregister);
  1104. end;
  1105. emitoverflowcheck(p^.left^.left);
  1106. emitrangecheck(p^.left^.left,p^.left^.left^.resulttype);
  1107. end;
  1108. in_assigned_x :
  1109. begin
  1110. secondpass(p^.left^.left);
  1111. p^.location.loc:=LOC_FLAGS;
  1112. if (p^.left^.left^.location.loc in [LOC_REGISTER,LOC_CREGISTER]) then
  1113. begin
  1114. exprasmlist^.concat(new(pai386,op_reg_reg(A_OR,S_L,
  1115. p^.left^.left^.location.register,
  1116. p^.left^.left^.location.register)));
  1117. ungetregister32(p^.left^.left^.location.register);
  1118. end
  1119. else
  1120. begin
  1121. exprasmlist^.concat(new(pai386,op_const_ref(A_CMP,S_L,0,
  1122. newreference(p^.left^.left^.location.reference))));
  1123. del_reference(p^.left^.left^.location.reference);
  1124. end;
  1125. p^.location.resflags:=F_NE;
  1126. end;
  1127. in_reset_typedfile,in_rewrite_typedfile :
  1128. begin
  1129. pushusedregisters(pushed,$ff);
  1130. exprasmlist^.concat(new(pai386,op_const(A_PUSH,S_L,pfiledef(p^.left^.resulttype)^.typed_as^.size)));
  1131. secondload(p^.left);
  1132. emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
  1133. if p^.inlinenumber=in_reset_typedfile then
  1134. emitcall('FPC_RESET_TYPED',true)
  1135. else
  1136. emitcall('FPC_REWRITE_TYPED',true);
  1137. popusedregisters(pushed);
  1138. end;
  1139. in_write_x :
  1140. handlereadwrite(false,false);
  1141. in_writeln_x :
  1142. handlereadwrite(false,true);
  1143. in_read_x :
  1144. handlereadwrite(true,false);
  1145. in_readln_x :
  1146. handlereadwrite(true,true);
  1147. in_str_x_string :
  1148. begin
  1149. handle_str;
  1150. maybe_loadesi;
  1151. end;
  1152. {$IfDef ValIntern}
  1153. in_val_x :
  1154. Begin
  1155. handle_val;
  1156. End;
  1157. {$EndIf ValIntern}
  1158. in_include_x_y,
  1159. in_exclude_x_y:
  1160. begin
  1161. secondpass(p^.left^.left);
  1162. if p^.left^.right^.left^.treetype=ordconstn then
  1163. begin
  1164. { calculate bit position }
  1165. l:=1 shl (p^.left^.right^.left^.value mod 32);
  1166. { determine operator }
  1167. if p^.inlinenumber=in_include_x_y then
  1168. asmop:=A_OR
  1169. else
  1170. begin
  1171. asmop:=A_AND;
  1172. l:=not(l);
  1173. end;
  1174. if (p^.left^.left^.location.loc=LOC_REFERENCE) then
  1175. begin
  1176. inc(p^.left^.left^.location.reference.offset,(p^.left^.right^.left^.value div 32)*4);
  1177. exprasmlist^.concat(new(pai386,op_const_ref(asmop,S_L,
  1178. l,newreference(p^.left^.left^.location.reference))));
  1179. del_reference(p^.left^.left^.location.reference);
  1180. end
  1181. else
  1182. { LOC_CREGISTER }
  1183. exprasmlist^.concat(new(pai386,op_const_reg(asmop,S_L,
  1184. l,p^.left^.left^.location.register)));
  1185. end
  1186. else
  1187. begin
  1188. { generate code for the element to set }
  1189. ispushed:=maybe_push(p^.left^.right^.left^.registers32,p^.left^.left);
  1190. secondpass(p^.left^.right^.left);
  1191. if ispushed then
  1192. restore(p^.left^.left);
  1193. { determine asm operator }
  1194. if p^.inlinenumber=in_include_x_y then
  1195. asmop:=A_BTS
  1196. else
  1197. asmop:=A_BTR;
  1198. if psetdef(p^.left^.resulttype)^.settype=smallset then
  1199. begin
  1200. if p^.left^.right^.left^.location.loc in [LOC_CREGISTER,LOC_REGISTER] then
  1201. hregister:=p^.left^.right^.left^.location.register
  1202. else
  1203. begin
  1204. hregister:=R_EDI;
  1205. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  1206. newreference(p^.left^.right^.left^.location.reference),R_EDI)));
  1207. end;
  1208. if (p^.left^.left^.location.loc=LOC_REFERENCE) then
  1209. exprasmlist^.concat(new(pai386,op_reg_ref(asmop,S_L,hregister,
  1210. newreference(p^.left^.right^.left^.location.reference))))
  1211. else
  1212. exprasmlist^.concat(new(pai386,op_reg_reg(asmop,S_L,hregister,
  1213. p^.left^.right^.left^.location.register)));
  1214. end
  1215. else
  1216. begin
  1217. pushsetelement(p^.left^.right^.left);
  1218. { normset is allways a ref }
  1219. emitpushreferenceaddr(exprasmlist,
  1220. p^.left^.left^.location.reference);
  1221. if p^.inlinenumber=in_include_x_y then
  1222. emitcall('FPC_SET_SET_BYTE',true)
  1223. else
  1224. emitcall('FPC_SET_UNSET_BYTE',true);
  1225. {CGMessage(cg_e_include_not_implemented);}
  1226. end;
  1227. end;
  1228. end;
  1229. else internalerror(9);
  1230. end;
  1231. { remove temp. objects, we don't generate them here }
  1232. removetemps(exprasmlist,temptoremove);
  1233. temptoremove^.clear;
  1234. { reset pushedparasize }
  1235. pushedparasize:=oldpushedparasize;
  1236. end;
  1237. end.
  1238. {
  1239. $Log$
  1240. Revision 1.30 1999-03-16 17:52:56 jonas
  1241. * changes for internal Val code (do a "make cycle OPT=-dvalintern" to test)
  1242. * in cgi386inl: also range checking for subrange types (compile with "-dreadrangecheck")
  1243. * in cgai386: also small fixes to emitrangecheck
  1244. Revision 1.29 1999/02/25 21:02:27 peter
  1245. * ag386bin updates
  1246. + coff writer
  1247. Revision 1.28 1999/02/22 02:15:11 peter
  1248. * updates for ag386bin
  1249. Revision 1.27 1999/02/17 14:21:40 pierre
  1250. * unused local removed
  1251. Revision 1.26 1999/02/15 11:40:21 pierre
  1252. * pred/succ with overflow check must use ADD DEC !!
  1253. Revision 1.25 1999/02/05 10:56:19 florian
  1254. * in some cases a writeln of temp. ansistrings cause a memory leak, fixed
  1255. Revision 1.24 1999/01/21 22:10:39 peter
  1256. * fixed array of const
  1257. * generic platform independent high() support
  1258. Revision 1.23 1999/01/06 12:23:29 florian
  1259. * str(...) for ansi/long and widestrings fixed
  1260. Revision 1.22 1998/12/11 23:36:07 florian
  1261. + again more stuff for int64/qword:
  1262. - comparision operators
  1263. - code generation for: str, read(ln), write(ln)
  1264. Revision 1.21 1998/12/11 00:02:50 peter
  1265. + globtype,tokens,version unit splitted from globals
  1266. Revision 1.20 1998/11/27 14:50:32 peter
  1267. + open strings, $P switch support
  1268. Revision 1.19 1998/11/26 13:10:40 peter
  1269. * new int - int conversion -dNEWCNV
  1270. * some function renamings
  1271. Revision 1.18 1998/11/24 17:04:27 peter
  1272. * fixed length(char) when char is a variable
  1273. Revision 1.17 1998/11/05 12:02:33 peter
  1274. * released useansistring
  1275. * removed -Sv, its now available in fpc modes
  1276. Revision 1.16 1998/10/22 17:11:13 pierre
  1277. + terminated the include exclude implementation for i386
  1278. * enums inside records fixed
  1279. Revision 1.15 1998/10/21 15:12:50 pierre
  1280. * bug fix for IOCHECK inside a procedure with iocheck modifier
  1281. * removed the GPF for unexistant overloading
  1282. (firstcall was called with procedinition=nil !)
  1283. * changed typen to what Florian proposed
  1284. gentypenode(p : pdef) sets the typenodetype field
  1285. and resulttype is only set if inside bt_type block !
  1286. Revision 1.14 1998/10/20 08:06:40 pierre
  1287. * several memory corruptions due to double freemem solved
  1288. => never use p^.loc.location:=p^.left^.loc.location;
  1289. + finally I added now by default
  1290. that ra386dir translates global and unit symbols
  1291. + added a first field in tsymtable and
  1292. a nextsym field in tsym
  1293. (this allows to obtain ordered type info for
  1294. records and objects in gdb !)
  1295. Revision 1.13 1998/10/13 16:50:02 pierre
  1296. * undid some changes of Peter that made the compiler wrong
  1297. for m68k (I had to reinsert some ifdefs)
  1298. * removed several memory leaks under m68k
  1299. * removed the meory leaks for assembler readers
  1300. * cross compiling shoud work again better
  1301. ( crosscompiling sysamiga works
  1302. but as68k still complain about some code !)
  1303. Revision 1.12 1998/10/08 17:17:12 pierre
  1304. * current_module old scanner tagged as invalid if unit is recompiled
  1305. + added ppheap for better info on tracegetmem of heaptrc
  1306. (adds line column and file index)
  1307. * several memory leaks removed ith help of heaptrc !!
  1308. Revision 1.11 1998/10/05 21:33:15 peter
  1309. * fixed 161,165,166,167,168
  1310. Revision 1.10 1998/10/05 12:32:44 peter
  1311. + assert() support
  1312. Revision 1.8 1998/10/02 10:35:09 peter
  1313. * support for inc(pointer,value) which now increases with value instead
  1314. of 0*value :)
  1315. Revision 1.7 1998/09/21 08:45:07 pierre
  1316. + added vmt_offset in tobjectdef.write for fututre use
  1317. (first steps to have objects without vmt if no virtual !!)
  1318. + added fpu_used field for tabstractprocdef :
  1319. sets this level to 2 if the functions return with value in FPU
  1320. (is then set to correct value at parsing of implementation)
  1321. THIS MIGHT refuse some code with FPU expression too complex
  1322. that were accepted before and even in some cases
  1323. that don't overflow in fact
  1324. ( like if f : float; is a forward that finally in implementation
  1325. only uses one fpu register !!)
  1326. Nevertheless I think that it will improve security on
  1327. FPU operations !!
  1328. * most other changes only for UseBrowser code
  1329. (added symtable references for record and objects)
  1330. local switch for refs to args and local of each function
  1331. (static symtable still missing)
  1332. UseBrowser still not stable and probably broken by
  1333. the definition hash array !!
  1334. Revision 1.6 1998/09/20 12:26:37 peter
  1335. * merged fixes
  1336. Revision 1.5 1998/09/17 09:42:15 peter
  1337. + pass_2 for cg386
  1338. * Message() -> CGMessage() for pass_1/pass_2
  1339. Revision 1.4 1998/09/14 10:43:49 peter
  1340. * all internal RTL functions start with FPC_
  1341. Revision 1.3.2.1 1998/09/20 12:20:07 peter
  1342. * Fixed stack not on 4 byte boundary when doing a call
  1343. Revision 1.3 1998/09/05 23:03:57 florian
  1344. * some fixes to get -Or work:
  1345. - inc/dec didn't take care of CREGISTER
  1346. - register calculcation of inc/dec was wrong
  1347. - var/const parameters get now assigned 32 bit register, but
  1348. const parameters only if they are passed by reference !
  1349. Revision 1.2 1998/09/04 08:41:40 peter
  1350. * updated some error CGMessages
  1351. Revision 1.1 1998/08/31 12:22:14 peter
  1352. * secondinline moved to cg386inl
  1353. Revision 1.19 1998/08/31 08:52:03 peter
  1354. * fixed error 10 with succ() and pref()
  1355. Revision 1.18 1998/08/20 21:36:38 peter
  1356. * fixed 'with object do' bug
  1357. Revision 1.17 1998/08/19 16:07:36 jonas
  1358. * changed optimizer switches + cleanup of DestroyRefs in daopt386.pas
  1359. Revision 1.16 1998/08/18 09:24:36 pierre
  1360. * small warning position bug fixed
  1361. * support_mmx switches splitting was missing
  1362. * rhide error and warning output corrected
  1363. Revision 1.15 1998/08/13 11:00:09 peter
  1364. * fixed procedure<>procedure construct
  1365. Revision 1.14 1998/08/11 14:05:33 peter
  1366. * fixed sizeof(array of char)
  1367. Revision 1.13 1998/08/10 14:49:45 peter
  1368. + localswitches, moduleswitches, globalswitches splitting
  1369. Revision 1.12 1998/07/30 13:30:31 florian
  1370. * final implemenation of exception support, maybe it needs
  1371. some fixes :)
  1372. Revision 1.11 1998/07/24 22:16:52 florian
  1373. * internal error 10 together with array access fixed. I hope
  1374. that's the final fix.
  1375. Revision 1.10 1998/07/18 22:54:23 florian
  1376. * some ansi/wide/longstring support fixed:
  1377. o parameter passing
  1378. o returning as result from functions
  1379. Revision 1.9 1998/07/07 17:40:37 peter
  1380. * packrecords 4 works
  1381. * word aligning of parameters
  1382. Revision 1.8 1998/07/06 15:51:15 michael
  1383. Added length checking for string reading
  1384. Revision 1.7 1998/07/06 14:19:51 michael
  1385. + Added calls for reading/writing ansistrings
  1386. Revision 1.6 1998/07/01 15:28:48 peter
  1387. + better writeln/readln handling, now 100% like tp7
  1388. Revision 1.5 1998/06/25 14:04:17 peter
  1389. + internal inc/dec
  1390. Revision 1.4 1998/06/25 08:48:06 florian
  1391. * first version of rtti support
  1392. Revision 1.3 1998/06/09 16:01:33 pierre
  1393. + added procedure directive parsing for procvars
  1394. (accepted are popstack cdecl and pascal)
  1395. + added C vars with the following syntax
  1396. var C calias 'true_c_name';(can be followed by external)
  1397. reason is that you must add the Cprefix
  1398. which is target dependent
  1399. Revision 1.2 1998/06/08 13:13:29 pierre
  1400. + temporary variables now in temp_gen.pas unit
  1401. because it is processor independent
  1402. * mppc68k.bat modified to undefine i386 and support_mmx
  1403. (which are defaults for i386)
  1404. Revision 1.1 1998/06/05 17:44:10 peter
  1405. * splitted cgi386
  1406. }