cg386ld.pas 36 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848
  1. {
  2. $Id$
  3. Copyright (c) 1993-98 by Florian Klaempfl
  4. Generate i386 assembler for load/assignment 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 cg386ld;
  19. interface
  20. uses
  21. tree,i386;
  22. procedure secondload(var p : ptree);
  23. procedure secondassignment(var p : ptree);
  24. procedure secondfuncret(var p : ptree);
  25. procedure secondarrayconstruct(var p : ptree);
  26. implementation
  27. uses
  28. cobjects,verbose,globals,systems,
  29. symtable,aasm,types,
  30. hcodegen,temp_gen,pass_2,
  31. cgai386,tgeni386,cg386cnv;
  32. {*****************************************************************************
  33. SecondLoad
  34. *****************************************************************************}
  35. procedure secondload(var p : ptree);
  36. var
  37. hregister : tregister;
  38. symtabletype : tsymtabletype;
  39. i : longint;
  40. hp : preference;
  41. begin
  42. simple_loadn:=true;
  43. reset_reference(p^.location.reference);
  44. case p^.symtableentry^.typ of
  45. { this is only for toasm and toaddr }
  46. absolutesym :
  47. begin
  48. stringdispose(p^.location.reference.symbol);
  49. if (pabsolutesym(p^.symtableentry)^.abstyp=toaddr) then
  50. begin
  51. if pabsolutesym(p^.symtableentry)^.absseg then
  52. p^.location.reference.segment:=R_FS;
  53. p^.location.reference.offset:=pabsolutesym(p^.symtableentry)^.address;
  54. end
  55. else
  56. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  57. maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
  58. end;
  59. varsym :
  60. begin
  61. hregister:=R_NO;
  62. { C variable }
  63. if (pvarsym(p^.symtableentry)^.var_options and vo_is_C_var)<>0 then
  64. begin
  65. stringdispose(p^.location.reference.symbol);
  66. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  67. if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
  68. maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
  69. end
  70. { DLL variable }
  71. else if (pvarsym(p^.symtableentry)^.var_options and vo_is_dll_var)<>0 then
  72. begin
  73. hregister:=getregister32;
  74. stringdispose(p^.location.reference.symbol);
  75. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  76. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hregister)));
  77. stringdispose(p^.location.reference.symbol);
  78. p^.location.reference.base:=hregister;
  79. if (pvarsym(p^.symtableentry)^.var_options and vo_is_external)<>0 then
  80. maybe_concat_external(p^.symtableentry^.owner,p^.symtableentry^.mangledname);
  81. end
  82. else
  83. begin
  84. symtabletype:=p^.symtable^.symtabletype;
  85. { in case it is a register variable: }
  86. if pvarsym(p^.symtableentry)^.reg<>R_NO then
  87. begin
  88. p^.location.loc:=LOC_CREGISTER;
  89. p^.location.register:=pvarsym(p^.symtableentry)^.reg;
  90. unused:=unused-[pvarsym(p^.symtableentry)^.reg];
  91. end
  92. else
  93. begin
  94. { first handle local and temporary variables }
  95. if (symtabletype in [parasymtable,inlinelocalsymtable,
  96. inlineparasymtable,localsymtable]) then
  97. begin
  98. p^.location.reference.base:=procinfo.framepointer;
  99. p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
  100. if (symtabletype=localsymtable) or (symtabletype=inlinelocalsymtable) then
  101. p^.location.reference.offset:=-p^.location.reference.offset;
  102. if (symtabletype=parasymtable) or (symtabletype=inlineparasymtable) then
  103. inc(p^.location.reference.offset,p^.symtable^.call_offset);
  104. if (lexlevel>(p^.symtable^.symtablelevel)) then
  105. begin
  106. hregister:=getregister32;
  107. { make a reference }
  108. hp:=new_reference(procinfo.framepointer,
  109. procinfo.framepointer_offset);
  110. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
  111. simple_loadn:=false;
  112. i:=lexlevel-1;
  113. while i>(p^.symtable^.symtablelevel) do
  114. begin
  115. { make a reference }
  116. hp:=new_reference(hregister,8);
  117. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
  118. dec(i);
  119. end;
  120. p^.location.reference.base:=hregister;
  121. end;
  122. end
  123. else
  124. case symtabletype of
  125. unitsymtable,globalsymtable,
  126. staticsymtable : begin
  127. stringdispose(p^.location.reference.symbol);
  128. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  129. if symtabletype=unitsymtable then
  130. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  131. end;
  132. stt_exceptsymtable:
  133. begin
  134. p^.location.reference.base:=procinfo.framepointer;
  135. p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
  136. end;
  137. objectsymtable:
  138. begin
  139. if (pvarsym(p^.symtableentry)^.properties and sp_static)<>0 then
  140. begin
  141. stringdispose(p^.location.reference.symbol);
  142. p^.location.reference.symbol:=
  143. stringdup(p^.symtableentry^.mangledname);
  144. if p^.symtable^.defowner^.owner^.symtabletype=unitsymtable then
  145. concat_external(p^.symtableentry^.mangledname,EXT_NEAR);
  146. end
  147. else
  148. begin
  149. p^.location.reference.base:=R_ESI;
  150. p^.location.reference.offset:=pvarsym(p^.symtableentry)^.address;
  151. end;
  152. end;
  153. withsymtable:
  154. begin
  155. hregister:=getregister32;
  156. p^.location.reference.base:=hregister;
  157. { make a reference }
  158. { symtable datasize field
  159. contains the offset of the temp
  160. stored }
  161. hp:=new_reference(procinfo.framepointer,
  162. p^.symtable^.datasize);
  163. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hregister)));
  164. p^.location.reference.offset:=
  165. pvarsym(p^.symtableentry)^.address;
  166. end;
  167. end;
  168. end;
  169. { in case call by reference, then calculate: }
  170. if (pvarsym(p^.symtableentry)^.varspez=vs_var) or
  171. ((pvarsym(p^.symtableentry)^.varspez=vs_const) and
  172. {$ifndef VALUEPARA}
  173. dont_copy_const_param(pvarsym(p^.symtableentry)^.definition)) or
  174. { call by value open arrays are also indirect addressed }
  175. is_open_array(pvarsym(p^.symtableentry)^.definition) then
  176. {$else}
  177. push_addr_param(pvarsym(p^.symtableentry)^.definition)) then
  178. {$endif}
  179. begin
  180. simple_loadn:=false;
  181. if hregister=R_NO then
  182. hregister:=getregister32;
  183. if is_open_array(pvarsym(p^.symtableentry)^.definition) or
  184. is_open_string(pvarsym(p^.symtableentry)^.definition) then
  185. begin
  186. if (p^.location.reference.base=procinfo.framepointer) then
  187. begin
  188. highframepointer:=p^.location.reference.base;
  189. highoffset:=p^.location.reference.offset;
  190. end
  191. else
  192. begin
  193. highframepointer:=R_EDI;
  194. highoffset:=p^.location.reference.offset;
  195. exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
  196. p^.location.reference.base,R_EDI)));
  197. end;
  198. end;
  199. if p^.location.loc=LOC_CREGISTER then
  200. begin
  201. exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,S_L,
  202. p^.location.register,hregister)));
  203. p^.location.loc:=LOC_REFERENCE;
  204. end
  205. else
  206. begin
  207. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,
  208. newreference(p^.location.reference),
  209. hregister)));
  210. end;
  211. clear_reference(p^.location.reference);
  212. p^.location.reference.base:=hregister;
  213. end;
  214. end;
  215. end;
  216. procsym:
  217. begin
  218. if p^.is_methodpointer then
  219. begin
  220. secondpass(p^.left);
  221. stringdispose(p^.location.reference.symbol);
  222. { virtual method ? }
  223. if (pprocsym(p^.symtableentry)^.definition^.options and povirtualmethod)<>0 then
  224. begin
  225. end
  226. else
  227. begin
  228. p^.location.reference.symbol:=stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
  229. maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
  230. end;
  231. end
  232. else
  233. begin
  234. {!!!!! Be aware, work on virtual methods too }
  235. stringdispose(p^.location.reference.symbol);
  236. p^.location.reference.symbol:=stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
  237. maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
  238. end;
  239. end;
  240. typedconstsym :
  241. begin
  242. stringdispose(p^.location.reference.symbol);
  243. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  244. maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
  245. end;
  246. else internalerror(4);
  247. end;
  248. end;
  249. {*****************************************************************************
  250. SecondAssignment
  251. *****************************************************************************}
  252. procedure secondassignment(var p : ptree);
  253. var
  254. opsize : topsize;
  255. otlabel,hlabel,oflabel : plabel;
  256. hregister : tregister;
  257. loc : tloc;
  258. r : preference;
  259. begin
  260. otlabel:=truelabel;
  261. oflabel:=falselabel;
  262. getlabel(truelabel);
  263. getlabel(falselabel);
  264. { calculate left sides }
  265. if not(p^.concat_string) then
  266. secondpass(p^.left);
  267. if codegenerror then
  268. exit;
  269. case p^.left^.location.loc of
  270. LOC_REFERENCE : begin
  271. { in case left operator uses to register }
  272. { but to few are free then LEA }
  273. if (p^.left^.location.reference.base<>R_NO) and
  274. (p^.left^.location.reference.index<>R_NO) and
  275. (usablereg32<p^.right^.registers32) then
  276. begin
  277. del_reference(p^.left^.location.reference);
  278. hregister:=getregister32;
  279. exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(
  280. p^.left^.location.reference),
  281. hregister)));
  282. clear_reference(p^.left^.location.reference);
  283. p^.left^.location.reference.base:=hregister;
  284. p^.left^.location.reference.index:=R_NO;
  285. end;
  286. loc:=LOC_REFERENCE;
  287. end;
  288. LOC_CREGISTER:
  289. loc:=LOC_CREGISTER;
  290. LOC_MMXREGISTER:
  291. loc:=LOC_MMXREGISTER;
  292. LOC_CMMXREGISTER:
  293. loc:=LOC_CMMXREGISTER;
  294. else
  295. begin
  296. CGMessage(cg_e_illegal_expression);
  297. exit;
  298. end;
  299. end;
  300. { lets try to optimize this (PM) }
  301. { define a dest_loc that is the location }
  302. { and a ptree to verify that it is the right }
  303. { place to insert it }
  304. {$ifdef test_dest_loc}
  305. if (aktexprlevel<4) then
  306. begin
  307. dest_loc_known:=true;
  308. dest_loc:=p^.left^.location;
  309. dest_loc_tree:=p^.right;
  310. end;
  311. {$endif test_dest_loc}
  312. if (p^.right^.treetype=realconstn) then
  313. begin
  314. if p^.left^.resulttype^.deftype=floatdef then
  315. begin
  316. case pfloatdef(p^.left^.resulttype)^.typ of
  317. s32real : p^.right^.realtyp:=ait_real_32bit;
  318. s64real : p^.right^.realtyp:=ait_real_64bit;
  319. s80real : p^.right^.realtyp:=ait_real_extended;
  320. { what about f32bit and s64bit }
  321. end;
  322. end;
  323. end;
  324. secondpass(p^.right);
  325. if codegenerror then
  326. exit;
  327. {$ifdef test_dest_loc}
  328. dest_loc_known:=false;
  329. if in_dest_loc then
  330. begin
  331. truelabel:=otlabel;
  332. falselabel:=oflabel;
  333. in_dest_loc:=false;
  334. exit;
  335. end;
  336. {$endif test_dest_loc}
  337. if p^.left^.resulttype^.deftype=stringdef then
  338. begin
  339. if is_ansistring(p^.left^.resulttype) then
  340. begin
  341. { the source and destinations are released
  342. in loadansistring, because an ansi string can
  343. also be in a register
  344. }
  345. loadansistring(p);
  346. end
  347. else
  348. if is_shortstring(p^.left^.resulttype) and
  349. not (p^.concat_string) then
  350. begin
  351. if is_ansistring(p^.right^.resulttype) then
  352. begin
  353. if (p^.right^.treetype=stringconstn) and
  354. (p^.right^.length=0) then
  355. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
  356. 0,newreference(p^.left^.location.reference))))
  357. else
  358. loadansi2short(p^.right,p^.left);
  359. end
  360. else
  361. begin
  362. { we do not need destination anymore }
  363. del_reference(p^.left^.location.reference);
  364. del_reference(p^.right^.location.reference);
  365. loadshortstring(p);
  366. ungetiftemp(p^.right^.location.reference);
  367. end;
  368. end
  369. else
  370. begin
  371. { its the only thing we have to do }
  372. del_reference(p^.right^.location.reference);
  373. end
  374. end
  375. else case p^.right^.location.loc of
  376. LOC_REFERENCE,
  377. LOC_MEM : begin
  378. { extra handling for ordinal constants }
  379. if (p^.right^.treetype in [ordconstn,fixconstn]) or
  380. (loc=LOC_CREGISTER) then
  381. begin
  382. case p^.left^.resulttype^.size of
  383. 1 : opsize:=S_B;
  384. 2 : opsize:=S_W;
  385. 4 : opsize:=S_L;
  386. end;
  387. if loc=LOC_CREGISTER then
  388. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
  389. newreference(p^.right^.location.reference),
  390. p^.left^.location.register)))
  391. else
  392. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,
  393. p^.right^.location.reference.offset,
  394. newreference(p^.left^.location.reference))));
  395. {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,opsize,
  396. p^.right^.location.reference.offset,
  397. p^.left^.location)));}
  398. end
  399. else
  400. begin
  401. if p^.right^.resulttype^.needs_inittable then
  402. begin
  403. { this would be a problem }
  404. if not(p^.left^.resulttype^.needs_inittable) then
  405. internalerror(3457);
  406. { increment source reference counter }
  407. new(r);
  408. reset_reference(r^);
  409. r^.symbol:=stringdup(lab2str(p^.right^.resulttype^.get_inittable_label));
  410. emitpushreferenceaddr(exprasmlist,r^);
  411. emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
  412. exprasmlist^.concat(new(pai386,
  413. op_csymbol(A_CALL,S_NO,newcsymbol('FPC_ADDREF',0))));
  414. if not (cs_compilesystem in aktmoduleswitches) then
  415. concat_external('FPC_ADDREF',EXT_NEAR);
  416. { decrement destination reference counter }
  417. new(r);
  418. reset_reference(r^);
  419. r^.symbol:=stringdup(lab2str(p^.left^.resulttype^.get_inittable_label));
  420. emitpushreferenceaddr(exprasmlist,r^);
  421. emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
  422. exprasmlist^.concat(new(pai386,
  423. op_csymbol(A_CALL,S_NO,newcsymbol('FPC_DECREF',0))));
  424. if not(cs_compilesystem in aktmoduleswitches) then
  425. concat_external('FPC_DECREF',EXT_NEAR);
  426. end;
  427. concatcopy(p^.right^.location.reference,
  428. p^.left^.location.reference,p^.left^.resulttype^.size,false,false);
  429. ungetiftemp(p^.right^.location.reference);
  430. end;
  431. end;
  432. {$ifdef SUPPORT_MMX}
  433. LOC_CMMXREGISTER,
  434. LOC_MMXREGISTER:
  435. begin
  436. if loc=LOC_CMMXREGISTER then
  437. exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
  438. p^.right^.location.register,p^.left^.location.register)))
  439. else
  440. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO,
  441. p^.right^.location.register,newreference(p^.left^.location.reference))));
  442. end;
  443. {$endif SUPPORT_MMX}
  444. LOC_REGISTER,
  445. LOC_CREGISTER : begin
  446. case p^.right^.resulttype^.size of
  447. 1 : opsize:=S_B;
  448. 2 : opsize:=S_W;
  449. 4 : opsize:=S_L;
  450. end;
  451. { simplified with op_reg_loc }
  452. if loc=LOC_CREGISTER then
  453. exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,
  454. p^.right^.location.register,
  455. p^.left^.location.register)))
  456. else
  457. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,
  458. p^.right^.location.register,
  459. newreference(p^.left^.location.reference))));
  460. {exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize,
  461. p^.right^.location.register,
  462. p^.left^.location))); }
  463. end;
  464. LOC_FPU : begin
  465. if loc<>LOC_REFERENCE then
  466. internalerror(10010)
  467. else
  468. floatstore(pfloatdef(p^.left^.resulttype)^.typ,
  469. p^.left^.location.reference);
  470. end;
  471. LOC_JUMP : begin
  472. getlabel(hlabel);
  473. emitl(A_LABEL,truelabel);
  474. if loc=LOC_CREGISTER then
  475. exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,
  476. 1,p^.left^.location.register)))
  477. else
  478. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
  479. 1,newreference(p^.left^.location.reference))));
  480. {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B,
  481. 1,p^.left^.location)));}
  482. emitl(A_JMP,hlabel);
  483. emitl(A_LABEL,falselabel);
  484. if loc=LOC_CREGISTER then
  485. exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,
  486. p^.left^.location.register,
  487. p^.left^.location.register)))
  488. else
  489. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
  490. 0,newreference(p^.left^.location.reference))));
  491. emitl(A_LABEL,hlabel);
  492. end;
  493. LOC_FLAGS : begin
  494. if loc=LOC_CREGISTER then
  495. exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
  496. p^.left^.location.register)))
  497. else
  498. exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
  499. newreference(p^.left^.location.reference))));
  500. end;
  501. end;
  502. freelabel(truelabel);
  503. freelabel(falselabel);
  504. truelabel:=otlabel;
  505. falselabel:=oflabel;
  506. end;
  507. {*****************************************************************************
  508. SecondFuncRet
  509. *****************************************************************************}
  510. procedure secondfuncret(var p : ptree);
  511. var
  512. hr : tregister;
  513. hp : preference;
  514. pp : pprocinfo;
  515. hr_valid : boolean;
  516. begin
  517. clear_reference(p^.location.reference);
  518. hr_valid:=false;
  519. if @procinfo<>pprocinfo(p^.funcretprocinfo) then
  520. begin
  521. hr:=getregister32;
  522. hr_valid:=true;
  523. hp:=new_reference(procinfo.framepointer,
  524. procinfo.framepointer_offset);
  525. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr)));
  526. pp:=procinfo.parent;
  527. { walk up the stack frame }
  528. while pp<>pprocinfo(p^.funcretprocinfo) do
  529. begin
  530. hp:=new_reference(hr,
  531. pp^.framepointer_offset);
  532. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr)));
  533. pp:=pp^.parent;
  534. end;
  535. p^.location.reference.base:=hr;
  536. end
  537. else
  538. p^.location.reference.base:=procinfo.framepointer;
  539. p^.location.reference.offset:=procinfo.retoffset;
  540. if ret_in_param(p^.retdef) then
  541. begin
  542. if not hr_valid then
  543. hr:=getregister32;
  544. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr)));
  545. p^.location.reference.base:=hr;
  546. p^.location.reference.offset:=0;
  547. end;
  548. end;
  549. {*****************************************************************************
  550. SecondArrayConstruct
  551. *****************************************************************************}
  552. const
  553. vtInteger = 0;
  554. vtBoolean = 1;
  555. vtChar = 2;
  556. vtExtended = 3;
  557. vtString = 4;
  558. vtPointer = 5;
  559. vtPChar = 6;
  560. vtObject = 7;
  561. vtClass = 8;
  562. vtWideChar = 9;
  563. vtPWideChar = 10;
  564. vtAnsiString = 11;
  565. vtCurrency = 12;
  566. vtVariant = 13;
  567. vtInterface = 14;
  568. vtWideString = 15;
  569. vtInt64 = 16;
  570. procedure secondarrayconstruct(var p : ptree);
  571. var
  572. hp : ptree;
  573. href : treference;
  574. lt : pdef;
  575. vaddr : boolean;
  576. vtype : longint;
  577. begin
  578. if not p^.cargs then
  579. begin
  580. clear_reference(p^.location.reference);
  581. gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference);
  582. href:=p^.location.reference;
  583. end;
  584. hp:=p;
  585. while assigned(hp) do
  586. begin
  587. secondpass(hp^.left);
  588. if codegenerror then
  589. exit;
  590. { find the correct vtype value }
  591. vtype:=$ff;
  592. vaddr:=false;
  593. lt:=hp^.left^.resulttype;
  594. case lt^.deftype of
  595. enumdef,
  596. orddef : begin
  597. if (lt^.deftype=enumdef) or
  598. is_integer(lt) then
  599. vtype:=vtInteger
  600. else
  601. if is_boolean(lt) then
  602. vtype:=vtBoolean
  603. else
  604. if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
  605. vtype:=vtChar;
  606. end;
  607. floatdef : begin
  608. vtype:=vtExtended;
  609. vaddr:=true;
  610. end;
  611. procvardef,
  612. pointerdef : begin
  613. if is_pchar(lt) then
  614. vtype:=vtPChar
  615. else
  616. vtype:=vtPointer;
  617. end;
  618. classrefdef : vtype:=vtClass;
  619. objectdef : begin
  620. vtype:=vtObject;
  621. end;
  622. stringdef : begin
  623. if is_shortstring(lt) then
  624. begin
  625. vtype:=vtString;
  626. vaddr:=true;
  627. end
  628. else
  629. if is_ansistring(lt) then
  630. vtype:=vtAnsiString;
  631. end;
  632. end;
  633. if vtype=$ff then
  634. internalerror(14357);
  635. { write C style pushes or an pascal array }
  636. if p^.cargs then
  637. begin
  638. if vaddr then
  639. begin
  640. emit_to_reference(hp^.left);
  641. emit_push_lea_loc(hp^.left^.location);
  642. end
  643. else
  644. emit_push_loc(hp^.left^.location);
  645. end
  646. else
  647. begin
  648. { update href to the vtype field and write it }
  649. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
  650. vtype,newreference(href))));
  651. inc(href.offset,4);
  652. { write changing field update href to the next element }
  653. if vaddr then
  654. begin
  655. emit_to_reference(hp^.left);
  656. emit_lea_loc_ref(hp^.left^.location,href);
  657. end
  658. else
  659. emit_mov_loc_ref(hp^.left^.location,href);
  660. inc(href.offset,4);
  661. end;
  662. { load next entry }
  663. hp:=hp^.right;
  664. end;
  665. end;
  666. end.
  667. {
  668. $Log$
  669. Revision 1.36 1998-12-04 10:18:06 florian
  670. * some stuff for procedures of object added
  671. * bug with overridden virtual constructors fixed (reported by Italo Gomes)
  672. Revision 1.35 1998/11/30 09:43:04 pierre
  673. * some range check bugs fixed (still not working !)
  674. + added DLL writing support for win32 (also accepts variables)
  675. + TempAnsi for code that could be used for Temporary ansi strings
  676. handling
  677. Revision 1.34 1998/11/28 16:20:48 peter
  678. + support for dll variables
  679. Revision 1.33 1998/11/27 14:50:33 peter
  680. + open strings, $P switch support
  681. Revision 1.32 1998/11/26 09:53:36 florian
  682. * for classes no init/final. code is necessary, fixed
  683. Revision 1.31 1998/11/20 15:35:54 florian
  684. * problems with rtti fixed, hope it works
  685. Revision 1.30 1998/11/18 17:45:24 peter
  686. * fixes for VALUEPARA
  687. Revision 1.29 1998/11/18 15:44:11 peter
  688. * VALUEPARA for tp7 compatible value parameters
  689. Revision 1.28 1998/11/17 11:32:44 peter
  690. * optimize str:='' in H+ mode
  691. + -! to test ansistrings
  692. Revision 1.27 1998/11/16 15:35:39 peter
  693. * rename laod/copystring -> load/copyshortstring
  694. * fixed int-bool cnv bug
  695. + char-ansistring conversion
  696. Revision 1.26 1998/11/10 10:09:10 peter
  697. * va_list -> array of const
  698. Revision 1.25 1998/11/05 12:02:35 peter
  699. * released useansistring
  700. * removed -Sv, its now available in fpc modes
  701. Revision 1.24 1998/10/14 08:47:14 pierre
  702. * bugs in secondfuncret for result in subprocedures removed
  703. Revision 1.23 1998/10/06 17:16:44 pierre
  704. * some memory leaks fixed (thanks to Peter for heaptrc !)
  705. Revision 1.22 1998/10/01 09:22:53 peter
  706. * fixed value openarray
  707. * ungettemp of arrayconstruct
  708. Revision 1.21 1998/09/28 11:07:39 peter
  709. + floatdef support for array of const
  710. Revision 1.20 1998/09/24 14:26:03 peter
  711. * updated for new tvarrec
  712. Revision 1.19 1998/09/23 17:49:59 peter
  713. * high(arrayconstructor) is now correct
  714. * procvardef support for variant record
  715. Revision 1.18 1998/09/23 09:58:48 peter
  716. * first working array of const things
  717. Revision 1.17 1998/09/20 18:00:19 florian
  718. * small compiling problems fixed
  719. Revision 1.16 1998/09/20 17:46:48 florian
  720. * some things regarding ansistrings fixed
  721. Revision 1.15 1998/09/17 09:42:16 peter
  722. + pass_2 for cg386
  723. * Message() -> CGMessage() for pass_1/pass_2
  724. Revision 1.14 1998/09/14 10:43:50 peter
  725. * all internal RTL functions start with FPC_
  726. Revision 1.13 1998/09/04 12:24:24 florian
  727. * bug0159 fixed
  728. Revision 1.12 1998/09/04 11:55:17 florian
  729. * problem with -Or fixed
  730. Revision 1.11 1998/09/03 16:03:14 florian
  731. + rtti generation
  732. * init table generation changed
  733. Revision 1.10 1998/08/21 14:08:40 pierre
  734. + TEST_FUNCRET now default (old code removed)
  735. works also for m68k (at least compiles)
  736. Revision 1.9 1998/08/20 09:26:37 pierre
  737. + funcret setting in underproc testing
  738. compile with _dTEST_FUNCRET
  739. Revision 1.8 1998/08/10 14:49:48 peter
  740. + localswitches, moduleswitches, globalswitches splitting
  741. Revision 1.7 1998/07/30 13:30:33 florian
  742. * final implemenation of exception support, maybe it needs
  743. some fixes :)
  744. Revision 1.6 1998/07/26 21:58:57 florian
  745. + better support for switch $H
  746. + index access to ansi strings added
  747. + assigment of data (records/arrays) containing ansi strings
  748. Revision 1.5 1998/07/24 22:16:54 florian
  749. * internal error 10 together with array access fixed. I hope
  750. that's the final fix.
  751. Revision 1.4 1998/06/11 13:58:45 peter
  752. * fixed too long line
  753. Revision 1.3 1998/06/09 16:01:35 pierre
  754. + added procedure directive parsing for procvars
  755. (accepted are popstack cdecl and pascal)
  756. + added C vars with the following syntax
  757. var C calias 'true_c_name';(can be followed by external)
  758. reason is that you must add the Cprefix
  759. which is target dependent
  760. Revision 1.2 1998/06/08 13:13:34 pierre
  761. + temporary variables now in temp_gen.pas unit
  762. because it is processor independent
  763. * mppc68k.bat modified to undefine i386 and support_mmx
  764. (which are defaults for i386)
  765. Revision 1.1 1998/06/05 17:44:12 peter
  766. * splitted cgi386
  767. }