htypechk.pas 30 KB

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