cg386ld.pas 35 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821
  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. {!!!!! Be aware, work on virtual methods too }
  219. stringdispose(p^.location.reference.symbol);
  220. p^.location.reference.symbol:=stringdup(pprocsym(p^.symtableentry)^.definition^.mangledname);
  221. maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
  222. end;
  223. typedconstsym :
  224. begin
  225. stringdispose(p^.location.reference.symbol);
  226. p^.location.reference.symbol:=stringdup(p^.symtableentry^.mangledname);
  227. maybe_concat_external(p^.symtable,p^.symtableentry^.mangledname);
  228. end;
  229. else internalerror(4);
  230. end;
  231. end;
  232. {*****************************************************************************
  233. SecondAssignment
  234. *****************************************************************************}
  235. procedure secondassignment(var p : ptree);
  236. var
  237. opsize : topsize;
  238. otlabel,hlabel,oflabel : plabel;
  239. hregister : tregister;
  240. loc : tloc;
  241. r : preference;
  242. begin
  243. otlabel:=truelabel;
  244. oflabel:=falselabel;
  245. getlabel(truelabel);
  246. getlabel(falselabel);
  247. { calculate left sides }
  248. if not(p^.concat_string) then
  249. secondpass(p^.left);
  250. if codegenerror then
  251. exit;
  252. case p^.left^.location.loc of
  253. LOC_REFERENCE : begin
  254. { in case left operator uses to register }
  255. { but to few are free then LEA }
  256. if (p^.left^.location.reference.base<>R_NO) and
  257. (p^.left^.location.reference.index<>R_NO) and
  258. (usablereg32<p^.right^.registers32) then
  259. begin
  260. del_reference(p^.left^.location.reference);
  261. hregister:=getregister32;
  262. exprasmlist^.concat(new(pai386,op_ref_reg(A_LEA,S_L,newreference(
  263. p^.left^.location.reference),
  264. hregister)));
  265. clear_reference(p^.left^.location.reference);
  266. p^.left^.location.reference.base:=hregister;
  267. p^.left^.location.reference.index:=R_NO;
  268. end;
  269. loc:=LOC_REFERENCE;
  270. end;
  271. LOC_CREGISTER:
  272. loc:=LOC_CREGISTER;
  273. LOC_MMXREGISTER:
  274. loc:=LOC_MMXREGISTER;
  275. LOC_CMMXREGISTER:
  276. loc:=LOC_CMMXREGISTER;
  277. else
  278. begin
  279. CGMessage(cg_e_illegal_expression);
  280. exit;
  281. end;
  282. end;
  283. { lets try to optimize this (PM) }
  284. { define a dest_loc that is the location }
  285. { and a ptree to verify that it is the right }
  286. { place to insert it }
  287. {$ifdef test_dest_loc}
  288. if (aktexprlevel<4) then
  289. begin
  290. dest_loc_known:=true;
  291. dest_loc:=p^.left^.location;
  292. dest_loc_tree:=p^.right;
  293. end;
  294. {$endif test_dest_loc}
  295. if (p^.right^.treetype=realconstn) then
  296. begin
  297. if p^.left^.resulttype^.deftype=floatdef then
  298. begin
  299. case pfloatdef(p^.left^.resulttype)^.typ of
  300. s32real : p^.right^.realtyp:=ait_real_32bit;
  301. s64real : p^.right^.realtyp:=ait_real_64bit;
  302. s80real : p^.right^.realtyp:=ait_real_extended;
  303. { what about f32bit and s64bit }
  304. end;
  305. end;
  306. end;
  307. secondpass(p^.right);
  308. if codegenerror then
  309. exit;
  310. {$ifdef test_dest_loc}
  311. dest_loc_known:=false;
  312. if in_dest_loc then
  313. begin
  314. truelabel:=otlabel;
  315. falselabel:=oflabel;
  316. in_dest_loc:=false;
  317. exit;
  318. end;
  319. {$endif test_dest_loc}
  320. if p^.left^.resulttype^.deftype=stringdef then
  321. begin
  322. if is_ansistring(p^.left^.resulttype) then
  323. begin
  324. { the source and destinations are released
  325. in loadansistring, because an ansi string can
  326. also be in a register
  327. }
  328. loadansistring(p);
  329. end
  330. else
  331. if is_shortstring(p^.left^.resulttype) and
  332. not (p^.concat_string) then
  333. begin
  334. if is_ansistring(p^.right^.resulttype) then
  335. begin
  336. if (p^.right^.treetype=stringconstn) and
  337. (p^.length=0) then
  338. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
  339. 0,newreference(p^.left^.location.reference))))
  340. else
  341. loadansi2short(p^.right,p^.left);
  342. end
  343. else
  344. begin
  345. { we do not need destination anymore }
  346. del_reference(p^.left^.location.reference);
  347. del_reference(p^.right^.location.reference);
  348. loadshortstring(p);
  349. ungetiftemp(p^.right^.location.reference);
  350. end;
  351. end
  352. else
  353. begin
  354. { its the only thing we have to do }
  355. del_reference(p^.right^.location.reference);
  356. end
  357. end
  358. else case p^.right^.location.loc of
  359. LOC_REFERENCE,
  360. LOC_MEM : begin
  361. { extra handling for ordinal constants }
  362. if (p^.right^.treetype in [ordconstn,fixconstn]) or
  363. (loc=LOC_CREGISTER) then
  364. begin
  365. case p^.left^.resulttype^.size of
  366. 1 : opsize:=S_B;
  367. 2 : opsize:=S_W;
  368. 4 : opsize:=S_L;
  369. end;
  370. if loc=LOC_CREGISTER then
  371. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,opsize,
  372. newreference(p^.right^.location.reference),
  373. p^.left^.location.register)))
  374. else
  375. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,opsize,
  376. p^.right^.location.reference.offset,
  377. newreference(p^.left^.location.reference))));
  378. {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,opsize,
  379. p^.right^.location.reference.offset,
  380. p^.left^.location)));}
  381. end
  382. else
  383. begin
  384. if p^.right^.resulttype^.needs_inittable then
  385. begin
  386. { this would be a problem }
  387. if not(p^.left^.resulttype^.needs_inittable) then
  388. internalerror(3457);
  389. { increment source reference counter }
  390. new(r);
  391. reset_reference(r^);
  392. r^.symbol:=stringdup(lab2str(p^.right^.resulttype^.get_inittable_label));
  393. emitpushreferenceaddr(exprasmlist,r^);
  394. emitpushreferenceaddr(exprasmlist,p^.right^.location.reference);
  395. exprasmlist^.concat(new(pai386,
  396. op_csymbol(A_CALL,S_NO,newcsymbol('FPC_ADDREF',0))));
  397. if not (cs_compilesystem in aktmoduleswitches) then
  398. concat_external('FPC_ADDREF',EXT_NEAR);
  399. { decrement destination reference counter }
  400. new(r);
  401. reset_reference(r^);
  402. r^.symbol:=stringdup(lab2str(p^.left^.resulttype^.get_inittable_label));
  403. emitpushreferenceaddr(exprasmlist,r^);
  404. emitpushreferenceaddr(exprasmlist,p^.left^.location.reference);
  405. exprasmlist^.concat(new(pai386,
  406. op_csymbol(A_CALL,S_NO,newcsymbol('FPC_DECREF',0))));
  407. if not(cs_compilesystem in aktmoduleswitches) then
  408. concat_external('FPC_DECREF',EXT_NEAR);
  409. end;
  410. concatcopy(p^.right^.location.reference,
  411. p^.left^.location.reference,p^.left^.resulttype^.size,false,false);
  412. ungetiftemp(p^.right^.location.reference);
  413. end;
  414. end;
  415. {$ifdef SUPPORT_MMX}
  416. LOC_CMMXREGISTER,
  417. LOC_MMXREGISTER:
  418. begin
  419. if loc=LOC_CMMXREGISTER then
  420. exprasmlist^.concat(new(pai386,op_reg_reg(A_MOVQ,S_NO,
  421. p^.right^.location.register,p^.left^.location.register)))
  422. else
  423. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOVQ,S_NO,
  424. p^.right^.location.register,newreference(p^.left^.location.reference))));
  425. end;
  426. {$endif SUPPORT_MMX}
  427. LOC_REGISTER,
  428. LOC_CREGISTER : begin
  429. case p^.right^.resulttype^.size of
  430. 1 : opsize:=S_B;
  431. 2 : opsize:=S_W;
  432. 4 : opsize:=S_L;
  433. end;
  434. { simplified with op_reg_loc }
  435. if loc=LOC_CREGISTER then
  436. exprasmlist^.concat(new(pai386,op_reg_reg(A_MOV,opsize,
  437. p^.right^.location.register,
  438. p^.left^.location.register)))
  439. else
  440. exprasmlist^.concat(new(pai386,op_reg_ref(A_MOV,opsize,
  441. p^.right^.location.register,
  442. newreference(p^.left^.location.reference))));
  443. {exprasmlist^.concat(new(pai386,op_reg_loc(A_MOV,opsize,
  444. p^.right^.location.register,
  445. p^.left^.location))); }
  446. end;
  447. LOC_FPU : begin
  448. if loc<>LOC_REFERENCE then
  449. internalerror(10010)
  450. else
  451. floatstore(pfloatdef(p^.left^.resulttype)^.typ,
  452. p^.left^.location.reference);
  453. end;
  454. LOC_JUMP : begin
  455. getlabel(hlabel);
  456. emitl(A_LABEL,truelabel);
  457. if loc=LOC_CREGISTER then
  458. exprasmlist^.concat(new(pai386,op_const_reg(A_MOV,S_B,
  459. 1,p^.left^.location.register)))
  460. else
  461. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
  462. 1,newreference(p^.left^.location.reference))));
  463. {exprasmlist^.concat(new(pai386,op_const_loc(A_MOV,S_B,
  464. 1,p^.left^.location)));}
  465. emitl(A_JMP,hlabel);
  466. emitl(A_LABEL,falselabel);
  467. if loc=LOC_CREGISTER then
  468. exprasmlist^.concat(new(pai386,op_reg_reg(A_XOR,S_B,
  469. p^.left^.location.register,
  470. p^.left^.location.register)))
  471. else
  472. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_B,
  473. 0,newreference(p^.left^.location.reference))));
  474. emitl(A_LABEL,hlabel);
  475. end;
  476. LOC_FLAGS : begin
  477. if loc=LOC_CREGISTER then
  478. exprasmlist^.concat(new(pai386,op_reg(flag_2_set[p^.right^.location.resflags],S_B,
  479. p^.left^.location.register)))
  480. else
  481. exprasmlist^.concat(new(pai386,op_ref(flag_2_set[p^.right^.location.resflags],S_B,
  482. newreference(p^.left^.location.reference))));
  483. end;
  484. end;
  485. freelabel(truelabel);
  486. freelabel(falselabel);
  487. truelabel:=otlabel;
  488. falselabel:=oflabel;
  489. end;
  490. {*****************************************************************************
  491. SecondFuncRet
  492. *****************************************************************************}
  493. procedure secondfuncret(var p : ptree);
  494. var
  495. hr : tregister;
  496. hp : preference;
  497. pp : pprocinfo;
  498. hr_valid : boolean;
  499. begin
  500. clear_reference(p^.location.reference);
  501. hr_valid:=false;
  502. if @procinfo<>pprocinfo(p^.funcretprocinfo) then
  503. begin
  504. hr:=getregister32;
  505. hr_valid:=true;
  506. hp:=new_reference(procinfo.framepointer,
  507. procinfo.framepointer_offset);
  508. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr)));
  509. pp:=procinfo.parent;
  510. { walk up the stack frame }
  511. while pp<>pprocinfo(p^.funcretprocinfo) do
  512. begin
  513. hp:=new_reference(hr,
  514. pp^.framepointer_offset);
  515. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,hp,hr)));
  516. pp:=pp^.parent;
  517. end;
  518. p^.location.reference.base:=hr;
  519. end
  520. else
  521. p^.location.reference.base:=procinfo.framepointer;
  522. p^.location.reference.offset:=procinfo.retoffset;
  523. if ret_in_param(p^.retdef) then
  524. begin
  525. if not hr_valid then
  526. hr:=getregister32;
  527. exprasmlist^.concat(new(pai386,op_ref_reg(A_MOV,S_L,newreference(p^.location.reference),hr)));
  528. p^.location.reference.base:=hr;
  529. p^.location.reference.offset:=0;
  530. end;
  531. end;
  532. {*****************************************************************************
  533. SecondArrayConstruct
  534. *****************************************************************************}
  535. const
  536. vtInteger = 0;
  537. vtBoolean = 1;
  538. vtChar = 2;
  539. vtExtended = 3;
  540. vtString = 4;
  541. vtPointer = 5;
  542. vtPChar = 6;
  543. vtObject = 7;
  544. vtClass = 8;
  545. vtWideChar = 9;
  546. vtPWideChar = 10;
  547. vtAnsiString = 11;
  548. vtCurrency = 12;
  549. vtVariant = 13;
  550. vtInterface = 14;
  551. vtWideString = 15;
  552. vtInt64 = 16;
  553. procedure secondarrayconstruct(var p : ptree);
  554. var
  555. hp : ptree;
  556. href : treference;
  557. lt : pdef;
  558. vaddr : boolean;
  559. vtype : longint;
  560. begin
  561. if not p^.cargs then
  562. begin
  563. clear_reference(p^.location.reference);
  564. gettempofsizereference((parraydef(p^.resulttype)^.highrange+1)*8,p^.location.reference);
  565. href:=p^.location.reference;
  566. end;
  567. hp:=p;
  568. while assigned(hp) do
  569. begin
  570. secondpass(hp^.left);
  571. if codegenerror then
  572. exit;
  573. { find the correct vtype value }
  574. vtype:=$ff;
  575. vaddr:=false;
  576. lt:=hp^.left^.resulttype;
  577. case lt^.deftype of
  578. enumdef,
  579. orddef : begin
  580. if (lt^.deftype=enumdef) or
  581. is_integer(lt) then
  582. vtype:=vtInteger
  583. else
  584. if is_boolean(lt) then
  585. vtype:=vtBoolean
  586. else
  587. if (lt^.deftype=orddef) and (porddef(lt)^.typ=uchar) then
  588. vtype:=vtChar;
  589. end;
  590. floatdef : begin
  591. vtype:=vtExtended;
  592. vaddr:=true;
  593. end;
  594. procvardef,
  595. pointerdef : begin
  596. if is_pchar(lt) then
  597. vtype:=vtPChar
  598. else
  599. vtype:=vtPointer;
  600. end;
  601. classrefdef : vtype:=vtClass;
  602. objectdef : begin
  603. vtype:=vtObject;
  604. end;
  605. stringdef : begin
  606. if is_shortstring(lt) then
  607. begin
  608. vtype:=vtString;
  609. vaddr:=true;
  610. end
  611. else
  612. if is_ansistring(lt) then
  613. vtype:=vtAnsiString;
  614. end;
  615. end;
  616. if vtype=$ff then
  617. internalerror(14357);
  618. { write C style pushes or an pascal array }
  619. if p^.cargs then
  620. begin
  621. if vaddr then
  622. begin
  623. emit_to_reference(hp^.left);
  624. emit_push_lea_loc(hp^.left^.location);
  625. end
  626. else
  627. emit_push_loc(hp^.left^.location);
  628. end
  629. else
  630. begin
  631. { update href to the vtype field and write it }
  632. exprasmlist^.concat(new(pai386,op_const_ref(A_MOV,S_L,
  633. vtype,newreference(href))));
  634. inc(href.offset,4);
  635. { write changing field update href to the next element }
  636. if vaddr then
  637. begin
  638. emit_to_reference(hp^.left);
  639. emit_lea_loc_ref(hp^.left^.location,href);
  640. end
  641. else
  642. emit_mov_loc_ref(hp^.left^.location,href);
  643. inc(href.offset,4);
  644. end;
  645. { load next entry }
  646. hp:=hp^.right;
  647. end;
  648. end;
  649. end.
  650. {
  651. $Log$
  652. Revision 1.34 1998-11-28 16:20:48 peter
  653. + support for dll variables
  654. Revision 1.33 1998/11/27 14:50:33 peter
  655. + open strings, $P switch support
  656. Revision 1.32 1998/11/26 09:53:36 florian
  657. * for classes no init/final. code is necessary, fixed
  658. Revision 1.31 1998/11/20 15:35:54 florian
  659. * problems with rtti fixed, hope it works
  660. Revision 1.30 1998/11/18 17:45:24 peter
  661. * fixes for VALUEPARA
  662. Revision 1.29 1998/11/18 15:44:11 peter
  663. * VALUEPARA for tp7 compatible value parameters
  664. Revision 1.28 1998/11/17 11:32:44 peter
  665. * optimize str:='' in H+ mode
  666. + -! to test ansistrings
  667. Revision 1.27 1998/11/16 15:35:39 peter
  668. * rename laod/copystring -> load/copyshortstring
  669. * fixed int-bool cnv bug
  670. + char-ansistring conversion
  671. Revision 1.26 1998/11/10 10:09:10 peter
  672. * va_list -> array of const
  673. Revision 1.25 1998/11/05 12:02:35 peter
  674. * released useansistring
  675. * removed -Sv, its now available in fpc modes
  676. Revision 1.24 1998/10/14 08:47:14 pierre
  677. * bugs in secondfuncret for result in subprocedures removed
  678. Revision 1.23 1998/10/06 17:16:44 pierre
  679. * some memory leaks fixed (thanks to Peter for heaptrc !)
  680. Revision 1.22 1998/10/01 09:22:53 peter
  681. * fixed value openarray
  682. * ungettemp of arrayconstruct
  683. Revision 1.21 1998/09/28 11:07:39 peter
  684. + floatdef support for array of const
  685. Revision 1.20 1998/09/24 14:26:03 peter
  686. * updated for new tvarrec
  687. Revision 1.19 1998/09/23 17:49:59 peter
  688. * high(arrayconstructor) is now correct
  689. * procvardef support for variant record
  690. Revision 1.18 1998/09/23 09:58:48 peter
  691. * first working array of const things
  692. Revision 1.17 1998/09/20 18:00:19 florian
  693. * small compiling problems fixed
  694. Revision 1.16 1998/09/20 17:46:48 florian
  695. * some things regarding ansistrings fixed
  696. Revision 1.15 1998/09/17 09:42:16 peter
  697. + pass_2 for cg386
  698. * Message() -> CGMessage() for pass_1/pass_2
  699. Revision 1.14 1998/09/14 10:43:50 peter
  700. * all internal RTL functions start with FPC_
  701. Revision 1.13 1998/09/04 12:24:24 florian
  702. * bug0159 fixed
  703. Revision 1.12 1998/09/04 11:55:17 florian
  704. * problem with -Or fixed
  705. Revision 1.11 1998/09/03 16:03:14 florian
  706. + rtti generation
  707. * init table generation changed
  708. Revision 1.10 1998/08/21 14:08:40 pierre
  709. + TEST_FUNCRET now default (old code removed)
  710. works also for m68k (at least compiles)
  711. Revision 1.9 1998/08/20 09:26:37 pierre
  712. + funcret setting in underproc testing
  713. compile with _dTEST_FUNCRET
  714. Revision 1.8 1998/08/10 14:49:48 peter
  715. + localswitches, moduleswitches, globalswitches splitting
  716. Revision 1.7 1998/07/30 13:30:33 florian
  717. * final implemenation of exception support, maybe it needs
  718. some fixes :)
  719. Revision 1.6 1998/07/26 21:58:57 florian
  720. + better support for switch $H
  721. + index access to ansi strings added
  722. + assigment of data (records/arrays) containing ansi strings
  723. Revision 1.5 1998/07/24 22:16:54 florian
  724. * internal error 10 together with array access fixed. I hope
  725. that's the final fix.
  726. Revision 1.4 1998/06/11 13:58:45 peter
  727. * fixed too long line
  728. Revision 1.3 1998/06/09 16:01:35 pierre
  729. + added procedure directive parsing for procvars
  730. (accepted are popstack cdecl and pascal)
  731. + added C vars with the following syntax
  732. var C calias 'true_c_name';(can be followed by external)
  733. reason is that you must add the Cprefix
  734. which is target dependent
  735. Revision 1.2 1998/06/08 13:13:34 pierre
  736. + temporary variables now in temp_gen.pas unit
  737. because it is processor independent
  738. * mppc68k.bat modified to undefine i386 and support_mmx
  739. (which are defaults for i386)
  740. Revision 1.1 1998/06/05 17:44:12 peter
  741. * splitted cgi386
  742. }