htypechk.pas 29 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765
  1. {
  2. $Id$
  3. Copyright (c) 1996-98 by Florian Klaempfl
  4. This unit exports some help routines for the type checking
  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 htypechk;
  19. interface
  20. uses
  21. tree,symtable;
  22. const
  23. { firstcallparan without varspez we don't count the ref }
  24. count_ref : boolean = true;
  25. allow_array_constructor : boolean = false;
  26. { Conversion }
  27. function isconvertable(def_from,def_to : pdef;
  28. var doconv : tconverttype;fromtreetype : ttreetyp;
  29. explicit : boolean) : boolean;
  30. { Register Allocation }
  31. procedure make_not_regable(p : ptree);
  32. procedure left_right_max(p : ptree);
  33. procedure calcregisters(p : ptree;r32,fpu,mmx : word);
  34. { subroutine handling }
  35. procedure test_protected_sym(sym : psym);
  36. procedure test_protected(p : ptree);
  37. function is_procsym_load(p:Ptree):boolean;
  38. function is_procsym_call(p:Ptree):boolean;
  39. function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
  40. implementation
  41. uses
  42. globtype,systems,tokens,
  43. cobjects,verbose,globals,
  44. aasm,types,
  45. hcodegen;
  46. {****************************************************************************
  47. Convert
  48. ****************************************************************************}
  49. function isconvertable(def_from,def_to : pdef;
  50. var doconv : tconverttype;fromtreetype : ttreetyp;
  51. explicit : boolean) : boolean;
  52. {$ifndef OLDCNV}
  53. { Tbasetype: uauto,uvoid,uchar,
  54. u8bit,u16bit,u32bit,
  55. s8bit,s16bit,s32,
  56. bool8bit,bool16bit,bool32bit,
  57. u64bit,s64bitint }
  58. type
  59. tbasedef=(bvoid,bchar,bint,bbool);
  60. const
  61. basedeftbl:array[tbasetype] of tbasedef =
  62. (bvoid,bvoid,bchar,
  63. bint,bint,bint,
  64. bint,bint,bint,
  65. bbool,bbool,bbool,bint,bint);
  66. basedefconverts : array[tbasedef,tbasedef] of tconverttype =
  67. ((tc_not_possible,tc_not_possible,tc_not_possible,tc_not_possible),
  68. (tc_not_possible,tc_equal,tc_not_possible,tc_not_possible),
  69. (tc_not_possible,tc_not_possible,tc_int_2_int,tc_int_2_bool),
  70. (tc_not_possible,tc_not_possible,tc_bool_2_int,tc_int_2_bool));
  71. {$else}
  72. const
  73. basedefconverts : array[tbasetype,tbasetype] of tconverttype =
  74. {uauto}
  75. ((tc_not_possible,tc_not_possible,tc_not_possible,
  76. tc_not_possible,tc_not_possible,tc_not_possible,
  77. tc_not_possible,tc_not_possible,tc_not_possible,
  78. tc_not_possible,tc_not_possible,tc_not_possible),
  79. {uvoid}
  80. (tc_not_possible,tc_not_possible,tc_not_possible,
  81. tc_not_possible,tc_not_possible,tc_not_possible,
  82. tc_not_possible,tc_not_possible,tc_not_possible,
  83. tc_not_possible,tc_not_possible,tc_not_possible),
  84. {uchar}
  85. (tc_not_possible,tc_not_possible,tc_only_rangechecks32bit,
  86. tc_not_possible,tc_not_possible,tc_not_possible,
  87. tc_not_possible,tc_not_possible,tc_not_possible,
  88. tc_not_possible,tc_not_possible,tc_not_possible),
  89. {u8bit}
  90. (tc_not_possible,tc_not_possible,tc_not_possible,
  91. tc_only_rangechecks32bit,tc_u8bit_2_u16bit,tc_u8bit_2_u32bit,
  92. tc_only_rangechecks32bit,tc_u8bit_2_s16bit,tc_u8bit_2_s32bit,
  93. tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
  94. {u16bit}
  95. (tc_not_possible,tc_not_possible,tc_not_possible,
  96. tc_u16bit_2_u8bit,tc_only_rangechecks32bit,tc_u16bit_2_u32bit,
  97. tc_u16bit_2_s8bit,tc_only_rangechecks32bit,tc_u16bit_2_s32bit,
  98. tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
  99. {u32bit}
  100. (tc_not_possible,tc_not_possible,tc_not_possible,
  101. tc_u32bit_2_u8bit,tc_u32bit_2_u16bit,tc_only_rangechecks32bit,
  102. tc_u32bit_2_s8bit,tc_u32bit_2_s16bit,tc_only_rangechecks32bit,
  103. tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
  104. {s8bit}
  105. (tc_not_possible,tc_not_possible,tc_not_possible,
  106. tc_only_rangechecks32bit,tc_s8bit_2_u16bit,tc_s8bit_2_u32bit,
  107. tc_only_rangechecks32bit,tc_s8bit_2_s16bit,tc_s8bit_2_s32bit,
  108. tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
  109. {s16bit}
  110. (tc_not_possible,tc_not_possible,tc_not_possible,
  111. tc_s16bit_2_u8bit,tc_only_rangechecks32bit,tc_s16bit_2_u32bit,
  112. tc_s16bit_2_s8bit,tc_only_rangechecks32bit,tc_s16bit_2_s32bit,
  113. tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
  114. {s32bit}
  115. (tc_not_possible,tc_not_possible,tc_not_possible,
  116. tc_s32bit_2_u8bit,tc_s32bit_2_u16bit,tc_only_rangechecks32bit,
  117. tc_s32bit_2_s8bit,tc_s32bit_2_s16bit,tc_only_rangechecks32bit,
  118. tc_int_2_bool,tc_int_2_bool,tc_int_2_bool),
  119. {bool8bit}
  120. (tc_not_possible,tc_not_possible,tc_not_possible,
  121. tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
  122. tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
  123. tc_only_rangechecks32bit,tc_int_2_bool,tc_int_2_bool),
  124. {bool16bit}
  125. (tc_not_possible,tc_not_possible,tc_not_possible,
  126. tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
  127. tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
  128. tc_int_2_bool,tc_only_rangechecks32bit,tc_int_2_bool),
  129. {bool32bit}
  130. (tc_not_possible,tc_not_possible,tc_not_possible,
  131. tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
  132. tc_bool_2_int,tc_bool_2_int,tc_bool_2_int,
  133. tc_int_2_bool,tc_int_2_bool,tc_only_rangechecks32bit));
  134. {$endif}
  135. var
  136. b : boolean;
  137. hd1,hd2 : pdef;
  138. begin
  139. { safety check }
  140. if not(assigned(def_from) and assigned(def_to)) then
  141. begin
  142. isconvertable:=false;
  143. exit;
  144. end;
  145. b:=false;
  146. { we walk the wanted (def_to) types and check then the def_from
  147. types if there is a conversion possible }
  148. case def_to^.deftype of
  149. orddef :
  150. begin
  151. case def_from^.deftype of
  152. orddef :
  153. begin
  154. {$ifndef OLDCNV}
  155. doconv:=basedefconverts[basedeftbl[porddef(def_from)^.typ],basedeftbl[porddef(def_to)^.typ]];
  156. b:=true;
  157. if (doconv=tc_not_possible) or
  158. ((doconv=tc_int_2_bool) and
  159. (not explicit) and
  160. (not is_boolean(def_from))) then
  161. b:=false;
  162. {$else}
  163. doconv:=basedefconverts[porddef(def_from)^.typ,porddef(def_to)^.typ];
  164. b:=true;
  165. if (doconv=tc_not_possible) or
  166. ((doconv=tc_int_2_bool) and
  167. (not explicit) and
  168. (not is_boolean(def_from))) then
  169. b:=false;
  170. {$endif}
  171. end;
  172. {$ifndef OLDCNV}
  173. enumdef :
  174. begin
  175. doconv:=tc_int_2_int;
  176. b:=true;
  177. end;
  178. {$endif}
  179. end;
  180. end;
  181. stringdef :
  182. begin
  183. case def_from^.deftype of
  184. stringdef : begin
  185. doconv:=tc_string_2_string;
  186. b:=true;
  187. end;
  188. orddef : begin
  189. { char to string}
  190. if is_char(def_from) then
  191. begin
  192. doconv:=tc_char_2_string;
  193. b:=true;
  194. end;
  195. end;
  196. arraydef : begin
  197. { string to array of char, the length check is done by the firstpass of this node }
  198. if is_equal(parraydef(def_from)^.definition,cchardef) then
  199. begin
  200. doconv:=tc_chararray_2_string;
  201. b:=true;
  202. end;
  203. end;
  204. pointerdef : begin
  205. { pchar can be assigned to short/ansistrings }
  206. if is_pchar(def_from) and not(m_tp in aktmodeswitches) then
  207. begin
  208. doconv:=tc_pchar_2_string;
  209. b:=true;
  210. end;
  211. end;
  212. end;
  213. end;
  214. floatdef :
  215. begin
  216. case def_from^.deftype of
  217. orddef : begin { ordinal to real }
  218. if is_integer(def_from) then
  219. begin
  220. if pfloatdef(def_to)^.typ=f32bit then
  221. doconv:=tc_int_2_fix
  222. else
  223. doconv:=tc_int_2_real;
  224. b:=true;
  225. end;
  226. end;
  227. floatdef : begin { 2 float types ? }
  228. if pfloatdef(def_from)^.typ=pfloatdef(def_to)^.typ then
  229. doconv:=tc_equal
  230. else
  231. begin
  232. if pfloatdef(def_from)^.typ=f32bit then
  233. doconv:=tc_fix_2_real
  234. else
  235. if pfloatdef(def_to)^.typ=f32bit then
  236. doconv:=tc_real_2_fix
  237. else
  238. doconv:=tc_real_2_real;
  239. { comp isn't a floating type }
  240. {$ifdef i386}
  241. if (pfloatdef(def_to)^.typ=s64bit) and
  242. (pfloatdef(def_from)^.typ<>s64bit) and
  243. not (explicit) then
  244. CGMessage(type_w_convert_real_2_comp);
  245. {$endif}
  246. end;
  247. b:=true;
  248. end;
  249. end;
  250. end;
  251. enumdef :
  252. begin
  253. if (def_from^.deftype=enumdef) then
  254. begin
  255. if assigned(penumdef(def_from)^.basedef) then
  256. hd1:=penumdef(def_from)^.basedef
  257. else
  258. hd1:=def_from;
  259. if assigned(penumdef(def_to)^.basedef) then
  260. hd2:=penumdef(def_to)^.basedef
  261. else
  262. hd2:=def_to;
  263. b:=(hd1=hd2);
  264. end;
  265. end;
  266. arraydef :
  267. begin
  268. { open array is also compatible with a single element of its base type }
  269. if is_open_array(def_to) and
  270. is_equal(parraydef(def_to)^.definition,def_from) then
  271. begin
  272. doconv:=tc_equal;
  273. b:=true;
  274. end
  275. else
  276. begin
  277. case def_from^.deftype of
  278. pointerdef : begin
  279. if (parraydef(def_to)^.lowrange=0) and
  280. is_equal(ppointerdef(def_from)^.definition,parraydef(def_to)^.definition) then
  281. begin
  282. doconv:=tc_pointer_2_array;
  283. b:=true;
  284. end;
  285. end;
  286. stringdef : begin
  287. { array of char to string }
  288. if is_equal(parraydef(def_to)^.definition,cchardef) then
  289. begin
  290. doconv:=tc_string_2_chararray;
  291. b:=true;
  292. end;
  293. end;
  294. end;
  295. end;
  296. end;
  297. pointerdef :
  298. begin
  299. case def_from^.deftype of
  300. stringdef : begin
  301. { string constant to zero terminated string constant }
  302. if (fromtreetype=stringconstn) and
  303. is_pchar(def_to) then
  304. begin
  305. doconv:=tc_cstring_2_pchar;
  306. b:=true;
  307. end;
  308. end;
  309. orddef : begin
  310. { char constant to zero terminated string constant }
  311. if (fromtreetype=ordconstn) and is_equal(def_from,cchardef) and
  312. is_pchar(def_to) then
  313. begin
  314. doconv:=tc_cchar_2_pchar;
  315. b:=true;
  316. end;
  317. end;
  318. arraydef : begin
  319. { chararray to pointer }
  320. if (parraydef(def_from)^.lowrange=0) and
  321. is_equal(parraydef(def_from)^.definition,ppointerdef(def_to)^.definition) then
  322. begin
  323. doconv:=tc_array_2_pointer;
  324. b:=true;
  325. end;
  326. end;
  327. pointerdef : begin
  328. { child class pointer can be assigned to anchestor pointers }
  329. if (
  330. (ppointerdef(def_from)^.definition^.deftype=objectdef) and
  331. (ppointerdef(def_to)^.definition^.deftype=objectdef) and
  332. pobjectdef(ppointerdef(def_from)^.definition)^.isrelated(
  333. pobjectdef(ppointerdef(def_to)^.definition))
  334. ) or
  335. { all pointers can be assigned to void-pointer }
  336. is_equal(ppointerdef(def_to)^.definition,voiddef) or
  337. { in my opnion, is this not clean pascal }
  338. { well, but it's handy to use, it isn't ? (FK) }
  339. is_equal(ppointerdef(def_from)^.definition,voiddef) then
  340. begin
  341. doconv:=tc_equal;
  342. b:=true;
  343. end;
  344. end;
  345. procvardef : begin
  346. { procedure variable can be assigned to an void pointer }
  347. { Not anymore. Use the @ operator now.}
  348. if not(m_tp_procvar in aktmodeswitches) and
  349. (ppointerdef(def_to)^.definition^.deftype=orddef) and
  350. (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
  351. begin
  352. doconv:=tc_equal;
  353. b:=true;
  354. end;
  355. end;
  356. classrefdef,
  357. objectdef : begin
  358. { class types and class reference type
  359. can be assigned to void pointers }
  360. if (
  361. ((def_from^.deftype=objectdef) and pobjectdef(def_from)^.isclass) or
  362. (def_from^.deftype=classrefdef)
  363. ) and
  364. (ppointerdef(def_to)^.definition^.deftype=orddef) and
  365. (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
  366. begin
  367. doconv:=tc_equal;
  368. b:=true;
  369. end;
  370. end;
  371. end;
  372. end;
  373. setdef :
  374. begin
  375. { automatic arrayconstructor -> set conversion }
  376. if (def_from^.deftype=arraydef) and (parraydef(def_from)^.IsConstructor) then
  377. begin
  378. doconv:=tc_arrayconstructor_2_set;
  379. b:=true;
  380. end;
  381. end;
  382. procvardef :
  383. begin
  384. { proc -> procvar }
  385. if (def_from^.deftype=procdef) then
  386. begin
  387. def_from^.deftype:=procvardef;
  388. doconv:=tc_proc_2_procvar;
  389. b:=is_equal(def_from,def_to);
  390. def_from^.deftype:=procdef;
  391. end
  392. else
  393. { for example delphi allows the assignement from pointers }
  394. { to procedure variables }
  395. if (m_pointer_2_procedure in aktmodeswitches) and
  396. (def_from^.deftype=pointerdef) and
  397. (ppointerdef(def_from)^.definition^.deftype=orddef) and
  398. (porddef(ppointerdef(def_from)^.definition)^.typ=uvoid) then
  399. begin
  400. doconv:=tc_equal;
  401. b:=true;
  402. end
  403. else
  404. { nil is compatible with procvars }
  405. if (fromtreetype=niln) then
  406. begin
  407. doconv:=tc_equal;
  408. b:=true;
  409. end;
  410. end;
  411. objectdef :
  412. begin
  413. { object pascal objects }
  414. if (def_from^.deftype=objectdef) {and
  415. pobjectdef(def_from)^.isclass and pobjectdef(def_to)^.isclass }then
  416. begin
  417. doconv:=tc_equal;
  418. b:=pobjectdef(def_from)^.isrelated(pobjectdef(def_to));
  419. end
  420. else
  421. { nil is compatible with class instances }
  422. if (fromtreetype=niln) and (pobjectdef(def_to)^.isclass) then
  423. begin
  424. doconv:=tc_equal;
  425. b:=true;
  426. end;
  427. end;
  428. classrefdef :
  429. begin
  430. { class reference types }
  431. if (def_from^.deftype=classrefdef) then
  432. begin
  433. doconv:=tc_equal;
  434. b:=pobjectdef(pclassrefdef(def_from)^.definition)^.isrelated(
  435. pobjectdef(pclassrefdef(def_to)^.definition));
  436. end
  437. else
  438. { nil is compatible with class references }
  439. if (fromtreetype=niln) then
  440. begin
  441. doconv:=tc_equal;
  442. b:=true;
  443. end;
  444. end;
  445. filedef :
  446. begin
  447. { typed files are all equal to the abstract file type
  448. name TYPEDFILE in system.pp in is_equal in types.pas
  449. the problem is that it sholud be also compatible to FILE
  450. but this would leed to a problem for ASSIGN RESET and REWRITE
  451. when trying to find the good overloaded function !!
  452. so all file function are doubled in system.pp
  453. this is not very beautiful !!}
  454. if (def_from^.deftype=filedef) and
  455. (
  456. (
  457. (pfiledef(def_from)^.filetype = ft_typed) and
  458. (pfiledef(def_to)^.filetype = ft_typed) and
  459. (
  460. (pfiledef(def_from)^.typed_as = pdef(voiddef)) or
  461. (pfiledef(def_to)^.typed_as = pdef(voiddef))
  462. )
  463. ) or
  464. (
  465. (
  466. (pfiledef(def_from)^.filetype = ft_untyped) and
  467. (pfiledef(def_to)^.filetype = ft_typed)
  468. ) or
  469. (
  470. (pfiledef(def_from)^.filetype = ft_typed) and
  471. (pfiledef(def_to)^.filetype = ft_untyped)
  472. )
  473. )
  474. ) then
  475. begin
  476. doconv:=tc_equal;
  477. b:=true;
  478. end
  479. end;
  480. else
  481. begin
  482. { assignment overwritten ?? }
  483. if is_assignment_overloaded(def_from,def_to) then
  484. b:=true;
  485. end;
  486. end;
  487. { nil is compatible with ansi- and wide strings }
  488. { no, that isn't true, (FK)
  489. if (fromtreetype=niln) and (def_to^.deftype=stringdef)
  490. and (pstringdef(def_to)^.string_typ in [st_ansistring,st_widestring]) then
  491. begin
  492. doconv:=tc_equal;
  493. b:=true;
  494. end
  495. else
  496. }
  497. { ansi- and wide strings can be assigned to void pointers }
  498. { no, (FK)
  499. if (def_from^.deftype=stringdef) and
  500. (pstringdef(def_from)^.string_typ in [st_ansistring,st_widestring]) and
  501. (def_to^.deftype=pointerdef) and
  502. (ppointerdef(def_to)^.definition^.deftype=orddef) and
  503. (porddef(ppointerdef(def_to)^.definition)^.typ=uvoid) then
  504. begin
  505. doconv:=tc_equal;
  506. b:=true;
  507. end
  508. else
  509. }
  510. { ansistrings can be assigned to pchar
  511. this needs an explicit type cast (FK)
  512. if is_ansistring(def_from) and
  513. (def_to^.deftype=pointerdef) and
  514. (ppointerdef(def_to)^.definition^.deftype=orddef) and
  515. (porddef(ppointerdef(def_to)^.definition)^.typ=uchar) then
  516. begin
  517. doconv:=tc_ansistring_2_pchar;
  518. b:=true;
  519. end
  520. else
  521. }
  522. isconvertable:=b;
  523. end;
  524. {****************************************************************************
  525. Register Calculation
  526. ****************************************************************************}
  527. { marks an lvalue as "unregable" }
  528. procedure make_not_regable(p : ptree);
  529. begin
  530. case p^.treetype of
  531. typeconvn :
  532. make_not_regable(p^.left);
  533. loadn :
  534. if p^.symtableentry^.typ=varsym then
  535. pvarsym(p^.symtableentry)^.var_options :=
  536. pvarsym(p^.symtableentry)^.var_options and not vo_regable;
  537. end;
  538. end;
  539. procedure left_right_max(p : ptree);
  540. begin
  541. if assigned(p^.left) then
  542. begin
  543. if assigned(p^.right) then
  544. begin
  545. p^.registers32:=max(p^.left^.registers32,p^.right^.registers32);
  546. p^.registersfpu:=max(p^.left^.registersfpu,p^.right^.registersfpu);
  547. {$ifdef SUPPORT_MMX}
  548. p^.registersmmx:=max(p^.left^.registersmmx,p^.right^.registersmmx);
  549. {$endif SUPPORT_MMX}
  550. end
  551. else
  552. begin
  553. p^.registers32:=p^.left^.registers32;
  554. p^.registersfpu:=p^.left^.registersfpu;
  555. {$ifdef SUPPORT_MMX}
  556. p^.registersmmx:=p^.left^.registersmmx;
  557. {$endif SUPPORT_MMX}
  558. end;
  559. end;
  560. end;
  561. { calculates the needed registers for a binary operator }
  562. procedure calcregisters(p : ptree;r32,fpu,mmx : word);
  563. begin
  564. left_right_max(p);
  565. { Only when the difference between the left and right registers < the
  566. wanted registers allocate the amount of registers }
  567. if assigned(p^.left) then
  568. begin
  569. if assigned(p^.right) then
  570. begin
  571. if (abs(p^.left^.registers32-p^.right^.registers32)<r32) then
  572. inc(p^.registers32,r32);
  573. if (abs(p^.left^.registersfpu-p^.right^.registersfpu)<fpu) then
  574. inc(p^.registersfpu,fpu);
  575. {$ifdef SUPPORT_MMX}
  576. if (abs(p^.left^.registersmmx-p^.right^.registersmmx)<mmx) then
  577. inc(p^.registersmmx,mmx);
  578. {$endif SUPPORT_MMX}
  579. end
  580. else
  581. begin
  582. if (p^.left^.registers32<r32) then
  583. inc(p^.registers32,r32);
  584. if (p^.left^.registersfpu<fpu) then
  585. inc(p^.registersfpu,fpu);
  586. {$ifdef SUPPORT_MMX}
  587. if (p^.left^.registersmmx<mmx) then
  588. inc(p^.registersmmx,mmx);
  589. {$endif SUPPORT_MMX}
  590. end;
  591. end;
  592. { error CGMessage, if more than 8 floating point }
  593. { registers are needed }
  594. if p^.registersfpu>8 then
  595. CGMessage(cg_e_too_complex_expr);
  596. end;
  597. {****************************************************************************
  598. Subroutine Handling
  599. ****************************************************************************}
  600. { protected field handling
  601. protected field can not appear in
  602. var parameters of function !!
  603. this can only be done after we have determined the
  604. overloaded function
  605. this is the reason why it is not in the parser, PM }
  606. procedure test_protected_sym(sym : psym);
  607. begin
  608. if ((sym^.properties and sp_protected)<>0) and
  609. ((sym^.owner^.symtabletype=unitsymtable) or
  610. ((sym^.owner^.symtabletype=objectsymtable) and
  611. (pobjectdef(sym^.owner^.defowner)^.owner^.symtabletype=unitsymtable))) then
  612. CGMessage(parser_e_cant_access_protected_member);
  613. end;
  614. procedure test_protected(p : ptree);
  615. begin
  616. case p^.treetype of
  617. loadn : test_protected_sym(p^.symtableentry);
  618. typeconvn : test_protected(p^.left);
  619. derefn : test_protected(p^.left);
  620. subscriptn : begin
  621. { test_protected(p^.left);
  622. Is a field of a protected var
  623. also protected ??? PM }
  624. test_protected_sym(p^.vs);
  625. end;
  626. end;
  627. end;
  628. function is_procsym_load(p:Ptree):boolean;
  629. begin
  630. is_procsym_load:=((p^.treetype=loadn) and (p^.symtableentry^.typ=procsym)) or
  631. ((p^.treetype=addrn) and (p^.left^.treetype=loadn)
  632. and (p^.left^.symtableentry^.typ=procsym)) ;
  633. end;
  634. { change a proc call to a procload for assignment to a procvar }
  635. { this can only happen for proc/function without arguments }
  636. function is_procsym_call(p:Ptree):boolean;
  637. begin
  638. is_procsym_call:=(p^.treetype=calln) and (p^.left=nil) and
  639. (((p^.symtableprocentry^.typ=procsym) and (p^.right=nil)) or
  640. ((p^.right<>nil) and (p^.right^.symtableprocentry^.typ=varsym)));
  641. end;
  642. function is_assignment_overloaded(from_def,to_def : pdef) : boolean;
  643. var
  644. passproc : pprocdef;
  645. convtyp : tconverttype;
  646. begin
  647. is_assignment_overloaded:=false;
  648. if assigned(overloaded_operators[assignment]) then
  649. passproc:=overloaded_operators[assignment]^.definition
  650. else
  651. exit;
  652. while passproc<>nil do
  653. begin
  654. if is_equal(passproc^.retdef,to_def) and
  655. isconvertable(from_def,passproc^.para1^.data,convtyp,
  656. ordconstn { nur Dummy},false ) then
  657. begin
  658. is_assignment_overloaded:=true;
  659. break;
  660. end;
  661. passproc:=passproc^.nextoverloaded;
  662. end;
  663. end;
  664. end.
  665. {
  666. $Log$
  667. Revision 1.14 1999-01-19 15:55:32 pierre
  668. * fix for boolean to comp conversion (now disabled)
  669. Revision 1.13 1998/12/15 17:11:37 peter
  670. * string:=pchar not allowed in tp mode
  671. Revision 1.12 1998/12/11 00:03:18 peter
  672. + globtype,tokens,version unit splitted from globals
  673. Revision 1.11 1998/12/10 09:47:21 florian
  674. + basic operations with int64/qord (compiler with -dint64)
  675. + rtti of enumerations extended: names are now written
  676. Revision 1.10 1998/11/29 12:40:23 peter
  677. * newcnv -> not oldcnv
  678. Revision 1.9 1998/11/26 13:10:42 peter
  679. * new int - int conversion -dNEWCNV
  680. * some function renamings
  681. Revision 1.8 1998/11/17 00:36:42 peter
  682. * more ansistring fixes
  683. Revision 1.7 1998/10/14 13:33:24 peter
  684. * fixed small typo
  685. Revision 1.6 1998/10/14 12:53:38 peter
  686. * fixed small tp7 things
  687. * boolean:=longbool and longbool fixed
  688. Revision 1.5 1998/10/12 09:49:58 florian
  689. + support of <procedure var type>:=<pointer> in delphi mode added
  690. Revision 1.4 1998/09/30 16:42:52 peter
  691. * fixed bool-bool cnv
  692. Revision 1.3 1998/09/24 23:49:05 peter
  693. + aktmodeswitches
  694. Revision 1.2 1998/09/24 09:02:14 peter
  695. * rewritten isconvertable to use case
  696. * array of .. and single variable are compatible
  697. Revision 1.1 1998/09/23 20:42:22 peter
  698. * splitted pass_1
  699. }